(* Copyright 2017-2021, École Polytechnique, France                     *)
(*                                                                      *)
(* Permission is hereby granted, free of charge, to any person          *)
(* obtaining a copy of this software and associated documentation       *)
(* files (the "Software"), to deal in the Software without restriction, *)
(* including without limitation the rights to use, copy, modify, merge, *)
(* publish, distribute, sublicense, and/or sell copies of the Software, *)
(* and to permit persons to whom the Software is furnished to do so,    *)
(* subject to the following conditions:                                 *)
(*                                                                      *)
(* The above copyright notice and this permission notice shall be       *)
(* included in all copies or substantial portions of the Software.      *)
(*                                                                      *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,      *)
(* EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF   *)
(* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND                *)
(* NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS  *)
(* BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN   *)
(* ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN    *)
(* CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE     *)
(* SOFTWARE.                                                            *)

(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra.
(* ------- *) Require Import Arith ZArith.

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

Local Open Scope ring_scope.
Local Open Scope nat_scope.
Local Open Scope Z_scope.

Import GRing.Theory Num.Theory Order.POrderTheory.

Local Notation "m ^ n" := (expn m n) : nat_scope.

Notation rmorph := (rmorphM, rmorphB, rmorphD, rmorphN, rmorph1, rmorph0).

(* -------------------------------------------------------------------- *)
Section PosInd.
Context (P : positive -> Prop).

Lemma posind : P 1%positive -> (forall p, P p -> P (p + 1)) -> forall p, P p.
Proof.
move=> h1 ih p; rewrite -[p]Pos2Nat.id; elim: (Pos.to_nat p) => //.
by move=> [|n] // ihSn; rewrite -addn1 Nat2Pos.inj_add //; apply/ih.
Qed.
End PosInd.

(* -------------------------------------------------------------------- *)
Lemma addP m n : (m + n)%coq_nat = (m + n)%nat.
Proof. by []. Qed.

Lemma mulP m n : (m * n)%coq_nat = (m * n)%nat.
Proof. by []. Qed.

(* -------------------------------------------------------------------- *)
Definition int_to_Z (z : int) : Z :=
  match z with
  | Posz n =>  (Z.of_nat n   )
  | Negz n => -(Z.of_nat n.+1)
  end.

Definition Z_to_int (z : Z) : int :=
  match z with
  | 0       => 0%:Z
  | Z.pos p => (Pos.to_nat p)%:Z
  | Z.neg p => - (Pos.to_nat p)%:Z
  end.

Lemma Z_to_intK : cancel Z_to_int int_to_Z.
Proof.
case=> [//|p|p] /=; first by rewrite positive_nat_Z.
have /ltP := Pos2Nat.is_pos p; case E: Pos.to_nat => [|n] // _.
by rewrite -NegzE /= (SuccNat2Pos.inv _ _ E).
Qed.

Lemma int_to_ZK : cancel int_to_Z Z_to_int.
Proof. by case=> [[|n]|n] //=; rewrite Pos.of_nat_succ Nat2Pos.id. Qed.

(* -------------------------------------------------------------------- *)
Lemma ZeqbP x y : reflect (x = y) (Z.eqb x y).
Proof. by apply: (iffP idP) => /Z.eqb_eq. Qed.

Definition Z_eqMixin := EqMixin ZeqbP.
Canonical Z_eqType := Eval hnf in EqType Z Z_eqMixin.

(* -------------------------------------------------------------------- *)
Definition Z_choiceMixin := CanChoiceMixin Z_to_intK.
Canonical Z_choiceType := Eval hnf in ChoiceType Z Z_choiceMixin.

Definition Z_countMixin := CanCountMixin Z_to_intK.
Canonical Z_counType := Eval hnf in CountType Z Z_countMixin.

(* -------------------------------------------------------------------- *)
Definition Z_zmodMixin :=
  ZmodMixin Z.add_assoc Z.add_comm Z.add_0_l Z.add_opp_diag_l.
Canonical Z_zmodType := Eval hnf in ZmodType Z Z_zmodMixin.

(* -------------------------------------------------------------------- *)
Definition Z_comRingMixin :=
  ComRingMixin
    Z.mul_assoc Z.mul_comm Z.mul_1_l Z.mul_add_distr_r (erefl true).
Canonical Z_ringType := Eval hnf in RingType Z Z_comRingMixin.
Canonical Z_comRingType := Eval hnf in ComRingType Z Z.mul_comm.

(* -------------------------------------------------------------------- *)
Module ZUnitRing.
Definition unitZ := [qualify a n : Z | (n == 1) || (n == -1)].
Definition invZ n : Z := n.

Lemma mulVZ : {in unitZ, left_inverse 1%R invZ *%R}.
Proof. by move=> n /pred2P[] ->. Qed.

Lemma unitZPl (m n : Z) : (n * m = 1)%R -> m \is a unitZ.
Proof. by rewrite mulrC => /Z.mul_eq_1 [] ->. Qed.

Lemma  invZ_out : {in [predC unitZ], invZ =1 id}.
Proof. exact. Qed.

Lemma idomain_axiomZ (m n : Z) : (m * n = 0)%R -> (m == 0) || (n == 0).
Proof. by move/Z.mul_eq_0 => [] ->; rewrite eqxx ?orbT. Qed.

Definition comUnitMixin := ComUnitRingMixin mulVZ unitZPl invZ_out.
End ZUnitRing.

Canonical Z_unitRingType :=
  Eval hnf in UnitRingType Z ZUnitRing.comUnitMixin.
Canonical Z_comUnitRing :=
  Eval hnf in [comUnitRingType of Z].
Canonical Z_iDomain :=
  Eval hnf in IdomainType Z ZUnitRing.idomain_axiomZ.

(* -------------------------------------------------------------------- *)
Lemma leZP x y : reflect (x <= y) (x <=? y).
Proof. by apply: (iffP idP) => /Z.leb_le. Qed.

Lemma ltZP x y : reflect (x < y) (x <? y).
Proof. by apply: (iffP idP) => /Z.ltb_lt. Qed.

Definition lteZP := (
  (fun x y => rwP (leZP x y)),
  (fun x y => rwP (ltZP x y))).

(* --------------------------------------------------------------------- *)
Module ZNumDomain.
Lemma leZ_anti (x : Z) : 0 <=? x -> x <=? 0 -> x = 0.
Proof. by move=> ??; apply: Zle_bool_antisym. Qed.

Lemma leZ_mul (x y : Z) : 0 <=? x -> 0 <=? y -> 0 <=? (x * y)%R.
Proof. by rewrite -!lteZP; apply: Z.mul_nonneg_nonneg. Qed.

Lemma leZ_add (x y : Z) :
  0 <=? x -> 0 <=? y -> 0 <=? (x + y)%R.
Proof. by rewrite -!lteZP; apply: Z.add_nonneg_nonneg. Qed.

Lemma subZ_ge0 (y x : Z) : (0 <=? (x - y)%R) = (y <=? x).
Proof.
by apply/leZP/leZP; [exact: Zle_0_minus_le | exact: Zle_minus_le_0].
Qed.

Lemma normZN x : Z.abs (- x) = Z.abs x.
Proof. exact: Z.abs_opp. Qed.

Lemma geZ0_norm x : 0 <=? x -> Z.abs x = x.
Proof. by rewrite -!lteZP; apply: Z.abs_eq. Qed.

Lemma leZ_norm_add (x y : Z) :
  Z.abs (x + y)%R <=? (Z.abs x + Z.abs y)%R.
Proof. by rewrite -!lteZP; apply/Z.abs_triangle. Qed.

Lemma eq0_normZ (x : Z) : Z.abs x = 0 -> x = 0.
Proof. by move/Z.abs_0_iff. Qed.

Lemma leZ_total (x y : Z) : (x <=? y) || (y <=? x).
Proof. by apply/orP; rewrite -!lteZP; apply/Z.le_ge_cases. Qed.

Lemma ltZ_def (x y : Z) : (x <? y) = (y != x) && (x <=? y).
Proof.
apply/idP/andP; rewrite -!lteZP.
* by move/Z.le_neq => [? /eqP]; rewrite eq_sym.
* by rewrite eq_sym; case=> /eqP ? ?; apply/Z.le_neq.
Qed.

Definition Z_realLeMixin :=
  RealLeMixin
    leZ_add leZ_mul leZ_anti subZ_ge0 (leZ_total 0)
    normZN geZ0_norm ltZ_def.
End ZNumDomain.

Canonical Z_porderType := POrderType ring_display Z ZNumDomain.Z_realLeMixin.
Canonical Z_latticeType := LatticeType Z ZNumDomain.Z_realLeMixin.
Canonical Z_distrLatticeType := DistrLatticeType Z ZNumDomain.Z_realLeMixin.
Canonical Z_orderType := OrderType Z ZNumDomain.leZ_total.
Canonical Z_numDomainType := NumDomainType Z ZNumDomain.Z_realLeMixin.
Canonical Z_normedZmodType := NormedZmodType Z Z ZNumDomain.Z_realLeMixin.
Canonical Z_realDomainType := [realDomainType of Z].

(* -------------------------------------------------------------------- *)
Lemma ltzE {z1 z2 : Z} : (z1 <? z2)%Z = (z1 < z2)%R.
Proof. by []. Qed.

Lemma ltzP {z1 z2 : Z} : reflect (z1 < z2)%Z (z1 < z2)%R.
Proof. by rewrite -ltzE; apply: (iffP idP) => /Z.ltb_lt. Qed.

Lemma lezE {z1 z2 : Z} : (z1 <=? z2)%Z = (z1 <= z2)%R.
Proof. by []. Qed.

Lemma lezP {z1 z2 : Z} : reflect (z1 <= z2)%Z (z1 <= z2)%R.
Proof. by rewrite -lezE; apply: (iffP idP) => /Z.leb_le. Qed.

(* -------------------------------------------------------------------- *)
Lemma addZE (x y : Z) : (x + y)%Z = (x + y)%R.
Proof. by []. Qed.

Lemma oppZE (x : Z) : (- x)%Z = (- x)%R.
Proof. by []. Qed.

Lemma subZE (x y : Z) : (x - y)%Z = (x - y)%R.
Proof. by []. Qed.

Lemma mulZE (x y : Z) : (x * y)%Z = (x * y)%R.
Proof. by []. Qed.

Lemma expZE (x : Z) n : (x ^ Z.of_nat n)%Z = x ^+ n.
Proof.
elim: n => // n ih; rewrite exprS Nat2Z.inj_succ.
by rewrite Z.pow_succ_r ?ih //; apply/Nat2Z.is_nonneg.
Qed.

(* ==================================================================== *)
Lemma Z_to_int_is_additive : additive Z_to_int.
Proof.
have h x y: Z_to_int (Z.pos_sub x y) = ((Pos.to_nat x)%:Z - (Pos.to_nat y)%:Z)%R.
+ rewrite Z.pos_sub_spec; case E: (_ ?= _)%positive => /=.
  - by move/Pos.compare_eq: E => ->; rewrite addrN.
  - move/Pos.compare_lt_iff: E => E; rewrite Pos2Nat.inj_sub //.
    rewrite -subzn ?opprB //; apply/leP.
    by apply/Pos2Nat.inj_le/Pos.lt_le_incl.
  - move/Pos.compare_gt_iff: E => E; rewrite Pos2Nat.inj_sub //.
    rewrite -subzn ?opprB //; apply/leP.
    by apply/Pos2Nat.inj_le/Pos.lt_le_incl.
case=> [|x|x] [|y|y] //=.
+ by rewrite sub0r.
+ by rewrite opprK add0r.
+ by rewrite subr0.
+ by apply/h.
+ by rewrite opprK -PoszD Pos2Nat.inj_add.
+ by rewrite subr0.
+ by rewrite -opprD -PoszD Pos2Nat.inj_add.
+ by rewrite opprK [RHS]addrC; apply/h.
Qed.

Canonical Z_to_int_additive := Additive Z_to_int_is_additive.

(* -------------------------------------------------------------------- *)
Lemma Z_to_int_is_rmorphism : rmorphism Z_to_int.
Proof.
do 2? split => //=; first by apply/Z_to_int_is_additive.
case=> [|x|x] y /=; first by rewrite mul0r.
- elim/posind: x => [|p ih]; first by rewrite !mul1r.
  rewrite Pos2Z.inj_add addZE mulrDl mul1r raddfD /=.
  by rewrite ih Pos2Nat.inj_add /= addP PoszD mulrDl mul1r.
- elim/posind: x => [|p ih]; first by rewrite !mulN1r raddfN.
  rewrite -Pos2Z.add_neg_neg addZE mulrDl mulN1r.
  rewrite raddfB /= ih Pos2Nat.inj_add addP PoszD.
  by rewrite opprD mulrDl mulN1r.
Qed.

Canonical Z_to_int_rmorphism := RMorphism Z_to_int_is_rmorphism.

(* -------------------------------------------------------------------- *)
Lemma int_to_Z_is_additive : additive int_to_Z.
Proof. by apply/(can2_additive _ int_to_ZK)/Z_to_intK. Qed.

Canonical int_to_Z_additive := Additive int_to_Z_is_additive.

(* -------------------------------------------------------------------- *)
Lemma int_to_Z_is_rmorphism : rmorphism int_to_Z.
Proof. by apply/(can2_rmorphism _ int_to_ZK)/Z_to_intK. Qed.

Canonical int_to_Z_rmorphism := RMorphism int_to_Z_is_rmorphism.

(* -------------------------------------------------------------------- *)
Lemma Z_to_int_of_natE k : Z_to_int (Z.of_nat k) = k%:Z.
Proof. by apply/(can_inj int_to_ZK); rewrite Z_to_intK. Qed.

(* -------------------------------------------------------------------- *)
Lemma int_of_Z_PoszE k : int_to_Z k%:Z = Z.of_nat k.
Proof. by []. Qed.

(* -------------------------------------------------------------------- *)
Coercion int_to_Z : int >-> Z.
Coercion Z_to_int : Z >-> int.

(* -------------------------------------------------------------------- *)
Delimit Scope int_scope with I.

Lemma leZE {x y : Z} : reflect (x <= y) (x <= y :> int).
Proof.
have h z: exists n : nat, Pos.to_nat z == n.+1.
- by case: (Pos2Nat.is_succ z)=> zS ->; exists zS.
case: x y => [|x|x] [|y|y] //=; try by constructor.
+ rewrite oppr_ge0 lez0_nat gtn_eqF; first by constructor.
  by apply/ltP/Pos2Nat.is_pos.
+ rewrite lez0_nat gtn_eqF; first by constructor.
  by apply/ltP/Pos2Nat.is_pos.
+ by rewrite lez_nat; apply: (iffP leP) => /Pos2Nat.inj_le.
+ by rewrite (eqP (xchooseP (h y))); constructor.
+ by rewrite oppr_le0; constructor.
+ by rewrite (eqP (xchooseP (h x))); constructor.
+ rewrite ler_oppr opprK; apply: (iffP idP).
  - by move/leP/Pos2Nat.inj_le/Pos2Z.neg_le_neg.
  rewrite -!Pos2Z.opp_pos -Z.opp_le_mono => {}h.
  by rewrite lez_nat -(rwP leP) -Pos2Nat.inj_le.
Qed.

Lemma ltZE (x y : Z) : reflect (x < y) (x < y :> int).
Proof. apply: (iffP idP).
+ rewrite lt_neqAle -(rwP andP) -(rwP leZE) => -[neq lt].
  apply/Z.le_neq; split=> // /(congr1 Z_to_int).
  by move/eqP; rewrite (negbTE neq).
+ move/Z.le_neq => [le neq]; rewrite lt_neqAle; apply/andP.
  rewrite -(rwP leZE); split=> //; apply/eqP.
  by move/(congr1 int_to_Z); rewrite !Z_to_intK.
Qed.

Definition lteZE :=
  (fun x y => rwP (@leZE x y), fun x y => rwP (@ltZE x y)).

Lemma divZE (a b : Z) : (0 < b)%R -> a / b = (a %/ b)%I.
Proof.
move/ltzP/(@ltZE 0) => h; have /(congr1 int_to_Z) := divz_eq a b.
rewrite mulrC !rmorph /= !Z_to_intK => /Zdiv_unique -> //.
rewrite !lteZE !rmorph /= !int_to_ZK subr_ge0 ltr_subl_addr.
rewrite (rwP andP) lez_floor ?gt_eqF //=.
by rewrite addrC -[X in (_ + X)%R]mul1r -mulrDl ltz_ceil.
Qed.

Lemma modZE (a b : Z) : (0 < b)%R -> a mod b = (a %% b)%I.
Proof.
move=> gt0_b; rewrite /modz Zmod_eq_full; last first.
+ by apply/eqP; rewrite gt_eqF.
+ by rewrite rmorphB !rmorphM /= !Z_to_intK divZE.
Qed.

Lemma divnZE (a b : nat) :
  b != 0%nat -> Z.of_nat (a %/ b) = (Z.of_nat a / Z.of_nat b)%Z.
Proof.
move=> nz_b; apply/(can_inj Z_to_intK); rewrite Z_to_int_of_natE.
rewrite -divz_nat divZE; last by case: b nz_b.
by rewrite int_to_ZK !Z_to_int_of_natE.
Qed.

Lemma modnZE (a b : nat) :
  b != 0%nat -> Z.of_nat (a %% b) = (Z.of_nat a mod Z.of_nat b)%Z.
Proof.
move=> nz_b; apply/(can_inj Z_to_intK); rewrite Z_to_int_of_natE.
rewrite -modz_nat modZE; last by case: b nz_b.
by rewrite int_to_ZK !Z_to_int_of_natE.
Qed.

(* ==================================================================== *)
Module Z2Nat.

(* -------------------------------------------------------------------- *)
Lemma z2n0 : Z.to_nat 0 = 0%nat.
Proof. by []. Qed.

(* -------------------------------------------------------------------- *)
Lemma z2nD z1 z2 : (0 <= z1)%R -> (0 <= z2)%R ->
  Z.to_nat (z1 + z2) = (Z.to_nat z1 + Z.to_nat z2)%nat.
Proof.
by move=> ge0_z1 ge0_z2; apply/Z2Nat.inj_add; apply/lezP.
Qed.

(* -------------------------------------------------------------------- *)
Lemma z2nM z1 z2 : (0 <= z1)%R -> (0 <= z2)%R ->
  Z.to_nat (z1 * z2) = (Z.to_nat z1 * Z.to_nat z2)%nat.
Proof.
by move=> ge0_z1 ge0_z2; apply/Z2Nat.inj_mul; apply/lezP.
Qed.

(* -------------------------------------------------------------------- *)
Lemma z2n_sum {T : Type} (P : ssrbool.pred T) (F : T -> Z) r :
     (forall x, P x -> (0 <= F x)%R)
  -> Z.to_nat (\sum_(x <- r | P x) F x)%R =
       \sum_(x <- r | P x) Z.to_nat (F x).
Proof.
move=> ge0_F; elim: r => [|x r ih]; first by rewrite !big_nil z2n0.
rewrite !big_cons; case: ifPn => // Px.
by rewrite z2nD ?ih //; [apply/ge0_F | apply/sumr_ge0].
Qed.

(* -------------------------------------------------------------------- *)
Lemma z2nX (z : Z) n :
  (0 <= z)%R -> Z.to_nat (z ^+ n)%R = (Z.to_nat z ^ n)%nat.
Proof.
move=> ge0_z; elim: n => // n ih; rewrite exprS.
by rewrite z2nM ?exprn_ge0 // ih expnS.
Qed.

(* -------------------------------------------------------------------- *)
Lemma z2n_natmul (z : Z) n :
  (0 <= z)%R -> Z.to_nat (z *+ n) = (Z.to_nat z * n)%nat.
Proof.
move=> ge0_z; elim: n; first by rewrite muln0.
move=> n ih; rewrite mulrS.
by rewrite z2nD ?mulrn_wge0 // ih mulnS.
Qed.

(* -------------------------------------------------------------------- *)
Lemma z2nr n : Z.to_nat (n%:R) = n.
Proof. by rewrite z2n_natmul // mul1n. Qed.

End Z2Nat.

(* ==================================================================== *)
Module Nat2Z.
Lemma n2z0 : Z.of_nat 0 = 0%R.
Proof. by []. Qed.

Lemma n2z1 : Z.of_nat 1 = 1%R.
Proof. by []. Qed.

Lemma n2zD n m : Z.of_nat (n + m) = (Z.of_nat n + Z.of_nat m)%R.
Proof. by rewrite -addZE Nat2Z.inj_add. Qed.

Lemma n2zB n m : (m <= n)%nat ->
  Z.of_nat (n - m) = (Z.of_nat n - Z.of_nat m)%R.
Proof.
by move=> le; rewrite -subZE Nat2Z.inj_sub //; apply/leP.
Qed.

Lemma n2zM n m : Z.of_nat (n * m) = (Z.of_nat n * Z.of_nat m)%R.
Proof. by rewrite -mulZE Nat2Z.inj_mul. Qed.

Lemma n2zX n m : Z.of_nat (n ^ m) = (Z.of_nat n ^+ m)%R.
Proof. by elim: m => // m ih; rewrite exprS -ih -n2zM -expnS. Qed.
End Nat2Z.

(* -------------------------------------------------------------------- *)
Lemma oddZE (z : Z) : (0 <= z)%R -> Z.odd z = odd (Z.to_nat z).
Proof.
move=> ge0_z; have : injective nat_of_bool by move=> [] [].
apply; rewrite -modn2; apply/Nat2Z.inj; rewrite modnZE //.
by rewrite Z2Nat.id ?(rwP lezP) // Zmod_odd; case: ifP.
Qed.


Require Import FP.Classes.
Require Import FP.CoreClasses.
Require Import FP.DerivingMonad.Core.

Class DM_FunctorI (T:Type -> Type) (U:Type -> Type) :=
  { DM_F_T_F_Eqv :> F_Eqv T
  ; DM_F_T_F_PER_WF :> F_PER_WF T
  ; DM_F_U_F_Eqv :> F_Eqv U
  ; DM_F_U_F_PER_WF :> F_PER_WF U
  ; DM_F_U_Monad :> Monad U
  ; DM_F_U_MonadWF :> MonadWF U
  }.

Class DM_FunctorI' T U := { dm_functor_i' : DM_FunctorI T U }.

Module Type DM_Functor_Arg.
  Local Existing Instance dm_functor_i'.

  Parameter T : Type -> Type.
  Parameter U : Type -> Type.
  Parameter to : forall {A}, T A -> U A.
  Parameter from : forall {A}, U A -> T A.
  Parameter _DM_FunctorI : DM_FunctorI' T U.
  Parameter IR_from_eqv :
    forall {A} `{! Eqv A ,! PER_WF A },
    InjectionRespect (U A) (T A) from eqv eqv.
  Parameter II_to_from_eqv :
    forall {A} `{! Eqv A ,! PER_WF A },
    InjectionInverse (T A) (U A) to from eqv.
  Parameter II_from_from_eqv :
    forall {A} `{! Eqv A ,! PER_WF A },
    InjectionInverse (U A) (T A) from to eqv.
  Parameter Proper_to_eqv :
    forall {A} `{! Eqv A ,! PER_WF A },
    Proper eqv (@to A).
  Parameter Proper_from_eqv :
    forall {A} `{! Eqv A ,! PER_WF A },
    Proper eqv (@from A).
End DM_Functor_Arg.

Module DM_Functor (M:DM_Functor_Arg).
  Local Existing Instance dm_functor_i'.

  Import M.
  Arguments T / _ .
  Arguments U / _ .
  Arguments to {A} / _ .
  Arguments from {A} / _ .
  Local Existing Instance DM_F_T_F_Eqv.
  Local Existing Instance DM_F_T_F_PER_WF.
  Local Existing Instance DM_F_U_F_Eqv.
  Local Existing Instance DM_F_U_F_PER_WF.
  Local Existing Instance DM_F_U_Monad.
  Local Existing Instance DM_F_U_MonadWF.

  Section Monad.
    Global Instance _Monad : Monad T := Deriving_Monad_Bijection (@to) (@from).

    Global Instance _MonadWF : MonadWF T := Deriving_MonadWF_Bijection (@to) (@from).
  End Monad.

  Section Applicative.
    Global Instance _Applicative : Applicative T := Deriving_Applicative_Monad.

    Global Instance _ApplicativeWF : ApplicativeWF T.
    Proof.
      apply Deriving_ApplicativeWF_MonadWF ; intros.
      - unfold fret ; simpl ; logical_eqv.
      - unfold fapply ; simpl ; logical_eqv.
    Qed.
  End Applicative.

  Section Functor.
    Global Instance _Functor : Functor T := Deriving_Functor_Applicative.

    Global Instance _FunctorWF : FunctorWF T.
    Proof.
      apply Deriving_FunctorWF_ApplicativeWF ; intros.
      unfold fmap ; simpl ; logical_eqv.
    Qed.
  End Functor.

  Section Pointed.
    Global Instance _Pointed : Pointed T := Deriving_Pointed_Applicative.

    Global Instance _PointedWF : PointedWF T.
    Proof.
      apply Deriving_PointedWF_ApplicativeWF ; intros.
      unfold point ; simpl ; logical_eqv.
    Qed.
  End Pointed.

End DM_Functor.

Class DMError_FunctorI
    (E:Type) (T:Type -> Type) (U:Type -> Type)
    `{! F_Eqv U ,! F_PER_WF U ,! Monad U } :=
  { DMError_Idx_E_Eqv : Eqv E
  ; DMError_Idx_E_PER_WF : PER_WF E
  ; DMError_Idx_U_MonadCatch : MonadCatch E U
  ; DMError_Idx_U_MonadCatchWF : MonadCatchWF E U
  }.

Module Type DMError_Functor_Arg.
  Local Existing Instance dm_functor_i'.

  Include DM_Functor_Arg.
  Parameter E : Type.
  Parameter _DMError_FunctorI : DMError_FunctorI E T U.
End DMError_Functor_Arg.

Module DMError_Functor (M:DMError_Functor_Arg).
  Local Existing Instance dm_functor_i'.
  Local Existing Instance DMError_Idx_E_Eqv.
  Local Existing Instance DMError_Idx_U_MonadCatch.
  Local Existing Instance DMError_Idx_U_MonadCatchWF.

  Import M.
  Module DM := DM_Functor M.
  Import DM.

  Arguments T / _.
  Arguments U / _.
  Arguments E /.
  Arguments to {A} / _ .
  Arguments from {A} / _ .

  Section MonadError.
    Global Instance _MonadCatch : MonadCatch E T := deriving_MonadCatch_Bijection (@to) (@from).
    Global Instance _MonadCatchWF : MonadCatchWF E T.
    Proof.
      apply (deriving_MonadCatchWF_Bijection (@to) (@from)) ; intros.
      - unfold mret at 1 ; simpl ; logical_eqv.
      - unfold mbind at 1 ; simpl ; logical_eqv.
    Qed.
  End MonadError.
End DMError_Functor.


Require Import MapProofs.Common.
Set Bullet Behavior "Strict Subproofs".
Require Import MapProofs.Bounds.
Require Import MapProofs.Tactics.
Require Import MapProofs.InsertProofs.
Require Import MapProofs.ToListProofs.
Require Import MapProofs.UnionIntersectDifferenceProofs.
Require Import Coq.Sorting.Sorted.
Require Import SortedUtil.
Require Import Coq.Program.Tactics.
Require Import GHC.DeferredFix.
Require Import Coq.Wellfounded.Wellfounded.

Section WF.
Context {e : Type} {a : Type} {HEq : Eq_ e} {HOrd : Ord e} {HEqLaws : EqLaws e}  {HOrdLaws : OrdLaws e}.

(** ** Verification of [fromDistinctAscList] *)

Definition fromDistinctAscList_create_f : (Int -> list (e * a) -> (Map e a) * list (e * a)) ->
(Int -> list (e * a) -> Map e a * list ( e * a)).
Proof.
  let rhs := eval unfold fromDistinctAscList in (@fromDistinctAscList e a) in
  lazymatch rhs with context [deferredFix2 ?f] => exact f end.
Defined.

Definition fromDistinctAscList_create : Int -> list (e * a) -> (Map e a) * list (e * a)
  := deferredFix2 (fromDistinctAscList_create_f).

Lemma Z_shiftr_pos:
  forall x, (1 < x -> 1 <= Z.shiftr x 1)%Z.
Proof.
  intros.
  rewrite Z.shiftr_div_pow2 by lia.
  replace (2^1)%Z with 2%Z by reflexivity.
  assert (2 <= x)%Z by lia. clear H.
  apply Z.div_le_mono with (c := 2%Z) in H0.
  apply H0.
  lia.
Qed.

Lemma Z_shiftl_pos:
  forall x, (1 <= x -> 1 <= Z.shiftl x 1)%Z.
Proof.
  intros.
  rewrite Z.shiftl_mul_pow2 by lia.
  lia.
Qed.

Lemma Z_shiftr_lt:
  forall x, (1 <= x -> Z.shiftr x 1 < x)%Z.
Proof.
  intros.
  rewrite Z.shiftr_div_pow2 by lia.
  replace (2^1)%Z with 2%Z by reflexivity.
  apply Z_div_lt; lia.
Qed.

Lemma fromDistinctAscList_create_eq:
  forall i xs, (1 <= i)%Z ->
  fromDistinctAscList_create i xs = fromDistinctAscList_create_f fromDistinctAscList_create i xs.
Proof.
  intros.
  change (uncurry fromDistinctAscList_create (i, xs) = uncurry (fromDistinctAscList_create_f fromDistinctAscList_create) (i, xs)).
  apply deferredFix_eq_on with
    (f := fun g => uncurry (fromDistinctAscList_create_f (curry g)))
    (P := fun p => (1 <= fst p)%Z)
    (R := fun x y => (1 <= fst x < fst y)%Z).
  * eapply wf_inverse_image with (R := fun x y => (1 <= x < y)%Z).
    apply Z.lt_wf with (z := 1%Z).
  * clear i xs H.
    intros g h x Px Heq.
    destruct x as [i xs]. simpl in *.
    unfold fromDistinctAscList_create_f.
    destruct_match; try reflexivity.
    repeat replace (#1) with 1%Z by reflexivity.
    unfold op_zeze__, Eq_Integer___, op_zeze____.
    destruct (Z.eqb_spec i 1); try reflexivity.
    unfold curry.
    assert (1 < i)%Z by lia.
    assert (1 <= Z.shiftr i 1)%Z by (apply Z_shiftr_pos; lia).
    assert (Z.shiftr i 1 < i)%Z by (apply Z_shiftr_lt; lia).
    repeat expand_pairs. simpl.
    rewrite Heq by eauto.
    destruct_match; try reflexivity.
    rewrite Heq by eauto.
    reflexivity.
  * simpl; lia.
Qed.

Check length.
(* We need to know that [create] returns no longer list than it receives. *)
Program Fixpoint fromDistinctAscList_create_preserves_length
  i xs {measure (Z.to_nat i)} :
  (1 <= i)%Z ->
  forall (P : Map e a * list (e * a) -> Prop),
  ( forall s ys,
    (length ys <= length xs)%nat ->
    P (s, ys)
  ) ->
  P (fromDistinctAscList_create i xs) := _.
Next Obligation.
  intros.
  rename fromDistinctAscList_create_preserves_length into IH.
  rewrite fromDistinctAscList_create_eq by assumption.
  unfold fromDistinctAscList_create_f.
  destruct xs.
  * apply H0. reflexivity.
  * repeat replace (#1) with 1%Z by reflexivity.
    unfold op_zeze__, Eq_Integer___, op_zeze____.
    destruct (Z.eqb_spec i 1).
    + destruct p. apply H0. simpl. lia.
    + assert (Z.to_nat (Bits.shiftR i #1) < Z.to_nat i)%nat. {
        apply Z2Nat.inj_lt.
        apply Z.shiftr_nonneg. lia.
        lia.
        apply Z_shiftr_lt; lia.
      }
      apply IH.
      - assumption.
      - apply Z_shiftr_pos; lia.
      - intros.
        destruct_match.
        ** apply H0. simpl in *. lia.
        ** apply IH.
           -- assumption.
           -- apply Z_shiftr_pos; lia.
           -- intros.
               destruct p0. apply H0. simpl in *. lia.
Qed.

Definition fromDistinctAscList_go_f : (Int -> Map e a -> list (e * a) -> Map e a) ->
 (Int -> Map e a -> list (e * a) -> Map e a).
Proof.
  let rhs := eval unfold fromDistinctAscList in (@fromDistinctAscList e a) in
  let rhs := eval fold fromDistinctAscList_create_f in rhs in
  let rhs := eval fold fromDistinctAscList_create in rhs in
  lazymatch rhs with context [deferredFix3 ?f] => exact f end.
Defined.

Definition fromDistinctAscList_go : Int -> Map e a -> list (e * a) -> Map e a
  := deferredFix3 (fromDistinctAscList_go_f).

Lemma fromDistinctAscList_go_eq:
  forall i s xs, (0 < i)%Z ->
  fromDistinctAscList_go i s xs = fromDistinctAscList_go_f fromDistinctAscList_go i s xs.
Proof.
  intros.
  change (deferredFix (fun g => uncurry (uncurry (fromDistinctAscList_go_f (curry (curry g))))) (i, s, xs) =
    uncurry (uncurry (fromDistinctAscList_go_f fromDistinctAscList_go)) (i, s, xs)).
  rewrite deferredFix_eq_on with
    (P := fun p => (1 <= fst (fst p))%Z)
    (R := fun x y => (length (snd x) < length (snd y))%nat); only 1: reflexivity.
  * apply well_founded_ltof with (f := fun x => length (snd x)).
  * intros g h p Px Heq.
    destruct p as [[x y] z].
    simpl in *.
    unfold fromDistinctAscList_go_f.
    destruct_match; try reflexivity.
    eapply fromDistinctAscList_create_preserves_length; try lia.
    intros s' ys Hlength. destruct p.
    apply Heq.
    + apply Z_shiftl_pos.
      lia.
    + simpl. lia.
  * simpl. lia.
Qed.

Definition safeHd {a} : list (e * a) -> option e := fun xs =>
  match xs with nil => None | ((x, y)::_) => Some x end.

Lemma mul_pow_sub:
  forall sz, (0 < sz)%Z -> (2 * 2 ^ (sz - 1) = 2^sz)%Z.
Proof.
  intros.
  rewrite <- Z.pow_succ_r by lia.
  f_equal.
  lia.
Qed.

(*Maps are sorted only by keys*)
Local Definition lt : e * a -> e * a -> Prop
  := fun x1 x2 => let (e1, a1) := x1 in let (e2, a2) := x2 in ( _GHC.Base.<_ e1 e2) = true.

Local Obligation Tactic := try solve [program_simpl].

(*TODO: FIGURE OUT WHY THIS IS NOT WORKING*)
Program Fixpoint fromDistinctAscList_create_Desc
  sz lb xs x {measure (Z.to_nat sz)} :
  (0 <= sz)%Z ->
  StronglySorted lt ((lb, x) :: xs) ->
  forall (P : (Map e a) * list (e * a) -> Prop),
  (( forall (s : Map e a) (ys: list (e * a)),
    Bounded s (Some lb) (safeHd ys) ->
    xs = toList s ++ ys ->
    ys = nil \/ size s = (2*2^sz-1)%Z ->
    P (s, ys)
  ) ->
  P (fromDistinctAscList_create (2^sz)%Z xs)) := _.
Next Obligation.
  intros ????? Hnonneg HSorted.
  rename fromDistinctAscList_create_Desc into IH.
  rewrite fromDistinctAscList_create_eq
    by (enough (0 < 2^sz)%Z by lia; apply Z.pow_pos_nonneg; lia).
  unfold fromDistinctAscList_create_f.
  destruct xs.
  * intros X HX. apply HX. clear HX.
    - solve_Bounded e.
    - reflexivity.
    - left. reflexivity.
  * repeat replace (#1) with 1%Z by reflexivity.
    unfold op_zeze__, Eq_Integer___, op_zeze____.

    inversion HSorted. subst.
    inversion H2. subst. clear H2.
    inversion H1. subst.
    destruct p.
    assert (isUB (safeHd xs) e0 = true). {
      destruct xs; try reflexivity.
      inversion H5. subst. unfold safeHd. destruct p. assumption. }

    destruct (Z.eqb_spec (2^sz) 1).
    - intros X HX. apply HX. clear HX.
      ++ solve_Bounded e.
      ++ rewrite toList_Bin, toList_Tip, app_nil_r. reflexivity.
      ++ right. rewrite size_Bin. lia.
    - assert (~ (sz = 0))%Z by (intro; subst; simpl in n; congruence).
      assert (sz > 0)%Z by lia.
      replace ((Bits.shiftR (2 ^ sz)%Z 1%Z)) with (2^(sz - 1))%Z.
      Focus 2.
        unfold Bits.shiftR, Bits.instance_Bits_Int.
        rewrite Z.shiftr_div_pow2 by lia.
        rewrite Z.pow_sub_r by lia.
        reflexivity.
      assert (Z.to_nat (sz - 1) < Z.to_nat sz)%nat.
      { rewrite Z2Nat.inj_sub by lia.
        apply Nat.sub_lt.
        apply Z2Nat.inj_le.
        lia.
        lia.
        lia.
        replace (Z.to_nat 1) with 1 by reflexivity.
        lia.
      }
      eapply IH.
      ++ assumption.
      ++ lia.
      ++ eassumption.
      ++ intros l ys HBounded_l Hlist_l Hsize_l.
         destruct ys.
         + intros X HX. apply HX. clear HX.
           ** solve_Bounded e.
           ** assumption.
           ** left; reflexivity.
         + simpl in HBounded_l. destruct p.
           destruct Hsize_l; try congruence.
           eapply IH; clear IH.
           ** assumption.
           ** lia.
           ** rewrite Hlist_l in H1.
              apply StronglySorted_app in H1.
              destruct H1.
              eassumption.
           ** intros r zs HBounded_r Hlist_r Hsize_r.
              rewrite Hlist_l in HSorted.
              assert (isLB (Some lb) e1 = true). {
                apply StronglySorted_inv in HSorted.
                destruct HSorted.
                simpl.
                rewrite Forall_forall in H10. unfold lt in H10.
                specialize (H10 (e1, a1)).
                apply H10.
                apply in_or_app. right. left. reflexivity.
              }
              rewrite Hlist_r in HSorted.
              assert (isUB (safeHd zs) e1 = true). {
                destruct zs; try reflexivity.
                apply StronglySorted_inv in HSorted.
                destruct HSorted.
                apply StronglySorted_app in H10.
                destruct H10.
                apply StronglySorted_inv in H12.
                destruct H12.
                rewrite Forall_forall in H13. specialize (H13 p). unfold isUB. simpl. destruct p.
                unfold lt in H13.
                apply H13.
                apply in_or_app. right. left. reflexivity.
              }
              intros X HX. apply HX. clear HX.
              -- applyDesc e (@link_Desc e a).
              -- erewrite toList_link by eassumption.
                 rewrite Hlist_l. rewrite Hlist_r.
                 rewrite <- !app_assoc.  reflexivity.
              -- destruct Hsize_r; [left; assumption| right].
                 applyDesc e (@link_Desc e a).
                 replace (size l). replace (size r).
                 rewrite mul_pow_sub in * by lia.
                 lia.
Qed.

(*The analogue of [sem] for lists - returns the first value associated with
a given key, or None if no such key exists. We will use this to
specify several lemmas in [fromList] rather than List.elem*)
Fixpoint sem_for_lists (l : list (e * a)) (i : e) :=
  match l with
  | nil => None
  | (x,y) :: t => if i == x then Some y else sem_for_lists t i
  end.

Lemma sem_list_app: forall i xs ys,
  sem_for_lists (xs ++ ys) i = sem_for_lists xs i ||| sem_for_lists ys i.
Proof.
  intros. generalize dependent ys. induction xs; intros.
  - simpl. reflexivity.
  - simpl. destruct a0. destruct (i == e0) eqn : ?. reflexivity.
    apply IHxs.
Qed.

Lemma toList_sem'':
  forall s lb ub, Bounded s lb ub ->
  forall i, sem s i = sem_for_lists (toList s) i.
Proof.
  intros. induction H.
  - simpl. reflexivity.
  - simpl. rewrite IHBounded1. rewrite IHBounded2. rewrite toList_Bin.
    rewrite sem_list_app. rewrite app_comm_cons. rewrite sem_list_app.
    simpl. unfold SomeIf. rewrite oro_assoc. reflexivity.
Qed.

Program Fixpoint fromDistinctAscList_go_Desc
  sz s xs {measure (length xs)} :
  (0 <= sz)%Z ->
  StronglySorted lt xs ->
  Bounded s None (safeHd xs) ->
  xs = nil \/ size s = (2*2^sz-1)%Z ->
  Desc (fromDistinctAscList_go (2^sz)%Z s xs) None None (size s + List.length xs)
    (fun i => sem s i ||| sem_for_lists xs i) := _.
Next Obligation.
  intros.
  rename fromDistinctAscList_go_Desc into IH.
  rewrite fromDistinctAscList_go_eq by (apply Z.pow_pos_nonneg; lia).
  unfold fromDistinctAscList_go_f.
  destruct xs.
  * replace (List.length nil) with 0%Z by reflexivity.
    rewrite Z.add_0_r.
    solve_Desc e.
  * repeat replace (#1) with 1%Z by reflexivity.
    replace ((Bits.shiftL (2 ^ sz)%Z 1))%Z with (2 ^ (1 + sz))%Z.
    Focus 2.
      unfold Bits.shiftL, Bits.instance_Bits_Int.
      rewrite Z.shiftl_mul_pow2 by lia.
      rewrite Z.pow_add_r by lia.
      lia. destruct p.

    destruct H2; try congruence.
    eapply fromDistinctAscList_create_Desc.
    - lia.
    - eassumption.
    - intros.
      subst.
      simpl safeHd in *.
      assert (isUB (safeHd ys) e0 = true). {
        destruct ys; try reflexivity.
        apply StronglySorted_inv in H0.
        destruct H0.
        rewrite Forall_forall in H4. specialize (H4 p). unfold isUB. destruct p. simpl.
        unfold lt in H4.
        apply H4.
        apply in_or_app. right. left. reflexivity.
      }
      applyDesc e (@link_Desc e a).
      eapply IH.
      + simpl. rewrite app_length. lia.
      + lia.
      + apply StronglySorted_inv in H0.
        destruct H0.
        apply StronglySorted_app in H0.
        destruct H0.
        assumption.
      + assumption.
      + destruct H5; [left; assumption | right].
        replace (size s1). replace (size s).  replace (size s0).
        rewrite Z.pow_add_r by lia.
        lia.
      + intros.
        solve_Desc e.
        ** replace (size s2). replace (size s1). replace (size s).
           rewrite !List.hs_coq_list_length, !Zlength_correct.
           simpl length.
           rewrite app_length, Nat2Z.inj_succ, Nat2Z.inj_add.
           erewrite <- size_spec by eassumption.
           lia.
        ** simpl.
           setoid_rewrite sem_list_app.
           setoid_rewrite <- toList_sem''; only 2: eassumption.
           f_solver e.
Qed.

Lemma fromDistinctAscList_Desc:
  forall xs,
  StronglySorted lt xs ->
  Desc (fromDistinctAscList xs) None None (List.length xs) (fun i => sem_for_lists xs i).
Proof.
  intros.
  unfold fromDistinctAscList.
  fold fromDistinctAscList_create_f.
  fold fromDistinctAscList_create.
  fold fromDistinctAscList_go_f.
  fold fromDistinctAscList_go.
  destruct xs.
  * solve_Desc e.
  * replace (#1) with (2^0)%Z by reflexivity. destruct p.
    eapply fromDistinctAscList_go_Desc.
    + lia.
    + apply StronglySorted_inv in H.
      destruct H.
      assumption.
    + assert (isUB (safeHd xs) e0 = true). {
        destruct xs; try reflexivity.
        apply StronglySorted_inv in H.
        destruct H.
        rewrite Forall_forall in H0. destruct p. unfold isUB. simpl.
        unfold lt in H0. specialize (H0 (e1, a1)).
        apply H0.
        left. reflexivity.
      }
      solve_Bounded e.
    + right. reflexivity.
    + intros.
      rewrite List.hs_coq_list_length, Zlength_cons in *.
      rewrite size_Bin in H1.
      solve_Desc e. simpl. f_solver e.
Qed.

(** ** Verification of [fromDistinctDescList] *)

(** Copy’n’paste from [fromDistinctAscList] *)

Local Definition gt : e * a -> e * a -> Prop
  := fun x1 x2 => let (e1, a1) := x1 in let (e2, a2) := x2 in (e1 > e2) = true.

Definition fromDistinctDescList_create_f : (Int -> list (e * a) -> (Map e a) * list (e * a)) ->
(Int -> list (e * a) -> Map e a * list ( e * a)).
Proof.
  let rhs := eval unfold fromDistinctDescList in (@fromDistinctDescList e a) in
  lazymatch rhs with context [deferredFix2 ?f] => exact f end.
Defined.

Definition fromDistinctDescList_create : Int -> list (e * a) -> (Map e a) * list (e * a)
  := deferredFix2 (fromDistinctDescList_create_f).

Lemma fromDistinctDescList_create_eq:
  forall i xs, (1 <= i)%Z ->
  fromDistinctDescList_create i xs = fromDistinctDescList_create_f fromDistinctDescList_create i xs.
Proof.
  intros.
  change (uncurry fromDistinctDescList_create (i, xs) = uncurry (fromDistinctDescList_create_f fromDistinctDescList_create) (i, xs)).
  apply deferredFix_eq_on with
    (f := fun g => uncurry (fromDistinctDescList_create_f (curry g)))
    (P := fun p => (1 <= fst p)%Z)
    (R := fun x y => (1 <= fst x < fst y)%Z).
  * eapply wf_inverse_image with (R := fun x y => (1 <= x < y)%Z).
    apply Z.lt_wf with (z := 1%Z).
  * clear i xs H.
    intros g h x Px Heq.
    destruct x as [i xs]. simpl in *.
    unfold fromDistinctDescList_create_f.
    destruct_match; try reflexivity.
    repeat replace (#1) with 1%Z by reflexivity.
    unfold op_zeze__, Eq_Integer___, op_zeze____.
    destruct (Z.eqb_spec i 1); try reflexivity.
    unfold curry.
    assert (1 < i)%Z by lia.
    assert (1 <= Z.shiftr i 1)%Z by (apply Z_shiftr_pos; lia).
    assert (Z.shiftr i 1 < i)%Z by (apply Z_shiftr_lt; lia).
    repeat expand_pairs. simpl.
    rewrite Heq by eauto.
    destruct_match; try reflexivity.
    rewrite Heq by eauto.
    reflexivity.
  * simpl; lia.
Qed.

(* We need to know that [create] returns no longer list than it receives. *)
Program Fixpoint fromDistinctDescList_create_preserves_length
  i xs {measure (Z.to_nat i)} :
  (1 <= i)%Z ->
  forall (P : Map e a * list (e * a) -> Prop),
  ( forall s ys,
    (length ys <= length xs)%nat ->
    P (s, ys)
  ) ->
  P (fromDistinctDescList_create i xs) := _.
Next Obligation.
  intros.
  rename fromDistinctDescList_create_preserves_length into IH.
  rewrite fromDistinctDescList_create_eq by assumption.
  unfold fromDistinctDescList_create_f.
  destruct xs.
  * apply H0. reflexivity.
  * repeat replace (#1) with 1%Z by reflexivity.
    unfold op_zeze__, Eq_Integer___, op_zeze____.
    destruct (Z.eqb_spec i 1).
    + destruct p. apply H0. simpl. lia.
    + assert (Z.to_nat (Bits.shiftR i #1) < Z.to_nat i)%nat. {
        apply Z2Nat.inj_lt.
        apply Z.shiftr_nonneg. lia.
        lia.
        apply Z_shiftr_lt; lia.
      }
      apply IH.
      - assumption.
      - apply Z_shiftr_pos; lia.
      - intros.
        destruct_match.
        ** apply H0. simpl in *. lia.
        ** apply IH.
           -- assumption.
           -- apply Z_shiftr_pos; lia.
           -- intros.
               destruct p0. apply H0. simpl in *. lia.
Qed.

Definition fromDistinctDescList_go_f : (Int -> Map e a -> list (e * a) -> Map e a) ->
 (Int -> Map e a -> list (e * a) -> Map e a).
Proof.
  let rhs := eval unfold fromDistinctDescList in (@fromDistinctDescList e a) in
  let rhs := eval fold fromDistinctDescList_create_f in rhs in
  let rhs := eval fold fromDistinctDescList_create in rhs in
  lazymatch rhs with context [deferredFix3 ?f] => exact f end.
Defined.

Definition fromDistinctDescList_go : Int -> Map e a -> list (e * a) -> Map e a
  := deferredFix3 (fromDistinctDescList_go_f).

Lemma fromDistinctDescList_go_eq:
  forall i s xs, (0 < i)%Z ->
  fromDistinctDescList_go i s xs = fromDistinctDescList_go_f fromDistinctDescList_go i s xs.
Proof.
  intros.
  change (deferredFix (fun g => uncurry (uncurry (fromDistinctDescList_go_f (curry (curry g))))) (i, s, xs) =
    uncurry (uncurry (fromDistinctDescList_go_f fromDistinctDescList_go)) (i, s, xs)).
  rewrite deferredFix_eq_on with
    (P := fun p => (1 <= fst (fst p))%Z)
    (R := fun x y => (length (snd x) < length (snd y))%nat); only 1: reflexivity.
  * apply well_founded_ltof with (f := fun x => length (snd x)).
  * intros g h p Px Heq.
    destruct p as [[x y] z].
    simpl in *.
    unfold fromDistinctDescList_go_f.
    destruct_match; try reflexivity.
    eapply fromDistinctDescList_create_preserves_length; try lia.
    intros s' ys Hlength. destruct p.
    apply Heq.
    + apply Z_shiftl_pos.
      lia.
    + simpl. lia.
  * simpl. lia.
Qed.

Program Fixpoint fromDistinctDescList_create_Desc
  sz ub xs x {measure (Z.to_nat sz)} :
  (0 <= sz)%Z ->
  StronglySorted (fun x y => gt x y) ((ub, x) :: xs) ->
  forall (P : (Map e a) * list (e * a) -> Prop),
  ( forall (s : Map e a) (ys: list (e * a)),
    Bounded s  (safeHd ys) (Some ub)->
    xs = rev(toList s) ++ ys ->
    ys = nil \/ size s = (2*2^sz-1)%Z ->
    P (s, ys)
  ) ->
  P (fromDistinctDescList_create (2^sz)%Z xs) := _.
Next Obligation.
  intros ????? Hnonneg HSorted.
  rename fromDistinctDescList_create_Desc into IH.
  rewrite fromDistinctDescList_create_eq
    by (enough (0 < 2^sz)%Z by lia; apply Z.pow_pos_nonneg; lia).
  unfold fromDistinctDescList_create_f.
  destruct xs.
  * intros X HX. apply HX. clear HX.
    - solve_Bounded e.
    - reflexivity.
    - left. reflexivity.
  * repeat replace (#1) with 1%Z by reflexivity.
    unfold op_zeze__, Eq_Integer___, op_zeze____.

    inversion HSorted. subst.
    inversion H2. subst. clear H2.
    inversion H1. subst.
    destruct p.
    assert (isLB (safeHd xs) e0 = true). {
      destruct xs; try reflexivity.
      inversion H5. subst. unfold safeHd. destruct p. unfold gt in H6.
      unfold isLB. order e. }

    destruct (Z.eqb_spec (2^sz) 1).
    - intros X HX. apply HX. clear HX.
      ++ solve_Bounded e. unfold gt in H3. unfold isUB. order e.
      ++ rewrite toList_Bin, toList_Tip, app_nil_r. reflexivity.
      ++ right. rewrite size_Bin. lia.
    - assert (~ (sz = 0))%Z by (intro; subst; simpl in n; congruence).
      assert (sz > 0)%Z by lia.
      replace ((Bits.shiftR (2 ^ sz)%Z 1%Z)) with (2^(sz - 1))%Z.
      Focus 2.
        unfold Bits.shiftR, Bits.instance_Bits_Int.
        rewrite Z.shiftr_div_pow2 by lia.
        rewrite Z.pow_sub_r by lia.
        reflexivity.
      assert (Z.to_nat (sz - 1) < Z.to_nat sz)%nat.
      { rewrite Z2Nat.inj_sub by lia.
        apply Nat.sub_lt.
        apply Z2Nat.inj_le.
        lia.
        lia.
        lia.
        replace (Z.to_nat 1) with 1 by reflexivity.
        lia.
      }
      eapply IH.
      ++ assumption.
      ++ lia.
      ++ eassumption.
      ++ intros l ys HBounded_l Hlist_l Hsize_l.
         destruct ys.
         + intros X HX. apply HX. clear HX.
           ** solve_Bounded e.
           ** assumption.
           ** left; reflexivity.
         + simpl in HBounded_l. destruct p.
           destruct Hsize_l; try congruence.
           eapply IH; clear IH.
           ** assumption.
           ** lia.
           ** rewrite Hlist_l in H1.
              apply StronglySorted_app in H1.
              destruct H1.
              eassumption.
           ** intros r zs HBounded_r Hlist_r Hsize_r.
              rewrite Hlist_l in HSorted.
              assert (isUB (Some ub) e1 = true). {
                apply StronglySorted_inv in HSorted.
                destruct HSorted.
                simpl.
                rewrite Forall_forall in H10. unfold gt in H10.
                specialize (H10 (e1, a1)).
                assert (e1 < ub = true <-> ub > e1 = true) by (order e). rewrite H11.
                apply H10.
                apply in_or_app. right. left. reflexivity.
              }
              rewrite Hlist_r in HSorted.
              assert (isLB (safeHd zs) e1 = true). {
                destruct zs; try reflexivity.
                apply StronglySorted_inv in HSorted.
                destruct HSorted.
                apply StronglySorted_app in H10.
                destruct H10.
                apply StronglySorted_inv in H12.
                destruct H12.
                rewrite Forall_forall in H13. specialize (H13 p). unfold isLB. simpl. destruct p.
                unfold gt in H13. assert (e2 < e1 = true <-> e1 > e2 = true) by (order e).
                rewrite H14.
                apply H13.
                apply in_or_app. right. left. reflexivity.
              }
              intros X HX. apply HX. clear HX.
              -- applyDesc e (@link_Desc e a).
              -- erewrite toList_link by eassumption.
                 rewrite Hlist_l. rewrite Hlist_r.
                 rewrite !rev_app_distr; simpl.
                 rewrite <- !app_assoc.  simpl. reflexivity.
              -- destruct Hsize_r; [left; assumption| right].
                 applyDesc e (@link_Desc e a).
                 replace (size l). replace (size r).
                 rewrite mul_pow_sub in * by lia.
                 lia.
Qed.

(*If we look for an element in a map's list, it is the same as looking in the reverse of that list.
This is euivalent to saying that the first key, value pair that matches a given key is the same
as the last pair*)
Lemma sem_list_rev:
  forall m lb ub x,
  Bounded m lb ub ->
  sem_for_lists (toList m) x = sem_for_lists (rev (toList m)) x.
Proof.
  intros. generalize dependent x. induction H; intros.
  - simpl. reflexivity.
  - rewrite toList_Bin. rewrite rev_app_distr.
 simpl. rewrite <- app_assoc. simpl.
    rewrite sem_list_app. rewrite sem_list_app. rewrite <- IHBounded2.
    assert (forall {a} (x : a) l, x :: l = (x :: nil) ++ l). { intros.
    simpl. reflexivity. } rewrite H5. rewrite sem_list_app.
    rewrite (H5 _ _ (rev (toList s1))). rewrite sem_list_app.
    rewrite <- IHBounded1. repeat(erewrite <- toList_sem'').
    destruct (sem s1 x0) eqn : ?. simpl.
    assert (sem s2 x0 = None). { eapply sem_outside_below. apply H0. solve_Bounds e. }
    rewrite H6. simpl. assert (x0 == x = false) by solve_Bounds e. rewrite H7; reflexivity.
    simpl. destruct (x0 == x) eqn : ?. assert (sem s2 x0 = None). { eapply sem_outside_below.
    apply H0. solve_Bounds e. } rewrite H6. reflexivity. simpl. rewrite oro_None_r. reflexivity.
    apply H0. apply H.
Qed.

Program Fixpoint fromDistinctDescList_go_Desc
  sz s xs {measure (length xs)} :
  (0 <= sz)%Z ->
  StronglySorted (fun x y => gt x y) xs ->
  Bounded s (safeHd xs) None  ->
  xs = nil \/ size s = (2*2^sz-1)%Z ->
  Desc (fromDistinctDescList_go (2^sz)%Z s xs) None None (size s + List.length xs)
    (fun i => sem s i ||| sem_for_lists xs i) := _.
Next Obligation.
  intros.
  rename fromDistinctDescList_go_Desc into IH.
  rewrite fromDistinctDescList_go_eq by (apply Z.pow_pos_nonneg; lia).
  unfold fromDistinctDescList_go_f.
  destruct xs.
  * replace (List.length nil) with 0%Z by reflexivity.
    rewrite Z.add_0_r.
    solve_Desc e.
  * repeat replace (#1) with 1%Z by reflexivity.
    replace ((Bits.shiftL (2 ^ sz)%Z 1))%Z with (2 ^ (1 + sz))%Z.
    Focus 2.
      unfold Bits.shiftL, Bits.instance_Bits_Int.
      rewrite Z.shiftl_mul_pow2 by lia.
      rewrite Z.pow_add_r by lia.
      lia. destruct p.

    destruct H2; try congruence.
    eapply fromDistinctDescList_create_Desc.
    - lia.
    - eassumption.
    - intros.
      subst.
      simpl safeHd in *.
      assert (isLB (safeHd ys) e0 = true). {
        destruct ys; try reflexivity.
        apply StronglySorted_inv in H0.
        destruct H0.
        rewrite Forall_forall in H4. specialize (H4 p). unfold isLB. destruct p. simpl.
        unfold gt in H4. assert (e1 < e0 = true <->e0 > e1 = true) by (order e). rewrite H6.
        apply H4.
        apply in_or_app. right. left. reflexivity.
      }
      applyDesc e (@link_Desc e a).
      eapply IH.
      + simpl. rewrite app_length. lia.
      + lia.
      + apply StronglySorted_inv in H0.
        destruct H0.
        apply StronglySorted_app in H0.
        destruct H0.
        assumption.
      + assumption.
      + destruct H5; [left; assumption | right].
        replace (size s1). replace (size s).  replace (size s0).
        rewrite Z.pow_add_r by lia.
        lia.
      + intros.
        solve_Desc e.
        ** replace (size s2). replace (size s1). replace (size s).
           rewrite !List.hs_coq_list_length, !Zlength_correct.
           simpl length.
           rewrite app_length, Nat2Z.inj_succ, Nat2Z.inj_add, rev_length.
           erewrite <- size_spec by eassumption.
           lia.
        ** simpl. setoid_rewrite sem_list_app.
            assert (forall i, sem_for_lists (rev (toList s0)) i = sem_for_lists (toList s0) i).
            setoid_rewrite (sem_list_rev s0 (safeHd ys) (Some e0) _ H3). intros. reflexivity.
            setoid_rewrite H9.
            setoid_rewrite <- toList_sem''; only 2: eassumption.
            f_solver e.
Qed.

Lemma fromDistinctDescList_Desc:
  forall xs,
  StronglySorted (fun x y => gt x y) xs ->
  Desc (fromDistinctDescList xs) None None (List.length xs) (fun i => sem_for_lists xs i).
Proof.
  intros.
  unfold fromDistinctDescList.
  fold fromDistinctDescList_create_f.
  fold fromDistinctDescList_create.
  fold fromDistinctDescList_go_f.
  fold fromDistinctDescList_go.
  destruct xs.
  * solve_Desc e.
  * replace (#1) with (2^0)%Z by reflexivity. destruct p.
    eapply fromDistinctDescList_go_Desc.
    + lia.
    + apply StronglySorted_inv in H.
      destruct H.
      assumption.
    + assert (isLB (safeHd xs) e0 = true). {
        destruct xs; try reflexivity.
        apply StronglySorted_inv in H.
        destruct H.
        rewrite Forall_forall in H0. destruct p. unfold isLB. simpl.
        unfold gt in H0. specialize (H0 (e1, a1)).
        assert (e1 < e0 = true <-> e0 > e1 = true) by (order e). rewrite H1.
        apply H0.
        left. reflexivity.
      }
      solve_Bounded e.
    + right. reflexivity.
    + intros.
      rewrite List.hs_coq_list_length, Zlength_cons in *.
      rewrite size_Bin in H1.
      solve_Desc e. simpl. f_solver e.
Qed.

(** ** Verification of [combineEq] *)

(*Since [combineEq'] and [combineEq] are defined inside [fromAscList] (unlike in Data.Set), we define them here
and then prove equivalence*)

Fixpoint combineEq' {e} {a} `{EqLaws e} (x : e * a) (l : list (e * a) ) :=
  match x, l with
  |z, nil => z :: nil
  |(a, b), (c, d) :: t => if a == c then combineEq' (c, d) t else (a,b) :: combineEq' (c,d) t
  end.

(*The combineEq' from Data.Map (defined here to make combineEq'_equiv nicer*)
Definition old_combineEq' :=(fix combineEq' (arg_0__ : e * a) (arg_1__ : list (e * a)) {struct arg_1__} : list (e * a) :=
   let (kz, _) := arg_0__ in
   match arg_1__ with
   | nil => arg_0__ :: nil
   | (kx, xx) as x :: xs' => if _GHC.Base.==_ kx kz then combineEq' (kx, xx) xs' else arg_0__ :: combineEq' x xs'
   end).

Definition combineEq {e} {a} `{EqLaws e} (l : list (e * a)) :=
  match l with
  | nil => nil
  | x :: nil => x :: nil
  | x :: t => combineEq' x t
  end.

Lemma combineEq'_equiv:
  forall l x, combineEq' x l = old_combineEq' x l.
Proof.
  intros. revert x. induction l; intros.
  - simpl. destruct x. reflexivity.
  - simpl. destruct x. destruct a0. destruct (e0 == e1) eqn : ?.
    assert (e1 == e0 = true) by (order e). rewrite H. apply IHl.
    assert (e1 == e0 = false) by (order e). rewrite H. rewrite IHl.
    reflexivity.
Qed.

Definition fromAscList' (l : list (e * a)) :=
  fromDistinctAscList (combineEq l).

Lemma fromAscList_equiv: forall (l : list (e * a)),
  fromAscList' l = fromAscList l.
Proof.
  intros l. unfold fromAscList', fromAscList. destruct l.
  - simpl. reflexivity.
  -  unfold combineEq. rewrite combineEq'_equiv. unfold old_combineEq'.
     reflexivity.
Qed.

Definition fromDescList' (l : list (e * a)) :=
  fromDistinctDescList (combineEq l).

Lemma fromDescList_equiv: forall (l : list (e * a)),
  fromDescList' l = fromDescList l.
Proof.
  intros l. unfold fromDescList', fromDescList. destruct l.
  - simpl. reflexivity.
  -  unfold combineEq. rewrite combineEq'_equiv. unfold old_combineEq'.
     reflexivity.
Qed.

Definition combineEqGo : (e * a) -> list (e * a) -> list (e * a).
Proof.
  intros.
 apply (@combineEq' e a HEq HEqLaws). apply X.  apply X0.
Defined.

(* Too much duplication here *)

(*See if a key is a (key, value) list*)
Fixpoint key_elem (l : list (e * a)) i :=
  match l with
  | nil => false
  | (x, y) :: t => (x == i) || key_elem t i
  end.

(*This finds the last value associated with a key in a list*)
Fixpoint last_value (l : list (e * a)) i:=
  match l with
  | nil => None
  | (x, y) :: t => if (x == i) then match last_value t i with
                               | None => Some y
                               | Some z => Some z
                               end else last_value t i
  end.

(*This proves that the last_value does in fact find the last value, since it finds
the first value in the reversed list. It also justifies using either
[sem_for_lists (rev l)] or [last_value l] based on which is more convienent. For
[combineEq] and [fromDescList] (and similar), I use [last_value l], and in
from_list, I use [sem_for_lists (rev l)]*)
Lemma last_sem_equiv: forall l x,
  sem_for_lists (rev l) x = last_value l x.
Proof.
  intros. revert x; induction l; intros.
  - simpl. reflexivity.
  - simpl. destruct a0. rewrite sem_list_app. rewrite IHl.
    simpl. destruct (e0 == x) eqn : ?. assert (x == e0 = true) by (order e).
    rewrite H. destruct (last_value l x) eqn : ?. simpl. reflexivity. simpl. reflexivity.
    assert (x == e0 = false) by (order e). rewrite H. rewrite oro_None_r. reflexivity.
Qed.

(*An element has a last occurrence iff it is in the list*)
Lemma last_iff_elem: forall l i,
  (exists v, last_value l i = Some v) <-> key_elem l i = true.
Proof.
  intros. revert  i. induction l; split; intros.
  - simpl in H. inversion H. inversion H0.
  - simpl in H. inversion H.
  - simpl. destruct a0.  simpl in H. destruct (e0 == i) eqn : ?.
    simpl. reflexivity. simpl. eapply IHl. apply H.
  - simpl. destruct a0. simpl in H. destruct (e0  == i) eqn : ?.
    destruct (last_value l i) eqn : ?. exists a1. reflexivity.
    exists a0. reflexivity. simpl in H. apply IHl. apply H.
Qed.

Local Definition le : e * a -> e * a -> Prop
  := fun x1 x2 => let (e1, a1) := x1 in let (e2, a2) := x2 in (e1 <= e2) = true.

Lemma Forall_le_elem:
  forall x x0 xs,
  Forall (fun y => le (x, x0) y) xs <-> (forall i, key_elem xs i = true -> x <= i = true).
Proof.
  intros.
  induction xs.
  * split; intro H.
    - intros i Hi; simpl in Hi; congruence.
    - constructor.
  * split; intro H.
    - inversion H; subst; clear H.
      rewrite IHxs in H3; clear IHxs.
      intros i Hi; simpl in Hi. destruct a0.
      rewrite orb_true_iff in Hi. destruct Hi.
      + unfold le in *.  order e.
      + apply H3; assumption.
    - constructor.
      + unfold le. destruct a0. apply H. simpl. rewrite Eq_Reflexive. simpl. reflexivity.
      + rewrite IHxs; clear IHxs.
        intros i Hi. apply H. simpl. rewrite Hi. destruct a0.  apply orb_true_r.
Qed.

Lemma Forall_le_last:
  forall x x0 xs,
  Forall (fun y => le (x, x0) y) xs <-> (forall i v, last_value xs i = Some v -> x <= i = true).
Proof.
  intros.
  rewrite Forall_le_elem. split; intros.
  - apply H. apply last_iff_elem. exists v. assumption.
  - apply last_iff_elem in H0. destruct H0. apply H in H0. assumption.
Qed.

Local Definition ge : e * a -> e * a -> Prop
  := fun x1 x2 => let (e1, a1) := x1 in let (e2, a2) := x2 in (e1 >= e2) = true.

Lemma Forall_ge_elem:
  forall x x0 xs,
  Forall (fun y => ge (x, x0) y) xs <-> (forall i, key_elem xs i = true -> x >= i = true).
Proof.
  intros.
  induction xs.
  * split; intro H.
    - intros i Hi; simpl in Hi; congruence.
    - constructor.
  * split; intro H.
    - inversion H; subst; clear H.
      rewrite IHxs in H3; clear IHxs.
      intros i Hi; simpl in Hi. destruct a0.
      rewrite orb_true_iff in Hi. destruct Hi.
      + unfold ge in *.  order e.
      + apply H3; assumption.
    - constructor.
      + unfold ge. destruct a0. apply H. simpl. rewrite Eq_Reflexive. simpl. reflexivity.
      + rewrite IHxs; clear IHxs.
        intros i Hi. apply H. simpl. rewrite Hi. destruct a0.  apply orb_true_r.
Qed.

Lemma Forall_ge_last:
  forall x x0 xs,
  Forall (fun y => ge (x, x0) y) xs <-> (forall i v, last_value xs i = Some v -> x >= i = true).
Proof.
  intros.
  rewrite Forall_ge_elem. split; intros.
  - apply H. apply last_iff_elem. exists v. assumption.
  - apply last_iff_elem in H0. destruct H0. apply H in H0. assumption.
Qed.

Lemma Forall_lt_elem:
  forall x x0 xs,
  Forall (fun y => lt (x, x0) y) xs <-> (forall i, key_elem xs i = true -> x < i = true).
Proof.
  intros.
  induction xs.
  * split; intro H.
    - intros i Hi; simpl in Hi; congruence.
    - constructor.
  * split; intro H.
    - inversion H; subst; clear H.
      rewrite IHxs in H3; clear IHxs.
      intros i Hi; simpl in Hi. destruct a0.
      rewrite orb_true_iff in Hi. destruct Hi.
      + unfold lt in *.  order e.
      + apply H3; assumption.
    - constructor.
      + unfold lt. destruct a0. apply H. simpl. rewrite Eq_Reflexive. simpl. reflexivity.
      + rewrite IHxs; clear IHxs.
        intros i Hi. apply H. simpl. rewrite Hi. destruct a0.  apply orb_true_r.
Qed.

Lemma Forall_lt_last:
  forall x x0 xs,
  Forall (fun y => lt (x, x0) y) xs <-> (forall i v, last_value xs i = Some v -> x < i = true).
Proof.
  intros.
  rewrite Forall_lt_elem. split; intros.
  - apply H. apply last_iff_elem. exists v. assumption.
  - apply last_iff_elem in H0. destruct H0. apply H in H0. assumption.
Qed.

Lemma Forall_gt_elem:
  forall x x0 xs,
  Forall (fun y => gt (x, x0) y) xs <-> (forall i, key_elem xs i = true -> x > i = true).
Proof.
  intros.
  induction xs.
  * split; intro H.
    - intros i Hi; simpl in Hi; congruence.
    - constructor.
  * split; intro H.
    - inversion H; subst; clear H.
      rewrite IHxs in H3; clear IHxs.
      intros i Hi; simpl in Hi. destruct a0.
      rewrite orb_true_iff in Hi. destruct Hi.
      + unfold gt in *.  order e.
      + apply H3; assumption.
    - constructor.
      + unfold gt. destruct a0. apply H. simpl. rewrite Eq_Reflexive. simpl. reflexivity.
      + rewrite IHxs; clear IHxs.
        intros i Hi. apply H. simpl. rewrite Hi. destruct a0.  apply orb_true_r.
Qed.

Lemma Forall_gt_last:
  forall x x0 xs,
  Forall (fun y => gt (x, x0) y) xs <-> (forall i v, last_value xs i = Some v -> x > i = true).
Proof.
  intros.
  rewrite Forall_gt_elem. split; intros.
  - apply H. apply last_iff_elem. exists v. assumption.
  - apply last_iff_elem in H0. destruct H0. apply H in H0. assumption.
Qed.

(*Note: This is significatly different than SetProofs. It is not enough that the keys are preserved,
we must show that each key is matched with its last value in the list*)
Lemma combineEqGo_spec:
  forall x xs,
  StronglySorted (fun x y => le x y) (x :: xs) ->
  forall P : list (e * a) -> Prop,
  (forall (ys: list (e * a)),
     StronglySorted (fun x y => lt x y) ys ->
     (forall i, last_value ys i = last_value (x :: xs) i) ->
     P ys) ->
  P (combineEqGo x xs).
Proof.
  intros x xs Hsorted.
  inversion Hsorted; subst; clear Hsorted.
  revert x H2.
  induction H1; intros x Hlt.
  * intros X HX; apply HX; clear X HX.
    + unfold lt. unfold le in Hlt. unfold combineEqGo. simpl. destruct x.
      constructor; constructor.
    + intro. unfold combineEqGo. simpl. destruct x. simpl. reflexivity.
  * inversion Hlt; subst; clear Hlt.
    simpl. unfold combineEqGo in *. simpl in *. destruct a0. destruct x.
    destruct_match.
    + eapply IHStronglySorted; only 1: assumption; intros ys Hsortedys Hiys.
      intros X HX; apply HX; clear X HX.
      - assumption.
      - intro i. rewrite Hiys. simpl.
        destruct (e0 == i) eqn:?, (e1 == i) eqn:?. destruct (last_value l i) eqn : ?.
        reflexivity. reflexivity. reflexivity. order e. reflexivity.
    + assert (Hlt : e1 < e0 = true) by (unfold le in H3; order e). clear H3 Heq.
      eapply IHStronglySorted; only 1: assumption; intros ys Hsortedys Hiys.
      intros X HX; apply HX; clear X HX.
      - constructor.
        ** eapply StronglySorted_R_ext; only 2: apply Hsortedys.
           intros. simpl. order e.
        ** apply Forall_lt_last.
           rewrite Forall_le_last in H.
           intros i v Hi. rewrite Hiys in Hi.  simpl in Hi. unfold lt.
           destruct (e0 == i) eqn : ?. order e. apply H in Hi. unfold le in Hi. order e.
      - intro i. simpl. rewrite Hiys. simpl. reflexivity.
Qed.

Lemma combineEqGo_spec2:
  forall x xs,
  StronglySorted (fun x y => ge x y) (x :: xs) ->
  forall P : list (e * a) -> Prop,
  (forall (ys: list (e * a)),
     StronglySorted (fun x y => gt x y) ys ->
     (forall i, last_value ys i = last_value (x :: xs) i) ->
     P ys) ->
  P (combineEqGo x xs).
Proof.
  intros x xs Hsorted.
  inversion Hsorted; subst; clear Hsorted.
  revert x H2.
  induction H1; intros x Hlt.
  * intros X HX; apply HX; clear X HX.
    + unfold lt. unfold ge in Hlt. unfold combineEqGo. simpl. destruct x.
      constructor; constructor.
    + intro. unfold combineEqGo. simpl. destruct x.  simpl. reflexivity.
  * inversion Hlt; subst; clear Hlt.
    simpl. unfold combineEqGo in *. simpl in *. destruct a0. destruct x.
    destruct_match.
    + eapply IHStronglySorted; only 1: assumption; intros ys Hsortedys Hiys.
      intros X HX; apply HX; clear X HX.
      - assumption.
      - intro i. rewrite Hiys. simpl.
        destruct (e0 == i) eqn:?, (e1 == i) eqn:?. destruct (last_value l i) eqn : ?.
        reflexivity. reflexivity. reflexivity. order e. reflexivity.
    + assert (Hlt : e1 > e0 = true) by (unfold ge in H3; order e). clear H3 Heq.
      eapply IHStronglySorted; only 1: assumption; intros ys Hsortedys Hiys.
      intros X HX; apply HX; clear X HX.
      - constructor.
        ** eapply StronglySorted_R_ext; only 2: apply Hsortedys.
           intros. simpl. order e.
        ** apply Forall_gt_last.
           rewrite Forall_ge_last in H.
           intros i v Hi. rewrite Hiys in Hi.  simpl in Hi. unfold lt.
           destruct (e0 == i) eqn : ?. order e. apply H in Hi. unfold ge in Hi. order e.
      - intro i. simpl. rewrite Hiys. simpl. reflexivity.
Qed.

Lemma combineEq_spec:
  forall xs,
  StronglySorted (fun x y => le x  y) xs ->
  forall P : list (e * a) -> Prop,
  (forall ys,
     StronglySorted (fun x y => lt x y) ys ->
     (forall i, last_value ys i = last_value xs i) ->
     P ys) ->
  P (combineEq xs).
Proof.
  intros xs Hsorted.
  inversion Hsorted.
  * intros X HX. apply HX. clear X HX.
    - constructor.
    - intro. reflexivity.
  * rewrite <- H1 in Hsorted. clear xs H0 H1.
    assert (combineEq (a0 :: l) = combineEqGo a0 l). {
    unfold combineEqGo. simpl. destruct l. simpl. destruct a0. reflexivity.
    reflexivity. } rewrite H0.
    apply combineEqGo_spec. assumption.
Qed.

Lemma combineEq_spec2:
  forall xs,
  StronglySorted (fun x y => ge x  y) xs ->
  forall P : list (e * a) -> Prop,
  (forall ys,
     StronglySorted (fun x y => gt x y) ys ->
     (forall i, last_value ys i = last_value xs i) ->
     P ys) ->
  P (combineEq xs).
Proof.
  intros xs Hsorted.
  inversion Hsorted.
  * intros X HX. apply HX. clear X HX.
    - constructor.
    - intro. reflexivity.
  * rewrite <- H1 in Hsorted. clear xs H0 H1.
    assert (combineEq (a0 :: l) = combineEqGo a0 l). {
    unfold combineEqGo. simpl. destruct l. simpl. destruct a0. reflexivity.
    reflexivity. } rewrite H0.
    apply combineEqGo_spec2. assumption.
Qed.

(** ** Verification of [fromAscList] *)

(*See whether a key, value pair is in a list, comparing the keys with Haskell equality
and the values with Coq equality. This will be used in place of List.In in the following
analogues of [Forall_forall]*)
Fixpoint weak_In (l : list (e * a)) (x : e * a) :=
  match l with
  | nil => False
  | (a,b) :: t => let (x0, y0) := x in (a == x0 = true) /\ b = y0 \/ weak_In t x
  end.

Lemma Forall_forall_lt:
  forall  (l : list (e * a)) t, Forall (lt t) l <-> (forall x, weak_In l x -> lt t x).
Proof.
  intros. split; intros; induction l; intros.
  - simpl in H0. destruct H0.
  - simpl in H0. destruct a0. destruct x. destruct H0. inversion H; subst.
    destruct H0. subst. destruct t. unfold lt in *. order e.
  - apply IHl. inversion H; subst. assumption. apply H0.
  - apply Forall_nil.
  - apply Forall_cons. simpl in H. destruct a0. apply H. left.
    split. apply Eq_Reflexive. reflexivity. simpl in H.
    destruct a0. apply IHl. intros. apply H. destruct x. right. assumption.
Qed.

Lemma Forall_forall_gt:
  forall  (l : list (e * a)) t, Forall (gt t) l <-> (forall x, weak_In l x -> gt t x).
Proof.
  intros. split; intros; induction l; intros.
  - simpl in H0. destruct H0.
  - simpl in H0. destruct a0. destruct x. destruct H0. inversion H; subst.
    destruct H0. subst. destruct t. unfold gt in *. order e.
  - apply IHl. inversion H; subst. assumption. apply H0.
  - apply Forall_nil.
  - apply Forall_cons. simpl in H. destruct a0. apply H. left.
    split. apply Eq_Reflexive. reflexivity. simpl in H.
    destruct a0. apply IHl. intros. apply H. destruct x. right. assumption.
Qed.

Lemma strongly_sorted_in_sem_lt: forall l x v,
  StronglySorted lt l ->
  sem_for_lists l x = Some v <-> weak_In l (x,v).
Proof.
  intros; revert x v; induction l; intros; split; intros.
  - inversion H0.
  - destruct H0.
  - simpl. simpl in H0. destruct a0. destruct (x == e0) eqn : ?.
    left. split. order e. inversion H0; subst; reflexivity.
    right. apply IHl. inversion H; subst; assumption. apply H0.
  - simpl in H0. simpl. destruct a0.
    destruct H0. destruct H0. subst. assert (x == e0 = true) by (order e).
    rewrite H1. reflexivity. inversion H; subst.
    rewrite Forall_forall_lt in H4. assert (A:=H0). apply H4 in H0. unfold lt in H0.
    assert (x == e0 = false) by (order e). rewrite H1. apply IHl. apply H3. apply A.
Qed.

Lemma strongly_sorted_in_sem_gt: forall l x v,
  StronglySorted gt l ->
  sem_for_lists l x = Some v <-> weak_In l (x,v).
Proof.
  intros; revert x v; induction l; intros; split; intros.
  - inversion H0.
  - destruct H0.
  - simpl. simpl in H0. destruct a0. destruct (x == e0) eqn : ?.
    left. split. order e. inversion H0; subst; reflexivity.
    right. apply IHl. inversion H; subst; assumption. apply H0.
  - simpl in H0. simpl. destruct a0.
    destruct H0. destruct H0. subst. assert (x == e0 = true) by (order e).
    rewrite H1. reflexivity. inversion H; subst.
    rewrite Forall_forall_gt in H4. assert (A:=H0). apply H4 in H0. unfold gt in H0.
    assert (x == e0 = false) by (order e). rewrite H1. apply IHl. apply H3. apply A.
Qed.

Lemma strongly_sorted_last_lt:
  forall l x,
  StronglySorted lt l ->
  last_value l x = sem_for_lists l x.
Proof.
  intros. revert x. induction H; intros.
  - simpl. reflexivity.
  - simpl. destruct a0. destruct (x == e0) eqn : ?.
    rewrite Forall_forall_lt in H0.
    rewrite IHStronglySorted.
    destruct (sem_for_lists l x) eqn : ?.
    + rewrite strongly_sorted_in_sem_lt in Heqo. apply H0 in Heqo.
      unfold lt in Heqo. order e. apply H. destruct (e0 == x) eqn : ?. reflexivity.
    order e. assert (e0 == x = false) by (order e). rewrite H1. apply IHStronglySorted.
Qed.

Lemma strongly_sorted_last_gt:
  forall l x,
  StronglySorted gt l ->
  last_value l x = sem_for_lists l x.
Proof.
  intros. revert x. induction H; intros.
  - simpl. reflexivity.
  - simpl. destruct a0. destruct (x == e0) eqn : ?.
    rewrite Forall_forall_gt in H0.
    rewrite IHStronglySorted.
    destruct (sem_for_lists l x) eqn : ?.
    + rewrite strongly_sorted_in_sem_gt in Heqo. apply H0 in Heqo.
      unfold gt in Heqo. order e. apply H. destruct (e0 == x) eqn : ?. reflexivity.
    order e. assert (e0 == x = false) by (order e). rewrite H1. apply IHStronglySorted.
Qed.

Lemma fromAscList_Desc:
  forall xs,
  StronglySorted (fun x y => le x y) xs ->
  Desc' (fromAscList xs) None None (fun i => last_value xs i).
Proof.
  intros. rewrite <- fromAscList_equiv. unfold fromAscList'.
  eapply combineEq_spec; only 1: assumption; intros ys HSorted Helem.
  apply fromDistinctAscList_Desc; only 1: assumption.
  intros s HB Hsz Hf.
  solve_Desc e. intros. rewrite <- Helem. rewrite strongly_sorted_last_lt.
  apply Hf. apply HSorted.
Qed.

(** ** Verification of [fromDescList] *)

Lemma fromDescList_Desc:
  forall xs,
  StronglySorted (fun x y => ge x y) xs ->
  Desc' (fromDescList xs) None None (fun i => last_value xs i).
Proof.
  intros. rewrite <- fromDescList_equiv. unfold fromDescList'.
  unfold fromDescList.
  eapply combineEq_spec2;  only 1: assumption; intros ys HSorted Helem.
  apply fromDistinctDescList_Desc; only 1: assumption.
  intros s HB Hsz Hf.
  solve_Desc e. intros. rewrite <- Helem. rewrite strongly_sorted_last_gt.
  apply Hf. apply HSorted.
Qed.

(** ** Verification of [fromList] *)

(** The verification of [fromList] should be similar to that of [fromDistinctAscList], only
that the condition is checked and -- if it fails -- we resort to a backup implementation. *)

(* The following definitions are copied from the local definitions of [fromList];
   my ltac foo failed to do that automatic.
*)

Definition fromList' :=
          fun (t0: Map e a) (xs: list (e * a)) =>
            let ins :=
              fun arg_2__ arg_3__ =>
                match arg_2__, arg_3__ with
                | t, pair k x => insert k x t
                end in
            Data.Foldable.foldl' ins t0 xs.

Definition not_ordered :=
          fun (arg_7__ : e) (arg_8__: list (e * a)) =>
            match arg_7__, arg_8__ with
            | _, nil => false
            | kx, cons (pair ky _) _ => kx GHC.Base.>= ky
            end .

Definition fromList_create_f : (Int -> list (e * a) -> Map e a * list (e * a) * list (e * a)) ->
(Int -> list (e * a) -> Map e a * list (e * a)  * list (e * a))
  := (fun create arg_11__ arg_12__ =>
      match arg_11__, arg_12__ with
      | _, nil => pair (pair Tip nil) nil
      | s, (cons xp xss as xs) =>
       if s GHC.Base.== #1 : bool
       then let 'pair kx x := xp in
         if not_ordered kx xss : bool
         then pair (pair (Bin #1 kx x Tip Tip) nil) xss else
         pair (pair (Bin #1 kx x Tip Tip) xss) nil else
         match create (Data.Bits.shiftR s #1) xs with
         | (pair (pair _ nil) _ as res) => res
         | pair (pair l (cons (pair ky y) nil)) zs =>
              pair (pair (insertMax ky y l) nil) zs
         | pair (pair l (cons (pair ky y) yss as ys)) _ =>
             if not_ordered ky yss : bool then pair (pair l nil) ys else
             let 'pair (pair r zs) ws := create (Data.Bits.shiftR s #1) yss in
                       pair (pair (link ky y l r) zs) ws
         end
       end).

Definition fromList_create : Int -> list (e * a) -> Map e a * list (e * a) * list (e * a)
  := deferredFix2 (fromList_create_f).

Definition fromList_go_f :=
  (fun (go: Int -> Map e a -> list (e * a) -> Map e a) (arg_28__ : Int)
   (arg_29__ : Map e a) (arg_30__: list (e * a)) =>
    match arg_28__, arg_29__, arg_30__ with
    | _, t, nil => t
    | _, t, cons (pair kx x) nil => insertMax kx x t
    | s, l, (cons (pair kx x) xss as xs) =>
          if not_ordered kx xss : bool then fromList' l xs else
          match fromList_create s xss with
          | pair (pair r ys) nil => go (Data.Bits.shiftL s #1) (link kx x l r) ys
          | pair (pair r _) ys => fromList' (link kx x l r) ys
          end
   end).

Definition fromList_go := deferredFix3 (fromList_go_f).

(** zeta-reduces exactly one (the outermost) [let] *)
Ltac zeta_one :=
  lazymatch goal with |- context A [let x := ?rhs in @?body x] =>
     let e' := eval cbv beta in (body rhs) in
     let e'' := context A [e'] in
     change e''
  end.

(* Identical to [fromDistinctAscList_create_eq] *)
Lemma fromList_create_eq:
  forall i xs, (1 <= i)%Z ->
  fromList_create i xs = fromList_create_f fromList_create i xs.
Proof.
  intros.
  change (uncurry fromList_create (i, xs) = uncurry (fromList_create_f fromList_create) (i, xs)).
  apply deferredFix_eq_on with
    (f := fun g => uncurry (fromList_create_f (curry g)))
    (P := fun p => (1 <= fst p)%Z)
    (R := fun x y => (1 <= fst x < fst y)%Z).
  * eapply wf_inverse_image with (R := fun x y => (1 <= x < y)%Z).
    apply Z.lt_wf with (z := 1%Z).
  * clear i xs H.
    intros g h x Px Heq.
    destruct x as [i xs]. simpl in *.
    unfold fromList_create_f.
    destruct_match; try reflexivity.
    repeat replace (#1) with 1%Z by reflexivity.
    unfold op_zeze__, Eq_Integer___, op_zeze____.
    destruct (Z.eqb_spec i 1); try reflexivity.
    unfold curry.
    assert (1 < i)%Z by lia.
    assert (1 <= Z.shiftr i 1)%Z by (apply Z_shiftr_pos; lia).
    assert (Z.shiftr i 1 < i)%Z by (apply Z_shiftr_lt; lia).
    repeat expand_pairs. simpl.
    rewrite Heq by eauto.
    destruct_match; try reflexivity.
    rewrite Heq by eauto.
    reflexivity.
  * simpl; lia.
Qed.

(* We need to know that [create] returns no longer list than it receives.
   Like [fromDistinctAscList_create_preserves_length], just a few more cases.
 *)
Program Fixpoint fromList_create_preserves_length
  i xs {measure (Z.to_nat i)} :
  (1 <= i)%Z ->
  forall (P : Map e a * list (e * a) * list (e * a) -> Prop),
  ( forall s ys zs ,
    (length ys <= length xs)%nat ->
    P (s, ys, zs)
  ) ->
  P (fromList_create i xs) := _.
Next Obligation.
  intros.
  rename fromList_create_preserves_length into IH.
  rewrite fromList_create_eq by assumption.
  unfold fromList_create_f.
  destruct xs.
  * apply H0. reflexivity.
  * repeat replace (#1) with 1%Z by reflexivity.
    unfold op_zeze__, Eq_Integer___, op_zeze____.
    destruct (Z.eqb_spec i 1).
    + destruct p. destruct_match.
      - apply H0. simpl. lia.
      - apply H0. simpl. lia.
    + assert (Z.to_nat (Bits.shiftR i #1) < Z.to_nat i)%nat. {
        apply Z2Nat.inj_lt.
        apply Z.shiftr_nonneg. lia.
        lia.
        apply Z_shiftr_lt; lia.
      }
      apply IH.
      - assumption.
      - apply Z_shiftr_pos; lia.
      - intros.
        destruct_match.
        ** apply H0. simpl in *. lia.
        ** apply IH.
           -- assumption.
           -- apply Z_shiftr_pos; lia.
           -- intros.
              repeat destruct_match.
              ++ apply H0. simpl in *. lia.
              ++ apply H0. simpl in *. lia.
              ++ apply H0. simpl in *. lia.
Qed.

Lemma fromList_go_eq:
  forall i s xs, (0 < i)%Z ->
  fromList_go i s xs = fromList_go_f fromList_go i s xs.
Proof.
  intros.
  change (deferredFix (fun g => uncurry (uncurry (fromList_go_f (curry (curry g))))) (i, s, xs) =
    uncurry (uncurry (fromList_go_f fromList_go)) (i, s, xs)).
  rewrite deferredFix_eq_on with
    (P := fun p => (1 <= fst (fst p))%Z)
    (R := fun x y => (length (snd x) < length (snd y))%nat); only 1: reflexivity.
  * apply well_founded_ltof with (f := fun x => length (snd x)).
  * intros g h p Px Heq.
    destruct p as [[x y] z].
    simpl in *.
    unfold fromList_go_f.
    destruct_match; try reflexivity.
    eapply fromList_create_preserves_length; try lia.
    intros s' ys zs Hlength.
    destruct_match; try reflexivity.
    destruct_match; try reflexivity.
    destruct_match; try reflexivity.
    destruct_match; try reflexivity.
    apply Heq.
    + apply Z_shiftl_pos.
      lia.
    + simpl. simpl in *. lia.
  * simpl. lia.
Qed.

Program Fixpoint fromList_create_Desc
  sz lb xs {measure (Z.to_nat sz)} :
  (0 <= sz)%Z ->
  not_ordered lb xs = false ->
(*   StronglySorted (fun x y => x < y = true) (lb :: xs) -> *)
  forall (P : Map e a * list (e * a) * list (e * a) -> Prop),
  ( forall s ys zs,
    Bounded s (Some lb) (safeHd ys) ->
    isUB (safeHd ys) lb = true ->
    xs = toList s ++ ys ++ zs->
    ys = nil \/ (size s = (2*2^sz-1)%Z /\ zs = nil) ->
    P (s, ys, zs)
  ) ->
  P (fromList_create (2^sz)%Z xs) := _.
Next Obligation.
  intros ???? Hnonneg HheadOrdered.
  rename fromList_create_Desc into IH.
  rewrite fromList_create_eq
    by (enough (0 < 2^sz)%Z by lia; apply Z.pow_pos_nonneg; lia).
  unfold fromList_create_f.
  destruct xs.
  * intros X HX. apply HX. clear HX.
    - solve_Bounded e.
    - reflexivity.
    - reflexivity.
    - left. reflexivity.
  * repeat replace (#1) with 1%Z by reflexivity.
    unfold op_zeze__, Eq_Integer___, op_zeze____.

    simpl in HheadOrdered. destruct p.

(*     assert (isUB (safeHd xs) e0 = true). {
      destruct xs; try reflexivity.
      inversion H5. assumption.
    } *)

    destruct (Z.eqb_spec (2^sz) 1); [ destruct_match | ].
    - intros X HX. apply HX; clear HX.
      ++ solve_Bounded e.
      ++ reflexivity.
      ++ rewrite toList_Bin, toList_Tip, app_nil_r. reflexivity.
      ++ left. reflexivity.
    - intros X HX. apply HX; clear HX.
      ++ destruct xs; simpl in Heq;  solve_Bounded e. destruct p. unfold safeHd. unfold isUB. order e.
      ++ destruct xs; simpl in *; solve_Bounds e. destruct p. solve_Bounds e.
      ++ rewrite toList_Bin, toList_Tip, !app_nil_r, !app_nil_l. reflexivity.
      ++ right. split. rewrite size_Bin. lia. reflexivity.
    - assert (~ (sz = 0))%Z by (intro; subst; simpl in n; congruence).
      assert (sz > 0)%Z by lia.
      replace ((Bits.shiftR (2 ^ sz)%Z 1%Z)) with (2^(sz - 1))%Z.
      Focus 2.
        unfold Bits.shiftR, Bits.instance_Bits_Int.
        rewrite Z.shiftr_div_pow2 by lia.
        rewrite Z.pow_sub_r by lia.
        reflexivity.
      assert (Z.to_nat (sz - 1) < Z.to_nat sz)%nat.
      { rewrite Z2Nat.inj_sub by lia.
        apply Nat.sub_lt.
        apply Z2Nat.inj_le.
        lia.
        lia.
        lia.
        replace (Z.to_nat 1) with 1 by reflexivity.
        lia.
      }
      eapply IH.
      ++ assumption.
      ++ lia.
      ++ eassumption.
      ++ intros l ys zs HBounded_l HisUB_l Hlist_l Hsize_l.
         destruct ys.
         + intros X HX. apply HX. clear HX.
           ** solve_Bounded e.
           ** assumption.
           ** assumption.
           ** left; reflexivity.
         + simpl in HBounded_l.
           destruct Hsize_l as [? | [??]]; try congruence.
           subst. rewrite app_nil_r in Hlist_l. destruct p.
           assert (isLB (Some lb) e1 = true) by solve_Bounds e.
           destruct ys; only 2: destruct_match.
           -- intros X HX. apply HX; clear HX.
              ** assert (isUB None e1 = true) by reflexivity.
                 applyDesc e (@insertMax_Desc e a).
              ** reflexivity.
              ** erewrite toList_insertMax by eassumption.
                 rewrite app_nil_l, <- app_assoc.
                 assumption.
              ** left; reflexivity.
           -- intros X HX. apply HX; clear HX.
              ** solve_Bounded e.
              ** reflexivity.
              ** rewrite app_nil_l. simpl in Hlist_l.
                 assumption.
              ** left; reflexivity.
           -- eapply IH; clear IH.
              ** assumption.
              ** lia.
              ** eassumption.
              ** simpl in Heq.
                 intros r zs zs' HBounded_r HisUB_r Hlist_r Hsize_r.
                 intros X HX. apply HX. clear HX.
                 --- applyDesc e (@link_Desc e a).
                 --- solve_Bounds e.
                 --- erewrite toList_link by eassumption.
                     rewrite Hlist_l. rewrite Hlist_r.
                     rewrite <- !app_assoc.  reflexivity.
                 --- destruct Hsize_r; [left; assumption| right].
                     destruct H4.
                     split; only 2: assumption.
                     applyDesc e (@link_Desc e a).
                     replace (size l). rewrite H4.
                     rewrite mul_pow_sub in * by lia.
                     lia.
Qed.

Lemma foldl_foldl' : forall {b} f (x : b) (l: list (e * a)),
  Foldable.foldl f x l = Foldable.foldl' f x l.
Proof.
  intros.  unfold Foldable.foldl, Foldable.foldl'; unfold Foldable.Foldable__list;
    unfold  Foldable.foldl__ , Foldable.foldl'__ ;
    unfold Foldable.Foldable__list_foldl', Foldable.Foldable__list_foldl;
    unfold Base.foldl, Base.foldl'. reflexivity.
Qed.

Definition fromList'' :=
          fun (t0: Map e a) (xs: list (e * a)) =>
            let ins :=
              fun arg_2__ arg_3__ =>
                match arg_2__, arg_3__ with
                | t, pair k x => insert k x t
                end in
            Data.Foldable.foldl ins t0 xs.

Lemma fromList'_fromList'': forall m l,
  fromList' m l = fromList'' m l.
Proof.
  intros. unfold fromList'. unfold fromList''. rewrite <- (foldl_foldl' _ m l). reflexivity.
Qed.

Lemma fromList'_Desc:
  forall s l,
  Bounded s None None ->
  Desc' (fromList' s l) None None (fun i => sem_for_lists (rev l) i ||| sem s i).
Proof.
  intros. rewrite fromList'_fromList''.
  unfold fromList''.
  rewrite Foldable.hs_coq_foldl_list.
  revert s H.
  induction l.
  * intros.
    simpl.
    solve_Desc e. reflexivity.
  * intros.
    simpl. destruct a0.
    applyDesc e (@insert_Desc e a).
    applyDesc e IHl.
    solve_Desc e. f_solver e; rewrite sem_list_app in Heqo0.
    + rewrite Heqo1 in Heqo0. inversion Heqo0. reflexivity.
    + rewrite Heqo1 in Heqo0. inversion Heqo0. reflexivity.
    + rewrite Heqo1 in Heqo0. simpl in Heqo0. rewrite Heqb in Heqo0. rewrite Hsem in Hsem0.
      rewrite Hsem0 in Heqo0. assumption.
    + rewrite Heqo1 in Heqo0. simpl in Heqo0. rewrite Heqb in Heqo0. inversion Heqo0.
    + rewrite Heqo2 in Heqo0. inversion Heqo0.
    + rewrite Heqo2 in Heqo0. inversion Heqo0.
    + rewrite Heqo2 in Heqo0. simpl in Heqo0. rewrite Heqb in Heqo0. inversion Heqo0.
    + rewrite Heqo2 in Heqo0. inversion Heqo0.
    + rewrite Heqo2 in Heqo0. inversion Heqo0.
    + rewrite Heqo2 in Heqo0. simpl in Heqo0. rewrite Heqb in Heqo0. inversion Heqo0.
    + rewrite Heqo1 in Heqo0. simpl in Heqo0. rewrite Heqb in Heqo0. inversion Heqo0.
Qed.

(*In a well formed map, we can only find each key once in the list, so it doesn't matter
if we look in the list or the reverse list*)
Lemma sem_toList_reverse: forall m lb ub i,
  Bounded m lb ub ->
  sem_for_lists (rev (toList m)) i = sem_for_lists (toList m) i.
Proof.
  intros. revert i. induction H; intros.
  - simpl. reflexivity.
  - rewrite toList_Bin. rewrite rev_app_distr. rewrite sem_list_app.
    rewrite sem_list_app. simpl. rewrite sem_list_app.
    rewrite IHBounded2. simpl. rewrite IHBounded1. repeat (erewrite <- toList_sem'').
    destruct (sem s2 i) eqn : ?. assert (sem s1 i = None). { eapply sem_outside_above.
    apply H. unfold isUB. apply (sem_inside H0) in Heqo. destruct Heqo. order_Bounds e. }
    rewrite H5. simpl. assert (i == x = false) by solve_Bounds e. rewrite H6. reflexivity.
    simpl. destruct (i == x) eqn : ?. assert (sem s1 i = None). { eapply sem_outside_above.
    apply H. unfold isUB. order_Bounds e. } rewrite H5. simpl. reflexivity. simpl.
    rewrite oro_None_r. reflexivity. apply H. apply H0.
Qed.

Program Fixpoint fromList_go_Desc
  sz s xs {measure (length xs)} :
  (0 <= sz)%Z ->
  Bounded s None (safeHd xs) ->
  xs = nil \/ size s = (2*2^sz-1)%Z ->
  Desc' (fromList_go (2^sz)%Z s xs) None None
    (fun i => sem_for_lists (rev xs) i ||| sem s i) := _.
Next Obligation.
  intros.
  rename fromList_go_Desc into IH.
  rewrite fromList_go_eq by (apply Z.pow_pos_nonneg; lia).
  unfold fromList_go_f.
  destruct xs as [ | ? [ | ?? ]].
  * solve_Desc e. intros. reflexivity.
  * destruct H1; try congruence.
    simpl safeHd in *. destruct p.
    assert (isUB None e0 = true) by reflexivity.
    applyDesc e (@insertMax_Desc e a).
    solve_Desc e. simpl.
    (*setoid_rewrite elem_cons.*)
    f_solver e.
  * destruct H1; try congruence.
    repeat replace (#1) with 1%Z by reflexivity.
    replace ((Bits.shiftL (2 ^ sz)%Z 1))%Z with (2 ^ (1 + sz))%Z.
    Focus 2.
      unfold Bits.shiftL, Bits.instance_Bits_Int.
      rewrite Z.shiftl_mul_pow2 by lia.
      rewrite Z.pow_add_r by lia.
      lia. destruct p.
    destruct_match.
    --  apply Bounded_relax_ub_None in H0.
        applyDesc e fromList'_Desc.
        solve_Desc e. assumption.
    --  eapply fromList_create_Desc.
        - lia.
        - eassumption.
        - intros.
          subst.
          simpl safeHd in *.

          applyDesc e (@link_Desc e a).
          destruct zs.
          ++  rewrite app_nil_r in H4.
              eapply IH.
              + rewrite H4. simpl. rewrite app_length. lia.
              + lia.
              + assumption.
              + destruct H5 as [?|[??]]; [left; assumption | right].
                replace (size s1). replace (size s).  replace (size s0).
                rewrite Z.pow_add_r by lia.
                lia.
              + intros.
                rewrite H4.
                solve_Desc e. simpl.
                (*setoid_rewrite elem_cons.*)
                setoid_rewrite sem_list_app. setoid_rewrite rev_app_distr.
                setoid_rewrite sem_list_app.
                setoid_rewrite (sem_toList_reverse s0 _ _ _ H2).
                setoid_rewrite <- toList_sem''; only 2: eassumption. f_solver e.
                ** assert (sem s i = None). { eapply sem_outside_above. apply H0. solve_Bounds e. }
                   rewrite H9 in Hsem. simpl in Hsem. assert (i == e0 = false) by solve_Bounds e.
                   rewrite H10 in Hsem. simpl in Hsem. rewrite Hsem in H8. inversion H8; reflexivity.
                ** simpl in Heqo2. destruct( i == e0) eqn : ?. simpl in Hsem.
                   assert (sem s i = None). { eapply sem_outside_above. apply H0.
                   solve_Bounds e. } rewrite H9 in Hsem. simpl in Hsem. rewrite Hsem in H8.
                  rewrite Heqo2 in H8. inversion H8; reflexivity.
                ** inversion Heqo2.
                ** simpl in Heqo2. destruct (i == e0) eqn : ?. inversion Heqo2.
                   simpl in Hsem. rewrite Hsem in H8. inversion H8.
                ** destruct (sem s i); simpl in Hsem; inversion Hsem. rewrite H8 in H10.
                   inversion H10. destruct (i == e0); simpl in Hsem; inversion Hsem.
                    rewrite H8 in H11. inversion H11. rewrite H11 in H8. inversion H8.
                ** simpl in Heqo2. destruct (i == e0) eqn : ?. simpl in Hsem.
                   destruct (sem s i); simpl in Hsem. rewrite Hsem in H8. inversion H8.
                    rewrite Hsem in H8; inversion H8. inversion Heqo2.
         ++ destruct H5 as [ ? | [? Habsurd]]; try congruence.
            subst. rewrite app_nil_l in H4.
            rewrite H4.
            apply Bounded_relax_ub_None in HB.
            applyDesc e fromList'_Desc.
            solve_Desc e. simpl.
            (*setoid_rewrite elem_cons.*)
            setoid_rewrite sem_list_app. setoid_rewrite rev_app_distr. simpl.
            setoid_rewrite sem_list_app. setoid_rewrite (sem_toList_reverse s0 _ _ _ H2).
            setoid_rewrite <- toList_sem''; only 2: eassumption. simpl in Hsem0.
            f_solver e.
            ** assert (sem s i = None). { eapply sem_outside_above. apply H0.
              solve_Bounds e. } rewrite H5 in Hsem. simpl in Hsem.
              assert (i == e0 = false) by solve_Bounds e. rewrite H6 in Hsem. simpl in Hsem.
              rewrite Hsem in Hsem0. inversion Hsem0; reflexivity.
            **  assert (sem s i = None). { eapply sem_outside_above. apply H0.
              solve_Bounds e. } rewrite H5 in Hsem. simpl in Hsem. rewrite Hsem in Hsem0.
              inversion Hsem0; reflexivity.
            ** destruct (sem s i); simpl in Hsem; rewrite Hsem in Hsem0. inversion Hsem0.
                destruct (i == e0); simpl in Hsem. inversion Hsem0. inversion Hsem0.
            ** destruct (sem s i). simpl in Hsem. rewrite Hsem in Hsem0. inversion Hsem0.
              simpl in Hsem. rewrite Hsem in Hsem0. inversion Hsem0.
Qed.

Lemma fromList_Desc:
  forall xs,
  Desc' (fromList xs) None None (fun i => sem_for_lists (rev xs) i).
Proof.
  intros.
  cbv beta delta [fromList].
  destruct xs as [ | ? [|??] ].
  * solve_Desc e. reflexivity.
  * destruct p. solve_Desc e. intros. simpl. destruct (i == e0); reflexivity.
  * fold fromList'. destruct p.
    zeta_one.
    fold not_ordered.
    zeta_one.
    fold fromList_create_f.
    fold fromList_create.
    zeta_one.
    fold fromList_go_f.
    fold fromList_go.
    zeta_one.
    destruct_match.
    - applyDesc e fromList'_Desc.
      solve_Desc e. simpl. setoid_rewrite sem_list_app. setoid_rewrite sem_list_app.
       simpl. destruct p0. simpl in Hsem. setoid_rewrite sem_list_app in Hsem. simpl in Hsem.
      (*setoid_rewrite elem_cons.*)
      f_solver e.
    - repeat replace (#1) with (2^0)%Z by reflexivity.
      eapply fromList_go_Desc.
      + lia.
      + destruct p0. simpl in Heq.
        solve_Bounded e.
      + right. reflexivity.
      + intros.
        solve_Desc e. simpl. setoid_rewrite sem_list_app. setoid_rewrite sem_list_app.
        simpl. simpl in H1. setoid_rewrite sem_list_app in H1. simpl in H1.
        f_solver e.
Qed.

End WF.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.NewProofs.ProofHelpers.
Require Import depoolContract.DePoolFunc.

(* Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100. *)

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Require Import depoolContract.DePoolConsts.
Module DePoolContract_Ф_cancelWithdrawal (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Module ProofHelpers := ProofHelpers dc.

Import dc.
Import ProofHelpers.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Opaque Z.eqb Z.add Z.sub Z.div Z.mul hmapLookup hmapInsert Z.ltb Z.geb Z.leb Z.gtb Z.modulo deleteListPair.

Lemma DePoolContract_Ф_cancelWithdrawal_exec : forall (l : Ledger),
let sender := eval_state msg_sender l in
let isInternalMessage : bool := negb (sender =? 0) in
(* let dePool := Ledger_ι_DePoolContract l in *)
let isPoolClosed : bool := eval_state (↑ε12 DePoolContract_ι_m_poolClosed) l in
let optParticipant := eval_state (↓ ParticipantBase_Ф_fetchParticipant sender) l in
let isEmptyParticipant : bool := negb (isSome optParticipant) (* match optParticipant with | None => true | _ => false end *) in
let participant := maybeGet optParticipant (* match optParticipant with | None => default | Some p => p end *) in
let newParticipant := {$ participant with (DePoolLib_ι_Participant_ι_reinvest, true);
                                          (DePoolLib_ι_Participant_ι_withdrawValue, 0) $} in
let l_set := exec_state (↓ ParticipantBase_Ф__setOrDeleteParticipant sender newParticipant) l in
let l_send := exec_state (↓ DePoolContract_Ф_sendAcceptAndReturnChange) l_set in
let statusDepoolClosed := DePool_ι_STATUS_DEPOOL_CLOSED in
let statusNoParticipant := DePool_ι_STATUS_NO_PARTICIPANT in

exec_state (↓ DePoolContract_Ф_cancelWithdrawal) l =

if isInternalMessage then
    if isPoolClosed then exec_state (↓ DePoolContract_Ф__sendError statusDepoolClosed 0) l else
        if isEmptyParticipant then exec_state (↓ DePoolContract_Ф__sendError statusNoParticipant 0) l
        else l_send
else l.
Proof.

  intros.
  destructLedger l.
  compute.

  Time repeat destructIf_solve.

Qed.

Lemma DePoolContract_Ф_cancelWithdrawal'_eval : forall (l : Ledger),
let sender := eval_state msg_sender l in
let isInternalMessage : bool := negb (sender =? 0) in
let isPoolClosed : bool := eval_state (↑ε12 DePoolContract_ι_m_poolClosed) l in
let optParticipant := eval_state (↓ ParticipantBase_Ф_fetchParticipant sender) l in
let isEmptyParticipant : bool := negb (isSome optParticipant) (* match optParticipant with | None => true | _ => false end *) in

eval_state (↓ DePoolContract_Ф_cancelWithdrawal') l =

if isInternalMessage then
    if isPoolClosed then Value (Error I) else
        if isEmptyParticipant then Value (Error I)
    else Value (Value I)
else  Error Errors_ι_IS_EXT_MSG.
Proof.

  intros.
  destructLedger l.
  compute.

  Time repeat destructIf_solve.
Qed.

Opaque DePoolContract_Ф_cancelWithdrawal'.

Lemma DePoolContract_Ф_cancelWithdrawal_eval : forall (l : Ledger),
let sender := eval_state msg_sender l in
let isInternalMessage : bool := negb (sender =? 0) in
let isPoolClosed : bool := eval_state (↑ε12 DePoolContract_ι_m_poolClosed) l in
let optParticipant := eval_state (↓ ParticipantBase_Ф_fetchParticipant sender) l in
let isEmptyParticipant : bool := negb (isSome optParticipant) (* match optParticipant with | None => true | _ => false end *) in

eval_state (↓ DePoolContract_Ф_cancelWithdrawal) l =

if isInternalMessage then
    if isPoolClosed then Value I else
        if isEmptyParticipant then Value I
    else Value I
else  Error Errors_ι_IS_EXT_MSG.
Proof.

  intros.

  assert (eval_state (↓ DePoolContract_Ф_cancelWithdrawal ) l =
  xErrorMapDefaultF (xValue ∘ fromValueValue) (eval_state (↓ DePoolContract_Ф_cancelWithdrawal' ) l) xError ).
  unfold DePoolContract_Ф_cancelWithdrawal.
  unfold callEmbeddedStateAdj.
  remember (DePoolContract_Ф_cancelWithdrawal' ).
  setoid_rewrite runbind.
  setoid_rewrite eval_bind2.
  rewrite eval_get.
  rewrite exec_get.
  remember (run l0 (injEmbed (T:=LocalState) DePoolFuncs.DePoolSpec.LedgerClass.local0 l)).
  setoid_rewrite <- Heqp.
  destruct p.
  destruct x.
  auto. auto.

  (**********************)
  rewrite H.
  rewrite DePoolContract_Ф_cancelWithdrawal'_eval.
  compute.
  repeat destructIf; auto.
Qed.

End DePoolContract_Ф_cancelWithdrawal.