(*
Copyright © 2006-2008 Russell O’Connor

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

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

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import CoRN.reals.fast.CRAlternatingSum.
Require Import CoRN.reals.fast.CRAlternatingSum_alg.
Require Import CoRN.reals.fast.CRstreams.
Require Import CoRN.reals.fast.CRexp.
Require Export CoRN.reals.fast.CRArith.
Require Import CoRN.reals.fast.CRIR.
Require Import Coq.QArith.Qpower Coq.QArith.Qabs Coq.QArith.Qround.
Require Import CoRN.model.ordfields.Qordfield.
Require Import CoRN.reals.Q_in_CReals.
Require Import CoRN.model.metric2.Qmetric.
Require Import CoRN.model.totalorder.QMinMax.
Require Import CoRN.model.totalorder.QposMinMax.
Require Import CoRN.transc.MoreArcTan.
Require Import CoRN.tactics.CornTac.
Require Import MathClasses.interfaces.abstract_algebra.
Require Import CoRN.stdlib_omissions.Q.
Require Import Coq.Init.Datatypes.

Set Implicit Arguments.

Local Open Scope Q_scope.
Local Open Scope uc_scope.

Opaque inj_Q CR.

Lemma Qmult_pos_neg : forall (a b : Q),
    0 <= a -> b <= 0 -> a*b <= 0.
Proof.
  intros. rewrite Qmult_comm.
  rewrite <- (Qmult_0_l a).
  apply Qmult_le_compat_r; assumption.
Qed.

Lemma Qmult_opp_1 : forall q : Q,
    eq (-q) (-1 * q).
Proof.
  reflexivity.
Qed.

(**
** Arctangent (small)
For values between in [[-1,1]], arctangent is computed by it's alternating
taylor series.
*)
Section ArcTanSeries.
Variable a:Q.

(* (1,a) -> (3, -a^3/3) -> ...
   With a bigger state type, 1/(2i+1) could be set directly. It will be
   done in faster reals with a stream of positive*AQ*AQ. *)
Definition arctanStream (px : prod positive Q) : prod positive Q
  := let d := Pos.add 2 (fst px) in
     (d, Qred (- snd px * a * a * (fst px#d))).

Lemma arctanStream_fst : forall p,
    fst (iterate _ arctanStream p (1%positive, a)) ≡ Pos.succ (2*p).
Proof.
  apply Pos.peano_ind.
  - reflexivity.
  - intros p H. rewrite iterate_succ.
    destruct (iterate (positive and Q) arctanStream p (1%positive, a)).
    simpl in H. subst p0.
    transitivity (Pos.add 2 (p~1)). reflexivity.
    clear q a. rewrite Pos.mul_succ_r.
    rewrite <- Pos.add_1_l, (Pos.add_comm 1).
    rewrite <- Pos.add_assoc. apply f_equal. reflexivity.
Qed.

Lemma Str_pth_arctanStream : forall p,
    Str_pth _ arctanStream p (xH, a)
    == (1#(1+2*p)) * ((-1)^p*a^(1+2*p))%Q.
Proof.
  apply Pos.peano_ind.
  - unfold arctanStream, Str_pth, iterate, snd.
    rewrite Qred_correct. simpl.
    rewrite (Qmult_comm (1#3)), Qmult_assoc, Qmult_assoc.
    reflexivity.
  - intros p pInd. unfold Str_pth.
    rewrite iterate_succ. unfold Str_pth in pInd.
    pose proof (arctanStream_fst p) as H0.
    destruct (iterate _ arctanStream p (1%positive, a)) as [p0 q].
    simpl in H0. subst p0. unfold snd in pInd.
    unfold arctanStream, snd, fst.
    rewrite Qred_correct. rewrite pInd. clear pInd q.
    (* Get rid of (-1)^p *)
    rewrite <- (Qmult_comm ((-1) ^ Pos.succ p * a ^ (1 + 2 * Pos.succ p))).
    rewrite <- (Pos.add_1_l p).
    rewrite Pos2Z.inj_add, (Qpower_plus (-1)%Q).
    simpl ((-1)^1).
    rewrite Qmult_opp_1.
    do 5 rewrite <- (Qmult_assoc (-1)).
    apply (Qmult_comp (-1)). reflexivity.
    rewrite (Qmult_comm (1 # (1 + 2 * p))).
    do 5 rewrite <- (Qmult_assoc ((-1)^p)).
    apply (Qmult_comp ((-1)^p)). reflexivity.
    (* Get rid of a *)
    setoid_replace (a ^ (1 + 2 * (1 + p))) with (a ^ (1 + 2 * p) * (a * a)).
    do 4 rewrite <- (Qmult_assoc (a ^ (1 + 2 * p))).
    apply Qmult_comp. reflexivity.
    rewrite <- (Qmult_assoc _ a a).
    rewrite (Qmult_comm (1 # (1 + 2 * p))).
    rewrite <- (Qmult_assoc (a*a)).
    apply Qmult_comp. reflexivity.
    (* Finish equalities *)
    unfold Qeq, Qmult, Qnum, Qden.
    rewrite Z.mul_1_l, Z.mul_1_l.
    reflexivity.
    rewrite <- (Qpower_plus_positive a 1 1).
    rewrite <- (Qpower_plus_positive a (1+2*p)).
    apply Qpower_positive_comp. reflexivity.
    rewrite <- Pos.add_assoc.
    apply f_equal. rewrite (Pos.add_comm 1 p).
    reflexivity.
    intro abs. discriminate.
Qed.

Hypothesis Ha: (-1 <= a <= 1).

Lemma arctanStream_alt : Str_alt_decr _ arctanStream (1%positive,a).
Proof.
  split.
  - (* Replace a by Qabs a *)
    rewrite Str_pth_arctanStream, Str_pth_arctanStream.
    rewrite Qabs_Qmult, Qabs_Qmult, Qabs_Qmult, Qabs_Qmult.
    rewrite Qabs_Qpower, Qabs_Qpower.
    change (Qabs (-1)) with 1.
    rewrite Qpower_1, Qpower_1, Qmult_1_l, Qmult_1_l.
    rewrite (Qabs_Qpower a (1+2*Pos.succ p)), (Qabs_Qpower a (1+2*p)).
    (* Finish inequality *)
    setoid_replace (Qabs a ^ (1 + 2 * Pos.succ p)%positive)
      with (Qabs a * Qabs a * Qabs a ^ (1 + 2 * p)%positive).
    rewrite Qmult_assoc.
    apply Qmult_le_compat_r.
    2: rewrite <- Qabs_Qpower; apply Qabs_nonneg.
    + rewrite Qmult_comm.
      apply (Qabs_Qle_condition a 1) in Ha.
      apply (Qle_trans _ (1* (1 # (1 + 2 * (Pos.succ p))))).
      apply Qmult_le_compat_r. 2: discriminate.
      apply (Qle_trans _ (1*Qabs a)).
      apply Qmult_le_compat_r. exact Ha.
      apply Qabs_nonneg. rewrite Qmult_1_l. exact Ha.
      rewrite Qmult_1_l. unfold Qabs, Z.abs.
      unfold Qle, Qnum, Qden.
      rewrite Z.mul_1_l, Z.mul_1_l.
      change (p <= Pos.succ p)%positive.
      apply Pos.lt_le_incl, Pos.lt_succ_r, Pos.le_refl.
    + replace (1 + 2 * Pos.succ p)%positive with (2 + (1 + 2 * p))%positive.
      generalize (1 + 2 * p)%positive. clear p. intro p.
      unfold Qpower.
      rewrite Qpower_plus_positive. reflexivity.
      rewrite Pos.add_comm, <- Pos.add_assoc. apply f_equal.
      rewrite <- Pos.add_1_l.
      rewrite Pos.mul_add_distr_l, Pos.mul_1_r.
      apply Pos.add_comm.
  - rewrite Str_pth_arctanStream, Str_pth_arctanStream.
    rewrite Qmult_comm, <- Qmult_assoc. apply Qmult_pos_neg.
    discriminate. rewrite Qmult_comm, <- Qmult_assoc.
    apply Qmult_pos_neg. discriminate.
    rewrite <- Pos.add_1_l.
    change ((-1) ^ (1 + p)%positive) with (Qpower_positive (-1) (1 + p)).
    rewrite Qpower_plus_positive. simpl (Qpower_positive (-1) 1).
    rewrite <- Qmult_assoc, <- Qmult_assoc.
    apply (Qopp_le_compat 0).
    rewrite (Qmult_comm (a ^ (1 + 2 * (1 + p)%positive))).
    rewrite Qmult_assoc, Qmult_assoc.
    rewrite <- Qmult_assoc.
    apply Qmult_le_0_compat.
    simpl.
    destruct (Qpower_positive (-1) p), Qnum; discriminate.
    setoid_replace (a ^ (1 + 2 * (1 + p))) with (a ^ (1 + 2 * p) * (a * a)).
    rewrite Qmult_assoc.
    apply Qmult_le_0_compat.
    destruct (a ^ (1 + 2 * p)), Qnum; discriminate.
    destruct a, Qnum; discriminate.
    change (a*a) with (Qpower_positive a 2).
    rewrite <- (Qpower_plus_positive a (1+2*p)).
    change (a ^ (1 + 2 * (1 + p))) with (Qpower_positive a (1 + 2 * (1 + p))).
    replace (1 + 2 * (1 + p))%positive with (1 + 2 * p + 2)%positive.
    reflexivity.
    rewrite <- Pos.add_assoc. apply f_equal.
    rewrite Pos.mul_add_distr_l, Pos.mul_1_r.
    apply Pos.add_comm.
Qed.

Lemma arctanStream_zl
  : Limit_zero _ arctanStream (xH,a)
               (fun e:Qpos => Z.to_pos (Qceiling (/ (proj1_sig e)))).
Proof.
  intros [e epos]. rewrite Str_pth_arctanStream, Qabs_Qmult, Qabs_Qmult.
  rewrite Qabs_Qpower. change (Qabs (-1)) with 1.
  rewrite Qpower_1, Qmult_1_l.
  rewrite Qmult_comm.
  apply (Qle_trans _ (1 * Qabs (1 # 1 + 2 * Z.to_pos (Qceiling (/ ` (e ↾ epos)))))).
  apply Qmult_le_compat_r. 2: apply Qabs_nonneg.
  - rewrite (Qabs_Qpower a (1 + 2 * Z.to_pos (Qceiling (/ ` (e ↾ epos))))).
    apply Qpower_le_1. split.
    apply Qabs_nonneg.
    apply Qabs_Qle_condition, Ha.
  - clear Ha a.
    rewrite Qmult_1_l. unfold Qabs, Z.abs, proj1_sig.
    rewrite <- (Qinv_involutive e) at 2.
    assert (0 < /e) as H.
    { apply Qinv_lt_0_compat, epos. }
    apply (@Qinv_le_compat (/e) (Zpos (1 + 2 * Z.to_pos (Qceiling (/ e))) # 1)).
    exact H.
    apply (Qle_trans _ _ _ (Qle_ceiling (/e))).
    generalize (Qceiling (/ e)).
    clear H epos e. intros [|p|p].
    discriminate. 2: discriminate.
    pose proof (Zle_Qle p (Z.pos (1 + 2 * Z.to_pos p))).
    unfold inject_Z.
    unfold inject_Z in H.
    rewrite <- H. clear H.
    change (p <= 1 + 2*p)%positive.
    rewrite <- Pplus_one_succ_l.
    apply Pos.lt_le_incl, Pos.lt_succ_r.
    apply (Pos.mul_le_mono_r p 1 2). discriminate.
Qed.

End ArcTanSeries.

Definition rational_arctan_small (a:Q) (p: -1 <= a <= 1) : CR :=
  (inject_Q_CR a + AltSeries _ (arctanStream a) (xH,a) _
                             (arctanStream_alt p) (arctanStream_zl p))%CR.

Lemma rational_arctan_small_wd : forall (a1 a2 : Q) (p1 : -1 <= a1 <= 1) (p2 : -1 <= a2 <= 1),
    a1 = a2 → rational_arctan_small p1 = rational_arctan_small p2.
Proof.
  intros. unfold rational_arctan_small.
  apply ucFun2_wd. rewrite H. reflexivity.
  apply AltSeries_wd.
  2: reflexivity. intro p.
  rewrite Str_pth_arctanStream, Str_pth_arctanStream, H. reflexivity.
Qed.

Lemma widen_interval : forall a:Q, -1 < a < 1 -> -1 <= a <= 1.
Proof.
  intros a [H H0]. split; apply Qlt_le_weak; assumption.
Qed.

Lemma rational_arctan_small_correct : forall (a:Q) (Ha : -1 < a < 1),
    (@rational_arctan_small a (widen_interval Ha) == IRasCR (ArcTan (inj_Q IR a)))%CR.
Proof.
  intros a Ha.
  unfold rational_arctan_small.
  rewrite <- (IR_inj_Q_as_CR a).
  rewrite
    (AltSeries_correct
       _ _ _ _ (arctanStream_alt (widen_interval Ha))
       (arctanStream_zl (widen_interval Ha))
       _ (AltSeries_convergent_0 _ _ _ _ (inj_Q IR a)
                                 (arctanStream_alt (widen_interval Ha)) (arctanStream_zl (widen_interval Ha)))).
  - apply IRasCR_wd.
    assert (olor ([--][1]) [1] (inj_Q IR a)) as X.
    { split.
      stepl (inj_Q IR (-1)). apply inj_Q_less, Ha.
      rewrite (inj_Q_inv IR 1), inj_Q_One. reflexivity.
      stepr (inj_Q IR 1); [| now apply inj_Q_One].
      apply inj_Q_less, Ha. }
    eapply eq_transitive_unfolded;
      [|apply (arctan_series (inj_Q IR a) (arctan_series_convergent_IR) X)].
    apply series_sum_wd.
    intros n.
    transitivity (inj_Q IR (((-1)^n)%Q *(a^(1+2*Z.of_nat n) * (1#(Pos.of_nat (1+2*n)))))).
    + destruct n. apply inj_Q_wd. simpl.
      rewrite Qmult_1_l, Qmult_1_r. reflexivity.
      apply inj_Q_wd.
      rewrite Str_pth_arctanStream.
      rewrite (Qmult_assoc ((-1)^S n)).
      rewrite (Qmult_comm ((-1) ^ S n * a ^ (1 + 2 * S n))). apply Qmult_comp.
      unfold Qeq, Qnum, Qden.
      rewrite Z.mul_1_l, Z.mul_1_l.
      change 2%positive with (Pos.of_nat 2).
      rewrite <- (Nat2Pos.inj_mul 2 (S n)).
      2: discriminate. 2: discriminate.
      rewrite <- (Nat2Pos.inj_add 1). reflexivity.
      discriminate. discriminate.
      apply Qmult_comp.
      rewrite <- Pos.of_nat_succ, POS_anti_convert.
      reflexivity.
      replace (1 + 2 * Z.pos (Pos.of_nat (S n)))%Z with (1 + 2 * S n)%Z.
      reflexivity.
      rewrite <- Pos.of_nat_succ, POS_anti_convert.
      reflexivity.
    + transitivity (([--][1][^]n[/]nring (R:=IR) (S (2 * n))[//]nringS_ap_zero IR (2 * n))[*]
     (inj_Q IR a)[^](2 * n + 1)).
      2: reflexivity.
      rstepr (([--][1][^]n)[*]((inj_Q IR a)[^](2*n+1)[/]nring (R:=IR) (S (2 * n))[//]nringS_ap_zero IR (2 * n))).
      rewrite inj_Q_mult.
      apply mult_wd.
      rewrite inj_Q_power.
      apply nexp_wd.
      rewrite (inj_Q_inv IR 1), inj_Q_One.
      reflexivity.
      apply mult_cancel_lft with (nring (R:=IR) (S (2 * n))).
      apply nringS_ap_zero.
      rstepr (inj_Q IR a[^](2 * n + 1)).
      stepr (inj_Q IR (a^(2*n+1)%nat)); [| now apply inj_Q_power].
      stepl ((inj_Q IR (nring (S (2*n))))[*]inj_Q IR (a ^ (1 + 2 * n) * (1 # Pos.of_nat (1 + 2 * n))));
        [| now apply mult_wdl; apply inj_Q_nring].
      rewrite <- inj_Q_mult.
      apply inj_Q_wd.
      setoid_rewrite (nring_Q (S (2*n))).
      change (S (2 * n) * (a ^ (1 + 2 * n) * (1 # Pos.of_nat (1 + 2 * n)))
              == a ^ (2 * n + 1)%nat)%Q.
      rewrite Qmult_comm.
      rewrite <- Qmult_assoc.
      setoid_replace ((1 # Pos.of_nat (1 + 2 * n)) * S (2 * n)) with 1%Q.
      rewrite Qmult_1_r, Nat.add_comm.
      rewrite Nat2Z.inj_add, Nat2Z.inj_mul. reflexivity.
      unfold Qeq, inject_Z, Qmult, Qnum, Qden.
      rewrite Z.mul_1_l, Z.mul_1_l, Z.mul_1_r, Pos.mul_1_r.
      unfold Z.of_nat.
      rewrite Pos.of_nat_succ. reflexivity.
  - intro p. destruct (Pos.to_nat p) eqn:des.
    exfalso. pose proof (Pos2Nat.is_pos p). rewrite des in H.
    inversion H.
    apply inj_Q_wd.
    rewrite <- des, Pos2Nat.id. reflexivity.
Qed.


(* Maps: Total and Partial Maps *)
(* Copied from SF's Maps.v *)
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Logic.FunctionalExtensionality.

Require Import List.
Import ListNotations.

Inductive id : Type :=
  | Id : nat -> id.

Definition beq_id id1 id2 :=
  match id1,id2 with
    | Id n1, Id n2 => beq_nat n1 n2
  end.

Theorem beq_id_refl : forall id, true = beq_id id id.
Proof.
  intros [n]. simpl. rewrite <- beq_nat_refl.
  reflexivity. Qed.

Theorem beq_id_true_iff : forall id1 id2 : id,
  beq_id id1 id2 = true <-> id1 = id2.
Proof.
   intros [n1] [n2].
   unfold beq_id.
   rewrite beq_nat_true_iff.
   split.
   - (* -> *) intros H. rewrite H. reflexivity.
   - (* <- *) intros H. inversion H. reflexivity.
Qed.

Theorem beq_id_false_iff : forall x y : id,
  beq_id x y = false
  <-> x <> y.
Proof.
  intros x y. rewrite <- beq_id_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.

Theorem false_beq_id : forall x y : id,
   x <> y
   -> beq_id x y = false.
Proof.
  intros x y. rewrite beq_id_false_iff.
  intros H. apply H. Qed.

Lemma id_dec :
  forall x x' : id, { x = x' } + { x <> x' }.
Proof.
  repeat (decide equality).
Qed.

(* Total maps *)

Definition total_map (A:Type) := id -> A.

Definition t_empty {A:Type} (v : A) : total_map A :=
  (fun _ => v).

Definition t_update {A:Type} (m : total_map A)
                    (x : id) (v : A) :=
  fun x' => if beq_id x x' then v else m x'.

Definition examplemap :=
  t_update (t_update (t_empty false) (Id 1) false)
           (Id 3) true.

Example update_example1 : examplemap (Id 0) = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap (Id 1) = false.
Proof. reflexivity. Qed.

Example update_example3 : examplemap (Id 2) = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap (Id 3) = true.
Proof. reflexivity. Qed.

Lemma t_apply_empty:  forall A x v, @t_empty A v x = v.
Proof.
  reflexivity.
Qed.

Lemma t_update_eq : forall A (m: total_map A) x v,
  (t_update m x v) x = v.
Proof.
  intros A m x v.
  unfold t_update.
  rewrite <- beq_id_refl.
  reflexivity.
Qed.

Theorem t_update_neq : forall (X:Type) v x1 x2
                         (m : total_map X),
  x1 <> x2 ->
  (t_update m x1 v) x2 = m x2.
Proof.
  intros X v x1 x2 m H.
  apply false_beq_id in H.
  unfold t_update.
  rewrite H.
  reflexivity.
Qed.

Lemma t_update_shadow : forall A (m: total_map A) v1 v2 x,
    t_update (t_update m x v1) x v2
  = t_update m x v2.
Proof.
  intros A m v1 v2 x.
  unfold t_update.
  apply functional_extensionality_dep. intros x'.
  destruct (beq_id x x') eqn:H.
  - reflexivity.
  - reflexivity.
Qed.

Lemma beq_idP : forall x y, reflect (x = y) (beq_id x y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. apply beq_id_true_iff.
Qed.

Theorem t_update_same : forall X x (m : total_map X),
  t_update m x (m x) = m.
Proof.
  intros X x m.
  unfold t_update.
  apply functional_extensionality_dep. intros x0.
  destruct (beq_id x x0) eqn:H.
  - apply beq_id_true_iff in H. rewrite H. reflexivity.
  - reflexivity.
Qed.

Theorem t_update_permute : forall (X:Type) v1 v2 x1 x2
                             (m : total_map X),
  x2 <> x1 ->
    (t_update (t_update m x2 v2) x1 v1)
  = (t_update (t_update m x1 v1) x2 v2).
Proof.
  intros X v1 v2 x1 x2 m H.
  unfold t_update.
  apply functional_extensionality_dep. intros x0.
  destruct (beq_id x1 x0) eqn:H1.
  - destruct (beq_id x2 x0) eqn:H2.
    * apply beq_id_true_iff in H1. rewrite H1 in H.
      apply beq_id_true_iff in H2. rewrite H2 in H.

      (*
      unfold not in H.
      exfalso.
      apply H.
      *)
      destruct H.
      reflexivity.
    * reflexivity.
  - destruct (beq_id x2 x0) eqn:H2.
    * reflexivity.
    * reflexivity.
Qed.

(* Partial maps *)

Definition partial_map (A:Type) := total_map (option A).

Definition empty {A:Type} : partial_map A :=
  t_empty None.

Definition update {A:Type} (m : partial_map A) (x : id) (v : A) :=
  t_update m x (Some v).

Definition key {A:Type} (m : partial_map A) (x : id) : bool :=
  match m x with
    | Some _ => true
    | None => false
  end.

Definition remove {A:Type} (m : partial_map A) (x : id) : partial_map A :=
  if key m x then t_update m x None else m.

Definition merge {A:Type} (m1 m2 : partial_map A) : partial_map A :=
  fun i => if key m2 i then m2 i else m1 i.

Fixpoint omit {A:Type} (m : partial_map A) (l : list id) : partial_map A :=
  match l with
    | [] => m
    | i::l' => omit (remove m i) l'
  end.

Fixpoint take {A:Type} (m : partial_map A) (l : list id) : partial_map A :=
  match l with
    | [] => @empty A
    | i::l' =>
      if key m i then t_update (take m l') i (m i) else take m l'
  end.

(** We can now lift all of the basic lemmas about total maps to
    partial maps.  *)

Lemma apply_empty : forall A x, @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty.
  reflexivity.
Qed.

Lemma update_eq : forall A (m: partial_map A) x v,
  (update m x v) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (X:Type) v x1 x2
                       (m : partial_map X),
  x2 <> x1 ->
  (update m x2 v) x1 = m x1.
Proof.
  intros X v x1 x2 m H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H.
Qed.

Lemma update_shadow : forall A (m: partial_map A) v1 v2 x,
  update (update m x v1) x v2 = update m x v2.
Proof.
  intros A m v1 v2 x1. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall X v x (m : partial_map X),
  m x = Some v ->
  update m x v = m.
Proof.
  intros X v x m H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (X:Type) v1 v2 x1 x2
                                (m : partial_map X),
  x2 <> x1 ->
    (update (update m x2 v2) x1 v1)
  = (update (update m x1 v1) x2 v2).
Proof.
  intros X v1 v2 x1 x2 m. unfold update.
  apply t_update_permute.
Qed.

Theorem key_true_iff : forall X (m : partial_map X) x,
  key m x = true <-> (exists x', m x = Some x').
Proof.
  intros X m x. split.
  - intros H.
    unfold key in H.
    destruct (m x) eqn:Hmx.
    * exists x0. reflexivity.
    * inversion H.
  - intros H.
    destruct H.
    unfold key.
    rewrite H.
    reflexivity.
Qed.

Theorem key_false_iff : forall X (m : partial_map X) x,
  key m x = false <-> m x = None.
Proof.
  intros X m x. split.
  - intros.
    unfold key in H.
    destruct (m x) eqn:Hmx.
    * inversion H.
    * reflexivity.
  - intros H.
    unfold key.
    rewrite H.
    reflexivity.
Qed.

Theorem key_empty : forall X x,
  key (@empty X) x = false.
Proof.
  intros.
  apply key_false_iff.
  apply apply_empty.
Qed.

Lemma remove_eq : forall A (m: partial_map A) x,
  (remove m x) x = None.
Proof.
  intros. unfold remove.
  destruct (key m x) eqn:Hmx.
  - apply t_update_eq.
  - apply key_false_iff. assumption.
Qed.

Theorem remove_neq : forall X (m : partial_map X) x1 x2,
  x2 <> x1 -> (remove m x2) x1 = m x1.
Proof.
  intros X m x1 x2 H.
  unfold remove.
  destruct (key m x2) eqn:Hmx2.
  - apply t_update_neq. assumption.
  - reflexivity.
Qed.

Theorem merge_shadow_key : forall A (m1 m2: partial_map A) x,
  key m2 x = true -> merge m1 m2 x = m2 x.
Proof.
  intros A m1 m2 x H.
  unfold merge.
  rewrite H.
  reflexivity.
Qed.

Theorem merge_shadow_not_key : forall A (m1 m2: partial_map A) x,
  key m2 x = false -> merge m1 m2 x = m1 x.
Proof.
  intros A m1 m2 x H.
  unfold merge.
  rewrite H.
  reflexivity.
Qed.

Theorem merge_empty_l : forall A (m : partial_map A),
  merge empty m = m.
Proof.
  intros A m.
  apply functional_extensionality_dep.
  intros i. unfold merge.
  destruct (key m i) eqn:Hkmi.
  - reflexivity.
  - rewrite apply_empty. symmetry.
    apply key_false_iff. assumption.
Qed.

Theorem merge_empty_r : forall A (m : partial_map A),
  merge m empty = m.
Proof.
  intros A m.
  apply functional_extensionality_dep.
  intros i. unfold merge.
  rewrite key_empty. reflexivity.
Qed.

Lemma omit_list :
  forall A l1 l2 (m : partial_map A),
    omit m (l1 ++ l2) = omit (omit m l1) l2.
Proof.
  intros A.
  induction l1 as [|i1 l1'];
  simpl.
  - reflexivity.
  - intros. rewrite (IHl1' l2 (remove m i1)). reflexivity.
Qed.

Lemma omit_none :
  forall A l i (m : partial_map A),
    m i = None -> (omit m l) i = None.
Proof.
  intros A.
  induction l as [|i' l'];
  intros i m Hmi;
  simpl.
  - assumption.
  - destruct (id_dec i' i) as [Heq|Hneq].
    * apply (IHl' i (remove m i')).
      rewrite Heq. apply remove_eq.
    * apply (IHl' i (remove m i')).
      rewrite <- Hmi. apply remove_neq.
      assumption.
Qed.

Lemma omit_not_in_list :
  forall A l i (m : partial_map A),
    not (In i l) -> (omit m l) i = m i.
Proof.
  intros A.
  induction l as [|i' l'];
  intros i m Hli;
  simpl.
  - reflexivity.
  - destruct (id_dec i' i) as [Heq|Hneq].
    * exfalso. apply Hli. simpl. left. assumption.
    * rewrite (IHl' i (remove m i')).
      + apply remove_neq. assumption.
      + intro. apply Hli. simpl. right. assumption.
Qed.

Lemma omit_in_list :
  forall A l i (m : partial_map A),
    In i l -> (omit m l) i = None.
Proof.
  intros A.
  induction l as [|i' l'];
  intros i m Hli;
  inversion Hli;
  simpl.
  - rewrite H. apply (omit_none A l' i (remove m i)). apply remove_eq.
  - apply (IHl' i (remove m i') H).
Qed.

Theorem omit_list_iff :
  forall A (m : partial_map A) l,
    (forall i, In i l -> m i = None) <-> omit m l = m.
Proof.
  intros. split.
  - intros Hmi. apply functional_extensionality_dep. intros.
    destruct (in_dec id_dec x l) as [Hxl|Hnxl].
    * rewrite (omit_in_list A l x m Hxl), (Hmi x Hxl). reflexivity.
    * rewrite (omit_not_in_list A l x m Hnxl). reflexivity.
  - intros Hml. intros x Hil.
    rewrite <- (omit_in_list A l x m Hil), Hml. reflexivity.
Qed.

Lemma take_none :
  forall A l i (m : partial_map A),
    m i = None -> (take m l) i = None.
Proof.
  intros A.
  induction l as [|i' l'];
  intros i m Hmi;
  simpl.
  - apply apply_empty.
  - destruct (id_dec i' i) as [Heq|Hneq].
    * assert (Hk: key m i = false).
        { apply key_false_iff. assumption. }
      rewrite Heq, Hmi. rewrite Hk.
      apply (IHl' i m Hmi).
    * destruct (key m i') eqn:Hk.
      + rewrite <- (IHl' i m Hmi). apply t_update_neq. assumption.
      + apply (IHl' i m Hmi).
Qed.

Lemma take_not_in_list :
  forall A l i (m : partial_map A),
    not (In i l) -> (take m l) i = None.
Proof.
  intros A.
  induction l as [|i' l'];
  intros i m Hli;
  simpl.
  - apply apply_empty.
  - destruct (id_dec i' i) as [Heq|Hneq].
    * exfalso. apply Hli. simpl. left. assumption.
    * apply not_in_cons in Hli. destruct Hli as [Hii' Hil'].
      destruct (key m i') eqn:Hk.
      + rewrite <- (IHl' i m Hil'). apply t_update_neq. assumption.
      + apply (IHl' i m Hil').
Qed.

Lemma take_in_list :
  forall A l i (m : partial_map A),
    In i l -> (take m l) i = m i.
Proof.
  intros A.
  induction l as [|i' l'];
  intros i m Hli;
  inversion Hli;
  simpl;
  destruct (key m i') eqn:Hk.
  - rewrite H. apply t_update_eq.
  - rewrite H in Hk.
    apply key_false_iff in Hk. rewrite Hk.
    apply (take_none A l' i m Hk).
  - destruct (id_dec i' i).
    * rewrite <- e. apply t_update_eq.
    * rewrite <- (IHl' i m H).
      apply t_update_neq. assumption.
  - apply (IHl' i m H).
Qed.

Lemma take_list :
  forall A l1 l2 (m : partial_map A),
    take m (l1 ++ l2) = merge (take m l1) (take m l2).
Proof.
  intros A.
  induction l1 as [|i1' l1'];
  simpl; intros.
  - rewrite merge_empty_l. reflexivity.
  - destruct (key m i1') eqn:Hkmi1'.
    * rewrite (IHl1' l2 m). apply functional_extensionality_dep.
      intros i. unfold merge. unfold t_update.
      destruct (beq_id i1' i) eqn:Hbeqidi1'i.
      + apply (beq_id_true_iff i1' i) in Hbeqidi1'i.
        rewrite Hbeqidi1'i. rewrite Hbeqidi1'i in Hkmi1'.
        destruct (in_dec id_dec i l2) eqn:Hinil2.
        { rewrite (take_in_list A l2 i m i0).
          apply key_true_iff in Hkmi1'.
          rewrite <- (take_in_list A l2 i m i0) in Hkmi1'.
          apply key_true_iff in Hkmi1'.
          rewrite Hkmi1'. reflexivity. }
        { assert (H: take m l2 i = None).
            { apply (take_not_in_list A l2 i m n). }
          rewrite H. apply (key_false_iff A (take m l2) i) in H.
          rewrite H. reflexivity. }
      + reflexivity.
    * rewrite (IHl1' l2 m). reflexivity.
Qed.

Theorem take_list_iff :
  forall A (m : partial_map A) l,
    (forall i, In i l -> m i = None) <-> take m l = @empty A.
Proof.
  intros. split.
  - intros Hmi. apply functional_extensionality_dep. intros.
    destruct (in_dec id_dec x l) as [Hxl|Hnxl].
    * rewrite (take_in_list A l x m Hxl), (Hmi x Hxl). reflexivity.
    * rewrite (take_not_in_list A l x m Hnxl). reflexivity.
  - intros Hml. intros x Hil.
    rewrite <- (take_in_list A l x m Hil), Hml. reflexivity.
Qed.

Lemma omit_take_list :
  forall A (m : partial_map A) l,
    omit (take m l) l = @empty A.
Proof.
  intros A m.
  induction l as [|i' l'];
  simpl.
  - reflexivity.
  - apply functional_extensionality_dep.
    intros i. rewrite (apply_empty A i).
    destruct (id_dec i' i) as [Hideq|Hidneq].
    * rewrite Hideq.
      apply omit_none.
      apply remove_eq.
    * destruct (in_dec id_dec i l') as [Hil'|Hnil'].
      + apply (omit_in_list A l' i (remove (if key m i' then t_update (take m l') i' (m i') else take m l') i') Hil').
      + rewrite (omit_not_in_list A l' i (remove (if key m i' then t_update (take m l') i' (m i') else take m l') i') Hnil').
        rewrite (remove_neq A (if key m i' then t_update (take m l') i' (m i') else take m l') i i' Hidneq).
        destruct (key m i') eqn:Hkmi'.
        { rewrite (t_update_neq (option A) (m i') i' i (take m l') Hidneq).
          apply (take_not_in_list A l' i m Hnil'). }
        { apply (take_not_in_list A l' i m Hnil'). }
Qed.

Lemma take_omit_list :
  forall A (m : partial_map A) l,
    take (omit m l) l = @empty A.
Proof.
  intros A m.
  induction l as [|i' l'];
  simpl.
  - reflexivity.
  - assert (Hkorml'i': key (omit (remove m i') l') i' = false).
      { apply key_false_iff.
        apply omit_none.
        apply remove_eq. }
    rewrite Hkorml'i'.
    apply functional_extensionality_dep.
    intros i. rewrite (apply_empty A i).
    destruct (id_dec i' i) as [Hideq|Hidneq].
    * rewrite Hideq.
      apply take_none.
      apply omit_none.
      apply remove_eq.
    * destruct (in_dec id_dec i l') as [Hil'|Hnil'].
      + rewrite (take_in_list A l' i (omit (remove m i') l') Hil').
        apply (omit_in_list A l' i (remove m i') Hil').
      + apply (take_not_in_list A l' i (omit (remove m i') l') Hnil').
Qed.

Theorem take_omit_permute :
  forall A (m : partial_map A) l,
    take (omit m l) l = omit (take m l) l.
Proof.
  intros.
  rewrite take_omit_list.
  rewrite omit_take_list.
  reflexivity.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj5synthconj6 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (lv0) (plus (plus lv1 lv2) (mult lv3 lv2))).
Admitted.
QuickChick conj5synthconj6.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj23eqsynthconj4 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (mult lv0 lv1) lv2) (plus (mult lv1 lv0) lv2)).
Admitted.
QuickChick conj23eqsynthconj4.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


Require Import core core_axioms fintype fintype_axioms.
Import ScopedNotations.
From Chapter9 Require Export stlc.
Set Implicit Arguments.
Unset Strict Implicit.
Require Import Setoid Morphisms.

(*** Rewriting laws that have to hold ***)
(* one of the rewriting laws of lambda-sigma *)
Goal forall m (s: tm (S m)), (ren_tm (var_zero .: shift) s) = s.
Proof.
  (* can be proved by asimpl both in the original form and reformulated as a substitution *)
  intros m s.
  asimpl.
  reflexivity.
  Restart.
  intros m s.
  substify.
  asimpl.
  reflexivity.
Qed.

(*** Iea for normalization ***)
(* I want to be able to say assert (H: s[sigma] = _) by (now asimpl)
 * so that it fills in the normal form in the evar.
 * With normal setoid rewriting this is not directly possible because setoid rewriting seems to behave differently on goals of the form
 * `s[sigma] = t[tau]` where it normalizes both sides.
than on goals of the form
 * `s[sigma] = ?E` where it fails to normalize the left side.
 *
 * A hack around this is the following tactic that asserts the trivial equality, then normalizes both sides and then builds another equality where we already know the normal form on the right hand side and proves it again with asimpl.
 * Of course it's slow since it uses asimpl twice.
 * Plus `asimpl in H` is naive and reverts H so asimpl is also applied to the rest of the goal which is not desirable and often defeeats the purpose of the tactic. But we might be able to write a more performant `asimpl in H` tactic.
 *)
Ltac normalize t :=
  let H := fresh "H" in
  assert (H: t = t) by (reflexivity);
  asimpl in H;
  match goal with
  | [ H2: ?t2 = ?t2 |- _ ] =>
    clear H;
    let H := fresh "H" in
    assert (H: t = t2) by (now asimpl)
  end.

(* this normalization tactic is a bit better since it does not apply asimpl to the original goal (like asimpl in H does)
 It uses the evar tactic to carry out information out of the second goal of the `enough`
 Could also be done by assert instead of enough and matching on the context but this seems safer. *)
Ltac normalize_evar t T :=
  let x := fresh "x" in
  let H := fresh "H" in
  evar (x : T);
  enough (H : t = t);
  [| asimpl;
     match goal with
     | [|- ?t2 = ?t2] =>
       instantiate (x := t2);
       reflexivity
     end ];
  clear H;
  assert (H : t = x) by (subst x; now asimpl);
  subst x.

(*** Testing out asimpl. ***)
(* this subsitution equation that appears for example in step_inst is pretty nice to test since it uses a lot of the lemmas.
 Experience shows that if asimpl works here it works for a lot of other lemmas of Chapter9 *)
Lemma default_subst_lemma {m n} (f : fin m -> tm n) (s : tm (S m)) (t : tm m) :
  s[t..][f] = s[up_tm_tm f][(t[f])..].
Proof.
  now asimpl.
  Restart.
  (* use normalization tactic *)
  normalize_evar (s[t..][f]) (tm n).
  (* manually apply the tactics based on the trace by asimpl
compComp
unfold
funcomp
scons_comp
fsimpl
renComp
varL
instId
fsimpl
funcomp
   *)
  auto_unfold.
  setoid_rewrite compComp_tm.
  unfold up_list_tm_tm, up_tm_tm, upRen_list_tm_tm, upRen_tm_tm, up_ren.
  unfold funcomp.
  (* the scons_comp happens inside fsimpl *)
  fsimpl.
  setoid_rewrite renComp_tm.
  setoid_rewrite varL_tm'.
  (* with this superfluous fsimpl we can see that the [shift >> (t[f] .: n__tm)] on the right evaluates to just n__tm *)
  (* fsimpl. *)
  setoid_rewrite instId_tm'.
  fsimpl.
  minimize.
  reflexivity.
  Restart.
  (* manually apply the tactics again but now we don't eta reduce after scons_comp which affects varL_tm and renComp. Both of these rewrites then fail *)
  auto_unfold.
  setoid_rewrite compComp_tm.
  unfold up_list_tm_tm, up_tm_tm, upRen_list_tm_tm, upRen_tm_tm, up_ren.
  unfold funcomp.
  setoid_rewrite scons_comp'.
  (* eta_reduce. *)
  (* the next rewrites all fail
   TODO make a MWE for this. It appears to fail because it's inside two lambdas (one of which can be removed by eta reduction) *)
  (* setoid_rewrite renComp_tm. *)
  (* setoid_rewrite varL_tm'. *)
  (* setoid_rewrite instId_tm'. *)
  (* fsimpl. *)
  (* minimize. *)
  (* reflexivity. *)
  (* Restart. *)
Abort.

Module MWE.
  (* As I thought the problem appears to be the eta expansion together with another operation (just fold without cons does not work) *)
  Parameter X : Type.
  Parameter op1 : (X -> X) -> X.
  Parameter op2 : X -> (X -> X) -> (X -> X).

  Instance op1_morphism:
    Proper (pointwise_relation _ eq ==> eq) op1.
  Proof.
  Admitted.

  Instance op2_morphism :
    Proper (eq ==> pointwise_relation _ eq ==> pointwise_relation _ eq) op2.
  Proof.
  Admitted.

  Lemma mwe (b:X) (f g h: X -> X) (H: forall x, f (g x) = h x) :
      op1 (op2 b (funcomp f g)) = op1 (op2 b h).
  Proof.
    unfold funcomp.
    setoid_rewrite H. reflexivity.
    Restart.
    unfold funcomp.
    change (op2 b (fun x => f (g x))) with (fun y => (op2 b (fun x => f (g x))) y).
    Set Typeclasses Debug.
    try setoid_rewrite H.
    (* needs eta reduction first *)
    eta_reduce.
    setoid_rewrite H.
    reflexivity.
  Qed.

  Lemma mwe2 (f g h: X -> X) (H: forall x, f (g x) = h x) :
    op1 (funcomp f g) = op1 h.
  Proof.
    unfold funcomp.
    setoid_rewrite H. reflexivity.
    Restart.
    unfold funcomp.
    change (fun x => f (g x)) with (fun y => (fun x => f (g x)) y).
    (* without op2 it works fine *)
    setoid_rewrite H.
    reflexivity.
  Qed.

  (* not sure if such an instance even makes sense. But it does not work *)
  Instance eta_morphism {A B:Type} :
    Proper (@pointwise_relation A B eq ==> @pointwise_relation A B eq) (fun f x => f x).
  Proof.
    intros f f' Hf x. apply Hf.
  Qed.

  Lemma mwe3 (b:X) (f g h: X -> X) (H: forall x, f (g x) = h x) :
      op1 (op2 b (funcomp f g)) = op1 (op2 b h).
  Proof.
    unfold funcomp.
    change (op2 b (fun x => f (g x))) with (fun y => (op2 b (fun x => f (g x))) y).
    Set Typeclasses Debug.
    try setoid_rewrite H.
    (* needs eta reduction first *)
    eta_reduce.
    setoid_rewrite H.
    reflexivity.
  Abort.

  Definition const (a b:X) := a.

  (* rewriting the part of the body of a function that does not depend on the argument seems possible *)
  Lemma rewrite_under_eta (a b:X) (H: a = b) :
    (fun x => const a x) = (fun x => const b x).
  Proof.
    rewrite H. reflexivity.
  Qed.

End MWE.


(** copied && added "C" **)
Require Export ZArith.
Require Export Znumtheory.
Require Export List.
Require Export Bool.

(** newly added **)
Require Export Coqlib.
Ltac check_safe := let n := numgoals in guard n < 2.
Require Export sflib.
From Paco Require Export paco.
Require Export Basics.

Require Import Relations.
Require Export RelationClasses.
Require Import Wellfounded.
Require Export Classical_Prop.
Require Export Lia.
Require Import AxiomsC.
Require Import Relation_Operators.
Require Export List.

Set Implicit Arguments.

Ltac determ_tac LEMMA :=
  let tac := eauto in
  let x := rev_all ltac:(fun f => apply f) in
  let y := all ltac:(fun f => apply f) in
  first[
      exploit LEMMA; [x|y|]
    | exploit LEMMA; [tac|x|y|]
    | exploit LEMMA; [tac|tac|x|y|]
    | exploit LEMMA; [tac|tac|tac|x|y|]
    | exploit LEMMA; [tac|tac|tac|tac|x|y|]
    ];
  i; des; clarify.

(* TODO: if it is mature enough, move it to sflib & remove this file *)

Definition update_fst {A B C: Type} (f: A -> C) (ab: A * B): C * B := (f (fst ab), (snd ab)).

Definition update_snd {A B C: Type} (f: B -> C) (ab: A * B): A * C := ((fst ab), f (snd ab)).

Lemma dep_split_right
      (A B: Prop) (PA: A)
      (PB: <<LEFT: A>> -> B):
    <<SPLIT: A /\ B>>.
Proof. split; eauto. Qed.

Lemma dep_split_left
      (A B: Prop)
      (PA: <<RIGHT: B>> -> A)
      (PB: B):
    A /\ B.
Proof. split; eauto. Qed.

Lemma list_forall2_map
      X Y (f: X -> Y) xs:
    list_forall2 (fun x0 x1 => x1 = f x0) xs (map f xs).
Proof. ginduction xs; ii; ss; econs; eauto. Qed.

Lemma list_forall2_map_right
      X Y (f: X -> Y) xs:
    list_forall2 (fun x0 x1 => x0 = f x1) (map f xs) xs.
Proof. ginduction xs; ii; ss; econs; eauto. Qed.

Lemma Forall_app A P (l0 l1: list A)
      (FORALL0: Forall P l0)
      (FORALL1: Forall P l1):
    Forall P (l0 ++ l1).
Proof. ginduction l0; i; ss. inv FORALL0. econs; eauto. Qed.

Lemma list_forall2_stronger
      X Y xs ys (P: X -> Y -> Prop) Q
      (FORALL2: list_forall2 P xs ys)
      (STRONGER: P <2= Q):
    <<FORALL2: list_forall2 Q xs ys>>.
Proof. ginduction FORALL2; ii; ss; econs; eauto. eapply IHFORALL2; eauto. Qed.

Global Program Instance incl_PreOrder {A}: PreOrder (@incl A).
Next Obligation. ii. ss. Qed.
Next Obligation. ii. eauto. Qed.

(* is_Some & is_None? a bit harder to type *)
Definition is_some {X} (x: option X): bool :=
  match x with
  | Some _ => true
  | _ => false
  end.

Definition is_none {X} := negb <*> (@is_some X).

Hint Unfold is_some is_none.

Notation "x $" := ((proj1_sig x)) (at level 50, no associativity (* , only parsing *)).

Notation top1 := (fun _ => True).
Notation top2 := (fun _ _ => True).
Notation top3 := (fun _ _ _ => True).
Notation top4 := (fun _ _ _ _ => True).
Notation top5 := (fun _ _ _ _ _ => True).
Notation top6 := (fun _ _ _ _ _ _ => True).

Notation " 'all1' p" := (forall x0, p x0) (at level 50, no associativity, only parsing).
Notation " 'all2' p" := (forall x0 x1, p x0 x1) (at level 50, no associativity, only parsing).
Notation " 'all3' p" := (forall x0 x1 x2, p x0 x1 x2) (at level 50, no associativity, only parsing).
Notation " 'all4' p" := (forall x0 x1 x2 x3, p x0 x1 x2 x3) (at level 50, no associativity, only parsing).

Notation " ~1 p" := (fun x0 => ~ (p x0)) (at level 50, no associativity).
Notation " ~2 p" := (fun x0 x1 => ~ (p x0 x1)) (at level 50, no associativity).
Notation " ~3 p" := (fun x0 x1 x2 => ~ (p x0 x1 x2)) (at level 50, no associativity).
Notation " ~4 p" := (fun x0 x1 x2 x3 => ~ (p x0 x1 x2 x3)) (at level 50, no associativity).

Notation "p /1\ q" := (fun x0 => and (p x0) (q x0)) (at level 50, no associativity).
Notation "p /2\ q" := (fun x0 x1 => and (p x0 x1) (q x0 x1)) (at level 50, no associativity).
Notation "p /3\ q" := (fun x0 x1 x2 => and (p x0 x1 x2) (q x0 x1 x2)) (at level 50, no associativity).
Notation "p /4\ q" := (fun x0 x1 x2 x3 => and (p x0 x1 x2 x3) (q x0 x1 x2 x3)) (at level 50, no associativity).

Notation "p -1> q" := (fun x0 => (forall (PR: p x0: Prop), q x0): Prop) (at level 50, no associativity).
Notation "p -2> q" := (fun x0 x1 => (forall (PR: p x0 x1: Prop), q x0 x1): Prop) (at level 50, no associativity).
Notation "p -3> q" := (fun x0 x1 x2 => ((forall (PR: p x0 x1 x2: Prop), q x0 x1 x2): Prop)) (at level 50, no associativity).
Notation "p -4> q" := (fun x0 x1 x2 x3 => (forall (PR: p x0 x1 x2 x3: Prop), q x0 x1 x2 x3): Prop) (at level 50, no associativity).

Goal all1 ((bot1: unit -> Prop) -1> top1). ii. ss. Qed.
Goal ((bot1: unit -> Prop) <1= top1). ii. ss. Qed.
Goal (bot2: unit -> unit -> Prop) <2= top2. ii. ss. Qed.

Definition less1 X0 (p q: X0 -> Prop) := (forall x0 (PR: p x0 : Prop), q x0 : Prop).
Definition less2 X0 X1 (p q: X0 -> X1 -> Prop) := (forall x0 x1 (PR: p x0 x1 : Prop), q x0 x1 : Prop).
Definition less3 X0 X1 X2 (p q: X0 -> X1 -> X2 -> Prop) := (forall x0 x1 x2 (PR: p x0 x1 x2 : Prop), q x0 x1 x2 : Prop).
Definition less4 X0 X1 X2 X3 (p q: X0 -> X1 -> X2 -> X3 -> Prop) := (forall x0 x1 x2 x3 (PR: p x0 x1 x2 x3 : Prop), q x0 x1 x2 x3 : Prop).

Notation "p <1= q" := (less1 p q) (at level 50).
Notation "p <2= q" := (less2 p q) (at level 50).
Notation "p <3= q" := (less3 p q) (at level 50).
Notation "p <4= q" := (less4 p q) (at level 50).

Global Program Instance less1_PreOrder X0: PreOrder (@less1 X0).
Next Obligation. ii. ss. Qed.
Next Obligation. ii. eapply H0; eauto. Qed.
Global Program Instance less2_PreOrder X0 X1: PreOrder (@less2 X0 X1).
Next Obligation. ii. ss. Qed.
Next Obligation. ii. eapply H0; eauto. Qed.
Global Program Instance less3_PreOrder X0 X1 X2: PreOrder (@less3 X0 X1 X2).
Next Obligation. ii. ss. Qed.
Next Obligation. ii. eapply H0; eauto. Qed.
Global Program Instance less4_PreOrder X0 X1 X2 X3 : PreOrder (@less4 X0 X1 X2 X3).
Next Obligation. ii. ss. Qed.
Next Obligation. ii. eapply H0; eauto. Qed.
Hint Unfold less1 less2 less3 less4.

Goal ((bot1: unit -> Prop) <1= top1). ii. ss. Qed.
Goal (bot2: unit -> unit -> Prop) <2= top2. ii. ss. Qed.

(* Notation "p =1= q" := (forall x0, eq (p x0) (q x0)) (at level 50, no associativity). *)
Notation "p =1= q" := (fun x0 => eq (p x0) (q x0)) (at level 50, no associativity).
Notation "p =2= q" := (fun x0 x1 => eq (p x0 x1) (q x0 x1)) (at level 50, no associativity).
Notation "p =3= q" := (fun x0 x1 x2 => eq (p x0 x1 x2) (q x0 x1 x2)) (at level 50, no associativity).
Notation "p =4= q" := (fun x0 x1 x2 x3 => eq (p x0 x1 x2 x3) (q x0 x1 x2 x3)) (at level 50, no associativity).

Notation "p <1> q" := (fun x0 => iff (p x0) (q x0)) (at level 50, no associativity).
Notation "p <2> q" := (fun x0 x1 => iff (p x0 x1) (q x0 x1)) (at level 50, no associativity).
Notation "p <3> q" := (fun x0 x1 x2 => iff (p x0 x1 x2) (q x0 x1 x2)) (at level 50, no associativity).
Notation "p <4> q" := (fun x0 x1 x2 x3 => iff (p x0 x1 x2 x3) (q x0 x1 x2 x3)) (at level 50, no associativity).

Lemma prop_ext1
      X0
      (P Q: X0 -> Prop)
      (IFF: all1 (P <1> Q)):
    <<EQ: all1 (P =1= Q)>>.
Proof. ss. ii. eapply prop_ext; eauto. Qed.

Lemma prop_ext2
      X0 X1
      (P Q: X0 -> X1 -> Prop)
      (IFF: all2 (P <2> Q)):
    <<EQ: all2 (P =2= Q)>>.
Proof. ss. ii. eapply prop_ext; eauto. Qed.

Lemma prop_ext3
      X0 X1 X2
      (P Q: X0 -> X1 -> X2 -> Prop)
      (IFF: all3 (P <3> Q)):
    <<EQ: all3 (P =3= Q)>>.
Proof. ss. ii. eapply prop_ext; eauto. Qed.

Lemma prop_ext4
      X0 X1 X2 X3
      (P Q: X0 -> X1 -> X2 -> X3 -> Prop)
      (IFF: all4 (P <4> Q)):
    <<EQ: all4 (P =4= Q)>>.
Proof. ss. ii. eapply prop_ext; eauto. Qed.

Lemma func_ext1
      X0 Y0
      (P Q: X0 -> Y0)
      (EQ: all1 (P =1= Q)):
    <<EQ: P = Q>>.
Proof. apply Axioms.functional_extensionality. ii; ss. Qed.

Lemma func_ext2
      X Y Z
      (P Q: X -> Y -> Z)
      (EQ: all2 (P =2= Q)):
    <<EQ: P = Q>>.
Proof. apply func_ext1; ss. i. apply func_ext1; ss. Qed.

Lemma func_ext3
      X Y Z W
      (P Q: X -> Y -> Z -> W)
      (EQ: all3 (P =3= Q)):
    <<EQ: P = Q>>.
Proof. apply func_ext2; ss. i. apply func_ext1; ss. Qed.

(* Originally in sflib, (t):Prop *)
(* Removed it for use in "privs" of ASTM *)
(* Notation "<< x : t >>" := (NW (fun x => (t))) (at level 80, x ident, no associativity). *)

Hint Unfold Basics.compose.

(* Note: not clos_refl_trans. That is not well-founded.. *)
Lemma well_founded_clos_trans
      index
      (order: index -> index -> Prop)
      (WF: well_founded order):
    <<WF: well_founded (clos_trans index order)>>.
Proof. hnf in WF. hnf. i. eapply Acc_clos_trans. eauto. Qed.

Lemma Forall2_impl
      X Y
      (xs: list X) (ys: list Y)
      (P Q: X -> Y -> Prop)
      (* (IMPL: all3 (P <3= Q)) *)
      (IMPL: (P <2= Q))
      (FORALL: Forall2 P xs ys):
    <<FORALL: Forall2 Q xs ys>>.
Proof. induction FORALL; econs; eauto. Qed.

Inductive Forall3 X Y Z (R: X -> Y -> Z -> Prop): list X -> list Y -> list Z -> Prop :=
| Forall3_nil: Forall3 R [] [] []
| Forall3_cons
    x y z xs ys zs
    (TAIL: Forall3 R xs ys zs):
    Forall3 R (x :: xs) (y :: ys) (z :: zs).

Lemma Forall3_impl
      X Y Z
      (xs: list X) (ys: list Y) (zs: list Z)
      (P Q: X -> Y -> Z -> Prop)
      (* (IMPL: all3 (P <3= Q)) *)
      (IMPL: (P <3= Q))
      (FORALL: Forall3 P xs ys zs):
    <<FORALL: Forall3 Q xs ys zs>>.
Proof. induction FORALL; econs; eauto. Qed.

Definition o_map A B (oa: option A) (f: A -> B): option B :=
  match oa with
  | Some a => Some (f a)
  | None => None
  end.

Definition o_join A (a: option (option A)): option A :=
  match a with
  | Some a => a
  | None => None
  end.

Definition o_bind A B (oa: option A) (f: A -> option B): option B := o_join (o_map oa f).
Hint Unfold o_map o_join o_bind.

Definition curry2 A B C (f: A -> B -> C): (A * B) -> C := fun ab => f (fst ab) (snd ab).

Definition o_bind2 A B C (oab: option (A * B)) (f: A -> B -> option C) : option C :=
o_join (o_map oab (curry2 f)).

(* Notation "o >>= f" := (o_bind o f) (at level 50, no associativity) : option_monad_scope. *)

(* Copied from Errors.v *)

Notation "'do' X <- A ; B" := (o_bind A (fun X => B))
 (at level 200, X ident, A at level 100, B at level 200)
 : o_monad_scope.

Notation "'do' ( X , Y ) <- A ; B" := (o_bind2 A (fun X Y => B))
 (at level 200, X ident, Y ident, A at level 100, B at level 200)
 : o_monad_scope.

Notation "'assertion' A ; B" := (if A then B else None)
  (at level 200, A at level 100, B at level 200, only parsing)
  : o_monad_scope.

Open Scope o_monad_scope.

Lemma o_bind_ignore
      X Y
      (x: option X) (y: option Y):
    (do _ <- x ; y) = assertion(x) ; y.
Proof. des_ifs. Qed.

Ltac subst_locals := all ltac:(fun H => is_local_definition H; subst H).

Hint Unfold flip.

Notation "p -1 q" := (p /1\ ~1 q) (at level 50).
Notation "p -2 q" := (p /2\ ~2 q) (at level 50).
Notation "p -3 q" := (p /3\ ~3 q) (at level 50).
Notation "p -4 q" := (p /4\ ~4 q) (at level 50).

Tactic Notation "u" "in" hyp(H) := repeat (autounfold with * in H; cbn in H).
Tactic Notation "u" := repeat (autounfold with *; cbn).
Tactic Notation "u" "in" "*" := repeat (autounfold with * in *; cbn in *).

Lemma dependent_split_right
      (A B: Prop)
      (PA: A)
      (PB: <<HINTLEFT: A>> -> B):
    <<PAB: A /\ B>>.
Proof. eauto. Qed.

Lemma dependent_split_left
      (A B: Prop)
      (PA: <<HINTRIGHT: B>> -> A)
      (PB: B):
    <<PAB: A /\ B>>.
Proof. eauto. Qed.

Ltac dsplit_r := eapply dependent_split_right.
Ltac dsplit_l := eapply dependent_split_left.
Ltac dsplits :=
  repeat (let NAME := fresh "SPLITHINT" in try (dsplit_r; [|intro NAME])).

Locate des_sumbool.
(* TODO: Update Coqlib *)
Lemma proj_sumbool_is_false
      P
      (a: {P} + {~ P})
      (FALSE: ~ P):
    <<FALSE: proj_sumbool a = false>>.
Proof. unfold proj_sumbool. des_ifs. Qed.

Ltac des_sumbool :=
  repeat
    (unfold Datatypes.is_true, is_true in *;
     match goal with
     | [ H: proj_sumbool ?x = true |- _ ] => apply proj_sumbool_true in H
     | [ H: proj_sumbool ?x = false |- _ ] => apply proj_sumbool_false in H
     | [ H: true = proj_sumbool ?x |- _ ] => symmetry in H; apply proj_sumbool_true in H
     | [ H: false = proj_sumbool ?x |- _ ] => symmetry in H; apply proj_sumbool_false in H

     | [ |- proj_sumbool ?x = true ] => apply proj_sumbool_is_true
     | [ |- proj_sumbool ?x = false ] => apply proj_sumbool_is_false
     | [ |- true = proj_sumbool ?x ] => symmetry; apply proj_sumbool_is_true
     | [ |- false = proj_sumbool ?x ] => symmetry; apply proj_sumbool_is_false
     end).

Ltac is_prop H :=
  let ty := type of H in
  match type of ty with
  | Prop => idtac
  | _ => fail 1
  end.

Ltac all_prop TAC := all ltac:(fun H => tryif is_prop H then TAC H else idtac).

Ltac all_prop_inv := all_prop inv.
(* TODO: infinite loop when inv-ing "a+b = c+d". "progress" tactic does not help here. *)
(* TODO: add all_once, which captures only current hypotheses and apply TAC *)

Ltac all_rewrite := all ltac:(fun H => rewrite_all H).

Definition bar_True: Type := True.
Global Opaque bar_True.
Ltac bar :=
  let NAME := fresh
                "TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT" in
  assert(NAME: bar_True) by ss.

Ltac clear_until id :=
  on_last_hyp ltac:(fun id' => match id' with
                               | id => idtac
                               | _ => clear id'; clear_until id
                               end).

Ltac clear_until_bar :=
  on_last_hyp ltac:(fun id' => match (type of id') with
                               | bar_True => idtac
                               | _ => clear id'; clear_until_bar
                               end).

Goal True -> True -> False.
  intro. bar. intro. clear_until H0. clear_until H. Undo 2. clear_until_bar. clear_tac.
Abort.

Definition aof_true: Type := True.
Global Opaque aof_true.

Ltac all_once_fast TAC :=
  generalize (I: aof_true);
  let name := fresh "bar" in
  assert(name: aof_true) by constructor; move name at top; revert_until name;
  repeat
    match goal with
    | [ |- aof_true -> _ ] => fail 1
    | _ => intro; on_last_hyp TAC
    end;
  intro; on_last_hyp ltac:(fun H => clear H);
  clear name.

Goal forall (a b c d e: bool) f,
    (negb true = false) -> (* IT SHOULD NOT RUN INF LOOP *)
    (negb false = true) ->
    (negb a = true) ->
    (negb b = true) ->
    (negb c = true) ->
    True -> (* SHOULD IGNORE THIS *)
    (negb d = true) ->
    (negb e = true) ->
    (0 :: 2 :: nil = f) -> (* SHOULD IGNORE THIS *)
    (negb (true && false) = true) -> True -> False.
Proof.
  i. revert H9. all_once_fast ltac:(fun H => try apply negb_true_iff in H).
Abort.

Ltac spc H :=
  let TAC := ss; eauto in
  let ty := type of H in
  match eval hnf in ty with
  | forall (a: ?A), _ =>
    (* let A := (eval compute in _A) in *)
    match goal with
    | [a0: A, a1: A, a2: A, a3: A, a4: A, a5: A |- _] => fail 2 "6 candidates!" a0 "," a1 "," a2 "," a3 "," a4 "," a5
    | [a0: A, a1: A, a2: A, a3: A, a4: A |- _] => fail 2 "5 candidates!" a0 "," a1 "," a2 "," a3 "," a4
    | [a0: A, a1: A, a2: A, a3: A |- _] => fail 2 "4 candidates!" a0 "," a1 "," a2 "," a3
    | [a0: A, a1: A, a2: A |- _] => fail 2 "3 candidates!" a0 "," a1 "," a2
    | [a0: A, a1: A |- _] => fail 2 "2 candidates!" a0 "," a1
    | [a0: A |- _] => specialize (H a0)
    | _ =>
      tryif is_prop A
      then
        let name := fresh in
        assert(name: A) by TAC; specialize (H name); clear name
      else
        fail 2 "No specialization possible!"
    end
  | _ => fail 1 "Nothing to specialize!"
  end.

Ltac spcN n H :=
  let TAC := ss; eauto in
  let ty := type of H in
  match type of n with
  | Z => idtac
  | _ => fail "second argument should be 'Z'"
  end;
  match eval hnf in ty with
  | forall (a: ?A), _ =>
    (* let A := (eval compute in _A) in *)
    match goal with
    | [a0: A, a1: A, a2: A, a3: A, a4: A, a5: A |- _] =>
      match n with
      | - 5 => specialize (H a1)
      | - 4 => specialize (H a2)
      | - 3 => specialize (H a3)
      | - 2 => specialize (H a4)
      | - 1 => specialize (H a5)
      | 0%Z => specialize (H a0)
      | 1%Z => specialize (H a1)
      | 2%Z => specialize (H a2)
      | 3%Z => specialize (H a3)
      | 4%Z => specialize (H a4)
      | 5%Z => specialize (H a5)
      | _ => fail 2 "6 candidates!" a0 "," a1 "," a2 "," a3 "," a4 "," a5
      end
    | [a0: A, a1: A, a2: A, a3: A, a4: A |- _] =>
      match n with
      | - 4 => specialize (H a1)
      | - 3 => specialize (H a2)
      | - 2 => specialize (H a3)
      | - 1 => specialize (H a4)
      | 0%Z => specialize (H a0)
      | 1%Z => specialize (H a1)
      | 2%Z => specialize (H a2)
      | 3%Z => specialize (H a3)
      | 4%Z => specialize (H a4)
      | _ => fail 2 "5 candidates!" a0 "," a1 "," a2 "," a3 "," a4
      end
    | [a0: A, a1: A, a2: A, a3: A |- _] =>
      match n with
      | - 3 => specialize (H a1)
      | - 2 => specialize (H a2)
      | - 1 => specialize (H a3)
      | 0%Z => specialize (H a0)
      | 1%Z => specialize (H a1)
      | 2%Z => specialize (H a2)
      | 3%Z => specialize (H a3)
      | _ => fail 2 "4 candidates!" a0 "," a1 "," a2 "," a3
      end
    | [a0: A, a1: A, a2: A |- _] =>
      match n with
      | - 2 => specialize (H a1)
      | - 1 => specialize (H a2)
      | 0%Z => specialize (H a0)
      | 1%Z => specialize (H a1)
      | 2%Z => specialize (H a2)
      | _ => fail 2 "3 candidates!" a0 "," a1 "," a2
      end
    | [a0: A, a1: A |- _] =>
      match n with
      | - 1 => specialize (H a1)
      | 0%Z => specialize (H a0)
      | 1%Z => specialize (H a1)
      | _ => fail 2 "2 candidates!" a0 "," a1
      end
    | [a0: A |- _] => specialize (H a0)
    | _ =>
      tryif is_prop A
      then
        let name := fresh in
        assert(name: A) by TAC; specialize (H name); clear name
      else
        fail 2 "No specialization possible!"
    end
  | _ => fail 1 "Nothing to specialize!"
  end.

Goal let my_nat := nat in
     let my_f := my_nat -> Prop in
     forall (f: my_f) (g: nat -> Prop) (x: nat) (y: my_nat), False.
  i. spc f. spc g.
Abort.

Lemma map_ext_strong
      X Y (f g: X -> Y) xs
      (EXT: forall x (IN: In x xs), f x = g x):
    map f xs = map g xs.
Proof.
  ginduction xs; ii; ss. exploit EXT; eauto. i; des.
  f_equal; ss. eapply IHxs; eauto.
Qed.

(* copied from : https://robbertkrebbers.nl/research/ch2o/tactics.html *)
Hint Extern 998 (_ = _) => f_equal : f_equal.
Hint Extern 999 => congruence : congruence.
Hint Extern 1000 => lia : lia.

Section ALIGN.

  Lemma align_refl
        x
        (NONNEG: x >= 0):
    <<ALIGN: align x x = x>>.
  Proof.
    destruct (Z.eqb x 0) eqn: T.
    { rewrite Z.eqb_eq in T. clarify. }
    rewrite Z.eqb_neq in T. red. unfold align.
    replace ((x + x - 1) / x) with 1.
    { xomega. }
    replace (x + x - 1) with (1 * x + (1 * x + (- 1))); cycle 1.
    { xomega. }
    rewrite Z.div_add_l; try eassumption.
    rewrite Z.div_add_l; try eassumption.
    replace (Z.div (Zneg xH) x) with (Zneg xH).
    { xomega. }
    destruct x; ss. clear - p. unfold Z.div. des_ifs. ginduction p; i; ss; des_ifs.
  Qed.

  Lemma align_zero: forall x, <<ALIGN: align x 0 = 0>>.
  Proof. i. unfold align. red. ss. xomega. Qed.

  Lemma align_divisible
        z y
        (DIV: (y | z))
        (NONNEG: y > 0):
      <<ALIGN: align z y = z>>.
  Proof.
    red. unfold align.
    replace ((z + y - 1) / y) with (z / y + (y - 1) / y); cycle 1.
    { unfold Z.divide in *. des. clarify. rewrite Z_div_mult; ss.
      replace (z0 * y + y - 1) with (z0 * y + (y - 1)); cycle 1.
      { xomega. }
      rewrite Z.div_add_l with (b := y); ss. xomega.
    }
    replace ((y - 1) / y) with 0; cycle 1.
    { erewrite Zdiv_small; ss. xomega. }
    unfold Z.divide in *. des. clarify. rewrite Z_div_mult; ss. rewrite Z.add_0_r. xomega.
  Qed.

  Lemma align_idempotence
        x y
        (NONNEG: y > 0):
      <<ALIGN: align (align x y) y = align x y>>.
  Proof. apply align_divisible; ss. apply align_divides; ss. Qed.

End ALIGN.

Hint Rewrite align_refl: align.
Hint Rewrite align_zero: align.
Hint Rewrite align_idempotence: align.

Ltac inv_all_once := all_once_fast ltac:(fun H => try inv H).
Ltac apply_all_once LEMMA :=  all_once_fast ltac:(fun H => try apply LEMMA in H).

Lemma find_map
      X Y (f: Y -> bool) (x2y: X -> Y) xs:
    find f (map x2y xs) = o_map (find (f <*> x2y) xs) x2y.
Proof. u. ginduction xs; ii; ss. des_ifs; ss. Qed.

Ltac revert_until_bar :=
  on_last_hyp ltac:(fun id' => match (type of id') with
                               | bar_True => idtac
                               | _ => revert id'; revert_until_bar
                               end).

(* Ltac folder := all_once_fast ltac:(fun H => try (is_local_definition H; fold_all H)). *)
Ltac folder :=
  repeat multimatch goal with
         | [ H: _ |- _ ] => is_local_definition H; fold_all H
         end.

(* copied from promising/lib/Basic.v *)

Ltac refl := reflexivity.
Ltac etrans := etransitivity.
Ltac congr := congruence.

Notation rtc := (clos_refl_trans_1n _). (* reflexive transitive closure *)
Notation rc := (clos_refl _). (* reflexive transitive closure *)
Notation tc := (clos_trans _). (* transitive closure *)
Hint Immediate rt1n_refl rt1n_trans t_step.

Program Instance rtc_PreOrder A (R:A -> A -> Prop): PreOrder (rtc R).
Next Obligation.
  ii. revert H0. induction H; auto. i. exploit IHclos_refl_trans_1n; eauto.
Qed.

Lemma rtc_tail A R
      (a1 a3:A)
      (REL: rtc R a1 a3):
  (exists a2, rtc R a1 a2 /\ R a2 a3) \/
  (a1 = a3).
Proof.
  induction REL; auto. des; subst; left; eexists; splits; [|eauto| | eauto]; econs; eauto.
Qed.

Lemma rtc_implies A (R1 R2: A -> A -> Prop)
      (IMPL: R1 <2= R2):
  rtc R1 <2= rtc R2.
Proof.
  ii. induction PR; eauto. etrans; [|eauto]. econs 2; [|econs 1]. apply IMPL. auto.
Qed.

Lemma rtc_refl
      A R (a b:A)
      (EQ: a = b):
  rtc R a b.
Proof. subst. econs. Qed.

Lemma rtc_n1
      A R (a b c:A)
      (AB: rtc R a b)
      (BC: R b c):
  rtc R a c.
Proof. etrans; eauto. econs 2; eauto. Qed.

Lemma rtc_reverse
      A R (a b:A)
      (RTC: rtc R a b):
  rtc (fun x y => R y x) b a.
Proof. induction RTC; eauto. etrans; eauto. econs 2; eauto. Qed.

Lemma rtc_once
      A (R: A -> A -> Prop) a b
      (ONCE: R a b):
    rtc R a b.
Proof. econs; eauto. Qed.

Lemma Forall2_length
      X Y (P: X -> Y -> Prop) xs ys
      (FORALL2: Forall2 P xs ys):
    length xs = length ys.
Proof. ginduction FORALL2; ii; ss. xomega. Qed.

Ltac hexpl_aux H NAME :=
  let n := fresh NAME in
  first[hexploit H; eauto; check_safe; repeat intro n; des].
Tactic Notation "hexpl" constr(H) := hexpl_aux H H.
(* Tactic Notation "hexpl" constr(H) tactic(TAC) := hexpl_aux H TAC. *)
Tactic Notation "hexpl" constr(H) ident(NAME) := hexpl_aux H NAME.

(* 0 goal *)
Goal forall (mytt: unit) (H: unit -> False), False.
  i. hexpl H.
Qed.

(* 1 goal *)
Goal forall (H: nat -> False), False.
  i. hexpl H.
Abort.

Goal forall (H: nat -> nat -> False), False.
  i. Fail hexpl H.
Abort.

(* name *)
Goal forall (mytt: unit) (HH: unit -> (True -> True /\ True)), False.
  i. hexpl HH ABC. hexpl HH.
Abort.

Hint Extern 997 => xomega : xomega.

Hint Rewrite
     Z.add_0_l Z.add_0_r Z.add_assoc Z.add_simpl_l Z.add_simpl_r Z.add_opp_r Z.add_opp_l
     Z.mul_0_l Z.mul_0_r Z.mul_assoc
     Z.sub_0_r Z.sub_diag Z.sub_simpl_l Z.sub_simpl_r Z.sub_0_l
     Z.div_0_l Zdiv_0_r Z.div_1_r
     Z.mod_1_r Z.mod_0_l Z.mod_same Z.mod_mul Z.mod_mod
     Z.sub_add
  : zsimpl.

Ltac zsimpl := repeat autorewrite with zsimpl in *.

Ltac rp := first [erewrite f_equal8|
                  erewrite f_equal7|
                  erewrite f_equal6|
                  erewrite f_equal5|
                  erewrite f_equal4|
                  erewrite f_equal3|
                  erewrite f_equal2|
                  erewrite f_equal|
                  fail].

Ltac align_bool :=
  (repeat match goal with
          | [ H: true <> true |- _ ] => tauto
          | [ H: false <> false |- _ ] => tauto
          | [ H: true <> _ |- _ ] => symmetry in H
          | [ H: false <> _ |- _ ] => symmetry in H
          | [ H: _ <> true |- _ ] => apply not_true_is_false in H
          | [ H: _ <> false |- _ ] => apply not_false_is_true in H
          end).
Ltac simpl_bool := unfold Datatypes.is_true in *; unfold is_true in *; autorewrite with simpl_bool in *.
Ltac bsimpl := simpl_bool.

Definition range (lo hi: Z): Z -> Prop := fun x => lo <= x < hi. (* TODO: Use Notation instead *)
Hint Unfold range.

Ltac sym := symmetry.
Tactic Notation "sym" "in" hyp(H) := symmetry in H.

Ltac eapply_all_once LEMMA :=
  all_once_fast ltac:(fun H => try eapply LEMMA in H; try eassumption; check_safe).

Ltac Nsimpl := all_once_fast ltac:(fun H => try apply NNPP in H; try apply not_and_or in H; try apply not_or_and in H).

Ltac hexploit1 H :=
  match goal with
  | [ H: ?A -> ?B |- _ ] =>
    apply (@mp B); [apply H|clear H; intro H]
  end.

Lemma rev_nil
      X (xs: list X)
      (NIL: rev xs = []):
    xs = [].
Proof.
  generalize (f_equal (@length _) NIL). i. ss. destruct xs; ss. rewrite app_length in *. ss. xomega.
Qed.

Fixpoint last_opt X (xs: list X): option X :=
  match xs with
  | [] => None
  | [hd] => Some hd
  | hd :: tl => last_opt tl
  end.

Lemma last_none
      X (xs: list X)
      (NONE: last_opt xs = None):
    xs = [].
Proof. ginduction xs; ii; ss. des_ifs. spc IHxs. ss. Qed.

Lemma last_some
      X (xs: list X) x
      (SOME: last_opt xs = Some x):
    exists hds, xs = hds ++ [x].
Proof.
  ginduction xs; ii; ss. des_ifs.
  { exists nil. ss. }
  exploit IHxs; eauto. i; des. rewrite H. exists (a :: hds). ss.
Qed.

Lemma forall2_eq
      X Y (P: X -> Y -> Prop) xs ys:
    list_forall2 P xs ys <-> Forall2 P xs ys.
Proof. split; i; ginduction xs; ii; ss; inv H; ss; econs; eauto. Qed.

(* Fixpoint zip X Y Z (f: option X -> option Y -> Z) (xs: list X) (ys: list Y): list Z := *)
(*   match xs, ys with *)
(*   | [], [] => [] *)
(*   | xhd :: xtl, [] => f (Some xhd) None :: zip f xtl [] *)
(*   | [], yhd :: ytl => f None (Some yhd) :: zip f [] ytl *)
(*   | xhd :: xtl, yhd :: ytl => f (Some xhd) (Some yhd) :: zip f xtl ytl *)
(*   end *)
(* . *)

Fixpoint zip X Y Z (f: X -> Y -> Z) (xs: list X) (ys: list Y): list Z :=
  match xs, ys with
  | xhd :: xtl, yhd :: ytl => f xhd yhd :: zip f xtl ytl
  | _, _ => []
  end.

Lemma zip_length
      X Y Z (f: X -> Y -> Z) xs ys:
    length (zip f xs ys) = min xs.(length) ys.(length).
Proof. ginduction xs; ii; ss. des_ifs. ss. rewrite IHxs. xomega. Qed.

Lemma in_zip_iff
      X Y Z (f: X -> Y -> Z) xs ys z:
    (<<ZIP: In z (zip f xs ys)>>)
    <-> (exists x y, <<F: f x y = z>> /\ exists n, <<X: nth_error xs n = Some x>> /\ <<Y: nth_error ys n = Some y>>).
Proof.
  split; ii.
  - ginduction xs; ii; ss. des_ifs. ss. des; ss.
    + esplits; eauto; try instantiate (1 := 0%nat); ss.
    + exploit IHxs; eauto. i; des. esplits; eauto; try instantiate (1:= (1+n)%nat); ss.
  - des. ginduction n; ii; ss.
    { des_ifs. ss. left; ss. }
    des_ifs. ss. exploit (@IHn _ _ _ f); eauto.
Qed.

Global Opaque Z.mul.

Lemma unit_ord_wf: well_founded (bot2: unit -> unit -> Prop).
Proof. ii. induction a; ii; ss. Qed.

Ltac et:= eauto.

Require Import Program.

Lemma f_equal_h
      X1 X2 Y1 Y2 (f1: X1 -> Y1) (f2: X2 -> Y2) x1 x2
      (TYPX: X1 = X2)
      (FUNC: f1 ~= f2)
      (ARG: x1 ~= x2)
      (TYPY: Y1 = Y2): (* Do we need this? *)
    f1 x1 ~= f2 x2.
Proof. subst. eapply JMeq_eq in ARG. subst. ss. Qed.

Lemma f_equal_hr
      X1 X2 Y (f1: X1 -> Y) (f2: X2 -> Y) x1 x2
      (FUNC: f1 ~= f2)
      (TYP: X1 = X2)
      (ARG: x1 ~= x2):
    f1 x1 = f2 x2.
Proof. eapply JMeq_eq. eapply f_equal_h; eauto. Qed.

Lemma f_equal_rh
      X Y1 Y2 (f1: X -> Y1) (f2: X -> Y2) x
      (FUNC: f1 ~= f2)
      (TYP: Y1 = Y2):
    f1 x ~= f2 x.
Proof. eapply f_equal_h; eauto. Qed.

Lemma cons_app
      X xhd (xtl: list X):
    xhd :: xtl = [xhd] ++ xtl.
Proof. ss. Qed.

Lemma list_map_injective A B (f: A -> B)
      (INJECTIVE: forall a0 a1 (EQ: f a0 = f a1), a0 = a1)
      l0 l1
      (LEQ: map f l0 = map f l1):
    l0 = l1.
Proof.
  revert l1 LEQ. induction l0; i; ss; destruct l1; ss. inv LEQ. f_equal; eauto.
Qed.

Lemma Forall_in_map A B al (R: B -> Prop) (f: A -> B)
      (RMAP: forall a (IN: In a al), R (f a)):
    Forall R (map f al).
Proof. induction al; econs; ss; eauto. Qed.

Lemma Forall2_in_map A B al (R: B -> A -> Prop) (f: A -> B)
      (RMAP: forall a (IN: In a al), R (f a) a):
    list_forall2 R (map f al) al.
Proof. induction al; econs; ss; eauto. Qed.

Lemma eq_Forall2_eq A (al0 al1 : list A):
    list_forall2 eq al0 al1 <-> al0 = al1.
Proof.
  revert al1. induction al0; ss; i; split; i; eauto; inv H; try econs; eauto.
  - f_equal. eapply IHal0. eauto.
  - eapply IHal0. eauto.
Qed.

Lemma list_forall2_lift A B (R0 R1: A -> B -> Prop) al bl
      (SAME: forall a (IN: In a al) b, R0 a b -> R1 a b)
      (FORALL: list_forall2 R0 al bl):
    list_forall2 R1 al bl.
Proof.
  generalize dependent bl. revert SAME. induction al; ss; i; inv FORALL; econs; eauto.
Qed.

Lemma Forall_map A B la (R: B -> Prop) (f: A -> B)
      (RMAP: forall a, R (f a)):
    Forall R (map f la).
Proof. induction la; econs; ss. Qed.

Lemma f_hequal A (B : A -> Type) (f : forall a, B a)
      a1 a2 (EQ : a1 = a2):
    f a1 ~= f a2.
Proof. destruct EQ. econs. Qed.

Lemma list_forall2_rev A B R (la: list A) (lb: list B)
      (FORALL: list_forall2 R la lb):
    list_forall2 (flip R) lb la.
Proof.
  generalize dependent lb. induction la; i; eauto; inv FORALL; econs; eauto.
Qed.

Ltac uo := unfold o_bind, o_map, o_join in *.

Lemma some_injective
      X (x0 x1: X)
      (EQ: Some x0 = Some x1):
    x0 = x1.
Proof. injection EQ. auto. Qed.

Ltac align_opt :=
  repeat
    match goal with
    (* remove trivial things *)
    | H: Some ?x = Some ?y |- _ => rewrite some_injective in H
    | H: Some _ = None |- _ => by (inversion H)
    | H: None = Some _ |- _ => by (inversion H)
    | H: None = None |- _ => clear H
    (* align *)
    | H: Some _ = ?x |- _ => symmetry in H
    | H: None = ?x |- _ => symmetry in H
    end.
(* Ltac clarify0 := repeat (align_opt; progress clarify). *)

Fixpoint list_diff X (dec: (forall x0 x1, {x0 = x1} + {x0 <> x1})) (xs0 xs1: list X): list X :=
  match xs0 with
  | [] => []
  | hd :: tl =>
    if in_dec dec hd xs1
    then list_diff dec tl xs1
    else hd :: list_diff dec tl xs1
  end.

Lemma list_diff_spec
      X dec (xs0 xs1 xs2: list X)
      (DIFF: list_diff dec xs0 xs1 = xs2):
    <<SPEC: forall x0, In x0 xs2 <-> (In x0 xs0 /\ ~ In x0 xs1)>>.
Proof.
  subst. split; i.
  - ginduction xs0; ii; des; ss. des_ifs.
    { exploit IHxs0; et. i; des. esplits; et. }
    ss. des; clarify.
    { tauto. }
    exploit IHxs0; et. i; des. esplits; et.
  - ginduction xs0; ii; des; ss. des; clarify; des_ifs; ss; try tauto; exploit IHxs0; et.
Qed.

Fixpoint last_option X (xs: list X): option X :=
  match xs with
  | [] => None
  | hd :: nil => Some hd
  | hd :: tl => last_option tl
  end.
Lemma not_ex_all_not
      U (P: U -> Prop)
      (NEX: ~ (exists n : U, P n)):
    <<NALL: forall n : U, ~ P n>>.
Proof. eauto. Qed.

(* Remark: if econs/econsr gives different goal, at least 2 econs is possible *)
Ltac econsr :=
  first
    [ econstructor 16
     |econstructor 15
     |econstructor 14
     |econstructor 13
     |econstructor 12
     |econstructor 11
     |econstructor 10
     |econstructor  9
     |econstructor  8
     |econstructor  7
     |econstructor  6
     |econstructor  5
     |econstructor  4
     |econstructor  3
     |econstructor  2
     |econstructor  1].

Ltac it TERM := instantiate (1:=TERM).
Ltac itl TERM :=
  first[ instantiate (10:=TERM)|
         instantiate (9:=TERM)|
         instantiate (8:=TERM)|
         instantiate (7:=TERM)|
         instantiate (6:=TERM)|
         instantiate (5:=TERM)|
         instantiate (4:=TERM)|
         instantiate (3:=TERM)|
         instantiate (2:=TERM)|
         instantiate (1:=TERM)|
         fail].

Lemma NoDup_norepet
      X (xs: list X):
    NoDup xs <-> list_norepet xs.
Proof. split; induction 1; econs; ss. Qed.

Ltac swapname NAME1 NAME2 :=
  let tmp := fresh "TMP" in
  rename NAME1 into tmp; rename NAME2 into NAME1; idtac NAME1; rename tmp into NAME2
.

Global Program Instance top2_PreOrder X: PreOrder (top2: X -> X -> Prop).

Lemma app_eq_inv
      A (x0 x1 y0 y1: list A)
      (EQ: x0 ++ x1 = y0 ++ y1)
      (LEN: x0.(length) = y0.(length)):
    x0 = y0 /\ x1 = y1.
Proof.
  ginduction x0; ii; ss.
  { destruct y0; ss. }
  destruct y0; ss. clarify. exploit IHx0; eauto. i; des. clarify.
Qed.

Lemma pos_elim_succ: forall p,
    <<ONE: p = 1%positive>> \/
    <<SUCC: exists q, (Pos.succ q) = p>>.
Proof. i. hexploit (Pos.succ_pred_or p); eauto. i; des; ss; eauto. Qed.

Lemma ple_elim_succ
      p q
      (PLE: Ple p q):
    <<EQ: p = q>> \/
    <<SUCC: Ple (Pos.succ p) q>>.
Proof.
  revert_until p. pattern p. apply Pos.peano_ind; clear p; i.
  { hexploit (pos_elim_succ q); eauto. i. des; clarify; eauto. right. r. xomega. }
  hexploit (pos_elim_succ q); eauto. i. des; clarify.
  { left. xomega. }
  exploit H; eauto.
  { it q0. xomega. }
  i; des; clarify.
  - left. r. xomega.
  - right. r. xomega.
Qed.

Section FLIPS.

Definition flip2 A B C D: (A -> B -> C -> D) -> A -> C -> B -> D. intros; eauto. Defined.
Definition flip3 A B C D E: (A -> B -> C -> D -> E) -> A -> B -> D -> C -> E. intros; eauto. Defined.
Definition flip4 A B C D E F: (A -> B -> C -> D -> E -> F) -> A -> B -> C -> E -> D -> F. intros; eauto. Defined.

Variable A B C D: Type.
Variable f: A -> B -> C -> D.

Let put_dummy_arg_without_filp A DUMMY B: (A -> B) -> (A -> DUMMY -> B) := fun f => (fun a _ => f a).
Let put_dummy_arg1 A DUMMY B: (A -> B) -> (A -> DUMMY -> B) := fun f => (flip (fun _ => f)).
Let put_dummy_arg21 A DUMMY B C: (A -> B -> C) -> (A -> DUMMY -> B -> C) := fun f => (flip (fun _ => f)).
Let put_dummy_arg22 A B DUMMY C: (A -> B -> C) -> (A -> B -> DUMMY -> C) :=
  fun f => (flip2 (flip (fun _ => f))).

End FLIPS.
Hint Unfold flip2 flip3 flip4.

Definition DUMMY_PROP := True.
Hint Unfold DUMMY_PROP.

Ltac clarify_meq :=
  repeat
    match goal with
    | [ H0: ?A m= ?B |- _ ] => inv H0
    | [ H0: ?A = ?A -> _ |- _ ] => exploit H0; eauto; check_safe; intro; des; clear H0
    end;
    clarify.

Local Transparent list_nth_z.
Lemma list_nth_z_eq
      A (l: list A) z
      (POS: 0 <= z):
    list_nth_z l z = List.nth_error l (Z.to_nat z).
Proof.
  ginduction l; ii; ss.
  - destruct ((Z.to_nat z)); ss.
  - des_ifs. destruct (Z.to_nat) eqn:T; ss.
    + destruct z; ss. destruct p; ss. xomega.
    + rewrite IHl; ss; eauto; try xomega. rewrite Z2Nat.inj_pred. rewrite T. ss.
Qed.
Local Opaque list_nth_z.

Lemma list_nth_z_firstn
      (A:Type) (l: list A) n x
      (T:list_nth_z l n = Some x):
      list_nth_z (firstn (Z.to_nat (n + 1)) l) n = Some x.
Proof.
  exploit list_nth_z_range; eauto. intro RANGE; des.
  rewrite list_nth_z_eq in *; try xomega. rewrite Z2Nat.inj_add; ss. rewrite Pos2Nat.inj_1. rewrite Nat.add_comm.
  exploit nth_error_Some; et. intro X. rewrite T in X. des.
  exploit X; eauto. { ss. } intro Y.
  erewrite <- (firstn_skipn (1 + (Z.to_nat n)) l) in T.
  rewrite nth_error_app1 in T; eauto. rewrite firstn_length. xomega.
Qed.

Lemma firstn_S
      (A: Type) (l: list A) n:
      (le (Datatypes.length l) n /\ firstn (n + 1) l = firstn n l)
    \/ (lt n (Datatypes.length l) /\ exists x, firstn (n + 1) l = (firstn n l) ++ [x]).
Proof.
  ginduction l; i; try by (left; do 2 rewrite firstn_nil; split; ss; omega). destruct n.
  { right. ss. split; try omega. eauto. }
  specialize (IHl n). ss. des.
  - left. split; try omega. rewrite IHl0. ss.
  - right. split; try omega. rewrite IHl0. eauto.
Qed.

Lemma map_firstn
      (A B: Type) (l: list A) (f: A -> B) n:
    map f (firstn n l) = firstn n (map f l).
Proof.
  ginduction l; ss; i.
  { ss. do 2 rewrite firstn_nil. ss. }
  destruct n; ss. rewrite IHl. ss.
Qed.

Lemma list_nth_z_map
      (A B: Type) (l: list A) n x (f: A -> B)
      (NTH: list_nth_z l n = Some x):
    list_nth_z (map f l) n = Some (f x).
Proof.
  exploit list_nth_z_range; eauto. intro RANGE; des.
  rewrite list_nth_z_eq in *; try xomega. rewrite list_map_nth in *. rewrite NTH. ss.
Qed.

Lemma tail_In A l0 l1 (a: A)
      (IN: In a l0)
      (TAIL: is_tail l0 l1):
    In a l1.
Proof. induction TAIL; auto. econs 2; eauto. Qed.

Lemma Forall2_apply_Forall2 A B C D (f: A -> C) (g : B -> D)
      (P: A -> B -> Prop) (Q: C -> D -> Prop)
      la lb
      (FORALL: Forall2 P la lb)
      (IMPLY: forall a b (INA: In a la) (INB: In b lb),
          P a b -> Q (f a) (g b)):
    Forall2 Q (map f la) (map g lb).
Proof.
  ginduction la; ss; i; inv FORALL; ss. econs; eauto.
Qed.

Lemma forall2_in_exists A B (P: A -> B -> Prop) la lb
      (ALL: list_forall2 P la lb)
      a
      (IN: In a la):
    exists b, (<<IN: In b lb>>) /\ (<<SAT: P a b>>).
Proof.
  revert la lb ALL a IN. induction la; ss.
  i. inv ALL. des.
  - clarify. esplits; eauto. econs. auto.
  - eapply IHla in H3; eauto. des. esplits; eauto. econs 2. auto.
Qed.


From Typonomikon Require Import F3. (* Streams. *)

Inductive SPXY (X Y A B : Type) : Type :=
| PutX : B -> X -> SPXY X Y A B
| GetX : (A -> Y) -> SPXY X Y A B.

Arguments PutX {X Y A B} _ _.
Arguments GetX {X Y A B} _.

CoInductive SP' (A B : Type) : Type :=
{
  Out : SPXY (SP' A B) (SP' A B) A B;
}.

Arguments Out {A B} _.

Inductive WF {A B : Type} : SP' A B -> Type :=
| WF_Put :
    forall (sp : SP' A B) (h : B) (t : SP' A B),
      Out sp = PutX h t -> WF sp
| wF_Get :
    forall (sp : SP' A B) (get : A -> SP' A B),
      Out sp = GetX get -> (forall a : A, WF (get a)) -> WF sp.

Record SP (A B : Type) : Type :=
{
  sp : SP' A B;
  wf : WF sp;
}.

Definition compSP {A B C : Type} (f : SP A B) (g : SP B C) : SP A C.
Proof.
  esplit. Unshelve. all: cycle 1.
  - destruct f as [f wff], g as [g wfg].
    revert f g wff wfg. cofix compSP. intros.
    inversion wfg as [g' h t H1 H2 | g' get H1 H2 H3].
    + refine {| Out := PutX h _ |}. (* exact (compSP f t wff). *)
Abort.

(** The first, naive way of doing it. *)

(*
Fixpoint head {A B : Type} (g : GetSP A B) (s : Stream A) : B :=
match g with
| In (PutX h t) => h
| In (GetX g')  => head (g' (hd s)) (tl s)
end.

Fixpoint tail {A B : Type} (g : GetSP A B) (s : Stream A) : SP A B * Stream A :=
match g with
| In (PutX h t) => (t, s)
| In (GetX g')  => tail (g' (hd s)) (tl s)
end.

CoFixpoint toStream {A B : Type} (f : SP A B) (s : Stream A) : Stream B :=
{|
  hd :=
    match Out f with
    | PutX h _ => h
    | GetX g   => head (g (hd s)) (tl s)
    end;
  tl :=
    match Out f with
    | PutX _ t => toStream t s
    | GetX g   => let (f', s') := tail (g (hd s)) (tl s) in toStream f' s'
    end;
|}.

(** A better way. *)

Fixpoint aux {A B : Type} (g : GetSP A B) (s : Stream A) : B * (SP A B * Stream A) :=
match g with
| In (PutX h t) => (h, (t, s))
| In (GetX g')  => aux (g' (hd s)) (tl s)
end.

CoFixpoint toStream' {A B : Type} (f : SP A B) (s : Stream A) : Stream B :=
match Out f with
| PutX h t =>
  {|
    hd := h;
    tl := toStream' t s;
  |}
| GetX g   => let '(h, (f', s')) := aux (g (hd s)) (tl s) in
  {|
    hd := h;
    tl := toStream' f' s';
  |}
end.

(** Lighter syntax. *)

CoFixpoint toStream'' {A B : Type} (f : SP A B) (s : Stream A) : Stream B :=
match Out f with
| PutX h t => scons h (toStream'' t s)
| GetX g   =>
  let '(h, (f', s')) := aux (g (hd s)) (tl s) in
    scons h (toStream'' f' s')
end.

(** Some proofs. *)

Lemma head_aux :
  forall {A B : Type} (g : GetSP A B) (s : Stream A),
    head g s = fst (aux g s).
Proof.
  fix IH 3.
  intros A B [[h t | g']] s; cbn.
    reflexivity.
    apply IH.
Qed.

Lemma tail_aux :
  forall {A B : Type} (g : GetSP A B) (s : Stream A),
    tail g s = snd (aux g s).
Proof.
  fix IH 3.
  intros A B [[h t | g']] s; cbn.
    reflexivity.
    apply IH.
Qed.

Lemma eq_Out :
  forall {A B : Type} (x y : SP A B),
    Out x = Out y -> x = y.
Proof.
  intros A B [] []. cbn. destruct 1. reflexivity.
Qed.

Lemma eq_Stream :
  forall {A : Type} (s1 s2 : Stream A),
    hd s1 = hd s2 -> tl s1 = tl s2 -> s1 = s2.
Proof.
  intros A [] []. cbn. intros [] []. reflexivity.
Qed.

Lemma toStream'_eq :
  forall {A B : Type} (f : SP A B) (s : Stream A),
    toStream' f s =
    match Out f with
    | PutX h t =>
      {|
        hd := h;
        tl := toStream' t s;
      |}
    | GetX g   => let '(h, (f', s')) := aux (g (hd s)) (tl s) in
      {|
        hd := h;
        tl := toStream' f' s';
      |}
  end.
Proof.
  intros. apply eq_Stream. destruct f as [[]]; cbn.
Admitted.

Lemma toStream_toStream' :
  forall {A B : Type} (f : SP A B) (s : Stream A),
    sim (toStream f s) (toStream' f s).
Proof.
  cofix CH.
  destruct f as [[h t | gsp]].
    constructor; cbn.
      reflexivity.
      apply CH.
    {
      constructor; cbn.
        rewrite head_aux, toStream'_eq. cbn. destruct (aux (gsp (hd s)) (tl s)), p; cbn. reflexivity.
        rewrite tail_aux, toStream'_eq. cbn. destruct (aux (gsp (hd s)) (tl s)), p; cbn. apply CH.
    }
Qed.

(** Composition of stream processors. *)

(* Fixpoint whnf {A B : Type} (g : GetSP B C) (i : SP A B) : C * (SP B C * SP A B) :=
match g with
| In (PutX h t) => (h, (t, i))
| In (GetX g')  => whnf (g' (hd s)) (tl s)
end.
 *)

Definition comp {X Y A B C : Type} (f : SPXY X Y A B) (g : SPXY X Y B C) : SPXY X Y A C.
Proof.
  destruct g as [hc tc | g'].
    refine (PutX hc tc).
Abort.

Fixpoint compMix {A B C : Type} (f : GetSP A B) (g : SP B C) {struct f} : GetSP A C.
Proof.
  destruct g as [[hc tc | g']].
    refine (In (PutX hc _)).
Abort.

Fixpoint compI {A B C : Type} (f : GetSP A B) (g : GetSP B C) : GetSP A C.
Proof.
  destruct g as [[hc tc | g']].
    refine (In (PutX hc _)). destruct f as [[hb tb | f']].
      admit.
      constructor. apply GetX. intro a. refine (compI _ _ _ (f' a) _). apply (compI _ B _).
Abort.

CoFixpoint compSP {A B C : Type} (f : SP A B) (g : SP B C) : SP A C.
Proof.
  constructor.
  destruct g as [[hc tc | g']].
    apply (PutX hc). exact (compSP _ _ _ f tc).
    destruct f as [[hb tb | f']].
      apply (compSP A B C).
        exact tb.
        admit.
      apply GetX. intro a.
Abort.
*)


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
Require Import Epsilon.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ssrnat_ext ssrZ ZArith_ext seq_ext machine_int multi_int.
Require Import encode_decode integral_type uniq_tac.
Import MachineInt.
Require Import mips_bipl mips_cmd mips_tactics mips_syntax.
Import mips_bipl.expr_m.
Require Import simu.
Import simu.simu_m.

Require Import multi_one_u_prg multi_one_u_simu multi_one_u_safe_termination.
Require Import multi_negate_prg pick_sign_prg pick_sign_simu.
Require Import multi_is_even_s_prg multi_is_even_s_simu.
Require Import begcd_mips_prelude begcd_mips_init begcd_mips_halve begcd_mips_reset begcd_mips_subtract.
Require Import begcd begcd_mips0.

Local Open Scope machine_int_scope.
Local Open Scope zarith_ext_scope.
Local Open Scope heap_scope.
Local Open Scope assoc_scope.
Local Open Scope uniq_scope.
Local Open Scope simu_scope.

Definition begcd_mips rk rg ru rv ru1 ru2 ru3 rv1 rv2 rv3 rt1 rt2 rt3
  a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 :=
  (multi_one_u rk rg a0 a1 ;
  prelude_mips rk rg ru rv a0 a1 a2 a3 ;
  init_mips rk ru rv ru1 ru2 ru3 rv1 rv2 rv3 rt1 rt2 rt3 a0 a1 a2 a3 a4 a5 a6 ;
  pick_sign rt3 a0 a1 ;
  While (bne a1 r0) {{
  ((multi_is_even_s rt3 a0 a1 a2 ;
    While (bne a2 r0) {{
      halve_mips rk ru rv rt1 rt2 rt3 a0 a1 a2 a3 a4 a5 a6;
      multi_is_even_s rt3 a0 a1 a2 }}) ;
    reset_mips rk ru rv ru1 ru2 ru3 rv1 rv2 rv3 rt1 rt2 rt3 a0 a1 a2 a3 a4 a7 a8 a9 ;
    subtract_mips rk ru rv ru1 ru2 ru3 rv1 rv2 rv3 rt1 rt2 rt3 a0 a1 a2 a3 a4 a5 a6 a7 a8);
    pick_sign rt3 a0 a1 }}
)%mips_cmd.

Lemma fwd_sim_begcd vu vv g u v u1 u2 u3 v1 v2 v3 t1 t2 t3 k
  rk rg ru rv ru1 ru2 ru3 rv1 rv2 rv3 rt1 rt2 rt3 a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 :
  uniq(g, u, v, u1, u2, u3, v1, v2, v3, t1, t2, t3) ->
  uniq(rk, rg, ru, rv, ru1, ru2, ru3, rv1, rv2, rv3, rt1, rt2, rt3, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, r0) ->
  0 < vu -> 0 < vv -> vu < Zbeta k -> vv < Zbeta k ->
  EGCD.BEGCD_TAOCP.begcd g u v u1 u2 u3 v1 v2 v3 t1 t2 t3
    <=( state_mint (g |=> unsign rk rg \U+ (u |=> unsign rk ru \U+ (v |=> unsign rk rv \U+
                   (u1 |=> signed k ru1 \U+ (u2 |=> signed k ru2 \U+ (u3 |=> signed k ru3 \U+
                   (v1 |=> signed k rv1 \U+ (v2 |=> signed k rv2 \U+ (v3 |=> signed k rv3 \U+
                   (t1 |=> signed k rt1 \U+ (t2 |=> signed k rt2 \U+ t3 |=> signed k rt3))))))))))),
        (fun st s h => EGCD.uv_init vu vv u v st /\ uv_bound rk s u v st k)%pseudo_expr)
  begcd_mips rk rg ru rv ru1 ru2 ru3 rv1 rv2 rv3 rt1 rt2 rt3 a0 a1 a2 a3 a4 a5 a6 a7 a8 a9.
Proof.
move=> Hvars Hregs Hvu Hvv vu_max vv_max.
rewrite /EGCD.BEGCD_TAOCP.begcd /begcd_mips.
(** g <- snat 1 *)
apply fwd_sim_seq with (fun st s _ => EGCD.C1 vu vv u v g st /\ uv_bound rk s u v st k) => //.
- rewrite /rela_hoare => st s h Hcond st' exec_pseudo s' h' exec_asm; split.
  + rewrite /EGCD.C1.
    rewrite /EGCD.uv_init in Hcond *.
    move/syntax_m.seplog_m.semop_prop_m.exec_cmd0_inv : exec_pseudo.
    case/syntax_m.seplog_m.exec0_assign_inv => _ ->.
    repeat syntax_m.seplog_m.assert_m.expr_m.Store_upd.
    tauto.
  + rewrite /uv_bound.
    repeat syntax_m.seplog_m.assert_m.expr_m.Store_upd.
    Rewrite_reg rk s. Rewrite_var u st. Rewrite_var v st.
    rewrite /uv_bound in Hcond; tauto.
- set st_s_h := state_mint _.
  apply pfwd_sim_fwd_sim; last first.
    apply safe_termination_stren with (fun st s h => st_s_h st s h /\
      (0 < '|u2Z ([rk ]_ s)%asm_expr|)%nat); last first.
      by apply safe_termination_one_u; Uniq_uniq r0.
    move=> st s h [] Hst_s_h [] _ [] [] H _ _.
    split=> //; exact/O_lt_Zabs_nat.
  rewrite /pfwd_sim => st s h Hst_s_h.
  apply pfwd_sim_one_u.
  + by Uniq_uniq r0.
  + by Disj_mints_regs.
  + by Notin_dom.
  + by Notin_cdom.
  + split; first tauto.
    case: Hst_s_h => _.
    rewrite /EGCD.uv_init /uv_bound => ?; tauto.
(** EGCD.prelude u v g *)
- apply fwd_sim_stren with (fun st s _ => EGCD.C2 vu vv u v g st /\ uv_bound rk s u v st k).
    move=> st s h.
    rewrite /EGCD.C1 /EGCD.C2 /EGCD.uv_init.
    move=> [[[Hu Hv] Hg] Hcond].
    by rewrite Hu Hv Hg !mulZ1.
  apply fwd_sim_seq with (fun st s _ => (EGCD.C2 vu vv u v g st /\ EGCD.C3 vu vv u v g st) /\
    uv_bound rk s u v st k) => //.
  + rewrite /rela_hoare => st s h Hcond st' exec_pseudo s' h' exec_asm.
    split.
      have Htmp : uniq(u,v,g) by rewrite [Equality.sort _]/= in Hvars *; Uniq_uniq O.
      move: (EGCD.BEGCD_TAOCP_FUN_COR.prelude_triple_strict _ _ _ _ _ Htmp Hvu Hvv) => {Htmp}.
      move/syntax_m.seplog_m.hoare_prop_m.soundness.
      rewrite /while.hoare_semantics.
      case/(_ st syntax_m.seplog_m.assert_m.heap.emp (proj1 Hcond)) => _.
      case/(_ _ _ exec_pseudo) => HC2 Hb.
      split; first by [].
      rewrite /EGCD.C3.
      split; last exact/negP.
      rewrite /EGCD.C2 in HC2.
      case: HC2 => Hu [Hv [Hg [u_g v_g]]].
      rewrite -Zgcd_mult; last lia.
      by rewrite mulZC u_g mulZC v_g.
    rewrite /uv_bound in Hcond *.
    Rewrite_reg rk s.
    repeat (split; first tauto).
    rewrite /EGCD.prelude in exec_pseudo.
    split.
    * have Hu0 : 0 < ([ u ]_ st)%pseudo_expr < Zbeta (k - 1) by tauto.
      apply (syntax_m.seplog_m.semop_prop_m.while_preserves _ _
        (fun st => 0 < ([u ]_ st)%pseudo_expr < Zbeta (k - 1)) _ _ _ _ Hu0 exec_pseudo) => {Hu0} s0 h0 s'0 h'0 Hu0 while_cond.
      case/syntax_m.seplog_m.hoare_prop_m.while_semop_prop_m.exec_seq_inv_Some.
      move=> [s1 h1] [Hs1 Hs'0].
      Rewrite_var u s1.
      move/syntax_m.seplog_m.semop_prop_m.exec_cmd0_inv : Hs1.
      case/syntax_m.seplog_m.exec0_assign_inv => ? ?; subst h1 s1.
      syntax_m.seplog_m.assert_m.expr_m.Store_upd.
      rewrite /= /ZIT.div; split.
      - apply Zlt_0_Zdiv => //.
        case/andP : while_cond => while_cond _.
        move/eqP : while_cond => /Zmod_2_Zeven.
        case/Zeven_ex => uhalf Huhalf.
        by rewrite [LHS]/= in Huhalf; lia.
      - apply (@leZ_ltZ_trans ([u]_s0)%pseudo_expr); last by tauto.
        apply Zdiv_le_upper_bound => //; lia.
    * have Hv0 : 0 < ([v ]_ st)%pseudo_expr < Zbeta (k - 1) by tauto.
      apply (syntax_m.seplog_m.semop_prop_m.while_preserves _ _ (fun st => 0 < ([v ]_ st)%pseudo_expr < Zbeta (k - 1)) _ _ _ _ Hv0 exec_pseudo) => {Hv0} s0 h0 s'0 h'0 Hv0 while_cond.
      move/syntax_m.seplog_m.semop_prop_m.exec_seq_assoc'.
      case/syntax_m.seplog_m.hoare_prop_m.while_semop_prop_m.exec_seq_inv_Some.
      move=> [s1 h1] [Hs1 Hs0].
      Rewrite_var v s1.
      case/syntax_m.seplog_m.hoare_prop_m.while_semop_prop_m.exec_seq_inv_Some : Hs1.
      move=> [s2 h2] [Hs2 Hs1].
      move/syntax_m.seplog_m.semop_prop_m.exec_cmd0_inv : Hs1.
      case/syntax_m.seplog_m.exec0_assign_inv => ? ?; subst h1 s1.
      syntax_m.seplog_m.assert_m.expr_m.Store_upd.
      rewrite /= /ZIT.div.
      Rewrite_var v s0.
      split.
      - apply Zlt_0_Zdiv => //.
        case/andP : while_cond => _.
        move/eqP/Zmod_2_Zeven.
        case/Zeven_ex => uhalf Huhalf.
        rewrite [LHS]/= in Huhalf; lia.
      - apply (@leZ_ltZ_trans ([v]_s0)%pseudo_expr); last tauto.
        apply Zdiv_le_upper_bound => //; lia.
  + eapply fwd_sim_stren; last first.
      apply sim_begcd_prelude.
      by rewrite [Equality.sort _]/= in Hvars *; Uniq_uniq O.
      by Uniq_uniq r0.
    move=> st s h [HC2 Hcond] /=.
    rewrite /EGCD.C2 in HC2.
    rewrite /uv_bound in Hcond.
    decompose [and] Hcond; clear Hcond.
    subst k.
    split; last lia.
    case: HC2 => Hu [Hv [Hg [u_g v_g]]].
    by rewrite u_g.
  (** EGCD.init u v u1 u2 u3 v1 v2 v3 t1 t2 t3 *)
  + apply fwd_sim_seq with (fun st s _ => EGCD.C2 vu vv u v g st /\ EGCD.C3 vu vv u v g st /\
      EGCD.uivi_init u v u1 u2 u3 v1 v2 v3 st /\ EGCD.ti_init u v t1 t2 t3 st /\
      uv_bound rk s u v st k) => //.
    * rewrite /rela_hoare => st s h Hcond st' exec_pseudo s' h' exec_asm.
      move: (EGCD.BEGCD_TAOCP_FUN_COR.triple_init _ _ _ _ _ _ _ _ _ _ _ _ _ _ Hvars Hvu Hvv).
      move/syntax_m.seplog_m.hoare_prop_m.soundness.
      rewrite /while.hoare_semantics.
      move/(_ _ _ (proj1 Hcond)).
      move/(_ syntax_m.seplog_m.assert_m.heap.emp).
      case=> _.
      move/(_ _ _ exec_pseudo) => Hcond'.
      repeat (split; first tauto).
      rewrite /uv_bound.
      Rewrite_reg rk s. Rewrite_var u st. Rewrite_var v st. tauto.
    * apply fwd_sim_begcd_init => //; by Uniq_uniq r0.
    (** While (var_e t3 \!= nat_e 0) {{ *)
    * apply fwd_sim_stren with (fun st s _ => (EGCD.C2 vu vv u v g st /\
        (Zodd [u ]_ st \/ Zodd [v ]_ st) /\
        EGCD.CVectors u v u1 u2 u3 v1 v2 v3 t1 t2 t3 st /\
        EGCD.C4 u3 v3 t3 st /\ EGCD.C5 u3 v3 st /\
        gcdZ [u ]_ st [v ]_ st = gcdZ [u3 ]_ st [v3 ]_ st /\
        EGCD.uivi_bounds u v u1 v1 u2 v2 u3 v3 st /\ EGCD.ti_bounds u v t1 t2 t3 st) /\
        uv_bound rk s u v st k)%pseudo_expr.
        move=> st s h; split.
        - apply EGCD.BEGCD_TAOCP_COR.triple_intermediate_invariant_stren => //.
          exact syntax_m.seplog_m.assert_m.heap.emp.
          repeat (split; first tauto).
          rewrite /EGCD.C2 in H; apply EGCD.init_bounds; tauto.
        - tauto.
      apply fwd_sim_while => //.
      - rewrite /invariant => st s h [st_s_h Hcond] s' h' exec_asm; split.
        + eapply state_mint_invariant; [idtac | idtac | apply st_s_h | apply exec_asm] => //.
          rewrite [mips_frame.modified_regs _]/=.
          by Disj_mints_regs.
        + rewrite /uv_bound.
          Rewrite_reg rk s. tauto.
      - rewrite /rela_hoare => st s h Hcond st' exec_pseudo s' h' exec_asm; split.
        + move: (EGCD.BEGCD_TAOCP_COR.triple_intermediate_invariant _ _ _ _ _ _ _ _ _ _ _ _ _ _ Hvars Hvu Hvv).
          move/syntax_m.seplog_m.hoare_prop_m.soundness.
          rewrite /while.hoare_semantics.
          move/(_ st syntax_m.seplog_m.assert_m.heap.emp).
          set tmp := (_ /\ _).
          have Htmp : tmp by rewrite {}/tmp; tauto.
          case/(_ Htmp) => {Htmp} _.
          move/(_ _ _ exec_pseudo); tauto.
        + rewrite /uv_bound.
          Rewrite_reg rk s. Rewrite_var u st. Rewrite_var v st. tauto.
      - assoc_tac_m.put_in_front t3.
        eapply fwd_sim_b_stren; last first.
          apply fwd_sim_b_pick_sign_bne.
          by Uniq_uniq r0.
        move=> st s ? [] H _; exact: H.
      - apply fwd_sim_seq with (fun st s _ => (EGCD.C2 vu vv u v g st /\
          (Zodd [u ]_ st \/ Zodd [v ]_ st) /\
          EGCD.CVectors u v u1 u2 u3 v1 v2 v3 t1 t2 t3 st /\
          EGCD.C4 u3 v3 t3 st /\ EGCD.C5 u3 v3 st /\
          gcdZ vu vv = [g ]_ st * gcdZ [u3 ]_ st [v3 ]_ st /\
          EGCD.uivi_bounds u v u1 v1 u2 v2 u3 v3 st /\
          EGCD.ti_bounds u v t1 t2 t3 st /\ Zodd [t3 ]_ st) /\ uv_bound rk s u v st k)%pseudo_expr => //.
        + rewrite /rela_hoare => st s h Hcond st' exec_p s' h' exec_c; split.
          * move: (EGCD.BEGCD_TAOCP_COR.while_halve _ _ _ _ _ _ _ _ _ _ _ _ _ _ Hvars Hvu Hvv).
            move/syntax_m.seplog_m.hoare_prop_m.soundness.
            rewrite /while.hoare_semantics /=.
            move/(_ st syntax_m.seplog_m.assert_m.heap.emp).
            set tmp := (_ /\ _).
            have Htmp : tmp by rewrite {}/tmp; tauto.
            case/(_ Htmp) => {Htmp} _.
            move/(_ _ _ exec_p); tauto.
          * rewrite /uv_bound.
            Rewrite_reg rk s. Rewrite_var u st. Rewrite_var v st. tauto.
        + apply fwd_sim_stren with (fun st s _ => ((EGCD.C2 vu vv u v g st /\
            (Zodd ([u ]_ st) \/ Zodd ([v ]_ st)) /\
            EGCD.CVectors u v u1 u2 u3 v1 v2 v3 t1 t2 t3 st /\
            EGCD.C4 u3 v3 t3 st /\ EGCD.C5 u3 v3 st /\
            gcdZ ([u ]_ st) ([v ]_ st) = gcdZ ([u3 ]_ st) ([v3 ]_ st) /\
            EGCD.uivi_bounds u v u1 v1 u2 v2 u3 v3 st /\
            EGCD.ti_bounds u v t1 t2 t3 st) /\ uv_bound rk s u v st k) /\
           ([var_e t3 \!= nat_e 0 ]b_ st))%pseudo_expr.
            move=> st s h; tauto.
          apply fwd_sim_while => //.
          * rewrite /invariant.
            move=> st s h [st_s_h Hcond] s' h' exec_asm; split.
            - eapply state_mint_invariant; [idtac | idtac | apply st_s_h | apply exec_asm] => //.
              rewrite [mips_frame.modified_regs _]/=.
              by Disj_mints_regs.
            - rewrite /uv_bound.
              Rewrite_reg rk s. tauto.
          * rewrite /rela_hoare => st s h Hcond st' exec_p s' h' exec_c.
            move: (EGCD.BEGCD_TAOCP_COR.while_halve_invariant _ _ _ _ _ _ _ _ _ _ _ _ _ _ Hvars Hvu Hvv).
            move/syntax_m.seplog_m.hoare_prop_m.soundness.
            rewrite /while.hoare_semantics /=.
            move/(_ st syntax_m.seplog_m.assert_m.heap.emp).
            set tmp := (_ /\ _).
            have Htmp : tmp.
              rewrite /tmp {tmp}.
              split.
              - repeat (split; first by tauto).
                have {}Hcond : ([var_e t3 \!= nat_e 0 ]b_ st)%pseudo_expr by tauto.
                rewrite /= in Hcond.
                by move/eqP : Hcond.
              - tauto.
            case/(_ Htmp) => {Htmp} _.
            move/(_ _ _ exec_p) => Htmp.
            split.
              split.
              - tauto.
              - rewrite /uv_bound.
                Rewrite_reg rk s. Rewrite_var u st. Rewrite_var v st. tauto.
            apply/eqP; tauto.
          * assoc_tac_m.put_in_front t3.
            apply fwd_sim_b_pull_out with (0 < Z_of_nat k < 2 ^^ 31).
              move=> st s h H.
              decompose [and] H; clear H.
              clear -H4.
              rewrite /uv_bound in H4.
              decompose [and] H4; clear H4.
              rewrite H Z_of_nat_Zabs_nat //; exact: min_u2Z.
            move=> Zk.
            set st_s_h := state_mint _.
            apply fwd_sim_b_stren with st_s_h; last first.
              apply fwd_sim_b_multi_is_even_s.
              by Uniq_uniq r0.
              exact: Zk.
            move=> st s ? [] H _; exact: H.
          * apply fwd_sim_stren with (fun st s _ => (((EGCD.C2 vu vv u v g st /\
              (Zodd ([u ]_ st) \/ Zodd ([v ]_ st)) /\
              EGCD.CVectors u v u1 u2 u3 v1 v2 v3 t1 t2 t3 st /\
              EGCD.C4 u3 v3 t3 st /\ EGCD.C5 u3 v3 st /\
              gcdZ ([u ]_ st) ([v ]_ st) = gcdZ ([u3 ]_ st) ([v3 ]_ st) /\
              EGCD.uivi_bounds u v u1 v1 u2 v2 u3 v3 st /\
              EGCD.ti_bounds u v t1 t2 t3 st) /\ uv_bound rk s u v st k) /\
             ([var_e t3 \!= nat_e 0 ]b_ st)) /\
             ([var_e t3 \% nat_e 2 \= nat_e 0 ]b_ st))%pseudo_expr.
              move=> st s _; tauto.
            apply fwd_sim_begcd_halve => //; by Uniq_uniq r0.
        + apply fwd_sim_seq with (fun st s _ => (EGCD.C2 vu vv u v g st /\
            (Zodd [u ]_ st \/ Zodd [v ]_ st) /\
            EGCD.CVectors u v u1 u2 u3 v1 v2 v3 t1 t2 t3 st /\
            (0 <= [t3 ]_ st ->
              gcdZ vu vv = [g ]_ st * gcdZ [t3 ]_ st [v3 ]_ st /\
              Zodd [u3 ]_ st /\ [u3 ]_ st = [t3 ]_ st) /\
            ([t3 ]_ st < 0 ->
              gcdZ vu vv = [g ]_ st * gcdZ [u3 ]_ st [t3 ]_ st /\
              Zodd [v3 ]_ st /\ [v3 ]_ st = - [t3 ]_ st) /\
            EGCD.uivi_bounds u v u1 v1 u2 v2 u3 v3 st /\
            EGCD.ti_bounds u v t1 t2 t3 st /\ EGCD.C5 u3 v3 st) /\
            uv_bound rk s u v st k)%pseudo_expr => //.
          * rewrite /rela_hoare => st s h Hcond st' exec_p s' h' exec_c; split.
            + move: (EGCD.BEGCD_TAOCP_COR.reset_triple _ _ _ _ _ _ _ _ _ _ _ _ _ _ Hvars Hvu Hvv).
              move/syntax_m.seplog_m.hoare_prop_m.soundness.
              rewrite /while.hoare_semantics /=.
              move/(_ st syntax_m.seplog_m.assert_m.heap.emp).
              set tmp := (_ /\ _).
              have Htmp : tmp.
                rewrite /tmp {tmp}.
                tauto.
              case/(_ Htmp) => {Htmp} _.
              move/(_ _ _ exec_p) => Htmp.
              tauto.
            + rewrite /uv_bound.
              Rewrite_reg rk s. Rewrite_var u st. Rewrite_var v st. tauto.
          * apply fwd_sim_begcd_reset => //; by Uniq_uniq r0.
          * apply fwd_sim_begcd_subtract => //; by Uniq_uniq r0.
Qed.