(*
    Copyright (C) 2012  G. Gonthier, B. Ziliani, A. Nanevski, D. Dreyer

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
*)

From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype.
From LemmaOverloading
Require Import heaps.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Class Indom (x : ptr) (h : heap) :=
   { indom : def h -> x \in dom h }.

Obligation Tactic := idtac.

Program Instance found : forall A x (v : A), Indom x (x:->v).
Next Obligation.
move=> A x v; rewrite defPt => xnull.
by rewrite domPt !inE eq_refl xnull.
Qed.

Program Instance found_left :
  forall x h1 h2 (xh1 : Indom x h1), Indom x (h1:+h2).
Next Obligation.
move=> x h1 h2 xh1 defh12; rewrite domUn !inE defh12.
case: xh1 => xh1; by rewrite (xh1 (defUnl defh12)).
Qed.

Program Instance found_right :
  forall x h1 h2 (xh2 : Indom x h2), Indom x (h1:+h2).
Next Obligation.
move=> x h1 h2 xh2 defh12; rewrite domUn !inE defh12.
by case: xh2 => xh2; rewrite (xh2 (defUnr defh12)) orbT.
Qed.

(* simple example *)
Example ex1 A (x1 x2 : ptr) (v1 v2 : A) (h1 h2 : heap) :
          def (h1 :+ x1 :-> 1 :+ (x2 :-> 3 :+ empty)) ->
          if x2 \in dom (h1 :+ x1 :-> 1 :+ (x2 :-> 3 :+ empty))
            then 1 == 1
            else 1 == 0.
Proof.
move=>D.
by rewrite indom.
Qed.

(* same example, automatically unfolding a definition *)
Example ex2 A (x1 x2 : ptr) (v1 v2 : A) (h1 h2 : heap) :
          def (h1 :+ x1 :-> 1 :+ (x2 :-> 3 :+ empty)) ->
          if x2 \in dom (h1 :+ x1 :-> 1 :+ (x2 :-> 3 :+ empty))
            then 1 == 1
            else 1 == 0.
Proof.
set H := _ :+ _ :+ (_ :+ _).
move=>D.
by rewrite indom.
Qed.


(** * A refinement of Mathcomp's rationals [rat] with [bigQ] from Coq standard library. *)

Require Import ZArith QArith Lia.
From Bignums Require Import BigQ.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat order.
From mathcomp Require Import ssralg ssrnum ssrint rat div intdiv.
From CoqEAL.refinements Require Import hrel refinements param binint.
Import Refinements.Op.

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

Local Open Scope ring_scope.
Local Open Scope Z_scope.
Delimit Scope Z_scope with coqZ.

Import GRing.Theory Order.Theory Num.Theory.

Section classes.

Class max_of C := max_op : C -> C -> C.
Class min_of C := min_op : C -> C -> C.

End classes.

(** ** Link between [Z] (Coq standard lib) and [int] (Mathcomp) *)
Section Zint.

(** *** Various lemmas about [nat_of_pos] *)

Lemma nat_of_pos_inj x y : nat_of_pos x = nat_of_pos y -> x = y.
Proof. rewrite -!binnat.to_natE; apply Pos2Nat.inj. Qed.

Lemma nat_of_pos_gt0 p : (0 < nat_of_pos p)%N.
Proof. by elim: p =>//= p IHp; rewrite NatTrec.doubleE double_gt0. Qed.

Lemma nat_of_pos_gtr0 p : (0 < Posz (nat_of_pos p))%R.
Proof. by rewrite -[0%R]/(Posz 0) ltz_nat nat_of_pos_gt0. Qed.

Lemma Posz_nat_of_pos_neq0 p : Posz (nat_of_pos p) == 0%R = false.
Proof.
rewrite -binnat.to_natE.
case E: (Pos.to_nat _)=>//; exfalso; move: E.
by move: (binnat.to_nat_gt0 p); case (Pos.to_nat _).
Qed.

(** *** Conversion from [Z] to [int] *)
Definition Z2int (z : BinNums.Z) :=
  match z with
  | Z0 => 0%:Z
  | Z.pos p => (nat_of_pos p)%:Z
  | Z.neg n => (- (nat_of_pos n)%:Z)%R
  end.

(** *** Conversion from [int] to [Z] *)
Definition int2Z (n : int) : BinNums.Z :=
  match n with
  | Posz O => Z0
  | Posz n => Z.pos (Pos.of_nat n)
  | Negz n => Z.neg (Pos.of_nat n.+1)
  end.

Lemma Z2int_inj x y : Z2int x = Z2int y -> x = y.
Proof.
rewrite /Z2int.
case x, y=>//.
{ move=>[] H.
  by rewrite -[Z0]/(Z.of_nat 0%N) H -binnat.to_natE positive_nat_Z. }
{ rewrite -binnat.to_natE /GRing.opp /= /intZmod.oppz /=.
  case E: (Pos.to_nat _)=>//=.
  by move: (binnat.to_nat_gt0 p); rewrite -E ltnn. }
{ rewrite -binnat.to_natE; case E: (Pos.to_nat _)=>//=.
  by move: (binnat.to_nat_gt0 p); rewrite -E ltnn. }
{ by move=>[] /nat_of_pos_inj ->. }
{ rewrite -!binnat.to_natE /GRing.opp /= /intZmod.oppz /=.
  case (Pos.to_nat p0)=>//=.
  by move=>[] H; move: (binnat.to_nat_gt0 p); rewrite H ltnn. }
{ rewrite -binnat.to_natE /GRing.opp /= /intZmod.oppz /=.
  case E: (Pos.to_nat _)=>//=.
  by move: (binnat.to_nat_gt0 p); rewrite -E ltnn. }
{ rewrite -!binnat.to_natE /GRing.opp /= /intZmod.oppz /=.
  case E: (Pos.to_nat p)=>//=.
  by move: (binnat.to_nat_gt0 p); rewrite -E ltnn. }
rewrite -!binnat.to_natE /GRing.opp /= /intZmod.oppz /=.
case E: (Pos.to_nat p)=>//=.
{ by move: (binnat.to_nat_gt0 p); rewrite -E ltnn. }
case E': (Pos.to_nat p0)=>//= [] [] H.
by move: E'; rewrite -H -E=>/Pos2Nat.inj ->.
Qed.

Lemma int2ZK : cancel int2Z Z2int.
Proof.
case => [n|n]; case: n => [|n] //=.
case: n => [//|n].
{ by rewrite -binnat.to_natE -Nat2Pos.inj_succ // Nat2Pos.id. }
case: n => [//|n].
{ by rewrite -binnat.to_natE -!Nat2Pos.inj_succ // Nat2Pos.id. }
Qed.

Lemma Z2intK : cancel Z2int int2Z.
Proof.
case => [|p|p] //=.
{ have Pp := nat_of_pos_gt0 p.
  by rewrite /= -(prednK Pp) (prednK Pp) -binnat.to_natE Pos2Nat.id. }
rewrite /int2Z.
have Pp := nat_of_pos_gt0 p.
rewrite -(prednK Pp) {Pp} /= -!binnat.to_natE.
rewrite -[in RHS](Pos2Nat.id p).
set n := Pos.to_nat p.
by case: n.
Qed.

(** *** [Z2int] is a morphism for arithmetic operations *)

Lemma Z2int_opp n : Z2int (- n) = (- (Z2int n))%R.
Proof. by case n=>// p /=; rewrite GRing.opprK. Qed.

Lemma Z2int_abs x : Z2int (Z.abs x) = `|Z2int x|%nat.
Proof. by case: x => // p /=; rewrite abszN. Qed.

Lemma Z2int_add x y : Z2int (x + y) = (Z2int x + Z2int y)%R.
Proof.
rewrite /Z2int /GRing.add /= /intZmod.addz /Z.add; case x, y=>//.
{ rewrite -binnat.to_natE /GRing.opp /= /intZmod.oppz.
  by case (Pos.to_nat p)=>// n; rewrite subn0. }
{ by rewrite addn0. }
{ (try by rewrite nat_of_add_pos) || by rewrite nat_of_addn_gt0. }
{ rewrite -binnat.to_natE /GRing.opp /= /intZmod.oppz.
  move: (Z.pos_sub_discr p p0); case (Z.pos_sub _ _).
  { move<-; rewrite -binnat.to_natE; case (Pos.to_nat _)=>// n.
    by rewrite ltnSn subnn. }
  { move=> p' ->; rewrite -!binnat.to_natE Pos2Nat.inj_add.
    case (Pos.to_nat p0); [by rewrite Nat.add_0_l addn0|move=> n].
    rewrite ifT; [by rewrite plusE addKn|].
    by rewrite plusE; apply ltn_addr; rewrite ltnSn. }
  move=> p' ->; rewrite -!binnat.to_natE Pos2Nat.inj_add.
  case (Pos.to_nat p').
  { rewrite Nat.add_0_r; case (Pos.to_nat p)=>// n.
    by rewrite ltnSn subnn. }
  move=> n.
  case E: (Pos.to_nat p)=>/=; [by rewrite subn0|].
  rewrite ifF.
  { by rewrite plusE addnS -addSn addKn. }
  by rewrite plusE addnS -addSn -ltn_subRL subnn ltn0. }
{ rewrite /GRing.opp /= /intZmod.oppz -binnat.to_natE.
  by case (Pos.to_nat p); [rewrite addn0|move=>n; rewrite subn0]. }
{ rewrite -binnat.to_natE /GRing.opp /= /intZmod.oppz.
  move: (Z.pos_sub_discr p p0); case E': (Z.pos_sub _ _).
  { move<-; rewrite -binnat.to_natE Z.pos_sub_diag; case (Pos.to_nat _)=>// n.
    by rewrite ltnSn subnn. }
  { move=> ->.
    rewrite -!binnat.to_natE Pos2Nat.inj_add Z.pos_sub_lt; last first.
    { by apply Pos.lt_add_diag_r. }
    rewrite -binnat.to_natE Pos2Nat.inj_sub ?Pos2Nat.inj_add; last first.
    { by apply Pos.lt_add_diag_r. }
    rewrite plusE minusE addKn; case (Pos.to_nat _).
    { by rewrite addn0; case (Pos.to_nat p0)=>// n; rewrite ltnSn subnn. }
    move=> n.
    case E: (Pos.to_nat p0 + n.+1)%N.
    { by exfalso; move: E; rewrite addnS. }
    rewrite -E ifF.
    { f_equal.
      have H: (Pos.to_nat p0 + n.+1 - n.+1 = Pos.to_nat p0 + n.+1 - n.+1)%N.
      { done. }
      move: H; rewrite {2}E addnK=>->.
      by rewrite subnS subSn /= ?subKn //; move: E;
        rewrite addnS=>[] [] <-; rewrite leq_addl. }
    by rewrite addnS -ltn_subRL subnn ltn0. }
  move=> ->; rewrite Z.pos_sub_gt; [|by apply Pos.lt_add_diag_r].
  rewrite -!binnat.to_natE !Pos2Nat.inj_sub; [|by apply Pos.lt_add_diag_r].
  rewrite Pos2Nat.inj_add; case (Pos.to_nat p).
  { by rewrite plusE minusE !add0n subn0. }
  by move=> n; rewrite plusE minusE addKn ifT // leq_addr. }
rewrite -!binnat.to_natE Pos2Nat.inj_add /GRing.opp /= /intZmod.oppz plusE.
case (Pos.to_nat p).
{ by rewrite add0n; case (Pos.to_nat p0)=>// n; rewrite ltn0 subn0. }
move=> n; case (Pos.to_nat p0); [by rewrite addn0 ltn0 subn0|].
by move=> n'; rewrite addSn -addnS.
Qed.

Lemma Z2int_mul_nat_of_pos (x : BinNums.Z) (y : positive) :
  (Z2int x * nat_of_pos y)%R = Z2int (Z.mul x (BinNums.Zpos y)).
Proof.
rewrite /Z2int; case Ex: x.
{ by rewrite mul0r Z.mul_0_l. }
{ by rewrite /= -!binnat.to_natE Pos2Nat.inj_mul. }
by rewrite /= mulNr  -!binnat.to_natE Pos2Nat.inj_mul.
Qed.

Lemma Z2int_mul x y : Z2int (x * y) = (Z2int x * Z2int y)%R.
Proof.
case y=>/=.
{ by rewrite GRing.mulr0 Z.mul_0_r. }
{ by move=> p; rewrite Z2int_mul_nat_of_pos. }
move=> p.
by rewrite GRing.mulrN Z2int_mul_nat_of_pos -Z2int_opp Zopp_mult_distr_r.
Qed.

Lemma divE x y : Nat.div x y = divn x y.
Proof.
case: y => [//|y].
rewrite /Nat.div.
move: (Nat.divmod_spec x y 0 y).
case: Nat.divmod => q r /(_ (le_n _)) [].
rewrite Nat.mul_0_r Nat.sub_diag !Nat.add_0_r Nat.mul_comm => + Hr /=.
rewrite multE minusE plusE => /(f_equal (fun x => divn x y.+1)) ->.
rewrite divnMDl // divn_small ?addn0 //.
rewrite ltn_subLR; [|exact/ssrnat.leP].
  by rewrite -addSnnS addnC addnS ltnS leq_addr.
Qed.

(* Mathcomp's divz and Z.div don't match for negative values. *)
Lemma Z2int_div x y : Z.le 0 x -> Z.le 0 y ->
  Z2int (Z.div x y) = (Z2int x %/ Z2int y)%Z.
Proof.
case: x => [|x|//] _; [by rewrite intdiv.div0z|].
case: y => [|y|//] _; [by rewrite intdiv.divz0|].
rewrite -!positive_nat_Z -div_Zdiv; last first.
{ rewrite Nat.neq_0_lt_0; exact: Pos2Nat.is_pos. }
rewrite !positive_nat_Z /= /divz gtr0_sgz ?mul1r; last first.
{ exact: nat_of_pos_gt0. }
rewrite divE !binnat.to_natE absz_nat /Z2int.
move: (Zle_0_nat (nat_of_pos x %/ nat_of_pos y)).
rewrite -[X in _ = Posz X]Nat2Z.id.
  by case: Z.of_nat => //= p _; rewrite binnat.to_natE.
Qed.

Lemma Z2int_le x y : (Z2int x <= Z2int y)%R <-> Z.le x y.
Proof.
rewrite /Z2int; case Ex: x; case Ey: y=> //.
{ rewrite oppr_ge0; split; move=> H; exfalso; move: H; [|by rewrite /Z.le].
  apply/negP; rewrite -ltNge; apply nat_of_pos_gt0. }
{ split; move=> H; exfalso; move: H; [|by rewrite /Z.le].
  apply/negP; rewrite -ltNge; apply nat_of_pos_gt0. }
{ rewrite -!binnat.to_natE /Num.Def.ler /=.
  by rewrite -!positive_nat_Z -Nat2Z.inj_le; split => /ssrnat.leP. }
{ split; move=> H; exfalso; move: H; [|by rewrite /Z.le].
  apply /negP; rewrite -ltNge.
  by apply: (@lt_trans _ _ 0%R); rewrite ?oppr_lt0; apply nat_of_pos_gt0. }
{ rewrite oppr_le0; split; by rewrite /Z.le. }
{ split=>_; [by rewrite /Z.le|].
  by apply: (@le_trans _ _ 0%R); [apply oppr_le0|apply ltW, nat_of_pos_gt0]. }
rewrite ler_opp2; split.
{ rewrite /Z.le /Z.compare -!binnat.to_natE /Num.Def.ler /= => /ssrnat.leP.
  by rewrite -Pos.compare_antisym -Pos2Nat.inj_le -Pos.compare_le_iff. }
rewrite /Z.le /Z.compare -!binnat.to_natE /Num.Def.ler /=.
rewrite -Pos.compare_antisym => H; apply/ssrnat.leP.
by rewrite -Pos2Nat.inj_le -Pos.compare_le_iff.
Qed.

Lemma Z2int_lt x y : (Z2int x < Z2int y)%R <-> Z.lt x y.
Proof.
rewrite -lez_addr1 -[1%R]/(Z2int 1) -Z2int_add Z2int_le; lia.
Qed.

Lemma nat_of_pos_Z_to_pos x : nat_of_pos x = `|Z2int (Z.pos x)|%N.
Proof. by rewrite /absz /Z2int. Qed.

Lemma Zabs_natE n : Z.abs_nat n = `|Z2int n|%N.
Proof.
case: n => //= p; first by rewrite binnat.to_natE.
by rewrite abszN absz_nat binnat.to_natE.
Qed.

Lemma Z2int_Z_of_nat n : Z2int (Z.of_nat n) = n.
Proof.
by case: n => //= n; rewrite Pos.of_nat_succ -binnat.to_natE Nat2Pos.id.
Qed.

(** *** Various lemmas about gcd *)

Lemma dvdnP m n : reflect (Z.divide (Z.of_nat m) (Z.of_nat n)) (m %| n).
Proof.
apply: (iffP idP) => H.
{ rewrite dvdn_eq in H; rewrite -(eqP H) /Z.divide; exists (Z.of_nat (n %/ m)).
  by rewrite Nat2Z.inj_mul. }
{ have [q Hq] := H; apply/dvdnP; exists `|Z2int q|%N; apply/Nat2Z.inj.
  have [Zq|NZq] := Z_zerop q.
  { by rewrite Zq /= in Hq *. }
  case: m Hq H => [|m] Hq H.
  { by rewrite Zmult_comm /= in Hq; rewrite mulnC /=. }
  rewrite Nat2Z.inj_mul -Zabs_natE Zabs2Nat.id_abs Z.abs_eq //.
  have H0 : (0 <= q * Z.of_nat m.+1) by rewrite -Hq; apply Zle_0_nat.
  by apply: Zmult_le_0_reg_r H0. }
Qed.

Lemma ZgcdE n d : Z.gcd n (Z.pos d) = Z.of_nat (div.gcdn `|Z2int n| (nat_of_pos d)).
Proof.
apply: Z.gcd_unique.
{ exact: Zle_0_nat. }
{ apply/Z.divide_abs_r; rewrite -Zabs2Nat.id_abs; apply/dvdnP.
  by rewrite Zabs_natE dvdn_gcdl. }
{ apply/Z.divide_abs_r; rewrite -Zabs2Nat.id_abs; apply/dvdnP.
  by rewrite Zabs_natE /= dvdn_gcdr. }
move=> q Hn Hd; apply/Z.divide_abs_l; rewrite -Zabs2Nat.id_abs; apply/dvdnP.
rewrite Zabs_natE dvdn_gcd.
apply/andP; split; apply/dvdnP; rewrite -!Zabs_natE !Zabs2Nat.id_abs.
{ by apply/Z.divide_abs_l/Z.divide_abs_r. }
{ by apply/Z.divide_abs_l; rewrite -binnat.to_natE positive_nat_Z. }
Qed.

Lemma ZgcdE' n m : Z.gcd n m = Z.of_nat (gcdn `|Z2int n| `|Z2int m|).
Proof.
case m.
{ rewrite Z.gcd_0_r {2}/absz {2}/Z2int /= gcdn0 -Zabs2Nat.id_abs; f_equal.
  rewrite /Z.abs_nat /absz /Z2int.
  case n=>// p; rewrite -!binnat.to_natE //.
  case (Pos.to_nat _); [by rewrite GRing.oppr0|move=> n'].
  by rewrite /GRing.opp /=. }
{ by move=> p; rewrite ZgcdE nat_of_pos_Z_to_pos. }
by move=> p; rewrite -Z.gcd_opp_r /= ZgcdE abszN /absz.
Qed.

Lemma Z_ggcd_1_r n : Z.ggcd n 1 = (1, (n, 1))%coqZ.
Proof.
move: (Z.ggcd_gcd n 1) (Z.ggcd_correct_divisors n 1); rewrite Z.gcd_1_r.
case (Z.ggcd _ _)=> g ab /= ->; case ab=> a b [].
by rewrite !Z.mul_1_l => <- <-.
Qed.

Lemma Z_ggcd_coprime a b :
  let '(g, (a', b')) := Z.ggcd a b in
  g <> 0%coqZ -> coprime `|Z2int a'| `|Z2int b'|.
Proof.
move: (Z.ggcd_gcd a b) (Z.ggcd_correct_divisors a b).
case (Z.ggcd _ _)=> g ab; case ab=> a' b' /= Hg [] Ha Hb Pg.
rewrite /coprime; apply/eqP /Nat2Z.inj; rewrite -ZgcdE' /=.
suff ->: a' = (a / g)%coqZ.
{ suff ->: b' = (b / g)%coqZ; [by apply Z.gcd_div_gcd|].
  by rewrite Hb Z.mul_comm Z_div_mult_full. }
by rewrite Ha Z.mul_comm Z_div_mult_full.
Qed.

Lemma Z2int_lcm x y : Z.le 0 x -> Z.le 0 y ->
  Z2int (Z.lcm x y) = lcmn `|Z2int x| `|Z2int y|.
Proof.
case: x => [|x|//] _; [by rewrite /= lcm0n|].
case: y => [|y|//] _; [by rewrite /= lcmn0|].
rewrite /Z.lcm Z2int_abs Z2int_mul Z2int_div //.
rewrite ZgcdE' abszM; apply: f_equal; apply/eqP.
rewrite -(@eqn_pmul2r (gcdn `|Z2int (Z.pos x)| `|Z2int (Z.pos y)|)); last first.
{ rewrite gcdn_gt0; apply/orP; left; rewrite absz_gt0 /= eqz_nat.
  apply: lt0n_neq0; exact: nat_of_pos_gt0. }
rewrite muln_lcm_gcd.
rewrite -(absz_nat (gcdn _ _)) -mulnA -abszM.
rewrite Z2int_Z_of_nat /=.
  by rewrite intdiv.divzK // /mem /in_mem /intdiv.dvdz /= dvdn_gcdr.
Qed.

End Zint.

(** ** Link between [bigQ] (Coq standard lib) and [rat] (Mathcomp) *)
Section binrat_theory.

Arguments refines A%type B%type R%rel _ _. (* Fix a scope issue with refines *)

(** *** Conversion from [bigQ] to [rat] *)
Program Definition bigQ2rat_def (bq : bigQ) :=
  let q := Qred (BigQ.to_Q bq) in
  ((Z2int (Qnum q))%:Q / (Z2int (Z.pos (Qden q)))%:Q)%R.
Fact bigQ2rat_key : unit. Proof. by []. Qed.
Program Definition bigQ2rat :=
  locked_with bigQ2rat_key bigQ2rat_def.
Canonical bigQ2rat_unlockable := [unlockable fun bigQ2rat].

(** *** Conversion from [rat] to [bigQ] *)
Definition rat2bigQ (q : rat) : bigQ :=
  let n := BigZ.of_Z (int2Z (numq q)) in
  let d := BigN.N_of_Z (int2Z (denq q)) in
  (n # d)%bigQ.

(** *** Refinement relation *)
Definition r_ratBigQ := fun_hrel bigQ2rat.

(** *** Main instances *)

#[export] Instance zero_bigQ : zero_of bigQ := 0%bigQ.
#[export] Instance one_bigQ : one_of bigQ := 1%bigQ.
#[export] Instance opp_bigQ : opp_of bigQ := BigQ.opp.
#[export] Instance add_bigQ : add_of bigQ := BigQ.add_norm.
#[export] Instance sub_bigQ : sub_of bigQ := BigQ.sub_norm.
#[export] Instance mul_bigQ : mul_of bigQ := BigQ.mul_norm.
#[export] Instance inv_bigQ : inv_of bigQ := BigQ.inv_norm.
#[export] Instance div_bigQ : div_of bigQ := BigQ.div_norm.
#[export] Instance eq_bigQ : eq_of bigQ := BigQ.eq_bool.
#[export] Instance lt_bigQ : lt_of bigQ := fun p q => if BigQ.compare p q is Lt then true else false.
#[export] Instance le_bigQ : leq_of bigQ := fun p q => if BigQ.compare q p is Lt then false else true.
#[export] Instance max_bigQ : max_of bigQ := BigQ.max.
#[export] Instance min_bigQ : min_of bigQ := BigQ.min.
#[export] Instance cast_of_nat_bigQ : cast_of nat bigQ := BigQ.of_Z \o Z.of_nat.
#[export] Instance spec_bigQ : spec_of bigQ rat := bigQ2rat.

(** *** Proofs of refinement *)

#[export] Instance refine_ratBigQ_zero : refines r_ratBigQ 0%R 0%C.
Proof. rewrite refinesE /r_ratBigQ unlock; red; exact: val_inj. Qed.

#[export] Instance refine_ratBigQ_one : refines r_ratBigQ 1%R 1%C.
Proof. rewrite refinesE /r_ratBigQ unlock; red; exact: val_inj. Qed.

#[export] Instance refine_ratBigQ_opp : refines (r_ratBigQ ==> r_ratBigQ) -%R -%C.
Proof.
rewrite refinesE => _ a <-; rewrite /r_ratBigQ unlock /fun_hrel /=.
rewrite BigQ.strong_spec_opp Qred_opp [in LHS]/Qnum /=.
by rewrite Z2int_opp mulrNz mulNr.
Qed.

Lemma Z2int_Qred n d :
  ((Z2int (Qnum (Qred (n # d))))%:Q / (nat_of_pos (Qden (Qred (n # d))))%:Q
   = (Z2int n)%:Q / (Z2int (Z.pos d))%:Q)%R.
Proof.
rewrite -(fracqE (Z2int n, Z2int (Z.pos d))) -[RHS]divq_num_den.
rewrite /Qred.
move: (Z.ggcd_gcd n (Z.pos d)) (Z.ggcd_correct_divisors n (Z.pos d)).
move: (Z_ggcd_coprime n (Z.pos d)).
case: Z.ggcd => g [n' d'] /=.
case: g => [|g|g].
{ by move=> _ _ [_]; rewrite Z.mul_0_l. }
{ move=> coprime_n'_d' => _ [->].
  rewrite (nat_of_pos_Z_to_pos d) => /[dup] posd' ->.
  have d'n0 : `|Z2int d'| != 0%R.
  { rewrite normr_eq0.
    case: d' posd' {coprime_n'_d'} => // d' _.
    by rewrite Posz_nat_of_pos_neq0. }
  rewrite !Z2int_mul abszM PoszM gez0_abs; [|by rewrite -[0%R]int2ZK Z2int_le].
  rewrite fracqMM ?Posz_nat_of_pos_neq0 // abszE.
  move: (@valq_frac (Z2int n', `|Z2int d'|) d'n0).
  rewrite scalqE // mul1r => [[neq deq]].
  have -> : nat_of_pos (Z.to_pos d') = `|Z2int d'| :> int.
  { rewrite nat_of_pos_Z_to_pos Z2Pos.id ?abszE //.
    by case: d' posd' {coprime_n'_d' d'n0 neq deq}. }
  rewrite [X in (X%:~R / _)%R]neq [X in (_ / X%:~R)%R]deq.
  rewrite (_ : gcdn _ _ = 1%nat) ?mul1r //; exact/eqP/coprime_n'_d'. }
by move: (Z.gcd_nonneg n (Z.pos d)) => + _ => /[swap] <-.
Qed.

Lemma BigQ_red_den_nonzero q :
  match BigQ.red q with BigQ.Qz _ => True | BigQ.Qq _ d => (BigN.to_Z d) <> Z0 end.
Proof.
case: q => [//|n d] /=.
rewrite /BigQ.norm.
rewrite BigN.spec_compare.
case: Z.compare_spec => [| |//] Hgcd.
{ rewrite /BigQ.check_int BigN.spec_compare.
  case Z.compare_spec => [//| |//] Hd.
  apply: BigNumPrelude.Zlt0_not_eq.
  move: Hd; exact: Z.lt_trans. }
rewrite /BigQ.check_int BigN.spec_compare.
case Z.compare_spec => [//| |//] Hd.
apply: BigNumPrelude.Zlt0_not_eq.
move: Hd; exact: Z.lt_trans.
Qed.

Lemma r_ratBigQ_red x y : r_ratBigQ x y ->
  match BigQ.red y with
  | BigQ.Qz n => numq x = Z2int (BigZ.to_Z n) /\ denq x = 1%R
  | BigQ.Qq n d => numq x = Z2int (BigZ.to_Z n) /\ denq x = Z2int (BigN.to_Z d)
  end.
Proof.
case: (ratP x) => nx dx nx_dx_coprime {x}.
rewrite /r_ratBigQ /fun_hrel unlock -BigQ.strong_spec_red.
have ry_red : Qred (BigQ.to_Q (BigQ.red y)) = BigQ.to_Q (BigQ.red y).
{ by rewrite BigQ.strong_spec_red Qcanon.Qred_involutive. }
have ry_dneq0 := BigQ_red_den_nonzero y.
case: (BigQ.red y) ry_dneq0 ry_red => [ny _ _|ny dy dy_neq0].
{ rewrite /BigQ.to_Q /Qnum /Qden mulr1.
  move=> /(f_equal ( *%R^~ dx.+1%:~R)%R).
  rewrite mulfVK ?mulrz_neq0 // -intrM => /intr_inj nx_eq.
  have dx_1 : (dx.+1 = 1)%nat.
  { by move: nx_dx_coprime => /eqP <-; rewrite -nx_eq abszM /= gcdnC gcdnMl. }
    by rewrite -nx_eq dx_1 mulr1. }
rewrite /BigQ.to_Q ifF ?BigN.spec_eqb ?Z.eqb_neq //.
rewrite Qcanon.Qred_iff ZgcdE -[1%coqZ]/(Z.of_nat 1%nat) => /Nat2Z.inj.
rewrite /Qnum /Qden nat_of_pos_Z_to_pos => /eqP ny_dy_coprime.
move=> /eqP; rewrite rat_eqE !coprimeq_num // !coprimeq_den //=.
rewrite !gtr0_sg ?nat_of_pos_gtr0 // !mul1r => /andP[/eqP <-].
rewrite ifF; [|exact/eqP/eqP/lt0r_neq0/nat_of_pos_gtr0].
rewrite -!abszE !absz_nat => /eqP[<-]; split=> [//|].
rewrite -[LHS]/(Z2int (Z.pos (Z.to_pos (BigN.to_Z dy)))) Z2Pos.id //.
exact: BigQ.N_to_Z_pos.
Qed.

#[export] Instance refine_ratBigQ_add :
  refines (r_ratBigQ ==> r_ratBigQ ==> r_ratBigQ) +%R +%C.
Proof.
rewrite refinesE => _ a <- _ b <-; rewrite /r_ratBigQ unlock /fun_hrel /=.
rewrite (Qred_complete _ _ (BigQ.spec_add_norm _ _)).
case: (BigQ.to_Q a) => na da {a}.
case: (BigQ.to_Q b) => nb db {b}.
rewrite /Qplus !Z2int_Qred.
rewrite Z2int_add !Z2int_mul /= nat_of_mul_pos.
rewrite intrD PoszM !intrM.
by rewrite [RHS]addf_div // intq_eq0 Posz_nat_of_pos_neq0.
Qed.

#[export] Instance refine_ratBigQ_sub :
  refines (r_ratBigQ ==> r_ratBigQ ==> r_ratBigQ) (fun x y => x - y)%R sub_op.
Proof.
apply refines_abstr2=> a b rab c d rcd.
rewrite /sub_op /sub_bigQ /BigQ.sub_norm; eapply refines_apply; tc.
Qed.

#[export] Instance refine_ratBigQ_mul :
  refines (r_ratBigQ ==> r_ratBigQ ==> r_ratBigQ) *%R *%C.
Proof.
rewrite refinesE => _ a <- _ b <-; rewrite /r_ratBigQ unlock /fun_hrel /=.
rewrite (Qred_complete _ _ (BigQ.spec_mul_norm _ _)).
case: (BigQ.to_Q a) => na da {a}.
case: (BigQ.to_Q b) => nb db {b}.
rewrite /Qmult !Z2int_Qred /=.
rewrite Z2int_mul nat_of_mul_pos.
rewrite PoszM !intrM.
by rewrite [RHS]mulf_div.
Qed.

#[export] Instance refine_ratBigQ_inv :
  refines (r_ratBigQ ==> r_ratBigQ)%rel GRing.inv inv_op.
Proof.
rewrite refinesE => _ a <-; rewrite /r_ratBigQ unlock /fun_hrel /=.
rewrite (Qred_complete _ _ (BigQ.spec_inv_norm _)).
case: (BigQ.to_Q a) => na da {a}.
rewrite /Qinv [Qnum (na # da)]/=.
case: na => [|na|na].
{ by rewrite /= !mul0r invr0. }
{ by rewrite [Qden (_ # da)]/= !Z2int_Qred invf_div. }
rewrite [Qden (_ #da)]/= !Z2int_Qred invf_div.
by rewrite -!Pos2Z.opp_pos !Z2int_opp !mulrNz mulNr invrN mulrN.
Qed.

#[export] Instance refine_ratBigQ_div :
  refines (r_ratBigQ ==> r_ratBigQ ==> r_ratBigQ)%rel (fun x y => x / y)%R div_op.
Proof.
apply: refines_abstr2 => x1 x2 rx y1 y2 ry.
rewrite /div_op /div_bigQ /BigQ.div_norm.
exact: refines_apply.
Qed.

#[export] Instance refine_ratBigQ_eq :
  refines (r_ratBigQ ==> r_ratBigQ ==> eq) eqtype.eq_op eq_op.
Proof.
rewrite refinesE => _ a <- _ b <-; rewrite /r_ratBigQ unlock /fun_hrel /=.
rewrite /eq_op /eq_bigQ BigQ.spec_eq_bool.
case: (BigQ.to_Q a) => na da {a}.
case: (BigQ.to_Q b) => nb db {b}.
rewrite /Qeq_bool !Z2int_Qred /= /Zeq_bool -Z.eqb_compare.
rewrite GRing.eqr_div ?intq_eq0 ?Posz_nat_of_pos_neq0 //.
rewrite !nat_of_pos_Z_to_pos.
rewrite !gez0_abs; [|by rewrite -[0%R]int2ZK Z2int_le..].
rewrite -!intrM -!Z2int_mul eqr_int.
by case: Z.eqb_spec => [->|eq]; apply/eqP => // eq'; apply/eq/Z2int_inj.
Qed.

#[export] Instance refine_ratBigQ_eq' :
  refines (r_ratBigQ ==> r_ratBigQ ==> bool_R)%rel eqtype.eq_op eq_op.
Proof.
rewrite refinesE => x1 x2 rx y1 y2 ry.
move: refine_ratBigQ_eq; rewrite refinesE => /(_ _ _ rx _ _ ry) <-.
case: (_ == _); constructor.
Qed.

#[export] Instance refine_ratBigQ_lt :
  refines (r_ratBigQ ==> r_ratBigQ ==> bool_R) Num.lt lt_op.
Proof.
rewrite refinesE => _ a <- _ b <-; rewrite /r_ratBigQ unlock /fun_hrel /=.
rewrite /lt_op /lt_bigQ BigQ.spec_compare.
case: (BigQ.to_Q a) => na da {a}.
case: (BigQ.to_Q b) => nb db {b}.
rewrite !Z2int_Qred /= /Qcompare /= -Z.ltb_compare.
rewrite ltr_pdivr_mulr ?ltr0z ?nat_of_pos_gtr0 //.
rewrite mulrAC ltr_pdivl_mulr ?ltr0z ?nat_of_pos_gtr0 //.
rewrite !nat_of_pos_Z_to_pos.
rewrite !gez0_abs; [|by rewrite -[0%R]int2ZK Z2int_le..].
rewrite -!intrM -!Z2int_mul ltr_int.
case: ltP.
{ by move=> /(proj1 (Z2int_lt _ _)) /(proj2 (Z.ltb_lt _ _)) => ->. }
by move=> /(proj1 (Z2int_le _ _)) /(proj2 (Z.ltb_ge _ _)) => ->.
Qed.

#[export] Instance refine_ratBigQ_le :
  refines (r_ratBigQ ==> r_ratBigQ ==> bool_R) Num.le leq_op.
Proof.
rewrite refinesE => _ a <- _ b <-; rewrite /r_ratBigQ unlock /fun_hrel /=.
rewrite /leq_op /le_bigQ BigQ.spec_compare.
case: (BigQ.to_Q a) => na da {a}.
case: (BigQ.to_Q b) => nb db {b}.
rewrite !Z2int_Qred /= /Qcompare /=.
rewrite ler_pdivr_mulr ?ltr0z ?nat_of_pos_gtr0 //.
rewrite mulrAC ler_pdivl_mulr ?ltr0z ?nat_of_pos_gtr0 //.
rewrite !nat_of_pos_Z_to_pos.
rewrite !gez0_abs; [|by rewrite -[0%R]int2ZK Z2int_le..].
rewrite -!intrM -!Z2int_mul ler_int.
case: leP.
{ move=> /(proj1 (Z2int_le _ _)) /Zle_compare.
  by rewrite Z.compare_antisym; case: Z.compare. }
by move=> /(proj1 (Z2int_lt _ _)) /Zlt_compare; case: Z.compare.
Qed.

#[export] Instance refine_ratBigQ_max :
  refines (r_ratBigQ ==> r_ratBigQ ==> r_ratBigQ)%rel Num.max max_op.
Proof.
apply: refines_abstr2 => x1 x2 rx y1 y2 ry.
have H := refines_apply (refines_apply refine_ratBigQ_lt rx) ry.
move: H => /refines_bool_eq; rewrite maxElt refinesE => ->.
rewrite /lt_op /lt_bigQ /max_op /max_bigQ /BigQ.max.
by case: (_ ?= _)%bigQ.
Qed.

#[export] Instance refine_ratBigQ_min :
  refines (r_ratBigQ ==> r_ratBigQ ==> r_ratBigQ)%rel Num.min min_op.
Proof.
apply: refines_abstr2 => x1 x2 rx y1 y2 ry.
have H := refines_apply (refines_apply refine_ratBigQ_lt ry) rx.
move: H => /refines_bool_eq; rewrite minEle leNgt refinesE => ->.
rewrite /lt_op /lt_bigQ /min_op /min_bigQ /BigQ.min.
rewrite !BigQ.spec_compare -QArith_base.Qcompare_antisym.
by case: QArith_base.Qcompare.
Qed.

#[export] Instance refine_ratBigQ_of_nat :
  refines (nat_R ==> r_ratBigQ)%rel (fun n => n%:~R%R) cast_op.
Proof.
rewrite refinesE => n _ /nat_R_eq <-; rewrite /r_ratBigQ unlock /fun_hrel.
rewrite /= Z_ggcd_1_r /= BigZ.spec_of_Z mulr1.
by apply/eqP; rewrite eqr_int Z2int_Z_of_nat.
Qed.

#[export] Instance refine_ratBigQ_spec :
  refines (eq ==> r_ratBigQ)%rel spec spec_id.
Proof. by rewrite refinesE => x _ <-. Qed.

#[export] Instance refine_ratBigQ_bigQ2rat a : refines r_ratBigQ (bigQ2rat a) a.
Proof. by rewrite refinesE. Qed.

End binrat_theory.


From Hammer Require Import Hammer.

Require Export BinInt Zcompare Zorder.

Local Open Scope Z_scope.

Notation Zmax_case := Z.max_case (compat "8.3").
Notation Zmax_case_strong := Z.max_case_strong (compat "8.3").
Notation Zmax_right := Z.max_r (compat "8.3").
Notation Zle_max_l := Z.le_max_l (compat "8.3").
Notation Zle_max_r := Z.le_max_r (compat "8.3").
Notation Zmax_lub := Z.max_lub (compat "8.3").
Notation Zmax_lub_lt := Z.max_lub_lt (compat "8.3").
Notation Zle_max_compat_r := Z.max_le_compat_r (compat "8.3").
Notation Zle_max_compat_l := Z.max_le_compat_l (compat "8.3").
Notation Zmax_idempotent := Z.max_id (compat "8.3").
Notation Zmax_n_n := Z.max_id (compat "8.3").
Notation Zmax_comm := Z.max_comm (compat "8.3").
Notation Zmax_assoc := Z.max_assoc (compat "8.3").
Notation Zmax_irreducible_dec := Z.max_dec (compat "8.3").
Notation Zmax_le_prime := Z.max_le (compat "8.3").
Notation Zsucc_max_distr := Z.succ_max_distr (compat "8.3").
Notation Zmax_SS := Z.succ_max_distr (compat "8.3").
Notation Zplus_max_distr_l := Z.add_max_distr_l (compat "8.3").
Notation Zplus_max_distr_r := Z.add_max_distr_r (compat "8.3").
Notation Zmax_plus := Z.add_max_distr_r (compat "8.3").
Notation Zmax1 := Z.le_max_l (compat "8.3").
Notation Zmax2 := Z.le_max_r (compat "8.3").
Notation Zmax_irreducible_inf := Z.max_dec (compat "8.3").
Notation Zmax_le_prime_inf := Z.max_le (compat "8.3").
Notation Zpos_max := Pos2Z.inj_max (compat "8.3").
Notation Zpos_minus := Pos2Z.inj_sub_max (compat "8.3").

Lemma Zmax_spec x y :
x >= y /\ Z.max x y = x  \/ x < y /\ Z.max x y = y.
Proof. hammer_hook "Zmax" "Zmax.Zmax_spec".
Z.swap_greater. destruct (Z.max_spec x y); auto.
Qed.

Lemma Zmax_left n m : n>=m -> Z.max n m = n.
Proof. hammer_hook "Zmax" "Zmax.Zmax_left".   Z.swap_greater. apply Z.max_l. Qed.

Lemma Zpos_max_1 p : Z.max 1 (Z.pos p) = Z.pos p.
Proof. hammer_hook "Zmax" "Zmax.Zpos_max_1".
now destruct p.
Qed.


From mathcomp Require Import all_ssreflect.
From stablesort Require Import stablesort.
From Coq Require Import Extraction.

Set Extraction Flag 2031.

Include CBV.

(******************************************************************************)

Extraction Language Haskell.

Extract Inductive bool => "Prelude.Bool" ["Prelude.True" "Prelude.False"].

Extract Inlined Constant negb => "Prelude.not".
Extract Inlined Constant eqb => "(Prelude.==)".

Extract Inductive list => "([])" ["([])" "(:)"].

Extraction "benchmark/haskell/MergesortCoqCbv.hs" sort1 sort2 sort3 sortN.

(******************************************************************************)

Extraction Language OCaml.

Extract Inductive bool => "bool" ["true" "false"].

Extract Inlined Constant negb => "not".
Extract Inlined Constant eqb => "((=) : bool -> bool -> bool)".

Extract Inductive list => "list" ["[]" "(::)"].

Extract Inlined Constant catrev => "List.rev_append".
Extract Inlined Constant rev => "List.rev".

Extraction "benchmark/ocaml/mergesort_coq_cbv.ml" sort1 sort2 sort3 sortN.


Require Import Autosubst.Autosubst.
Require Import Relations.
From Metatheories Require Import ARS Term.

Inductive red : relation term :=
  | red_appabs t11 t2 : red (tapp (tabs t11) t2) (t11.[t2/])
  | red_appl t1 t1' t2 :
      red t1 t1' ->
      red (tapp t1 t2) (tapp t1' t2)
  | red_appr t1 t2 t2' :
      red t2 t2' ->
      red (tapp t1 t2) (tapp t1 t2')
  | red_abs t t' :
      red t t' ->
      red (tabs t) (tabs t').
Hint Constructors red.
Local Hint Constructors clos_refl_trans clos_refl_sym_trans.

Lemma ered_appabs t11 t2 t :
  t = t11.[t2/] ->
  red (tapp (tabs t11) t2) t.
Proof. intros. subst. econstructor. Qed.

Lemma ered_appr t1 t2 t2' t' :
  red t2 t2' ->
  t' = tapp t1 t2' ->
  red (tapp t1 t2) t'.
Proof. intros. subst. eauto. Qed.

Lemma red_abs_multi t t' :
  clos_refl_trans _ red t t' ->
  clos_refl_trans _ red (tabs t) (tabs t').
Proof. induction 1; eauto. Qed.

Lemma red_appl_multi t1 t1' t2 :
  clos_refl_trans _ red t1 t1' ->
  clos_refl_trans _ red (tapp t1 t2) (tapp t1' t2).
Proof. induction 1; eauto. Qed.

Lemma red_appr_multi t1 t2 t2' :
  clos_refl_trans _ red t2 t2' ->
  clos_refl_trans _ red (tapp t1 t2) (tapp t1 t2').
Proof. induction 1; eauto. Qed.

Lemma red_app_equiv t1 t1' t2 t2' :
  clos_refl_sym_trans _ red t1 t1' ->
  clos_refl_sym_trans _ red t2 t2' ->
  clos_refl_sym_trans _ red (tapp t1 t2) (tapp t1' t2').
Proof.
  intros Hrstc Hrstc'.
  apply rst_trans with (y := tapp t1' t2).
  - induction Hrstc; eauto.
  - induction Hrstc'; eauto.
Qed.

Hint Resolve red_abs_multi red_appl_multi red_appr_multi red_app_equiv.

Lemma red_var_multi_inv x t :
  clos_refl_trans _ red (tvar x) t ->
  t = tvar x.
Proof.
  intros Hrt.
  apply clos_rt_rt1n in Hrt.
  inversion Hrt; subst; eauto.
  - inversion H.
Qed.

Lemma red_abs_multi_inv t t' :
  clos_refl_trans _ red t t' ->
  forall t1, t = tabs t1 ->
  exists t1', t' = tabs t1' /\ clos_refl_trans _ red t1 t1'.
Proof.
  intros Hrt.
  apply clos_rt_rt1n in Hrt.
  induction Hrt; intros ? ?; subst; eauto.
  - inversion H; subst.
    destruct (IHHrt _ eq_refl) as [? []]; eauto.
Qed.

Lemma red_rename t t' :
  red t t' ->
  forall r,
  red (rename r t) (rename r t').
Proof.
  induction 1; simpl; intros ?; eauto.
  - apply ered_appabs.
    autosubst.
Qed.

Lemma red_rename_multi r t t' :
  clos_refl_trans _ red t t' ->
  clos_refl_trans _ red (rename r t) (rename r t').
Proof.
  Local Hint Resolve red_rename.
  induction 1; simpl; eauto.
Qed.

Lemma red_subst t t' :
  red t t' ->
  forall s,
  red t.[s] t'.[s].
Proof.
  induction 1; simpl; intros ?; eauto.
  - apply ered_appabs.
    autosubst.
Qed.

Lemma neutral_red t t' :
  neutral t' ->
  red t t' ->
  neutral t.
Proof. induction 2; simpl; eauto. Qed.

Lemma neutral_red_multi t t' :
  neutral t' ->
  clos_refl_trans _ red t t' ->
  neutral t.
Proof.
  induction 2; eauto.
  eapply neutral_red; eauto.
Qed.

Lemma red_subst_multi_aux t : forall s s',
  (forall x, clos_refl_trans _ red (s x) (s' x)) ->
  clos_refl_trans _ red t.[s] t.[s'].
Proof.
  induction t; simpl; eauto 6.
  - intros.
    apply red_abs_multi.
    apply IHt.
    intros [| ?].
    + apply rt_refl.
    + apply red_rename_multi. eauto.
Qed.

Lemma red_subst_multi t t' s s' :
  clos_refl_trans _ red t t' ->
  (forall x, clos_refl_trans _ red (s x) (s' x)) ->
  clos_refl_trans _ red t.[s] t'.[s'].
Proof.
  Local Hint Resolve red_subst.
  intros Hrt ?.
  eapply rt_trans.
  - apply red_subst_multi_aux. eauto.
  - apply clos_rt_rt1n in Hrt.
    induction Hrt; eauto.
Qed.

Section Confluence.
  Inductive pr : relation term :=
    | pr_appabs t11 t11' t2 t2' :
        pr t11 t11' ->
        pr t2 t2' ->
        pr (tapp (tabs t11) t2) (t11'.[t2'/])
    | pr_var x : pr (tvar x) (tvar x)
    | pr_app t1 t1' t2 t2' :
        pr t1 t1' ->
        pr t2 t2' ->
        pr (tapp t1 t2) (tapp t1' t2')
    | pr_abs t t' :
        pr t t' ->
        pr (tabs t) (tabs t').
  Local Hint Constructors pr.

  Lemma epr_appabs t11 t11' t2 t2' t' :
    pr t11 t11' ->
    pr t2 t2' ->
    t' = t11'.[t2'/] ->
    pr (tapp (tabs t11) t2) t'.
  Proof. intros. subst. eauto. Qed.

  Lemma pr_refl t : pr t t.
  Proof. induction t; eauto. Qed.
  Local Hint Resolve pr_refl.

  Lemma red_pr t t' : red t t' -> pr t t'.
  Proof. induction 1; eauto. Qed.
  Local Hint Resolve red_pr.

  Lemma pr_red_multi t t' : pr t t' -> clos_refl_trans _ red t t'.
  Proof. induction 1; eauto 7. Qed.
  Local Hint Resolve pr_red_multi.

  Lemma pr_multi_red_multi t t' : clos_refl_trans _ pr t t' -> clos_refl_trans _ red t t'.
  Proof.
    intros ?.
    apply clos_rt_idempotent.
    eapply clos_rt_impl.
    - apply pr_red_multi.
    - eauto.
  Qed.

  Lemma red_multi_pr_multi t t' : clos_refl_trans _ red t t' -> clos_refl_trans _ pr t t'.
  Proof. induction 1; eauto. Qed.

  Lemma pr_rename t t' :
    pr t t' ->
    forall r,
    pr (rename r t) (rename r t').
  Proof.
    induction 1; simpl; intros ?; eauto.
    - eapply epr_appabs; eauto.
      autosubst.
  Qed.

  Lemma pr_subst t t' :
    pr t t' ->
    forall s s',
    (forall x, pr (s x) (s' x)) ->
    pr t.[s] t'.[s'].
  Proof.
    induction 1; simpl; intros ? ? Hsub; eauto 6.
    - apply epr_appabs with (t11' := t11'.[up s']) (t2' := t2'.[s']); eauto.
      + apply IHpr1.
        intros [| ?].
        * apply pr_refl.
        * apply pr_rename. eauto.
      + autosubst.
    - constructor.
      apply IHpr.
      intros [| ?].
      + apply pr_refl.
      + apply pr_rename. eauto.
  Qed.

  Fixpoint development t :=
    match t with
    | tvar x => tvar x
    | tabs t1 => tabs (development t1)
    | tapp (tabs t11) t2 => (development t11).[development t2/]
    | tapp t1 t2 => tapp (development t1) (development t2)
    end.

  Lemma finite_development t t' :
    pr t t' ->
    pr t' (development t).
  Proof.
    induction 1; simpl; eauto.
    - apply pr_subst; eauto.
      intros [| ?].
      + apply IHpr2.
      + apply pr_refl.
    - destruct t1; simpl in *; eauto.
      inversion H; subst.
      inversion IHpr1; subst.
      eauto.
  Qed.

  Corollary pr_diamond : diamond_property _ pr.
  Proof.
    intros H H'.
    repeat eexists; apply finite_development; eauto.
  Qed.

  Definition pr_confluent := diamond_property_impl_confluent _ _ pr_diamond.

  Theorem red_confluent : confluent _ red.
  Proof.
    eapply confluent_same_relation.
    - apply pr_confluent.
    - intros.
      split.
      + apply pr_multi_red_multi.
      + apply red_multi_pr_multi.
  Qed.
End Confluence.


From Fiat.Narcissus Require Import Examples.TutorialPrelude.

Record msg := { data : word 8; tag : word 8 }.
Definition format := format_word ◦ data.
Definition invariant (_ : msg) := True.

Definition dec : CorrectAlignedDecoderFor invariant format.
Proof.
  synthesize_aligned_decoder.
Defined.


From iris.proofmode Require Import base.
From iris.algebra Require Export base.
Set Default Proof Using "Type".

Inductive env (A : Type) : Type :=
  | Enil : env A
  | Esnoc : env A → ident → A → env A.
Arguments Enil {_}.
Arguments Esnoc {_} _ _ _.
Instance: Params (@Enil) 1.
Instance: Params (@Esnoc) 1.

Fixpoint env_lookup {A} (i : ident) (Γ : env A) : option A :=
  match Γ with
  | Enil => None
  | Esnoc Γ j x => if ident_beq i j then Some x else env_lookup i Γ
  end.

Module env_notations.
  Notation "y ≫= f" := (option_bind f y).
  Notation "x ← y ; z" := (y ≫= λ x, z).
  Notation "' x1 .. xn ← y ; z" := (y ≫= (λ x1, .. (λ xn, z) .. )).
  Notation "Γ !! j" := (env_lookup j Γ).
End env_notations.
Import env_notations.

Inductive env_wf {A} : env A → Prop :=
  | Enil_wf : env_wf Enil
  | Esnoc_wf Γ i x : Γ !! i = None → env_wf Γ → env_wf (Esnoc Γ i x).

Fixpoint env_to_list {A} (E : env A) : list A :=
  match E with Enil => [] | Esnoc Γ _ x => x :: env_to_list Γ end.
Coercion env_to_list : env >-> list.
Instance: Params (@env_to_list) 1.

Fixpoint env_dom {A} (Γ : env A) : list ident :=
  match Γ with Enil => [] | Esnoc Γ i _ => i :: env_dom Γ end.

Fixpoint env_app {A} (Γapp : env A) (Γ : env A) : option (env A) :=
  match Γapp with
  | Enil => Some Γ
  | Esnoc Γapp i x =>
     Γ' ← env_app Γapp Γ;
     match Γ' !! i with None => Some (Esnoc Γ' i x) | Some _ => None end
  end.

Fixpoint env_replace {A} (i: ident) (Γi: env A) (Γ: env A) : option (env A) :=
  match Γ with
  | Enil => None
  | Esnoc Γ j x =>
     if ident_beq i j then env_app Γi Γ else
     match Γi !! j with
     | None => Γ' ← env_replace i Γi Γ; Some (Esnoc Γ' j x)
     | Some _ => None
     end
  end.

Fixpoint env_delete {A} (i : ident) (Γ : env A) : env A :=
  match Γ with
  | Enil => Enil
  | Esnoc Γ j x => if ident_beq i j then Γ else Esnoc (env_delete i Γ) j x
  end.

Fixpoint env_lookup_delete {A} (i : ident) (Γ : env A) : option (A * env A) :=
  match Γ with
  | Enil => None
  | Esnoc Γ j x =>
     if ident_beq i j then Some (x,Γ)
     else ''(y,Γ') ← env_lookup_delete i Γ; Some (y, Esnoc Γ' j x)
  end.

Inductive env_Forall2 {A B} (P : A → B → Prop) : env A → env B → Prop :=
  | env_Forall2_nil : env_Forall2 P Enil Enil
  | env_Forall2_snoc Γ1 Γ2 i x y :
     env_Forall2 P Γ1 Γ2 → P x y → env_Forall2 P (Esnoc Γ1 i x) (Esnoc Γ2 i y).

Inductive env_subenv {A} : relation (env A) :=
  | env_subenv_nil : env_subenv Enil Enil
  | env_subenv_snoc Γ1 Γ2 i x :
     env_subenv Γ1 Γ2 → env_subenv (Esnoc Γ1 i x) (Esnoc Γ2 i x)
  | env_subenv_skip Γ1 Γ2 i y :
     env_subenv Γ1 Γ2 → env_subenv Γ1 (Esnoc Γ2 i y).

Section env.
Context {A : Type}.
Implicit Types Γ : env A.
Implicit Types i : ident.
Implicit Types x : A.
Hint Resolve Esnoc_wf Enil_wf.

Ltac simplify :=
  repeat match goal with
  | _ => progress simplify_eq/=
  | H : context [ident_beq ?s1 ?s2] |- _ => destruct (ident_beq_reflect s1 s2)
  | |- context [ident_beq ?s1 ?s2] => destruct (ident_beq_reflect s1 s2)
  | H : context [option_bind _ ?x] |- _ => destruct x eqn:?
  | |- context [option_bind _ ?x] => destruct x eqn:?
  | _ => case_match
  end.

Lemma env_lookup_perm Γ i x : Γ !! i = Some x → Γ ≡ₚ x :: env_delete i Γ.
Proof.
  induction Γ; intros; simplify; rewrite 1?Permutation_swap; f_equiv; eauto.
Qed.

Lemma env_lookup_snoc Γ i P : env_lookup i (Esnoc Γ i P) = Some P.
Proof. induction Γ; simplify; auto. Qed.
Lemma env_lookup_snoc_ne Γ i j P :
  i ≠ j → env_lookup i (Esnoc Γ j P) = env_lookup i Γ.
Proof. induction Γ=> ?; simplify; auto. Qed.

Lemma env_app_perm Γ Γapp Γ' :
  env_app Γapp Γ = Some Γ' → env_to_list Γ' ≡ₚ Γapp ++ Γ.
Proof. revert Γ'; induction Γapp; intros; simplify; f_equal; auto. Qed.
Lemma env_app_fresh Γ Γapp Γ' i :
  env_app Γapp Γ = Some Γ' → Γapp !! i = None → Γ !! i = None → Γ' !! i = None.
Proof. revert Γ'. induction Γapp; intros; simplify; eauto. Qed.
Lemma env_app_fresh_1 Γ Γapp Γ' i x :
  env_app Γapp Γ = Some Γ' → Γ' !! i = None → Γ !! i = None.
Proof. revert Γ'. induction Γapp; intros; simplify; eauto. Qed.
Lemma env_app_disjoint Γ Γapp Γ' i :
  env_app Γapp Γ = Some Γ' → Γapp !! i = None ∨ Γ !! i = None.
Proof.
  revert Γ'.
  induction Γapp; intros; simplify; naive_solver eauto using env_app_fresh_1.
Qed.
Lemma env_app_wf Γ Γapp Γ' : env_app Γapp Γ = Some Γ' → env_wf Γ → env_wf Γ'.
Proof. revert Γ'. induction Γapp; intros; simplify; eauto. Qed.

Lemma env_replace_fresh Γ Γj Γ' i j :
  env_replace j Γj Γ = Some Γ' →
  Γj !! i = None → env_delete j Γ !! i = None → Γ' !! i = None.
Proof. revert Γ'. induction Γ; intros; simplify; eauto using env_app_fresh. Qed.
Lemma env_replace_wf Γ Γi Γ' i :
  env_replace i Γi Γ = Some Γ' → env_wf (env_delete i Γ) → env_wf Γ'.
Proof.
  revert Γ'. induction Γ; intros ??; simplify; [|inversion_clear 1];
    eauto using env_app_wf, env_replace_fresh.
Qed.
Lemma env_replace_lookup Γ Γi Γ' i :
  env_replace i Γi Γ = Some Γ' → is_Some (Γ !! i).
Proof. revert Γ'. induction Γ; intros; simplify; eauto. Qed.
Lemma env_replace_perm Γ Γi Γ' i :
  env_replace i Γi Γ = Some Γ' → Γ' ≡ₚ Γi ++ env_delete i Γ.
Proof.
  revert Γ'. induction Γ as [|Γ IH j y]=>Γ' ?; simplify; auto using env_app_perm.
  rewrite -Permutation_middle -IH //.
Qed.

Lemma env_lookup_delete_correct Γ i :
  env_lookup_delete i Γ = (x ← Γ !! i; Some (x,env_delete i Γ)).
Proof. induction Γ; intros; simplify; eauto. Qed.
Lemma env_lookup_delete_Some Γ Γ' i x :
  env_lookup_delete i Γ = Some (x,Γ') ↔ Γ !! i = Some x ∧ Γ' = env_delete i Γ.
Proof. rewrite env_lookup_delete_correct; simplify; naive_solver. Qed.

Lemma env_lookup_env_delete Γ j : env_wf Γ → env_delete j Γ !! j = None.
Proof. induction 1; intros; simplify; eauto. Qed.
Lemma env_lookup_env_delete_ne Γ i j : i ≠ j → env_delete j Γ !! i = Γ !! i.
Proof. induction Γ; intros; simplify; eauto. Qed.
Lemma env_delete_fresh Γ i j : Γ !! i = None → env_delete j Γ !! i = None.
Proof. induction Γ; intros; simplify; eauto. Qed.

Lemma env_delete_wf Γ j : env_wf Γ → env_wf (env_delete j Γ).
Proof. induction 1; simplify; eauto using env_delete_fresh. Qed.

Global Instance env_Forall2_refl (P : relation A) :
  Reflexive P → Reflexive (env_Forall2 P).
Proof. intros ? Γ. induction Γ; constructor; auto. Qed.
Global Instance env_Forall2_sym (P : relation A) :
  Symmetric P → Symmetric (env_Forall2 P).
Proof. induction 2; constructor; auto. Qed.
Global Instance env_Forall2_trans (P : relation A) :
  Transitive P → Transitive (env_Forall2 P).
Proof.
  intros ? Γ1 Γ2 Γ3 HΓ; revert Γ3.
  induction HΓ; inversion_clear 1; constructor; eauto.
Qed.
Global Instance env_Forall2_antisymm (P Q : relation A) :
  AntiSymm P Q → AntiSymm (env_Forall2 P) (env_Forall2 Q).
Proof. induction 2; inversion_clear 1; constructor; auto. Qed.
Lemma env_Forall2_impl {B} (P Q : A → B → Prop) Γ Σ :
  env_Forall2 P Γ Σ → (∀ x y, P x y → Q x y) → env_Forall2 Q Γ Σ.
Proof. induction 1; constructor; eauto. Qed.

Global Instance Esnoc_proper (P : relation A) :
  Proper (env_Forall2 P ==> (=) ==> P ==> env_Forall2 P) Esnoc.
Proof. intros Γ1 Γ2 HΓ i ? <-; by constructor. Qed.
Global Instance env_to_list_proper (P : relation A) :
  Proper (env_Forall2 P ==> Forall2 P) env_to_list.
Proof. induction 1; constructor; auto. Qed.

Lemma env_Forall2_fresh {B} (P : A → B → Prop) Γ Σ i :
  env_Forall2 P Γ Σ → Γ !! i = None → Σ !! i = None.
Proof. by induction 1; simplify. Qed.
Lemma env_Forall2_wf {B} (P : A → B → Prop) Γ Σ :
  env_Forall2 P Γ Σ → env_wf Γ → env_wf Σ.
Proof. induction 1; inversion_clear 1; eauto using env_Forall2_fresh. Qed.

Lemma env_subenv_fresh Γ Σ i : env_subenv Γ Σ → Σ !! i = None → Γ !! i = None.
Proof. by induction 1; simplify. Qed.
Lemma env_subenv_wf Γ Σ : env_subenv Γ Σ → env_wf Σ → env_wf Γ.
Proof. induction 1; inversion_clear 1; eauto using env_subenv_fresh. Qed.
Global Instance env_to_list_subenv_proper :
  Proper (env_subenv ==> sublist) (@env_to_list A).
Proof. induction 1; simpl; constructor; auto. Qed.
End env.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Functor.Diagonal.
Require Import Category.Structure.Cone.
Require Import Category.Construction.Comma.
Require Import Category.Instance.Cones.
Require Import Category.Instance.Fun.
Require Import Category.Instance.Cat.

Generalizable All Variables.

Theorem Cones_to_Comma `(F : [J, C]) : Cones F ⟶ (Δ ↓ =(F)).
Proof.
  functor; simpl; intros.
  - exists (vertex_obj[X], ttt).
    transform; simpl; intros.
    + apply @vertex_map. exact (@coneFrom _ _ _ X).
    + abstract (rewrite id_right; apply cone_coherence).
    + abstract (rewrite id_right; symmetry; apply cone_coherence).
  - exists (`1 f, ttt); abstract (simpl; intros; cat).
  - abstract proper.
  - abstract cat.
  - abstract cat.
Defined.

Theorem Cones_from_Comma `(F : [J, C]) : (Δ ↓ =(F)) ⟶ Cones F.
Proof.
  functor; simpl; intros.
  - construct; simpl; intros.
    + exact (fst ``X).
    + exists (transform[`2 X]). abstract (intros; rewrite (naturality[`2 X]); cat).
  - destruct f; simpl in *.
    exists (fst x0); abstract (intros; rewrite e; cat).
  - abstract proper.
  - abstract cat.
  - abstract cat.
Defined.

(* Wikipedia: "We can define the category of cones to F as the comma category
  (Δ ↓ F). Morphisms of cones are then just morphisms in this category. This
  equivalence is rooted in the observation that a natural map between constant
  functors Δ(N), Δ(M) corresponds to a morphism between N and M. In this
  sense, the diagonal functor acts trivially on arrows. In similar vein,
  writing down the definition of a natural map from a constant functor Δ(N) to
  F yields the same diagram as the above. As one might expect, a morphism from
  a cone (N, ψ) to a cone (L, φ) is just a morphism N → L such that all the
  "obvious" diagrams commute." *)

Theorem Cones_Comma `(F : [J, C]) : Cones F ≅[Cat] (Δ ↓ =(F)).
Proof.
  isomorphism; simpl; intros.
  - apply Cones_to_Comma.
  - apply Cones_from_Comma.
  - constructive.
    + exists (id, ttt); abstract cat.
    + exists (id, ttt); abstract cat.
    + abstract (simpl; cat).
    + abstract (simpl; cat).
    + abstract (simpl; cat).
  - constructive.
    + exists id; abstract (intros; cat).
    + exists id; abstract (intros; cat).
    + abstract (simpl; cat).
    + abstract (simpl; cat).
    + abstract (simpl; cat).
Qed.


Require Import UsefulTypes.
Require Import list.
Require Import Coq.Lists.List.
Require Import tactics.
Require Import Omega.
Require Import universe.
Require Import bin_rels.
Require Import eq_rel.
Require Import universe.
Require Import LibTactics.
Require Import tactics.
Require Import Coq.Bool.Bool.
Require Import Coq.Program.Tactics.
Require Import Omega.
Require Import Coq.Program.Basics.
Require Import Coq.Lists.List.
Require Import Coq.Init.Notations.
Require Import UsefulTypes.
Require Import Coq.Classes.DecidableClass.
Require Import Coq.Classes.Morphisms.
Require Import varInterface.

Hint Rewrite diff_nil : fast.
Set Implicit Arguments.
Section AssociationList.
Variables Key Value : Type.
Definition AssocList : Type := list (Key * Value).
Definition ALDom : AssocList -> list Key := map (fun x => fst x).
Definition ALRange : AssocList -> list Value := map (fun x => snd x).

Theorem ALDomCombine :
  forall lv lnt,
    length lv = length lnt
    -> ALDom (combine lv lnt) = lv.
Proof.
  induction lv; sp; simpl; destruct lnt; allsimpl; sp; try omega.
  f_equal; auto.
Qed.

Theorem ALRangeCombine :
  forall lv lnt,
    length lv = length lnt
    -> ALRange (combine lv lnt) = lnt.
Proof.
  induction lv; sp; simpl; destruct lnt; allsimpl; sp; try omega.
  f_equal; auto.
Qed.

Lemma ALInEta : forall sub v t,
  LIn (v,t) sub -> (LIn v (ALDom sub)) # (LIn t (ALRange sub)).
Proof.
  induction sub as [| ? Hind]; introv Hin; auto.
  allsimpl. dorn Hin; subst; auto;[].
  apply IHHind in Hin. repnd.
  split; right; auto.
Qed.

Definition ALMap {TK TV : Type}
  (fk : Key -> TK)
  (fv : Value -> TV) (al : AssocList):=
map (fun p => (fk (fst p), fv (snd p))) al.

Definition ALMapRange {T : Type} (f : Value -> T) (al : AssocList):=
ALMap (fun x=>x) f al.

Definition ALMapDom {T : Type} (f : Key -> T) (al : AssocList):=
ALMap f (fun x=>x)  al.

Context {deqKey : (Deq Key)}.
(** All definitions/lemmas below need decidable equality on Key.
    If not, they should placed before the line above *)
Fixpoint ALFind
    (al : AssocList) (key : Key): option Value :=
match al with
| nil => None
| (k, v) :: xs => if (beq_var k key)
                  then Some v
                  else ALFind xs key
end.

Definition ALFindDef
    (al : AssocList) (key : Key) (def: Value):  Value :=
match (ALFind al key) with
| Some v => v
| None => def
end.

(** Same as [AlFind] above, but the output contains proofs of
    correctness. *)
Lemma ALFind2 :
  forall  (sub: AssocList) (a : Key) ,
    { b: Value & LIn (a,b) sub}
    + !(LIn a (ALDom sub)).
Proof.
   induction sub as [| (a', b') sub Hind]; intro a.
   - right.  sp.
   - simpl. destruct (decideP (a=a')) as [Hc|Hc]; subst.
      + left. exists b'. left; refl.
      + destruct (Hind a) as [Hl | Hr]; exrepnd ;[left | right].
          * exists b. right; auto.
          * intro Hf. apply Hr. simpl in Hf. destruct (split sub).
              dorn Hf; sp.
Defined.

Definition ALFindDef2
    (al : AssocList) (key : Key) (def: Value):  Value :=
match (ALFind2 al key) with
| inl (existT _ v _ ) => v
| inr _ => def
end.

(** In proofs, it is often convenient to replace
  [ALFindDef] with [ALFindDef2] so that we get some
  correctness hypotheses for free on destruction*)
Lemma ALFindDef2Same : forall
  (key : Key) (def: Value) (al : AssocList),
  ALFindDef al key def=ALFindDef2 al key def.
Proof.
  induction al as [|h th Hind]; auto;[]. destruct h as [k v].
  allunfold ALFindDef. allunfold ALFindDef2.
  simpl. setoid_rewrite decide_decideP.
  cases_ifd Hd; auto.
  - rw Hdt; auto. subst. rewrite deqP_refl. simpl. refl.
  - unfold ALFindDef2 in Hind.
    rw  Hind.  destruct_head_match; simpl; auto.
    destruct s; auto.
Abort.

Fixpoint ALFilter (sub : AssocList) (keys : list Key) : AssocList :=
  match sub with
  | nil => nil
  | (k, v) :: xs =>
      if (memvar k keys)
      then ALFilter xs keys
      else (k, v) :: ALFilter xs keys
  end.

Lemma ALFilter_nil_r :
  forall sub, ALFilter sub [] = sub.
Proof.
  induction sub; simpl; sp.
  rewrite IHsub; auto.
Qed.

Notation DeqKey := (fun (x y: Key) => decideP (x=y)).

Ltac dec :=
unfold beq_var in *;
unfold memvar in *;
(repeat rewrite decide_decideP);
(repeat rewrite memberb_din);
repeat match goal with
[H:context[decide _] |- _] => rewrite decide_decideP in H
|[H:context[memberb _ _ _] |- _] => rewrite memberb_din in H
end.

Lemma ALDomFilterCommute :
  forall l sub,
    diff l (ALDom sub) = ALDom (ALFilter sub l).
Proof.
  induction sub; simpl; sp; allsimpl.
  - apply diff_nil.
  - rewrite diff_cons_r. dec.
    cases_if; simpl; f_equal; auto.
Qed.

(* for some tactics like cpx *)

Ltac dest t :=
let tf := eval cbv beta in t in
destruct tf.

Lemma ALFindSome :
  forall sub : AssocList,
  forall v : Key,
  forall u : Value,
    ALFind sub v = Some u
    -> LIn (v, u) sub.
Proof.
  induction sub; simpl; sp.
  setoid_rewrite decide_decideP in H.
  dest (DeqKey a0 v); subst; cpx.
  inverts H. cpx.
Qed.

Lemma ALFindNone :
  forall sub v,
    ALFind sub v = None
    -> ! LIn v (ALDom sub).
Proof.
  induction sub; simpl; sp;
  inversion H;
  setoid_rewrite decide_decideP in H;
  setoid_rewrite decide_decideP in H2;
  dest (DeqKey a0 v); cpx.
  apply IHsub in H0;  cpx.
Qed.

Lemma ALFind2Same : forall (sub: AssocList) v, ALFind sub v =
        proj_as_option (ALFind2 sub v).
Proof using.
  induction sub as [| a]; intros; auto; simpl.
  destruct a. dec. dec.
  destruct (decideP (k = v));
  subst; autorewrite with SquiggleEq; simpl in *; auto.
  rewrite IHsub. destruct ((ALFind2 sub v)); simpl;
  try(destruct s; simpl); auto;
  destruct (decideP (v = k)); cpx.
Qed.

Lemma ALFindFilterSome :
  forall l v t sub,
    (ALFind (ALFilter sub l) v = Some t)
    <=> (ALFind sub v = Some t # ! LIn v l).
Proof.
  induction sub; simpl; sp; split; introv H; sp; allsimpl; dec.
  -  destruct (in_deq Key _ a0 l); allsimpl.
    + rw IHsub in H; sp;case_if as Hd; subst;auto; try contradiction.
    + dec.
       case_if as Hd; subst; auto; try contradiction.
      rw IHsub in H; exrepnd; auto.

  - destruct (in_deq Key _ a0 l); allsimpl.
    + apply IHsub in H; exrepnd; auto.
    + dec. dest (DeqKey a0 v); allsimpl; subst; sp;[].
      rw IHsub in H; exrepnd; auto.

  - destruct (in_deq Key _ a0 l); allsimpl.
    + apply IHsub; split; auto. dec.
      dest (DeqKey a0 v); allsimpl; subst; sp.

    + dec. dest (DeqKey a0 v); allsimpl; subst; sp.
       apply IHsub; split; auto.
Qed.

Lemma ALFindFilterNone :
  forall l v sub,
    (ALFind (ALFilter sub l) v = None)
    <=> (ALFind sub v = None [+] LIn v l).
  induction sub; simpl; sp; split; introv H; sp; allsimpl; dec.
  - destruct (in_deq Key _ a0 l); allsimpl; dec;
    dest (DeqKey a0 v); allsimpl;
    subst;
    try(rw IHsub in H);
    exrepnd; auto;cpx.
  - destruct (in_deq Key _ a0 l); allsimpl;dec;
    dest (DeqKey a0 v); allsimpl;
    subst;cpx;apply IHsub; cpx.
  - dec. dest (in_deq Key _ a0 l); allsimpl; dec;
    dest (DeqKey a0 v); allsimpl;
    subst;cpx;apply IHsub; cpx.
Qed.

Lemma ALFilterSwap :
  forall l1 l2 sub,
    ALFilter (ALFilter sub l1) l2
    = ALFilter (ALFilter sub l2) l1.
Proof.
  induction sub; simpl; sp.
  allsimpl; cases_if as H1d; cases_if as H2d;
  allsimpl; try (rw H1d); try (rw H2d);
  cpx; try (rw IHsub); cpx.
Qed.

Lemma ALFilterAppR :
  forall sub vs1 vs2,
    ALFilter sub (vs1 ++ vs2)
    = ALFilter (ALFilter sub vs1) vs2.
Proof.
  induction sub; simpl; sp; dec.
  rw <- memberb_din.
  rw <- memberb_din.
  rw memberb_app.
  destructr (memberb _ a0 vs1) as [m1 | m1]; simpl.
  apply IHsub. unfold memvar.
  allsimpl. destruct (memberb _ a0 vs2) as [m2 | m2];
  simpl; subst;
  try(rw IHsub); auto.
Qed.

Lemma ALFilterAppAsDiff :
  forall sub l1 l2,
    ALFilter sub (l1 ++ l2)
    = ALFilter sub (l1 ++ diff l1 l2).
Proof.
  induction sub; simpl; sp; allsimpl;[].
  dec.
  cases_ifd  Hd; cases_ifd  Hdd; cpx;
  allrw in_app_iff;
  allrw in_diff.
  - provefalse. apply Hddf.
    dorn Hdt; cpx.
  - provefalse. apply Hdf.
    dorn Hddt; exrepnd; cpx.
  - f_equal. auto.
Qed.

(** [lv] is needs to make the induction
    hypothesis strong enough *)
Lemma ALFilterDom : forall  sub lv,
  ALFilter sub (lv++ALDom sub) =[].
Proof.
  induction sub as [|(v,u) sub Hind] ; introv ; auto;[].
  allsimpl; dec.
  cases_ifd Hd; cpx; allsimpl; allrw in_app_iff;
  cpx; dec.
  - rw cons_as_app. rw app_assoc. rw Hind; auto.
  - provefalse. apply Hdf. right. cpx.
Qed.

Fixpoint ALKeepFirst (sub : AssocList) (vars : list Key) : AssocList :=
match sub with
| nil => nil
| (v, t) :: xs =>
    if in_deq _ _ v vars
    then (v, t) :: ALKeepFirst
                   xs
                   (diff [v] vars)
    else ALKeepFirst xs vars
end.

Lemma ALKeepFirstNil :
  forall sub,
    ALKeepFirst sub [] = [].
Proof.
  induction sub; simpl; sp.
Qed.

Lemma ALFindSomeKeepFirstSingleton:
  forall sub v t,
    ALFind sub v = Some t
    -> ALKeepFirst sub [v] = [(v,t)].
Proof.
  induction sub as [|(v,t) sub Hind];
  introv Heq; allsimpl; cpx. dec.
  dest (DeqKey v v0);
  subst;allsimpl; cpx.
  rewrite deqP_refl.
  rw ALKeepFirstNil; auto.
  inversion Heq.
  cpx.
  cases_if; cpx.
Qed.

Lemma ALFindNoneKeepFirstSingleton:
  forall sub v,
    ALFind sub v = None
    -> ALKeepFirst sub [v] = [].
Proof.
  induction sub as [|(v,t) sub Hind];
  introv Heq; allsimpl; cpx.
  dec.
  dest (DeqKey v v0);
  subst;allsimpl; cpx.
  cases_if; cpx.
Qed.
Hint Rewrite ALKeepFirstNil ALFilterDom ALFilter_nil_r : fast.

Ltac cpx :=
  repeat match goal with
           (* false hypothesis *)
           | [ H : [] = snoc _ _ |- _ ] =>
             complete (apply nil_snoc_false in H; sp)
           | [ H : snoc _ _ = [] |- _ ] =>
             complete (symmetry in H; apply nil_snoc_false in H; sp)

           (* simplifications *)
           | [ H : _ :: _ = _ :: _ |- _ ] => inversion H; subst; GC

           | [ H : Some _ = Some _ |- _ ] => inversion H; subst; GC
           | [ H : Some _ = None |- _ ] => inversion H; GC
           | [ H : None = Some _ |- _ ] => inversion H; GC

           | [ H : 0 = length _ |- _ ] =>
             symmetry in H; trw_h length0 H; subst
           | [ H : length _ = 0 |- _ ] =>
             trw_h length0 H; subst

           | [ H : 1 = length _ |- _ ] =>
             symmetry in H; trw_h length1 H; exrepd; subst
           | [ H : length _ = 1 |- _ ] =>
             trw_h length1 H; exrepd; subst

           | [ H : [_] = snoc _ _ |- _ ] =>
             symmetry in H; trw_h snoc1 H; repd; subst
           | [ H : snoc _ _ = [_] |- _ ] =>
             trw_h snoc1 H; repd; subst

           | [ H : context[length (snoc _ _)] |- _ ] =>
             rewrite length_snoc in H
         end;
  inj;
  try (complete (allsimpl; sp)).

Lemma ALKeepFirstLin:
  forall sub v vs t,
    LIn (v,t) (ALKeepFirst sub vs)
    <=> (ALFind sub v = Some t # LIn v vs).
Proof.
  induction sub; simpl; sp;[split;sp|]. dec.
  dest (DeqKey a0 v);
  destruct (in_deq Key _ a0 vs);
  subst; cpx; split; introns Hyp; allsimpl; exrepnd; cpx.
  - dec. dorn Hyp; cpx; cpx. apply IHsub in Hyp.
    exrepnd.
    apply in_remove in Hyp; cpx.
  - dec. cpx.
     apply IHsub in Hyp; exrepnd; cpx.
  - dorn Hyp; cpx. apply IHsub in Hyp.
    exrepnd.
    apply in_remove in Hyp; cpx.
  - right. apply IHsub; dands; cpx.
    apply in_remove; dands; cpx.
Qed.

Lemma ALKeepFirstLinApp:
  forall sub v vs vss t,
    LIn (v,t) (ALKeepFirst sub (vs))
    -> LIn (v,t) (ALKeepFirst sub (vs++ vss)).
Proof.
  introv X.
  apply ALKeepFirstLin in X.
  apply ALKeepFirstLin.
  exrepnd; dands; auto.
  apply in_app_iff.
  cpx.
Qed.

Lemma ALFilterLIn :
  forall v t sub vars,
    LIn (v, t) (ALFilter sub vars)
    <=>
    (
      LIn (v, t) sub
      #
      ! LIn v vars
    ).
Proof.
  induction sub; simpl; sp; dec.
  split; sp. cases_if;
  simpl; allrw; split; sp; cpx.
Qed.

Lemma ALFilterSubset :
  forall sub vars,
    subset (ALFilter sub vars) sub.
Proof.
  introv Hin.
  destruct x;
  rw ALFilterLIn in Hin; cpx.
Qed.

Lemma ALKeepFirstSubst :
  forall sub vars,
    subset (ALKeepFirst sub vars) sub.
Proof.
  introv Hin.
  destruct x;
  rw ALKeepFirstLin in Hin; exrepnd;
  cpx.
  apply ALFindSome; cpx.
Qed.

Hint Resolve ALFilterSubset ALKeepFirstSubst :
  SetReasoning.

Lemma ALKeepFirstAppLin:
  forall lv1 lv2 sub v u,
  LIn (v,u) (ALKeepFirst sub (lv1++lv2))
  -> LIn (v,u) (ALKeepFirst sub lv1) [+]
     LIn (v,u) (ALKeepFirst sub lv2).
Proof. introv Hin.
  apply ALKeepFirstLin in Hin.
  repnd.
  apply in_app_iff in Hin. dorn Hin;[left|right];
  apply ALKeepFirstLin;sp.
Qed.

Lemma ALKeepFirstFilterDiff:
forall sub lvk lvf,
  (ALKeepFirst  sub (diff lvf lvk))
  =
  (ALKeepFirst (ALFilter sub lvf) lvk).
Proof.
  induction sub; allsimpl;
  autorewrite with fast; cpx; dec;[].
  intros. allsimpl.
  destruct a. dec.
  cases_ifd H1d; cases_ifd H2d;
   allrw in_diff; exrepnd; allsimpl; cpx.
  - cases_ifd H3d; cpx. f_equal.
    rw <- diff_remove. apply IHsub.
  - cases_ifd H3d; cpx. provefalse.
    apply H1df. dands;cpx.
Qed.

Lemma ALFilterAppSub :
  forall sub1 sub2 l,
  ALFilter (sub1++sub2) l
  = (ALFilter sub1 l)++(ALFilter sub2 l).
Proof.
  induction sub1; simpl; sp;[].
  rw IHsub1.
  cases_ifd Hd; cpx.
Qed.

Lemma ALFindApp :
  forall v sub1 sub2,
    ALFind (sub1 ++ sub2) v
    = match ALFind sub1 v with
        | Some t => Some t
        | None => ALFind sub2 v
      end.
Proof.
  induction sub1; simpl; sp.
  cases_if; auto.
Qed.

Lemma ALFindRangeMapSome :
  forall v t sub f,
    ALFind sub v = Some t
    -> ALFind (ALMapRange f sub) v
        = Some (f t).
Proof.
  induction sub; simpl; sp; allsimpl;[].
  cases_ifd Hd; cpx.
Qed.

Lemma ALFindRangeMapNone :
  forall v sub f,
    ALFind sub v = None
    -> ALFind (ALMapRange f sub) v = None.
Proof.
  induction sub; simpl; sp; allsimpl.
  cases_ifd Hd; cpx.
Qed.

Fixpoint ALRangeRel  (R : Value -> Value-> [univ])
    (subl subr : AssocList) : [univ] :=
match (subl, subr) with
| ([],[]) => True
| ((vl,tl) :: sl , (vr,tr) :: sr) => (vl=vr # R tl tr # ALRangeRel R sl sr)
| ( _ , _) => False
end.

Lemma ALRangeRelApp : forall R subl1 subl2 subr1 subr2,
  (ALRangeRel  R subl1 subl2 # ALRangeRel R subr1 subr2)
  ->   ALRangeRel R (subl1 ++ subr1)  (subl2 ++ subr2).
Proof.
  induction subl1 as [|(v1,t1) subl1 Hind]; introv Hsr;
  destruct subl2 as [|(v2,t2) subl2]; inverts Hsr; allsimpl;sp.
Qed.

Lemma ALRangeRelRefl : forall R,
  refl_rel R -> refl_rel (ALRangeRel R).
Proof.
  introv Hr. unfold refl_rel in Hr. unfold refl_rel.
  induction x as [|(v1,t1) subl1 Hind];  allsimpl;sp.
Qed.

Lemma ALRangeRelSameDom : forall R
  (subl subr : AssocList),
  ALRangeRel R subl subr
  -> ALDom subl = ALDom subr.
Proof.
  induction subl as [| (kl,vl) subl Hind]; introv Hal;
  destruct subr as [| (kr,vr) subr]; allsimpl; repnd; dands; cpx.
  f_equal; cpx.
Qed.

Lemma ALRangeRelFind : forall R
  (subl subr : AssocList) k t,
  ALRangeRel R subl subr
  -> ALFind subl k = Some t
  -> { tr : Value & ALFind subr k = Some tr # R t tr}.
Proof.
  induction subl as [| (kl,vl) subl Hind]; cpx; introv HAl Hf.
  allsimpl. destruct subr as [| (kr,vr) subr]; cpx;[].
  allsimpl. repnd. subst.
  cases_ifd Hd; cpx.
  eexists; eauto.
Qed.

Lemma ALRangeRelFilter : forall R
  (subl subr : AssocList) l,
  ALRangeRel R subl subr
  ->  ALRangeRel R
        (ALFilter  subl l)
        (ALFilter  subr l).
Proof.
  induction subl as [| (kl,vl) subl Hind]; introv Hal;
  destruct subr as [| (kr,vr) subr]; allsimpl; repnd; dands; subst; cpx.
  cases_if; cpx.
Qed.

(* hints should be placed (again) after this line.
  the ones in the section get deactivated
 *)
End AssociationList.
Hint Rewrite ALKeepFirstNil ALFilterDom ALFilter_nil_r
  ALRangeCombine ALDomCombine: fast.

Hint Resolve ALFilterSubset ALKeepFirstSubst :
  SetReasoning.

Definition ALSwitch {K V} (sub : AssocList K V)  : AssocList V K :=
  map (fun x => (snd x, fst x)) sub.

Lemma ALSwitchCombine : forall {K V} (lv: list V) (lk : list K) ,
  combine lv lk = ALSwitch (combine lk lv).
Proof.
  induction lv; allsimpl.
  - destruct lk; cpx.
  - destruct lk; cpx.
    allsimpl. f_equal. cpx.
Qed.

Lemma ALMapRangeFilterCommute :
  forall K V l T (deq : Deq K) (f: V -> T) (sub : AssocList K V),
  (ALFilter (ALMapRange f sub) l)  = ALMapRange f (ALFilter sub l).
Proof.
  induction sub; simpl; sp; allsimpl.
  cases_if; simpl; auto; f_equal; auto.
Qed.

Ltac dec :=
unfold beq_var in *;
(repeat rewrite decide_decideP);
(repeat rewrite memberb_din);
repeat match goal with
[H:context[decide _] |- _] => rewrite decide_decideP in H
|[H:context[memberb _ _ _] |- _] => rewrite memberb_din in H
end.

Lemma ALFindMapSome :
  forall {KA KB VA VB : Type}
    (DKA : Deq KA)
    (DKB : Deq KB)
    (fk : KA -> KB)
    (fv : VA -> VB),
  injective_fun fk
  -> forall (sub : AssocList KA VA)
      v t, ALFind sub v = Some t
  -> ALFind  (ALMap fk fv sub) (fk v)
        = Some (fv t).
Proof.
  introv Hik.
  induction sub;simpl; introv Heq; sp; allsimpl;[].
  dec.
  cases_ifd Hd; cpx.
  + f_equal. apply Hik in Hdt.
    destruct Hdt. rewrite deqP_refl in Heq.
    invertsn Heq. refl.
  + apply IHsub. revert Heq. cases_ifd Hdd;
    subst; cpx.
Qed.

Lemma ALFindMapNone :
  forall {KA KB VA VB : Type}
    (DKA : Deq KA)
    (DKB : Deq KB)
    (fk : KA -> KB)
    (fv : VA -> VB),
  injective_fun fk
  -> forall (sub : AssocList KA VA)
      v, ALFind  sub v = None
  -> ALFind (ALMap fk fv sub) (fk v)
        = None.
Proof.
  introv Hik.
  induction sub;simpl; introv Heq; sp; allsimpl;[].
  dec.
  cases_ifd Hd; cpx.
  + f_equal. apply Hik in Hdt.
    destruct Hdt. rewrite deqP_refl in Heq.
    invertsn Heq.
  + apply IHsub. revert Heq. cases_ifd Hdd;
    subst; cpx.
Qed.

Lemma ALFindEndoMapSome :
  forall {KA VA VB: Type}
    (DKA : Deq KA)
    (fk : KA -> KA)
    (fv : VA -> VB),
  injective_fun fk
  -> forall (sub : AssocList KA VA)
      v, ALFind sub v = None
  -> ALFind (ALMap fk fv sub) (fk v)
        = None.
Proof.
  intros. eapply ALFindMapNone; eauto.
Qed.

Lemma ALMapFilterCommute :
  forall {KA KB VA VB : Type}
  (DKA : Deq KA)
  (DKB : Deq KB)
  (fk : KA -> KB)
  (fv : VA -> VB),
  injective_fun fk
  -> forall (sub : AssocList KA VA) l,
      (ALFilter  (ALMap fk fv sub) (map fk l))
          = ALMap fk fv (ALFilter  sub l).
Proof.
  introv Hin.
  induction sub; simpl; sp; allsimpl;
  dec. dec.
  cases_ifd Hd; cases_ifd Hc;
    simpl; auto; f_equal; auto.
  - dec. apply in_map_iff in Hdt. exrepnd. apply Hin in Hdt1.
    subst. cpx.
  - rw in_map_iff in Hdf. provefalse.
    apply Hdf. eexists; eauto.
Qed.

(** endo maps avoid the need to provide another
    decider for keys *)
Lemma ALEndoMapFilterCommute :
  forall {KA VA VB : Type}
  (DKA : Deq KA)
  (fk : KA -> KA)
  (fv : VA -> VB),
  injective_fun fk
  -> forall (sub : AssocList KA VA) l,
      (ALFilter  (ALMap fk fv sub) (map fk l))
          = ALMap fk fv (ALFilter  sub l).
Proof.
  intros. apply ALMapFilterCommute; auto.
Qed.

Lemma ALMapRangeFindCommute :
  forall K V T (v: K) (deq : Deq K) (f: V -> T) (sub : AssocList K V),
  (ALFind  (ALMapRange f sub) v)  = option_map f (ALFind  sub v).
Proof.
  induction sub; simpl; sp; allsimpl.
  cases_if; simpl; auto; f_equal; auto.
Qed.

(* Move *)
Ltac dALFind sn :=
  match goal with
    | [  |- context[ALFind ?s ?v] ] =>
      let sns := fresh sn "s" in
      remember (ALFind s v) as sn;
        destruct sn as [sns |]
    | [ H: context[ALFind ?s ?v] |- _ ] =>
      let sns := fresh sn "s" in
      remember (ALFind s v) as sn;
        destruct sn as [sns |]
  end.

Lemma ALMapCombine :
  forall {KA KB VA VB : Type}
    (fk : KA -> KB)
    (fv : VA -> VB) ka va,
  ALMap fk fv (combine ka va)
  = (combine (map fk ka) (map fv va)).
Proof using.
  induction ka; intros ?; eauto.
  simpl.
  destruct va; auto.
  unfold ALMap. simpl.
  f_equal. eauto.
Qed.

Lemma ALFindMap2 :
  forall {KA KB VA VB : Type}
    {DKA : Deq KA}
    {DKB : Deq KB}
    (fk : KA -> KB)
    (fv : VA -> VB),
  forall (sub : AssocList KA VA) k,
  (forall s, In s sub -> fk (fst s) = fk k -> fst s = k)
  -> ALFind  (ALMap fk fv sub) (fk k) = option_map fv (ALFind  sub k).
Proof using.
  clear.
  introv Hik.
  induction sub;simpl; sp; allsimpl;[].
  dec.
  cases_ifd Hd; cpx.
  + specialize (Hik _ (or_introl eq_refl)). symmetry in Hdt.
    simpl in Hik. symmetry in Hdt.
    apply Hik in Hdt. subst.
    rewrite deqP_refl. refl.
  + rewrite IHsub.
    * clear IHsub. dec. cases_if as Hd;
      subst; cpx.
    * intros ? ?. apply Hik. cpx.
Qed.

Lemma ALFindMap :
  forall {KA KB VA VB : Type}
    {DKA : Deq KA}
    {DKB : Deq KB}
    (fk : KA -> KB)
    (fv : VA -> VB),
  injective_fun fk
  -> forall (sub : AssocList KA VA) k,
  ALFind  (ALMap fk fv sub) (fk k) = option_map fv (ALFind  sub k).
Proof using.
  introv Hik. intros. apply ALFindMap2.
  intros ? ?. apply Hik.
Qed.

Lemma ALFindNoneIf {KA VA : Type}
    {DKA : Deq KA} :
  forall k (sub: AssocList KA VA),
  (not (In k (ALDom sub))) -> ALFind  sub k = None.
Proof using.
  intros ? ? ?.
  dALFind ss;[| refl].
  provefalse.
  symmetry in Heqss.
  apply ALFindSome in Heqss.
  apply ALInEta in Heqss. tauto.
Qed.

Notation lmap := AssocList.

(*this is slightly different from ALFind2*)
Lemma lmap_find :
  forall {A B: Type}
         (eqdec: Deq A) (sub: lmap A B) (a : A) ,
    { b: B & LIn (a,b) sub}
    + !(LIn a (fst (split sub))).
Proof.
   induction sub as [| (a', b') sub Hind]; intro a.
   - right.  sp.
   - destruct (decideP (a'= a)) as [Hc|Hc]; subst.
      + left. exists b'. left; refl.
      + destruct (Hind a) as [Hl | Hr]; exrepnd ;[left | right].
          * exists b. right; auto.
          * intro Hf. apply Hr. simpl in Hf. destruct (split sub).
              dorn Hf; sp.
Defined.

Notation dom_lmap := ALDom.

(**same as above, but the impelemtation is guaranteed to return the first match*)
Lemma lmap_find_first: forall {A B: Type}
  (eqdec: Deq A) (sub: lmap A B) (a : A) ,
    { b: B & {n:nat & n < length sub
            # nth n sub (a,b) = (a,b)
            # (forall m, m<n ->  (nth m (dom_lmap sub) a) <> a) } }
       + !LIn a (dom_lmap sub).
Proof.
   induction sub as [| (a', b') sub Hind]; intro a.
   - right.  sp.
   - destruct (decideP (a'=a)) as [Hc|Hc]; subst.
      + left. exists b'. exists 0. split; simpl; auto. apply  lt_0_Sn.
        split; auto. introv Hm; inverts Hm.
      + destruct (Hind a) as [Hl | Hr]; exrepnd ;[left | right].
          * exists b. exists (S n). repeat(split); auto; simpl. apply lt_n_S. auto.
            introv Hlt. destruct m; auto. apply Hl1. apply lt_S_n; auto.
          * introv Hf. apply Hr. simpl in Hf.
              dorn Hf; sp.
Defined.

Lemma ALFindMap3:
forall {KA KB VA VB : Type} {DKA : Deq KA} {DKB : Deq KB}
         (fv : VA -> VB) (sub : lmap KA VA) (k : KA),
       ALFind (ALMap id fv sub) k = option_map fv (ALFind sub k).
Proof using.
  intros.
  apply (ALFindMap2 id fv).
  intros; destruct s; simpl in *; assumption.
Qed.

(* Move :there must be something similar in stdlib or, Extlib, or UsefulTypes.v *)
Definition eqfun {A B:Type} (f g : A -> B) :=
  forall a, f a = g a.

Definition ALFindEndo {Key:Type} {d:Deq Key} (sub: AssocList Key Key)  (k:Key) : Key :=
  ALFindDef sub k k.

Lemma ALFindEndoId {Key:Type} {d:Deq Key} (sub: AssocList Key Key) v :
  disjoint [v] (ALDom sub)
  -> ALFindEndo sub v = v.
Proof using.
  intros.
  unfold ALFindEndo, ALFindDef.
  rewrite ALFindNoneIf;[refl|].
  firstorder.
Qed.

Lemma ALFindEndoId2 {Key:Type} {d:Deq Key} lv v:
  ALFindEndo (map (fun x=> (x,x)) lv) v = v.
Proof using.
  unfold ALFindEndo, ALFindDef.
  dALFind sd; [| refl].
  symmetry in Heqsd.
  apply ALFindSome in Heqsd. apply in_map_iff in Heqsd.
  exrepnd. inverts Heqsd1. refl.
Qed.

Lemma ALFindMapEndoId {Key:Type} {d:Deq Key} (sub: AssocList Key Key) lv:
  disjoint lv (ALDom sub)
  -> map (ALFindEndo sub) lv = lv.
Proof using.
  intros Hd.
  rewrite <- (map_id lv) at 2.
  apply eq_maps.
  intros ? Hin.
  apply ALFindEndoId.
  eapply subset_disjoint;[| apply Hd].
  apply singleton_subset. assumption.
Qed.

Lemma vmap_app_nest {NVar:Type} {deq : Deq NVar} (sub1 sub2: AssocList NVar NVar):
  disjoint (ALRange sub1) (ALDom sub2)
  -> eqfun (ALFindEndo (sub1++sub2)) ((ALFindEndo sub2) ∘ (ALFindEndo sub1)).
Proof using.
  intros Hd.
  intros v. unfold compose, ALFindEndo, ALFindDef.
  rewrite ALFindApp. dALFind s1v; auto.
  rewrite ALFindNoneIf;[refl|].
  apply Hd. symmetry in Heqs1v.
  apply ALFindSome in Heqs1v. apply in_map_iff.
  eexists; dands ; eauto. auto.
Qed.

Lemma vmap_decompose {NVar:Type} {deq : Deq NVar}  (lv : list NVar) (sub: AssocList NVar NVar):
  let subOuter := map (fun v => (v,  (ALFindEndo sub) v)) lv in
  let subInner := ALFilter sub lv in
  disjoint (ALRange sub) lv
  -> eqfun (ALFindEndo sub) ((ALFindEndo subOuter) ∘ (ALFindEndo subInner)).
Proof using.
  simpl. intros Hd a.
  rewrite  <- vmap_app_nest;
    [| setoid_rewrite map_map; unfold compose; simpl; rewrite map_id;
       eapply subset_disjoint; try apply Hd; apply map_monotone, ALFilterSubset].
  unfold ALFindEndo, ALFindDef.
  setoid_rewrite ALFindApp. symmetry.
  dALFind sfa; simpl; symmetry in Heqsfa;
    [apply ALFindFilterSome in Heqsfa | apply ALFindFilterNone in Heqsfa]; repnd;
      try rewrite  Heqsfa0;[refl|].
  dALFind sm; symmetry in Heqsm.
  - apply ALFindSome in Heqsm. apply in_map_iff in Heqsm. exrepnd. inverts Heqsm1. refl.
  - apply ALFindNone in Heqsm. setoid_rewrite map_map in Heqsm. unfold compose in Heqsm.
    simpl in Heqsm. rewrite map_id in Heqsm. dorn Heqsfa; cpx;[]. rewrite Heqsfa. refl.
Qed.

Global Instance eqfunEquiv {A B:Type}: Equivalence (@eqfun A B).
Proof using.
  constructor; introv; unfold eqfun; try congruence.
Qed.

Lemma combine_of_map_snd {A B C :Type} (f: B->C) (la:list A) lb :
  combine la (map f lb) = map (fun x => (fst x, f (snd x))) (combine la lb).
Proof.
  revert lb.
  induction la as [| a la Hind]; intros;[|destruct lb as [|b lb]]; simpl; auto.
  f_equal.
  eauto.
Qed.

Lemma vmap_nest_same {NVar:Type} {deq : Deq NVar}  (vl vi vr : list NVar):
  let subOuter := combine vi vr  in
  let subInner := combine vl vi in
  let sub := combine vl vr in
  length vi = length vr
  -> length vi = length vl
  -> NoDup vi
  -> eqfun (ALFindEndo sub) ((ALFindEndo subOuter) ∘ (ALFindEndo subInner)).
Proof using.
  simpl. intros Hd H1l H2l a.
  rewrite (combine_map_snd2 vr vi) at 1 by omega.
  rewrite (combine_map_fst2 vi vr) at 3 by omega.
  unfold ALFindEndo, ALFindDef. simpl.  simpl. unfold compose. simpl.
  remember  (ALFind (combine vl (map fst (combine vi vr))) a) as ss.
  do 1 rewrite combine_of_map_snd.
  setoid_rewrite combine_of_map_snd in Heqss.
  replace (map (fun x : NVar * (NVar * NVar) => (fst x, snd (snd x))) (combine vl (combine vi vr)))
          with (ALMapRange snd  (combine vl (combine vi vr))) by refl.
  replace (map (fun x : NVar * (NVar * NVar) => (fst x, fst (snd x))) (combine vl (combine vi vr)))
     with (ALMapRange fst  (combine vl (combine vi vr))) in Heqss by refl.
  setoid_rewrite ALFindMap3.
  setoid_rewrite ALFindMap3 in Heqss.
  subst.
  dALFind  sa; simpl; symmetry in Heqsa.
- admit.
- assert (~ LIn a (remove_nvars vl vi)) as Ha by admit.
  apply ALFindNone in Heqsa.
  setoid_rewrite <- combine_map_fst2 in Heqsa;[| rewrite length_combine_eq; omega].
  rewrite in_remove_nvars in Ha.
  dALFind sia; auto.
  symmetry in Heqsia.
  apply ALFindSome in Heqsia.
  apply in_combine_l in Heqsia. tauto.
Abort.

Require Import SetoidList.
(* move to SquiggleEq.AssocList *)
   Lemma ALRangeRelCombine {V T:Type} (lv:list V) lt1 lt2  (R: T-> T-> Prop):
    eqlistA R lt1 lt2 -> ALRangeRel R (combine lv lt1) (combine lv lt2).
 Proof using.
   intros Heq. revert lv.
   induction Heq;destruct lv; simpl; eauto.
 Qed.


Require Import include_frm.
Require Import sep_auto.

Set Implicit Arguments.

(* Aabsdata _ _ imply OSAbstMod.get *)

Lemma emp_disj:
  forall  (A B T : Type) (MC: PermMap A B T)   O ,
    disjoint O emp.
Proof.
  intros.
  unfolds.
  exists O.
  apply map_join_emp.
Qed.

Hint Resolve emp_disj : abst_solver_base.

Lemma absdata_elim :
  forall s O gamma x y P,
    (s, O, gamma) |= Aabsdata x y ** P ->
    get O x = Some y.
Proof.
  intros.
  destruct s as [ [ [ [ ] ] ] ].
  simpl in *.
  simp join.
  eapply  join_sig_get_disj; eauto.
Qed.

(*
Lemma disj_is_disjoin :
  forall a b,
    disjoint a b -> OSAbstMod.disj a b.
Proof.
  intros.
  unfold OSAbstMod.disj.
  unfold disjoint in H.
  intros.
  simpljoin.
  unfold join in H.
  simpl in H.
  unfold OSAbstMod.join in H.
  lets ff: H a0.
  destruct (OSAbstMod.get a a0);
  destruct (OSAbstMod.get b a0);
  auto.
Qed.
*)

Lemma absdata_elim' :
  forall s O O' gamma x y P,
    (s, O, gamma) |= Aabsdata x y ** P ->
    disjoint O O' ->
    get (merge O O') x = Some y.
Proof.
  intros.
  destruct s as [ [ [ [ ] ] ] ].
  simpl in *.
  simp join.
  eapply  join_sig_get_disj in H3.
  simp join.
  eapply disj_get_merge_get; eauto.
  unfolds; simpl; auto.
Qed.

Lemma get_set_idneq:
  forall (O: OSAbstMod.listset) Of id id' x y,
    disjoint O Of ->
    get O id' = Some y ->
    get O id = Some x ->
    id <> id' ->
    get (merge (set O id' y) Of) id = Some x.
Proof.
  intros.
  eapply disj_get_merge_get .
  unfolds; simpl; auto.
  eapply abst_get_set_disj; eauto.
  eapply get_set_neq; eauto.
Qed.

Lemma get_set_idneq':
  forall (O: OSAbstMod.listset) O' x y x' y' y'',
    disjoint O O' ->
    get O x = Some y ->
    get O x' = Some y' ->
    x <> x' ->
    get (merge (set O x y'') O')  x' = Some y'.
Proof.
  intros.
  eapply disj_get_merge_get .
  unfolds; simpl ; auto.
  eapply abst_get_set_disj; eauto.
  eapply get_set_neq; eauto.
Qed.

Lemma absdata_elim'' :
  forall (s : taskst) (O O' O'' : OSAbstMod.map)
         (gamma : absop) (x x': absdataid) (y y' y'' : absdata) (P : asrt),
    O'' = set O x y'' ->
    (s, O, gamma) |= Aabsdata x y ** Aabsdata x' y' ** P ->
    disjoint O O' ->
    get (merge O'' O') x' = Some y' /\ disjoint O'' O'.
Proof.
  intros.
  simpl in H0.
  simp join.
  apply join_sig_get_disj in H9.
  simp join.
  apply join_sig_get_disj in H4.
  simp join.
  assert (get O x' = Some y').
  eapply sub_get_get; eauto.
  split.
  eapply  get_set_idneq'; eauto.
  introv Hf.
  subst x.
  tryfalse.
  eapply abst_get_set_disj; eauto.
  unfolds; simpl; auto.
  unfolds; simpl; auto.
Qed.

Lemma eqdomO_same:forall O,eqdomO O O.
Proof.
  intros.
  unfolds;split; intros.
  split; auto.
  eexists.
  split;eauto.
  unfolds.
  intros;split;auto.
Qed.
(*
Lemma set_eqdom: forall O Of id x y, OSAbstMod.disj O Of -> OSAbstMod.get O id = Some x -> eqdomO (OSAbstMod.merge O Of) (OSAbstMod.merge (OSAbstMod.set O id y) Of).
Proof.
  intros.
  eapply OSAbstMod.eqdom_merge_set; eauto.
Qed.
*)
Lemma eqdomtls_trans : forall a b c, eqdomtls a b -> eqdomtls b c -> eqdomtls a c.
Proof.
  intros.
  unfold eqdomtls in *.
  intro.
  rewrite H.
  auto.
Qed.

Lemma eqdomO_trans:forall O O' O'', eqdomO O O' -> eqdomO O' O'' -> eqdomO O O''.
Proof.
  intros; unfold eqdomO in *.
  simpljoin.
  intros; split.
  intros.
  rewrite H.
  auto.
  intros.
  lets fff: H2 H3.
  simpljoin.
  lets bb: H1 H4.
  simpljoin.
  exists x0.
  split; auto.
  eapply eqdomtls_trans; eauto.
Qed.

(*

Lemma set_eqdom': forall O O' Of id x y, OSAbstMod.disj O' Of -> OSAbstMod.get O' id = Some x ->eqdomO (OSAbstMod.merge O Of) (OSAbstMod.merge O' Of) -> eqdomO (OSAbstMod.merge O Of) (OSAbstMod.merge (OSAbstMod.set O' id y) Of).
Proof.
  intros.
  eapply eqdomO_trans;eauto.
  eapply set_eqdom;eauto.
Qed.
*)

Lemma get_set_ideq:
  forall(O: OSAbstMod.listset)  Of id y y',
    disjoint O Of ->
    get O id =  Some y' ->
    isRw y' = true ->
    get (merge (set O id y) Of) id = Some y.
Proof.
  intros.
  eapply disj_get_merge_get; eauto.
  eapply abst_get_set_disj; eauto.
  eapply get_set_eq.
Qed.

Lemma abst_disj_merge_set_eq:
  forall x y id (O: OSAbstMod.listset) Of,
    disjoint O Of ->
    get O id = Some x ->
    isRw x = true ->
    merge (set O id y) Of = set (merge O Of) id y.
Proof.
  intros.
  unfold disjoint in H.
  destruct H.
  eapply  join_merge_set_eq; eauto.
Qed.

Lemma abst_disj_merge_set_eq':
  forall x y y' x' id id' (O: OSAbstMod.listset) Of,
    disjoint O Of ->
    get O id = Some x ->
    get O id' = Some x' ->
    merge (set (set O id y) id' y') Of =set (set (merge O Of) id y) id' y'.
Proof.
  intros.
  unfolds in H.
  destruct H.
  assert (merge (set (set O id y) id' y') Of = set (merge (set O id y) Of) id' y').
  assert (id = id' \/ id <> id') by tauto.
  destruct H2.
  eapply  join_merge_set_eq; eauto.
  eapply  join_set_set; eauto.
  subst.
  eapply get_set_eq ; eauto.
  eapply  join_merge_set_eq; eauto.
  eapply  join_set_set; eauto.
  eapply get_set_neq ; eauto.
  rewrite H2.
  assert (merge (set O id y) Of = set (merge O Of) id y).
  eapply abst_disj_merge_set_eq;eauto.
  unfolds.
  eauto.
  rewrite H3.
  auto.
Qed.

Lemma abst_set_get_neq'':
  forall id1 id2 y (O: OSAbstMod.listset),
    id1<>id2 ->
    get (set O id2 y) id1 = get O id1.
Proof.
  intros.
  erewrite get_set_neq; eauto.
Qed.

Lemma abs_join_sig_set_join:
  forall a b (O O1 : OSAbstMod.map) id,
    join (sig id a) O1 O -> join (sig id b) O1 (set O id b).
Proof.
  intros.
  eapply  join_sig_set; eauto.
Qed.

Ltac find_absdata' Hp id :=
  match Hp with
    | ?A ** ?B =>
      match find_absdata' A id with
        | some ?a => constr:(some a)
        | none ?a =>
          match find_absdata' B id with
            | some ?b => constr:(some (a + b)%nat)
            | none ?b => constr:(none (a + b)%nat)
          end
      end
    | Aabsdata id _  => constr:(some 1%nat)
    | _ => constr:(none 1%nat)
  end.

Ltac find_absdata Hp id :=
  let x := find_absdata' Hp id in
  eval compute in x.

Lemma get_none_joinisig:
  forall (qls:EcbMod.map)  qid x,
    get qls qid = None ->
    joinsig qid x qls (set qls qid x).
Proof.
  intros.
  unfolds.
  eapply get_join_sig_set; eauto.
Qed.

Lemma joinisig_get_none:
  forall (qls :EcbMod.map)  qls' qid x,
    joinsig qid x qls qls' ->
    get qls qid = None /\ qls'= (set qls qid x).
Proof.
  intros.
  split.
  apply join_sig_get_disj in H.
  simp join.
  auto.
  unfolds; simpl; auto.
  apply get_join_sig_set_rev; auto.
Qed.

Ltac absdata_solver :=
  match goal with
    | H : (_,?O,_) |= ?P |- get (merge ?O _) ?id = Some _ =>
      match find_absdata P id with
        | none _ => fail 1
        | some ?n =>
          sep lift n in H; eapply absdata_elim' in H; eauto with abst_solver_base
      end
    | H : (_,?O,_) |= ?P |- get ?O ?id = Some _ =>
      match find_absdata P id with
        | none _ => fail 1
        | some ?n =>
          sep lift n in H; eapply absdata_elim in H; eauto with abst_solver_base
      end
    | |- merge (set (set _ _ _) _ _) _ =
         set ( set (merge _ _) _ _) _ _    =>
      eapply  abst_disj_merge_set_eq';first [absdata_solver | eauto ]
    | |- merge (set _ _ _ ) _ = set (merge _ _) _ _ =>
      eapply abst_disj_merge_set_eq;first [absdata_solver | eauto ]
    | |- get (set _ _ _) _ = Some _ =>
      try solve  [ eapply  get_set_eq; auto
                 | erewrite abst_set_get_neq'';[ absdata_solver | auto ;try (intro; tryfalse)]]
    | |- _ _ _ _ _ => try solve [eapply get_none_joinisig;eauto]
  end.

Import DeprecatedTactic.

Lemma cancel_absdata_p:
  forall s O gamma gamma' P Q id a b,
    (forall O', (s, O', gamma) |= P -> (s, O', gamma') |= Q) ->
    ((s, O, gamma) |= Aabsdata id a ** P -> (s, set O id b, gamma') |= Aabsdata id b ** Q).
Proof.
  intros.
  simpl in *;mytac.
  exists empmem.
  destruct s as [[[[]]]].
  simpl in H5.
  simpl in H6.
  subst x;simpl in H1.
  exists m m.
  exists (sig id b) x3 (set O id b).
  simpl;mytac.
  eapply abs_join_sig_set_join; eauto.
  auto.
Qed.

Lemma cancel_absdata_p':
  forall s O gamma P id a b,
    (s, O, gamma) |= Aabsdata id a ** P -> (s, set O id b, gamma) |= Aabsdata id b ** P.
Proof.
  introv Hx.
  intros.
  simpl in *;mytac.
  exists empmem.
  destruct s as [[[[]]]].
  simpl in H5.
  simpl in H4.
  subst x;simpl in H0.
  exists m m.
  exists (sig id b) x3 (set O id b).
  simpl;mytac.
  eapply abs_join_sig_set_join; eauto.
  auto.
Qed.

Ltac get_absdata_number' P id :=
  match P with
    | ?A ** ?B => match get_absdata_number' A id with
                    | (some ?m) => constr:(some m)
                    | (none ?m) => match get_absdata_number' B id with
                                     | (some ?n) => constr:(some (m + n)%nat)
                                     | (none ?n) => constr:(none (m + n)%nat)
                                   end
                  end
    | Aabsdata id _ => constr:(some 1%nat)
    | _ => constr:(none 1%nat)
  end.

Ltac get_absdata_number P id :=
  let y := get_absdata_number' P id in
  eval compute in y.

Ltac cancel_absdata :=
  match goal with
    | H: (?s,?O,_) |= ?P |- (?s,set ?O ?id _,_) |= ?Q =>
      match (get_absdata_number P id) with
        | some ?n => match (get_absdata_number Q id) with
                     | some ?m =>
                       sep lift n in H; sep lift m;
                       generalize dependent H; eapply cancel_absdata_p; intros
                     | _ => idtac
                   end
        | _ => idtac
      end
  end.

Ltac cancel_absdata' :=
  match goal with
    | |- (?s,set ?O ?id _,_) |= ?P =>
      match (get_absdata_number P id) with
        | some ?n => sep lift n; eapply cancel_absdata_p'; cancel_absdata'
        | _ => idtac
      end
    | _ =>idtac
  end.

(*

Ltac ins_aop :=
  match goal with
    | H: (_, ?O, ?aop) |= _ |- _ |= <|| ?aop' ||> ** _ =>
      instantiate (1:=aop')
  end.

Ltac ins_abst' P O tm:=
  match P with
    | ?P1 ** ?P2 => match (ins_abst' P2 O tm) with
                      | ?O' => ins_abst' P1 O' tm
                    end
    | HECBList (EcbMod.set ?ecbls ?x ?b) =>
      constr:(OSAbstMod.set O absecblsid (absecblist (EcbMod.set ecbls x b)))
    | HTCBList (TcbMod.set ?tcbls ?x ?b) =>
      constr:(OSAbstMod.set O abstcblsid (abstcblist (TcbMod.set tcbls x b)))
    | HTime tm => constr:(O)
    | HTime ?tm' => constr:(OSAbstMod.set O ostmid (ostm tm'))
    | _ => constr:(O)
  end.

Ltac ins_abst:=
  match goal with
    | H: (_,?O,_) |= HECBList _ ** HTCBList _ ** HTime ?tm ** HCurTCB _ ** _ |- _|= ?P =>
      match ins_abst' P O tm with
        | ?O' => instantiate (1:=O')
      end
  end.
Ltac exists_O_aop:=
  do 2 eexists;splits;[ ins_aop;ins_abst | | ].

Definition absimp'':= fun p p' : asrt =>
forall (s : taskst) (O : osabst) (gamma : absop),
(s, O, gamma) |= p ->
forall Of : OSAbstMod.map,
OSAbstMod.disj O Of ->
exists O' gamma',
(s, O', gamma') |= p'/\
OSAbstMod.disj O' Of /\
hmstepstar gamma (OSAbstMod.merge O Of) gamma' (OSAbstMod.merge O' Of) .

Lemma absimp'_imp_absimp:
 forall P P',absimp' P P' -> absimp' P P'.
  intros.
  unfold absimp,absimp' in *.
  intros.
  lets Hx: H H0 H1.
  mytac;do 2 eexists;splits;eauto.
Qed.

Ltac disj_solver:=
    match goal with
      | |- OSAbstMod.disj (OSAbstMod.set _ _ _) _ =>
        eapply abst_get_set_disj;[ auto;absdata_solver | disj_solver;auto ]
      | _ => auto
    end.

(*
Ltac eqdomO_solver :=
  match goal with
    | |- eqdomO _ _ => first [ eapply eqdomO_same | eapply set_eqdom'; [disj_solver | absdata_solver | eqdomO_solver]]
  end. *)

Lemma hmstepS_One:
  forall a b c d,
    hmstep a b c d->
    hmstepstar a b c d.
Proof.
  intros.
  eapply spec_stepS;
   [
      eauto  | eapply spec_stepO].
Qed.

*)


From Ltac2 Require Import Ltac2.
Require Import Waterproof.tactics.unfold.

Require Import Waterproof.notations.notations.
Require Import Reals.
Require Import Waterproof.load.
Import databases_RealsAndIntegers.
(*Require Import Waterproof.populate_database.waterproof_integers.
Require Import Waterproof.populate_database.waterproof_reals.*)
Open Scope R_scope.

(** * Sequences in metric spaces *)
(** * TODO change the naming in this file *)
Definition convergence {M : Metric_Space}
                       (a : ℕ → Base M)
                       (c : Base M) :=
  ∀ ε : ℝ, ε > 0 ⇒
    ∃ N : ℕ, ∀ n : ℕ, (n ≥ N)%nat ⇒
      dist M (a n) c < ε.

Definition bounded {X : Metric_Space} (a : ℕ → Base X) :=
  ∃ q : Base X,
    ∃ M : ℝ, M > 0 ⇒
      ∀ n : ℕ, dist X (a n) q ≤ M.

Declare Scope metric_scope.
Notation "a ⟶ c" := (convergence a c) (at level 20) : metric_scope.
Local Ltac2 unfold_convergence    ()          := unfold convergence.
Local Ltac2 unfold_convergence_in (h : ident) := unfold convergence in $h.
Ltac2 Notation "Expand" "the" "definition" "of" "⟶" cl(opt(seq("in", "(", ident, ")"))) :=
  expand_def_framework unfold_convergence unfold_convergence_in cl.

(* With -->, waterproof complains, giving the following error:
    Command not supported (No proof-editing in progress)*)

Notation "a '_converges' 'to_' p" := (convergence a p) (at level 68) : metric_scope.
Notation "a 'converges' 'to' p" := (convergence a p) (at level 68, only parsing) : metric_scope.
Ltac2 Notation "Expand" "the" "definition" "of" "converges" "to" cl(opt(seq("in", "(", ident, ")"))) :=
  expand_def_framework unfold_convergence unfold_convergence_in cl.

(* Index shift*)
Require Import Waterproof.AllTactics.
Require Import Waterproof.populate_database.all_databases.
Require Import Waterproof.load_database.RealsAndIntegers.
Lemma relation_shift {X : Metric_Space} (a : nat -> Base X) (k : nat) (n : nat) (n_ge_k : (n ≥ k)%nat) :
  a ((n - k) + k)%nat = a n.
Proof.
We conclude that (a (n - k + k) = a n)%nat.
Qed.

#[export] Hint Resolve relation_shift : waterproof_integers.
#[export] Hint Extern 1 (_ = _) => (rewrite relation_shift) : waterproof_integers.

Close Scope R_scope.