Require Import Reals Psatz.
From stdpp Require Import tactics.
From mathcomp Require Import ssrfun ssreflect eqtype ssrbool seq fintype choice.
From discprob.basic Require Import base sval order monad bigop_ext nify.
From discprob.idxval Require Import pival_dist pival ival_dist ival ival_pair subset_coupling pidist_singleton extrema.
From discprob.prob Require Import prob countable finite stochastic_order.

Record idist_pidist_couplingP {A1 A2} (I1: ivdist A1) (I2: pidist A2) (P: A1 → A2 → Prop) : Type :=
  mkIPCoupling { elem_coupling : ivdist A2;
                 elem_member : le_pidist (singleton elem_coupling) I2;
                 elem_coupled :> ival_couplingP I1 elem_coupling P }.

Arguments elem_coupling {_ _ _ _ _} _.

Definition lsupport {A1 A2 Is1 Is2 P} (Icouple: idist_pidist_couplingP Is1 Is2 P) (y: A2) :=
  { x : A1 |  ∃ i Hpf, ival.ind Icouple i = (exist _ (x, y) Hpf) ∧ ival.val Icouple i > 0 }.
Definition rsupport {A1 A2 Is1 Is2 P} (Icouple: idist_pidist_couplingP Is1 Is2 P) (x: A1) :=
  { y : A2 |  ∃ i Hpf, ival.ind Icouple i = (exist _ (x, y) Hpf) ∧ ival.val Icouple i > 0 }.

Lemma ip_subset_singleton {A1 A2} (I1 : ivdist A1) (Is2: pidist A2) P:
  (∃ ic : idist_pidist_couplingP I1 Is2 P, True) ↔ subset_couplingP (singleton I1) Is2 P.
Proof.
  split.
  - intros ([I2 Imem Icouple]&_).
    apply In_pidist_le_singleton in Imem; rewrite /In_pidist in Imem.
    destruct Imem as (I2'&?&?).
    intros I Hin. rewrite /In/singleton//= in Hin.
    subst; exists I2'; split; auto.
    eexists; eauto.
    eapply ival_coupling_proper; eauto.
  - intros Hsub. destruct (Hsub I1) as (I2&Hin&Hcouple&_); first by done.
    eexists; auto.
    exists (lift_In_pidist I2 Hin); auto.
    apply In_pidist_le_singleton. rewrite /In_pidist.
    exists I2; split; auto.
Qed.

Lemma ip_coupling_eq {A} (Is1 : ivdist A) (Is2: pidist A)
      (Ic: idist_pidist_couplingP Is1 Is2 (λ x y, x = y)): In_pidist Is1 Is2.
Proof.
  destruct Ic as [Ic Hp1 Hp2].
  apply In_pidist_le_singleton.
  etransitivity; last by eauto.
  cut (eq_ivd Is1 Ic).
  { intros Heq. setoid_rewrite Heq; reflexivity.  }
  by apply ival_coupling_eq.
Qed.

Lemma ip_coupling_singleton {A} (I: ivdist A) :
  idist_pidist_couplingP I (singleton I) (λ x y, x = y).
Proof.
  exists I.
  - reflexivity.
  - apply ival_coupling_refl.
Qed.

Lemma ip_coupling_mret {A1 A2} (P: A1 → A2 → Prop) x y:
  P x y →
  idist_pidist_couplingP (mret x) (mret y) P.
Proof.
  intros HP. exists (mret y).
  { setoid_rewrite singleton_mret. reflexivity. }
  by apply ival_coupling_mret.
Qed.

Lemma ip_coupling_bind {A1 A2 B1 B2} (f1: A1 → ivdist B1) (f2: A2 → pidist B2)
      Is1 Is2 P Q (Ic: idist_pidist_couplingP Is1 Is2 P):
  (∀ x y, P x y → idist_pidist_couplingP (f1 x) (f2 y) Q) →
  idist_pidist_couplingP (mbind f1 Is1) (mbind f2 Is2) Q.
Proof.
  intros Hfc.
  destruct (ip_subset_singleton ((mbind f1 Is1)) (mbind f2 Is2) Q) as (_&Hc2).
  eapply ClassicalEpsilon.constructive_indefinite_description in Hc2 as (Hc&?);
    first by exact Hc.
  eapply subset_coupling_proper.
  { setoid_rewrite singleton_bind. reflexivity. }
  { reflexivity. }
  eapply subset_coupling_bind; intros; apply ip_subset_singleton; eauto.
Qed.

Lemma ip_coupling_conseq {A1 A2} (P1 P2: A1 → A2 → Prop) (I: ivdist A1) (Is: pidist A2):
  (∀ x y, P1 x y → P2 x y) →
  idist_pidist_couplingP I Is P1 →
  idist_pidist_couplingP I Is P2.
Proof.
  intros HP [I' ? Ic].
  exists I'; eauto.
  eapply ival_coupling_conseq; eauto.
Qed.

Lemma ip_coupling_proper {A1 A2} (I1 I2 : ivdist A1) (Is1 Is2: pidist A2) P:
  eq_ival I1 I2 →
  eq_pidist Is1 Is2 →
  idist_pidist_couplingP I1 Is1 P →
  idist_pidist_couplingP I2 Is2 P.
Proof.
  intros Heq Heqp [Ielem ? ?].
  exists Ielem.
  - etransitivity; first eauto.
    setoid_rewrite Heqp. reflexivity.
  - eapply ival_coupling_proper; eauto.
Qed.

Lemma ip_coupling_proper' {A1 A2} (I1 I2 : ivdist A1) (Is1 Is2: pidist A2) P:
  eq_ivd I1 I2 →
  eq_pidist Is1 Is2 →
  idist_pidist_couplingP I1 Is1 P →
  idist_pidist_couplingP I2 Is2 P.
Proof.
  intros Heq Heqp [Ielem ? ?].
  exists Ielem.
  - etransitivity; first eauto.
    setoid_rewrite Heqp. reflexivity.
  - eapply ival_coupling_proper; eauto.
Qed.

Lemma ip_coupling_proper_mono {A1 A2} (I1 I2 : ivdist A1) (Is1 Is2: pidist A2) P:
  eq_ivd I1 I2 →
  le_pidist Is1 Is2 →
  idist_pidist_couplingP I1 Is1 P →
  idist_pidist_couplingP I2 Is2 P.
Proof.
  intros Heq Heqp [Ielem ? ?].
  exists Ielem.
  - etransitivity; first eauto.
    setoid_rewrite Heqp. reflexivity.
  - eapply ival_coupling_proper; eauto.
Qed.

Lemma ip_coupling_support {X Y} I1 I2 (P: X → Y → Prop) :
  ∀ (Ic: idist_pidist_couplingP I1 I2 P),
  idist_pidist_couplingP I1 I2 (λ x y, ∃ Hpf: P x y,  In_isupport x I1 ∧ In_psupport y I2 ∧
                        In_isupport (exist _ (x, y) Hpf) Ic).
Proof.
  intros Ic.
  destruct Ic as [Ielem ? Ic].
  specialize (ival_coupling_support _ _ _ Ic) => Ic'.
  exists Ielem; auto.
  eapply ival_coupling_conseq; eauto.
  intros x y (Hpf&Hin1&Hin2&?); exists Hpf; repeat split; auto.
  eapply le_pidist_support_coerce_aux; eauto.
  apply In_psupport_alt. exists Ielem; split; done.
Qed.

Lemma ip_coupling_support_wit {X Y} I1 I2 (P: X → Y → Prop)
      (Ic: idist_pidist_couplingP I1 I2 P):
       { xy : X * Y | ∃ Hpf : P (fst xy) (snd xy),
           In_isupport (fst xy) I1 ∧ In_psupport (snd xy) I2 ∧ In_isupport (exist _ xy Hpf) Ic}.
Proof.
  destruct Ic as [Ielem ? Ic].
  specialize (ival_coupling_support_wit _ _ _ Ic) => wit.
  destruct wit as ((x&y)&Hpf).
  exists (x, y).
  destruct Hpf as (Hpf&Hin1&Hin2&Hin3).
  exists Hpf. intuition.
  eapply le_pidist_support_coerce_aux; eauto.
  apply In_psupport_alt. exists Ielem; split; done.
Qed.

Lemma ip_coupling_plus {A1 A2} p Hpf p' Hpf'
      (P : A1 → A2 → Prop) (Is1 Is1': ivdist A1) (Is2 Is2': pidist A2) :
  p = p' →
  idist_pidist_couplingP Is1 Is2 P →
  idist_pidist_couplingP Is1' Is2' P →
  idist_pidist_couplingP (ivdplus p Hpf Is1 Is1') (pidist_plus p' Hpf' Is2 Is2') P.
Proof.
  intros; subst.
  edestruct (ip_subset_singleton (ivdplus p' Hpf Is1 Is1')
                                 (pidist_plus p' Hpf' Is2 Is2')) as (?&Hc2).
  eapply ClassicalEpsilon.constructive_indefinite_description in Hc2 as (Hc&?);
    first exact Hc.

  eapply subset_coupling_proper.
  { setoid_rewrite singleton_plus. reflexivity. }
  { reflexivity. }
  eapply subset_coupling_plus; eauto; apply ip_subset_singleton; eexists; eauto.
Qed.

Lemma ip_coupling_union_l {A1 A2} I Is Is' (P: A1 → A2 → Prop):
  idist_pidist_couplingP I Is P →
  idist_pidist_couplingP I (pidist_union Is Is') P.
Proof.
  intros [Iwit ? Ic].
  exists Iwit; eauto.
  by apply pidist_union_le_l.
Qed.

Lemma ip_coupling_union_r {A1 A2} I Is Is' (P: A1 → A2 → Prop):
  idist_pidist_couplingP I Is' P →
  idist_pidist_couplingP I (pidist_union Is Is') P.
Proof.
  intros [Iwit ? Ic].
  exists Iwit; eauto.
  by apply pidist_union_le_r.
Qed.

Lemma indef_disj (P1 P2: Prop): P1 ∨ P2 → {P1} + {P2}.
Proof.
    { intros Hcase.
      assert (∃ b, if (b: bool) then P1 else P2) as Hb.
      { destruct Hcase; [ exists true | exists false ]; eauto.  }
      eapply ClassicalEpsilon.constructive_indefinite_description in Hb.
      destruct Hb as ([|]&HP'); eauto.
    }
Qed.

Lemma ip_coupling_union_list {A1 A2} I Is Ishd Iss (P: A1 → A2 → Prop):
  idist_pidist_couplingP I Is P →
  (∃ Is', eq_pidist Is Is' ∧ List.In Is' (Ishd :: Iss)) →
  idist_pidist_couplingP I (fold_left pidist_union Iss Ishd) P.
Proof.
  revert Ishd Is.
  induction Iss as [| Ishd' Iss] => Ishd Is.
  - intros Ic Hin. rewrite //=.
    apply ClassicalEpsilon.constructive_indefinite_description in Hin.
    destruct Hin as (Is'&Hequiv&Hin).
    assert (Is' = Ishd).
    { destruct Hin as [|[]]; done. }
    subst. eapply ip_coupling_proper; eauto.
  - intros Ic Hin. rewrite //=.
    rewrite //= in Hin.
    apply ClassicalEpsilon.constructive_indefinite_description in Hin.
    destruct Hin as (Is'&Hequiv&Hin).
    apply indef_disj in Hin as [Heq1|Htl].
    { subst. eapply IHIss.
      ** apply ip_coupling_union_l.  eauto.
      ** eexists; split; last by (left; eauto).
         setoid_rewrite Hequiv; reflexivity.
    }
    apply indef_disj in Htl as [Heq2|Htl].
    { subst. eapply IHIss.
      ** apply ip_coupling_union_r.  eauto.
      ** eexists; split; last by (left; eauto).
         setoid_rewrite Hequiv; reflexivity.
    }
    eapply IHIss; eauto.
    exists Is'; split; eauto.
    right. done.
Qed.

(* TODO: strengthen these to be bounded_fun_on as is done for the irrel couplings to match the presentation in the text *)
Lemma idist_coupling_eq_ex_Ex {A1 A2} f g (I: ivdist A1) (Is: pidist A2) :
  idist_pidist_couplingP I Is (λ x y, f x = g y) →
  bounded_fun g →
  ex_Ex_ival f I.
Proof.
  intros.
  assert (idist_pidist_couplingP (x ← I; mret (f x))
                                 (x ← Is; mret (g x))
                                 (λ x y, x = y)) as Ic'.
  { eapply ip_coupling_bind; eauto => ???.
    apply ip_coupling_mret; auto. }

  destruct Ic' as [I2 Hmem Ic'].
  apply ival_coupling_eq in Ic'.
  rewrite (ex_Ex_ival_fmap id f).
  setoid_rewrite Ic'.
  cut (ex_Ex_extrema id (x ← Is; mret (g x))).
  { intros Hex'. edestruct (Hmem I2) as (I2'&Heq'&?); first done.
    rewrite Heq'. eapply Hex'; eauto. }
  rewrite -ex_Ex_extrema_fmap. eauto.
  eapply ex_Ex_extrema_bounded_fun.
  eauto.
Qed.

Lemma idist_coupling_eq_Ex_min {A1 A2} f g (I: ivdist A1) (Is: pidist A2) :
  idist_pidist_couplingP I Is (λ x y, f x = g y) →
  bounded_fun g →
  Rbar_le (Ex_min g Is) (Ex_ival f I).
Proof.
  intros Hirrel Hb.
  feed pose proof (idist_coupling_eq_ex_Ex f g I Is) as Hex; eauto.
  assert (idist_pidist_couplingP (x ← I; mret (f x))
                                 (x ← Is; mret (g x))
                                 (λ x y, x = y)) as Ic'.
  { eapply ip_coupling_bind; eauto => ???.
    apply ip_coupling_mret; auto. }

  destruct Ic' as [I2 Hmem Ic'].
  apply ival_coupling_eq in Ic'.
  transitivity (Ex_min (λ x, id (g x)) Is); first reflexivity.
  rewrite (Ex_min_comp g id).
  - transitivity (Ex_ival (λ x, Ex_ival id (mret (f x))) I); last first.
    { apply Ex_ival_mono.
      * intros. rewrite Ex_ival_mret. reflexivity.
      * setoid_rewrite Ex_ival_mret; eauto.
      * eauto.
    }
    rewrite -Ex_ival_bind_post; last first.
    { rewrite -ex_Ex_ival_fmap. eauto. }
    transitivity (Ex_ival id I2); last first.
    { refl_right. f_equal. symmetry. eapply Ex_ival_proper; eauto.
      rewrite -ex_Ex_ival_fmap. eauto. }

    apply In_pidist_le_singleton in Hmem.
    destruct Hmem as (I2'&Heq22'&?).
    transitivity (Ex_ival id I2'); last first.
    { refl_right. f_equal. symmetry. eapply Ex_ival_proper; eauto.
      eapply ex_Ex_ival_proper; eauto.
      rewrite -ex_Ex_ival_fmap. eauto. }
    apply Ex_min_spec1'; auto.
    eapply ex_Ex_ival_proper; eauto.
    eapply ex_Ex_ival_proper; eauto.
    rewrite -ex_Ex_ival_fmap. eauto.
  - apply Ex_min_bounded_fun_finite; eauto.
  - apply ex_Ex_extrema_bounded_fun; eauto.
Qed.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition init_common_sysregs_spec (rec: Pointer) (rd: Pointer) (adt: RData) : option RData :=
    rely (peq (base rec) buffer_loc);
    rely (peq (base rd) buffer_loc);
    when rec_gidx == ((buffer (priv adt)) @ (offset rec));
    when rd_gidx == ((buffer (priv adt)) @ (offset rd));
    let g_rd := (gs (share adt)) @ rd_gidx in
    let g_rec := (gs (share adt)) @ rec_gidx in
    rely (g_tag (ginfo g_rd)) =? GRANULE_STATE_RD;
    rely (g_tag (ginfo g_rec)) =? GRANULE_STATE_REC;
    rely prop_dec (glock g_rd = Some CPU_ID);
    rely (ref_accessible g_rec CPU_ID);
    let rtt := g_rtt (gnorm g_rd) in
    rely is_gidx rtt;
    let rtt_addr := __gidx_to_addr rtt in
    let rtt := Z.land rtt_addr VTTBR_ADDR_MASK in
    rely is_int64 rtt_addr;
    let sysregs' := (g_regs (grec g_rec)) {r_hcr_el2 : HCR_FLAGS} {r_vtcr_el2 : VTCR_FLAGS} {r_vttbr_el2: rtt} in
    let g' := g_rec {grec: (grec g_rec) {g_regs: sysregs'}} in
    Some adt {share: (share adt) {gs: (gs (share adt)) # rec_gidx == g'}}.

End Spec.


From isla Require Import opsem.

Definition a40 : isla_trace :=
  Smt (DeclareConst 0%Z (Ty_BitVec 64%N)) Mk_annot :t:
  Assume (AExp_Binop (Eq) (AExp_Unop (Extract 1%N 1%N) (AExp_Val (AVal_Var "PC" []) Mk_annot) Mk_annot) (AExp_Val (AVal_Bits (BV 1%N 0x0%Z)) Mk_annot) Mk_annot) Mk_annot :t:
  ReadReg "PC" [] (RegVal_Base (Val_Symbolic 0%Z)) Mk_annot :t:
  Smt (DefineConst 1%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 0%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DeclareConst 13%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "x9" [] (RegVal_Base (Val_Symbolic 13%Z)) Mk_annot :t:
  Smt (DeclareConst 14%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "x21" [] (RegVal_Base (Val_Symbolic 14%Z)) Mk_annot :t:
  Smt (DefineConst 17%Z (Binop ((Bvcomp Bvsge)) (Unop (ZeroExtend 64%N) (Val (Val_Symbolic 13%Z) Mk_annot) Mk_annot) (Unop (ZeroExtend 64%N) (Val (Val_Symbolic 14%Z) Mk_annot) Mk_annot) Mk_annot)) Mk_annot :t:
  Smt (DefineConst 18%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 0%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x38%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  tcases [
    Smt (Assert (Val (Val_Symbolic 17%Z) Mk_annot)) Mk_annot :t:
    Smt (DefineConst 19%Z (Unop (Extract 0%N 0%N) (Binop ((Bvarith Bvlshr)) (Val (Val_Symbolic 18%Z) Mk_annot) (Val (Val_Bits (BV 64%N 0x1%Z)) Mk_annot) Mk_annot) Mk_annot)) Mk_annot :t:
    BranchAddress (RegVal_Base (Val_Symbolic 18%Z)) Mk_annot :t:
    WriteReg "PC" [] (RegVal_Base (Val_Symbolic 18%Z)) Mk_annot :t:
    tnil;
    Smt (Assert (Unop (Not) (Val (Val_Symbolic 17%Z) Mk_annot) Mk_annot)) Mk_annot :t:
    WriteReg "PC" [] (RegVal_Base (Val_Symbolic 1%Z)) Mk_annot :t:
    tnil
  ]
.


(* -*- company-coq-local-symbols: (("|=" . ?⊨) ("=|" . ?⫤) ("->>" . ?↠) ("=~" . ?≈) ("<|" . ?⟨) ("|>" . ?⟩) ); -*- *)
Set Warnings "-notation-overridden".

Require Import Prelude.Prelude.

Require Import Defs.DEnv.
Require Import Defs.Lc.
Require Import Defs.Set.
Require Import Defs.Substs.
Require Import Defs.WfDTy.

Notation "A |= B <= C" := (SubSump A B C) (at level 50) : type_scope.

Theorem SubSump_DEnv_sub : forall denv1 denv2 sch1 sch2,
    SubSump denv1 sch1 sch2
  -> denv1 [<=]de denv2
  -> SubSump denv2 sch1 sch2.
Proof.
  introv SS SUB. gen denv2. induction SS; intros.
  - auto.
  - econstructor. intros. apply H. eassumption. crush.
  - econstructor. intros. eapply WfDTy_DEnv_sub. 1,2:eassumption.
    eauto.
Qed.
#[export] Hint Resolve SubSump_DEnv_sub : core.

#[export] Instance SubSump_DEnv_sub_proper : Proper (DEnv_sub ==> eq ==> eq ==> impl) SubSump.
Proof. autounfold. intros. subst. eauto. Qed.

Lemma SubSump_weaken_subst : forall dskA dty denv2 denv1 sch1 sch2,
    SubSump denv1 sch1 sch2
  -> denv2 |=dty DS_Mono dty
  -> DEnv_dskvars denv1 [<=] DEnv_dskvars denv2 \u singleton dskA
  -> SubSump denv2 (subst_dskvar_DSch dty dskA sch1) (subst_dskvar_DSch dty dskA sch2).
Proof.
  introv SS WFDTY SUB. gen denv2. induction SS; intros.
  - crush.
  - eapply (SubSumpSkol (L \u singleton dskA)). fold subst_dskvar_DSch. intros.
    forwards: H dskA0. fsetdec. instantiate (1 := (denv2 :::s dskA0)). eauto. rewr. fsetdec.
    rewrite subst_dskvar_DSch_open_DSch_wrt_DTy_var. eassumption. fsetdec. eauto.
  - rename dty into dty1. rename DTy1 into dty2.
    eapply (SubSumpInst (L \u free_dskvars_DSch (subst_dskvar_DSch dty1 dskA DSch5) \u free_dskvars_DSch (subst_dskvar_DSch dty1 dskA DSch5) \u singleton dskA \u free_dskvars_DTy dty1) _ ).
    instantiate (1 := (subst_dskvar_DTy dty1 dskA dty2)).
    apply WfDTy_props. apply WfDTy_props in WFDTY. apply WfDTy_props in WFDTY0.
    destr. split. simpl.
    rewrite free_dskvars_DTy_subst_dskvar_DTy_upper. rewrite H0. fsetdec.
    constructor. crush.
    intros dskB NI__dskB. fold subst_dskvar_DSch.
    forwards IH: H. instantiate (1 := dskB). fsetdec. eassumption. eassumption. simpl in IH.
    rewrite subst_dskvar_DSch_open_DSch_wrt_DTy in IH. 2:eauto. simpl in IH. if_taut.
    rewrite subst_dskvar_DSch_open_DSch_wrt_DTy in IH. 2:eauto.
    rewrite subst_dskvar_DSch_subst_dskvar_DSch in IH. 2,3:fsetdec.
    rewrite subst_dskvar_DSch_open_DSch_wrt_DTy. simpl. if_taut.
    apply subst_dskvar_DTy_lc_DTy; eauto.
Qed.

Theorem SubSump_transitive (denv : DEnv) : Transitive (SubSump denv).
Proof.
  unfold Transitive. intros dsch1 dsch2 dsch3 SS1 SS2.
  gen dsch1 SS1. induction SS2.
  - intros. induction SS1; eauto.
  - eauto using SubSump_DEnv_sub.
  - intros dsch1 SS1.
    inverts SS1.
    forwards [dskA NI__dskA]: atom_fresh (L \u L0 \u free_dskvars_DSch dsch1).
    eapply (H dskA). fsetdec. forwards: SS0 dskA. fsetdec.
    apply (SubSump_weaken_subst dskA DTy1 DEnv5) in H0.
    rewrite subst_dskvar_DSch_not_in_DSch_idempotent in H0. eassumption. fsetdec. eassumption. rewr. fsetdec.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.Arith.Arith.
Require Import Coq.Sorting.Permutation.
Import ListNotations.

Fixpoint flatten {A: Type} (l: list (list A)): list A :=
  match l with
  | nil => nil
  | lh :: lt => lh ++ flatten lt
  end.

Fixpoint filter_option {A: Type} (l: list (option A)): list A :=
  match l with
  | nil => nil
  | Some h :: lt => h :: filter_option lt
  | None :: lt => filter_option lt
  end.

Tactic Notation "if_tac" :=
  match goal with |- context [if ?a then _ else _] =>
    lazymatch type of a with
    | sumbool _ _ => destruct a
    | bool => destruct a eqn: ?
    | ?t => fail "Use if_tac only for sumbool; your expression"a" has type" t
    end end.

Tactic Notation "if_tac" "in" hyp(H0)
  := match type of H0 with context [if ?a then _ else _] =>
    lazymatch type of a with
    | sumbool _ _ => destruct a
    | bool => destruct a eqn: ?
    | ?t => fail "Use if_tac only for sumbool; your expression"a" has type" t
    end end.

Lemma seq_S: forall i num, seq i (S num) = seq i num ++ [num + i].
Proof. intros. rewrite <- Nat.add_1_r, seq_app, Nat.add_comm. reflexivity. Qed.

Lemma fold_right_ext: forall {A B: Type} (g f: B -> A -> A) a l,
    (forall x y, f x y = g x y) -> fold_right f a l = fold_right g a l.
Proof. intros. induction l; simpl; [| rewrite H, IHl]; easy. Qed.

Lemma fold_right_split: forall {A B: Type} (f: A -> A -> A) (g h: B -> A) a l,
    f a a = a -> (forall x y, f x y = f y x) ->
    (forall x y z, f (f x y) z = f x (f y z)) ->
    fold_right (fun x => f (f (g x) (h x))) a l =
    f (fold_right (fun x => f (g x)) a l) (fold_right (fun x => f (h x)) a l).
Proof.
  intros. induction l; simpl; auto. rewrite IHl, !H1. f_equal.
  now rewrite <- (H1 (h a0)), (H0 (h a0)), H1.
Qed.

Lemma fold_right_map: forall {A B C: Type} (f: B -> A -> A) (g: C -> B) a l,
    fold_right (fun x => f (g x)) a l = fold_right f a (map g l).
Proof. intros. induction l; simpl; [|rewrite IHl]; easy. Qed.

Lemma fold_right_perm: forall {A} (f: A -> A -> A) a l1 l2,
    (forall x y, f x y = f y x) -> (forall x y z, f (f x y) z = f x (f y z)) ->
    Permutation l1 l2 -> fold_right f a l1 = fold_right f a l2.
Proof.
  intros. induction H1; simpl; auto.
  - now rewrite IHPermutation.
  - now rewrite <- !H0, (H x y).
  - now rewrite IHPermutation1.
Qed.

Lemma fold_right_distr: forall {A B: Type} (f: B -> A -> A) (g: A -> A -> A) b a l,
    (forall z x y, f z (g x y) = g (f z x) (f z y)) ->
    f b (fold_right g a l) = fold_right g (f b a) (map (f b) l).
Proof. intros. induction l; simpl; [| rewrite H, IHl]; easy. Qed.

Lemma map_binary_func: forall {A B C: Type} (f: A -> B -> C) a l,
    map (f a) l = map (fun x => f (fst x) (snd x)) (combine (repeat a (length l)) l).
Proof. intros. induction l; simpl; [| rewrite IHl]; easy. Qed.

Lemma map_fst_combine: forall {A B: Type} (l1: list A) (l2: list B),
    length l1 <= length l2 -> map fst (combine l1 l2) = l1.
Proof.
  intros A B. induction l1, l2; simpl; intros; auto.
  - inversion H.
  - apply le_S_n in H. now rewrite IHl1.
Qed.

Lemma map_binary_snd_combine:
  forall {A B C D: Type} (l1: list A) (l2: list D) (f: A -> B -> C) (g: D -> B),
    map (fun x => f (fst x) (g (snd x))) (combine l1 l2) =
    map (fun x => f (fst x) (snd x)) (combine l1 (map g l2)).
Proof.
  intros. revert l2. induction l1; intros; simpl; auto.
  destruct l2; simpl; auto. now rewrite IHl1.
Qed.