Require Coq.funind.Recdef.
Require Import Bitoychain.Coqlib.
Require Import Bitoychain.Integers.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Coq.Lists.List.
Require Import Coq.Sorting.Permutation.
Require Import Bitoychain.Coqlib2.
Require Import Bitoychain.coqlib4.

Lemma power_nat_one_divede_other: forall n m : nat,
  (two_power_nat n | two_power_nat m) \/ (two_power_nat m | two_power_nat n).
Proof.
  intros.
  pose proof Zle_0_nat n.
  pose proof Zle_0_nat m.
  rewrite !two_power_nat_two_p.
  destruct (zle (Z.of_nat n) (Z.of_nat m)).
  + left.
    exists (two_p (Z.of_nat m - Z.of_nat n)).
    rewrite <- two_p_is_exp by omega.
    f_equal.
    omega.
  + right.
    exists (two_p (Z.of_nat n - Z.of_nat m)).
    rewrite <- two_p_is_exp by omega.
    f_equal.
    omega.
Qed.

Lemma multiple_divide_mod: forall a b c, b > 0 -> ((a | b) \/ (b | a)) -> (a | (c * a mod b)).
Proof.
  intros.
  destruct H0.
  + apply Z.divide_add_cancel_r with (b * (c * a / b))%Z.
    apply Z.divide_mul_l; auto.
    rewrite <- Z_div_mod_eq; auto.
    apply Z.divide_mul_r, Z.divide_refl.
  + destruct H0.
    subst.
    rewrite Z.mul_assoc, Z_mod_mult.
    apply Z.divide_0_r.
Qed.

Lemma divide_align: forall x y: Z, x > 0 -> Zdivide x y -> align y x = y.
Proof.
  intros.
  unfold align.
  destruct H0.
  rewrite H0.
  pose proof Zdiv_unique (x0 * x + x - 1) x x0 (x - 1).
  assert (x0 * x + x - 1 = x0 * x + (x - 1)) by omega.
  assert (0 <= x - 1 < x) by omega.
  rewrite (H1 H2 H3).
  reflexivity.
Qed.

Lemma arith_aux00: forall a b, b <= a -> 0%nat = nat_of_Z (a - b) -> a - b = 0.
Proof.
  intros.
  pose proof Z2Nat.id (a - b).
  unfold nat_of_Z in H0.
  rewrite <- H0 in H1.
  simpl Z.of_nat in H1.
  omega.
Qed.

Lemma arith_aux01: forall a b n, S n = nat_of_Z (a - b) -> b < a.
Proof.
  intros.
  destruct (zlt a b); auto.
  + rewrite Z2Nat_neg in H by omega.
    inversion H.
  + pose proof Z2Nat.id (a - b).
    unfold nat_of_Z in H; rewrite <- H in H0.
    spec H0; [omega |].
    rewrite Nat2Z.inj_succ in H0.
    omega.
Qed.

Lemma arith_aux02: forall n a b, S n = nat_of_Z (a - b) -> n = nat_of_Z (a - Z.succ b).
Proof.
  intros.
  pose proof arith_aux01 _ _ _ H.
  unfold nat_of_Z in *.
  pose proof Z2Nat.id (a - b).
  spec H1; [omega |].
  rewrite <- H in H1.
  replace (a - Z.succ b) with (a - b - 1) by omega.
  rewrite <- H1.
  rewrite Nat2Z.inj_succ.
  replace (Z.succ (Z.of_nat n) - 1) with (Z.of_nat n) by omega.
  rewrite Nat2Z.id.
  auto.
Qed.

Lemma arith_aux03: forall a b c,
  0 <= b ->
  0 <= a + b * c ->
  0 <= a + b * Z.succ c.
Proof.
  intros.
  assert (b * c <= b * Z.succ c) by (apply Zmult_le_compat_l; omega).
  omega.
Qed.

Lemma arith_aux04: forall a b c,
  0 <= b <= c ->
  (a | b) ->
  (a | b mod c).
Proof.
  intros.
  destruct (zlt b c).
  + rewrite Zmod_small by omega.
    auto.
  + assert (b = c) by omega.
    subst.
    rewrite Z_mod_same_full.
    apply Z.divide_0_r.
Qed.

Lemma arith_aux05: forall lo hi, 0 <= lo -> 0 <= hi ->
  0 <= Z.max 0 (hi - lo) <= hi.
Proof.
  intros.
  destruct (zle lo hi).
  + rewrite Z.max_r by omega.
    omega.
  + rewrite Z.max_l by omega.
    omega.
Qed.

Lemma arith_aux06: forall lo hi n, 0 <= lo <= n -> 0 <= hi <= n -> 0 <= lo + Z.max 0 (hi - lo) <= n.
Proof.
  intros.
  destruct (zle lo hi).
  + rewrite Z.max_r by omega.
    omega.
  + rewrite Z.max_l by omega.
    omega.
Qed.

Ltac inv_int i :=
  let ofs := fresh "ofs" in
  let H := fresh "H" in
  let H0 := fresh "H" in
  let H1 := fresh "H" in
 match type of i with
 | int =>
  pose proof Int.repr_unsigned i as H;
  pose proof Int.unsigned_range i as H0;
  remember (Int.unsigned i) as ofs eqn:H1;
  rewrite <- H in *;
  clear H H1; try clear i
 | ptrofs =>
  pose proof Ptrofs.repr_unsigned i as H;
  pose proof Ptrofs.unsigned_range i as H0;
  remember (Ptrofs.unsigned i) as ofs eqn:H1;
  rewrite <- H in *;
  clear H H1; try clear i
end.

(**************************************************

Solve_mod_modulus

**************************************************)

Definition int_modm x := x mod Int.modulus.

Lemma int_modm_mod_eq: forall x y, Int.eqmod Int.modulus x y -> x mod Int.modulus = int_modm y.
Proof.
  intros.
  apply Int.eqmod_mod_eq; auto.
  apply Int.modulus_pos.
Qed.

Lemma int_modm_mod_elim: forall x y, Int.eqmod Int.modulus x y -> Int.eqmod Int.modulus (x mod Int.modulus) y.
Proof.
  intros.
  eapply Int.eqmod_trans; eauto.
  apply Int.eqmod_sym, Int.eqmod_mod.
  apply Int.modulus_pos.
Qed.

Definition int_reprm := Int.repr.

Lemma int_modm_repr_eq: forall x y, Int.eqmod Int.modulus x y -> Int.repr x = int_reprm y.
Proof.
  intros.
  apply Int.eqm_samerepr; auto.
Qed.

Ltac int_simpl_mod A H :=
  let H0 := fresh "H" in
  let H1 := fresh "H" in
  match A with
  | (?B + ?C)%Z =>
    int_simpl_mod B H0; int_simpl_mod C H1;
    pose proof Int.eqmod_add Int.modulus _ _ _ _ H0 H1 as H;
    clear H1 H0
  | (?B - ?C)%Z =>
    int_simpl_mod B H0; int_simpl_mod C H1;
    pose proof Int.eqmod_sub Int.modulus _ _ _ _ H0 H1 as H;
    clear H1 H0
  | (?B * ?C)%Z =>
    int_simpl_mod B H0; int_simpl_mod C H1;
    pose proof Int.eqmod_mult Int.modulus _ _ _ _ H0 H1 as H;
    clear H1 H0
  | (- ?B)%Z =>
    int_simpl_mod B H0;
    pose proof Int.eqmod_neg Int.modulus _ _ H0 as H;
    clear H0
  | ?B mod Int.modulus =>
    int_simpl_mod B H0;
    pose proof int_modm_mod_elim B _ H0 as H;
    clear H0
  | int_modm ?B =>
    int_simpl_mod B H0;
    pose proof int_modm_mod_elim B _ H0 as H;
    clear H0
  | _ =>
    pose proof Int.eqmod_refl Int.modulus A as H
  end.

Definition ptrofs_modm x := x mod Ptrofs.modulus.

Lemma ptrofs_modm_mod_eq: forall x y, Ptrofs.eqmod Ptrofs.modulus x y -> x mod Ptrofs.modulus = ptrofs_modm y.
Proof.
  intros.
  apply Ptrofs.eqmod_mod_eq; auto.
  apply Ptrofs.modulus_pos.
Qed.

Lemma ptrofs_modm_mod_elim: forall x y, Ptrofs.eqmod Ptrofs.modulus x y -> Ptrofs.eqmod Ptrofs.modulus (x mod Ptrofs.modulus) y.
Proof.
  intros.
  eapply Ptrofs.eqmod_trans; eauto.
  apply Ptrofs.eqmod_sym, Ptrofs.eqmod_mod.
  apply Ptrofs.modulus_pos.
Qed.

Definition ptrofs_reprm := Ptrofs.repr.

Lemma ptrofs_modm_repr_eq: forall x y, Ptrofs.eqmod Ptrofs.modulus x y -> Ptrofs.repr x = ptrofs_reprm y.
Proof.
  intros.
  apply Ptrofs.eqm_samerepr; auto.
Qed.

Ltac ptrofs_simpl_mod A H :=
  let H0 := fresh "H" in
  let H1 := fresh "H" in
  match A with
  | (?B + ?C)%Z =>
    ptrofs_simpl_mod B H0; ptrofs_simpl_mod C H1;
    pose proof Ptrofs.eqmod_add Ptrofs.modulus _ _ _ _ H0 H1 as H;
    clear H1 H0
  | (?B - ?C)%Z =>
    ptrofs_simpl_mod B H0; ptrofs_simpl_mod C H1;
    pose proof Ptrofs.eqmod_sub Ptrofs.modulus _ _ _ _ H0 H1 as H;
    clear H1 H0
  | (?B * ?C)%Z =>
    ptrofs_simpl_mod B H0; ptrofs_simpl_mod C H1;
    pose proof Ptrofs.eqmod_mult Ptrofs.modulus _ _ _ _ H0 H1 as H;
    clear H1 H0
  | (- ?B)%Z =>
    ptrofs_simpl_mod B H0;
    pose proof Ptrofs.eqmod_neg Ptrofs.modulus _ _ H0 as H;
    clear H0
  | ?B mod Ptrofs.modulus =>
    ptrofs_simpl_mod B H0;
    pose proof ptrofs_modm_mod_elim B _ H0 as H;
    clear H0
  | ptrofs_modm ?B =>
    ptrofs_simpl_mod B H0;
    pose proof ptrofs_modm_mod_elim B _ H0 as H;
    clear H0
  | _ =>
    pose proof Ptrofs.eqmod_refl Ptrofs.modulus A as H
  end.

Ltac solve_mod_modulus :=
  unfold Int.add; rewrite ?Int.unsigned_repr_eq;
  unfold Ptrofs.add; rewrite ?Ptrofs.unsigned_repr_eq;
  repeat
  match goal with
  | |- context [?A mod Int.modulus] =>
         let H := fresh "H" in int_simpl_mod A H;
         rewrite (int_modm_mod_eq A _ H);
         clear H
  | |- context [Int.repr ?A] =>
         let H := fresh "H" in int_simpl_mod A H;
         rewrite (int_modm_repr_eq A _ H);
         clear H
  | |- context [?A mod Ptrofs.modulus] =>
         let H := fresh "H" in int_simpl_mod A H;
         rewrite (int_modm_mod_eq A _ H);
         clear H
  | |- context [Int.repr ?A] =>
         let H := fresh "H" in int_simpl_mod A H;
         rewrite (int_modm_repr_eq A _ H);
         clear H
  | |- context [?A mod Ptrofs.modulus] =>
         let H := fresh "H" in ptrofs_simpl_mod A H;
         rewrite (ptrofs_modm_mod_eq A _ H);
         clear H
  | |- context [Ptrofs.repr ?A] =>
         let H := fresh "H" in ptrofs_simpl_mod A H;
         rewrite (ptrofs_modm_repr_eq A _ H);
         clear H
  | |- context [?A mod Ptrofs.modulus] =>
         let H := fresh "H" in ptrofs_simpl_mod A H;
         rewrite (ptrofs_modm_mod_eq A _ H);
         clear H
  | |- context [Ptrofs.repr ?A] =>
         let H := fresh "H" in ptrofs_simpl_mod A H;
         rewrite (ptrofs_modm_repr_eq A _ H);
         clear H
  end;
  unfold int_modm, int_reprm, ptrofs_modm, ptrofs_reprm in *.

(**************************************************

List lemmas

**************************************************)

Lemma add_repr: forall i j, Int.add (Int.repr i) (Int.repr j) = Int.repr (i+j).
Proof. intros.
  rewrite Int.add_unsigned.
 apply Int.eqm_samerepr.
 unfold Int.eqm.
 apply Int.eqm_add; apply Int.eqm_sym; apply Int.eqm_unsigned_repr.
Qed.

Lemma mul_repr:
 forall x y, Int.mul (Int.repr x) (Int.repr y) = Int.repr (x * y).
Proof.
intros. unfold Int.mul.
apply Int.eqm_samerepr.
repeat rewrite Int.unsigned_repr_eq.
apply Int.eqm_mult; unfold Int.eqm; apply Int.eqmod_sym;
apply Int.eqmod_mod; compute; congruence.
Qed.

Lemma sub_repr: forall i j,
  Int.sub (Int.repr i) (Int.repr j) = Int.repr (i-j).
Proof.
  intros.
 unfold Int.sub.
 apply Int.eqm_samerepr.
 unfold Int.eqm.
 apply Int.eqm_sub; apply Int.eqm_sym; apply Int.eqm_unsigned_repr.
Qed.

Lemma ptrofs_add_repr: forall i j, Ptrofs.add (Ptrofs.repr i) (Ptrofs.repr j) = Ptrofs.repr (i+j).
Proof. intros.
  rewrite Ptrofs.add_unsigned.
 apply Ptrofs.eqm_samerepr.
 unfold Ptrofs.eqm.
 apply Ptrofs.eqm_add; apply Ptrofs.eqm_sym; apply Ptrofs.eqm_unsigned_repr.
Qed.

Lemma ptrofs_mul_repr:
 forall x y, Ptrofs.mul (Ptrofs.repr x) (Ptrofs.repr y) = Ptrofs.repr (x * y).
Proof.
intros. unfold Ptrofs.mul.
apply Ptrofs.eqm_samerepr.
repeat rewrite Ptrofs.unsigned_repr_eq.
apply Ptrofs.eqm_mult; unfold Ptrofs.eqm; apply Ptrofs.eqmod_sym;
apply Ptrofs.eqmod_mod; compute; congruence.
Qed.

Lemma ptrofs_sub_repr: forall i j,
  Ptrofs.sub (Ptrofs.repr i) (Ptrofs.repr j) = Ptrofs.repr (i-j).
Proof.
  intros.
 unfold Ptrofs.sub.
 apply Ptrofs.eqm_samerepr.
 unfold Ptrofs.eqm.
 apply Ptrofs.eqm_sub; apply Ptrofs.eqm_sym; apply Ptrofs.eqm_unsigned_repr.
Qed.

Lemma Zland_two_p:
 forall i n, (0 <= n)%Z -> Z.land i (Z.ones n) = i mod (2 ^ n).
Proof.
intros.
rewrite Z.land_ones by auto.
reflexivity.
Qed.

Lemma and_repr
     : forall i j : Z, Int.and (Int.repr i) (Int.repr j) = Int.repr (Z.land i j).
Proof.
  intros.
  unfold Int.and.
  rewrite <- (Int.repr_unsigned (Int.repr (Z.land i j))).
  rewrite !Int.unsigned_repr_eq.
  change Int.modulus with (2 ^ 32).
  rewrite <- !Zland_two_p by omega.
  f_equal.
  rewrite <- !Z.land_assoc.
  f_equal.
  rewrite (Z.land_comm (Z.ones 32)).
  rewrite <- !Z.land_assoc.
  f_equal.
Qed.

Lemma or_repr
     : forall i j : Z, Int.or (Int.repr i) (Int.repr j) = Int.repr (Z.lor i j).
Proof.
  intros.
  unfold Int.or.
  rewrite <- (Int.repr_unsigned (Int.repr (Z.lor i j))).
  rewrite !Int.unsigned_repr_eq.
  change Int.modulus with (2 ^ 32).
  rewrite <- !Zland_two_p by omega.
  f_equal.
  rewrite <- Z.land_lor_distr_l.
  reflexivity.
Qed.

Lemma add64_repr: forall i j, Int64.add (Int64.repr i) (Int64.repr j) = Int64.repr (i+j).
Proof. intros.
  rewrite Int64.add_unsigned.
 apply Int64.eqm_samerepr.
 unfold Int64.eqm.
 apply Int64.eqm_add; apply Int64.eqm_sym; apply Int64.eqm_unsigned_repr.
Qed.

Lemma mul64_repr:
 forall x y, Int64.mul (Int64.repr x) (Int64.repr y) = Int64.repr (x * y).
Proof.
intros. unfold Int64.mul.
apply Int64.eqm_samerepr.
repeat rewrite Int64.unsigned_repr_eq.
apply Int64.eqm_mult; unfold Int64.eqm; apply Int64.eqmod_sym;
apply Int64.eqmod_mod; compute; congruence.
Qed.

Lemma sub64_repr: forall i j,
  Int64.sub (Int64.repr i) (Int64.repr j) = Int64.repr (i-j).
Proof.
 intros. unfold Int64.sub.
 apply Int64.eqm_samerepr.
 unfold Int64.eqm.
 apply Int64.eqm_sub; apply Int64.eqm_sym; apply Int64.eqm_unsigned_repr.
Qed.

Lemma and64_repr
     : forall i j : Z, Int64.and (Int64.repr i) (Int64.repr j) = Int64.repr (Z.land i j).
Proof.
  intros.
  unfold Int64.and.
  rewrite <- (Int64.repr_unsigned (Int64.repr (Z.land i j))).
  rewrite !Int64.unsigned_repr_eq.
  change Int64.modulus with (2 ^ 64).
  rewrite <- !Zland_two_p by omega.
  f_equal.
  rewrite <- !Z.land_assoc.
  f_equal.
  rewrite (Z.land_comm (Z.ones 64)).
  rewrite <- !Z.land_assoc.
  f_equal.
Qed.

Lemma or64_repr
     : forall i j : Z, Int64.or (Int64.repr i) (Int64.repr j) = Int64.repr (Z.lor i j).
Proof.
  intros.
  unfold Int64.or.
  rewrite <- (Int64.repr_unsigned (Int64.repr (Z.lor i j))).
  rewrite !Int64.unsigned_repr_eq.
  change Int64.modulus with (2 ^ 64).
  rewrite <- !Zland_two_p by omega.
  f_equal.
  rewrite <- Z.land_lor_distr_l.
  reflexivity.
Qed.

Lemma neg_repr: forall i, Int.neg (Int.repr i) = Int.repr (-i).
Proof.
intros. unfold Int.neg.
apply Int.eqm_samerepr.
apply Int.eqm_neg.
apply Int.eqm_unsigned_repr_l.
apply Int.eqm_refl.
Qed.

Lemma neg64_repr: forall i, Int64.neg (Int64.repr i) = Int64.repr (-i).
Proof.
intros. unfold Int64.neg.
apply Int64.eqm_samerepr.
apply Int64.eqm_neg.
apply Int64.eqm_unsigned_repr_l.
apply Int64.eqm_refl.
Qed.

Arguments Int.unsigned n : simpl never.
Arguments Ptrofs.unsigned n : simpl never.
Arguments Pos.to_nat !x / .

Lemma align_0: forall z,
    z > 0 -> align 0 z = 0.
Proof. unfold align; intros. rewrite Zdiv_small; omega.
Qed.
Hint Rewrite align_0 using omega : norm.

Lemma align_1: forall n, align n 1 = n.
Proof.  intros; unfold align. rewrite Z.div_1_r. rewrite Z.mul_1_r. omega.
Qed.
Hint Rewrite align_1 using omega : norm.

Lemma fold_right_andb: forall bl b, fold_right andb b bl = true -> forall b0, In b0 bl -> b0 = true.
Proof.
  intros.
  induction bl.
  + inversion H0.
  + destruct H0.
    - simpl in H.
      rewrite andb_true_iff in H.
      subst; tauto.
    - simpl in H.
      rewrite andb_true_iff in H.
      tauto.
Qed.

Lemma Z2Nat_inj_0: forall z, z >= 0 -> Z.to_nat z = 0%nat -> z = 0.
Proof.
  intros.
  destruct (zlt 0 z).
  + replace z with (1 + (z - 1)) in H0 by omega.
    rewrite Z2Nat.inj_add in H0 by omega.
    change (Z.to_nat 1) with (1%nat) in H0.
    inversion H0.
  + omega.
Qed.

Lemma Z2Nat_id': forall n, Z.of_nat (Z.to_nat n) = Z.max 0 n.
Proof.
intros.
 destruct (zlt n 0).
 rewrite Z2Nat_neg by auto. rewrite Z.max_l by omega; reflexivity.
 rewrite Z2Nat.id, Z.max_r by omega; omega.
Qed.

Lemma nil_or_non_nil: forall {A} (a: list A), {a = nil} + {a <> nil}.
Proof.
  intros.
  destruct a; [left | right]; congruence.
Qed.

Lemma Permutation_concat: forall {A} (P Q: list (list A)),
  Permutation P Q ->
  Permutation (concat P) (concat Q).
Proof.
  intros.
  induction H.
  + apply Permutation_refl.
  + simpl.
    apply Permutation_app_head; auto.
  + simpl.
    rewrite !app_assoc.
    apply Permutation_app_tail.
    apply Permutation_app_comm.
  + eapply Permutation_trans; eauto.
Qed.

Lemma proj_sumbool_is_false:
  forall (P: Prop) (a: {P}+{~P}), ~P -> proj_sumbool a = false.
Proof.
intros. destruct a; auto; contradiction.
Qed.
Hint Rewrite proj_sumbool_is_true using (solve [auto 3]) : norm.
Hint Rewrite proj_sumbool_is_false using (solve [auto 3]) : norm.

Lemma ptrofs_to_int_repr:
 forall x, (Ptrofs.to_int (Ptrofs.repr x)) = Int.repr x.
Proof.
intros.
destruct Archi.ptr64 eqn:Hp.
*
unfold Ptrofs.to_int.
apply Int.eqm_samerepr.
unfold Int.eqm.
rewrite Ptrofs.unsigned_repr_eq.
unfold Ptrofs.modulus.
unfold Ptrofs.wordsize.
unfold Wordsize_Ptrofs.wordsize.
rewrite Hp.
unfold Int.modulus.
unfold Int.wordsize.
unfold Wordsize_32.wordsize.
apply Int.eqmod_divides with (two_power_nat 64).
apply Int.eqmod_sym.
apply Int.eqmod_mod.
compute. auto.
exists (two_power_nat 32).
reflexivity.
*
erewrite Ptrofs.agree32_to_int_eq. reflexivity.
apply Ptrofs.agree32_repr.
auto.
Qed.


Require Import rt.util.all.
Require Import rt.model.arrival.basic.arrival_sequence rt.model.suspension
               rt.model.priority.
Require Import rt.model.schedule.uni.susp.schedule.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module PlatformWithSuspensions.

  Export ScheduleWithSuspensions Priority.

  Section Definitions.

    Context {Task: eqType}.
    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_task: Job -> Task.

    (* Assume that job suspension times are given. *)
    Variable next_suspension: job_suspension Job.

    (* Consider any job arrival sequence ...*)
    Variable arr_seq: arrival_sequence Job.

    (* ...and any uniprocessor schedule of these jobs. *)
    Variable sched: schedule Job.

    (* For simplicity, let's recall the definitions of pending, scheduled, and backlogged job.
       Note that this notion of backlogged is specific for suspension-aware schedulers. *)
    Let job_pending_at := pending job_arrival job_cost sched.
    Let job_scheduled_at := scheduled_at sched.
    Let job_backlogged_at := backlogged job_arrival job_cost next_suspension sched.

    (* In this section, we define schedule constraints for suspension-aware schedules. *)
    Section ScheduleConstraints.

      (* First, we consider constraints related to execution. *)
      Section Execution.

        (* We say that a scheduler is work-conserving iff whenever a job j
           is backlogged, the processor is always busy with another job. *)
        Definition work_conserving :=
          forall j t,
            arrives_in arr_seq j ->
            job_backlogged_at j t ->
            exists j_other, job_scheduled_at j_other t.

      End Execution.

      (* Next, we consider constraints related to FP policies. *)
      Section FP.

        (* We say that an FP policy...*)
        Variable higher_eq_priority: FP_policy Task.

        (* ... is respected by the scheduler iff at any time t, a scheduled job
           has higher (or same) priority than (as) any backlogged job. *)
        Definition respects_FP_policy :=
          forall j j_hp t,
            arrives_in arr_seq j ->
            job_backlogged_at j t ->
            job_scheduled_at j_hp t ->
            higher_eq_priority (job_task j_hp) (job_task j).

      End FP.

      (* Next, we consider constraints related to JLFP policies. *)
      Section JLFP.

        (* We say that a JLFP policy ...*)
        Variable higher_eq_priority: JLFP_policy Job.

        (* ... is respected by the scheduler iff every scheduled job
           has higher (or same) priority than (as) any backlogged job. *)
        Definition respects_JLFP_policy :=
          forall j j_hp t,
            arrives_in arr_seq j ->
            job_backlogged_at j t ->
            job_scheduled_at j_hp t ->
            higher_eq_priority j_hp j.

      End JLFP.

      (* Next, we consider constraints related to JLDP policies. *)
      Section JLDP.

        (* We say that a JLDP policy ...*)
        Variable higher_eq_priority: JLDP_policy Job.

        (* ... is respected by the scheduler iff at any time t, a scheduled job
           has higher (or same) priority than (as) any backlogged job. *)
        Definition respects_JLDP_policy :=
          forall j j_hp t,
            arrives_in arr_seq j ->
            job_backlogged_at j t ->
            job_scheduled_at j_hp t ->
            higher_eq_priority t j_hp j.

      End JLDP.

    End ScheduleConstraints.

  End Definitions.

End PlatformWithSuspensions.


Require Import Parametricity.

Require Import List.
Import ListNotations.

Definition bind_option {A B} (f : A -> option B) (x : option A) :
  option B :=
  match x with
   | Some x => f x
   | None => None
  end.

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

Definition bind_option2 {A B C} (f : A -> B -> option C)
   (x : option (A * B)) : option C :=
  do yz <- x in let (y, z) := yz : A * B in f y z.

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

Require Import List.

Record Queue := {
  t :> Type;
  empty : t;
  push : nat -> t -> t;
  pop : t -> option (nat * t)
}.

Definition program (Q : Queue) (n : nat) : option nat :=
   (* q := 0::1::2::...::n *)
   let q : Q :=
     nat_rect (fun _ => Q) Q.(empty) Q.(push) (S n)
   in
   let q : option Q := nat_rect (fun _ => option Q) (Some q)
     (fun _ (q : option Q) =>
         do q <- q in
         do x, q <- Q.(pop) q in
         do y, q <- Q.(pop) q in
         Some (Q.(push) (x + y) q)) n
   in
   do q <- q in
   option_map fst (Q.(pop) q).

Definition ListQueue := {|
  t := list nat;
  empty := nil;
  push := @cons nat;
  pop := fun l =>
    match rev l with
      | nil => None
      | hd :: tl => Some (hd, rev tl) end
|}.

Definition DListQueue := {|
  t := list nat * list nat;
  empty := (nil, nil);
  push x l :=
    let (back, front) := l in
    (cons x back,front);
  pop := fun l =>
    let (back, front) := l in
    match front with
      | [] =>
         match rev back with
            | [] => None
            | hd :: tl => Some (hd, (nil, tl))
         end
      | hd :: tl => Some (hd, (back, tl))
    end
|}.

Parametricity Recursive nat.

Print nat_R.

Lemma nat_R_equal :
  forall x y, nat_R x y -> x = y.
intros x y H; induction H; subst; trivial.
Defined.
Lemma equal_nat_R :
  forall x y, x = y -> nat_R x y.
intros x y H; subst.
induction y; constructor; trivial.
Defined.

Parametricity Recursive option.

Lemma option_nat_R_equal :
  forall x y, option_R nat nat nat_R x y -> x = y.
intros x1 x2 H; destruct H as [x1 x2 x_R | ].
rewrite (nat_R_equal _ _ x_R); reflexivity.
reflexivity.
Defined.
Lemma equal_option_nat_R :
  forall x y, x = y -> option_R nat nat nat_R x y.
intros x y H; subst.
destruct y; constructor; apply equal_nat_R; reflexivity.
Defined.

Parametricity Recursive prod.
Parametricity Recursive Queue.

Print Queue_R.
Check Queue_R.

Notation Bisimilar := Queue_R.

Print Queue_R.

Definition R (l1 : list nat) (l2 : list nat * list nat) :=
 let (back, front) := l2 in
  l1 = back ++ rev front.

Lemma rev_app :
  forall A (l1 l2 : list A),
    rev (l1 ++ l2) = rev l2 ++ rev l1.
induction l1.
intro; symmetry; apply app_nil_r.
intro; simpl; rewrite IHl1; rewrite app_ass.
reflexivity.
Defined.

Lemma rev_list_rect A  :
      forall P:list A-> Type,
	P [] ->
	(forall (a:A) (l:list A), P (rev l) -> P (rev (a :: l))) ->
	forall l:list A, P (rev l).
Proof.
  induction l; auto.
Defined.

Theorem rev_rect A :
  forall P:list A -> Type,
	P [] ->
	(forall (x:A) (l:list A), P l -> P (l ++ [x])) ->
  forall l:list A, P l.
Proof.
  intros.
  generalize (rev_involutive l).
  intros E; rewrite <- E.
  apply (rev_list_rect _ P).
  auto.

  simpl.
  intros.
  apply (X0 a (rev l0)).
  auto.
Defined.

Lemma bisim_list_dlist : Bisimilar ListQueue DListQueue.
apply (Queue_R_Build_Queue_R _ _ R).

* reflexivity.

* intros n1 n2 n_R.
pose (nat_R_equal _ _ n_R) as H.
destruct H. clear n_R.
intros l [back front].
unfold R.
simpl.
intro; subst.
simpl.
reflexivity.

* intros l  [back front].
generalize l. clear l.
unfold R; fold R.
pattern back.

apply rev_rect.

intros l H; subst.
rewrite rev_app.
simpl.
rewrite app_nil_r.
rewrite rev_involutive.

destruct front.
constructor.
repeat constructor.
apply equal_nat_R; reflexivity.

clear back; intros hd back IHR l H.
subst.
rewrite rev_app.
rewrite rev_involutive.
rewrite rev_app.
simpl.
destruct front.
simpl.
repeat constructor.
apply equal_nat_R; reflexivity.
simpl.
repeat constructor.
apply equal_nat_R; reflexivity.
unfold R.
rewrite rev_app.
simpl.
rewrite rev_involutive.
reflexivity.
Defined.

Print program.
Check program.
Parametricity Recursive program.
Check program_R.

Lemma program_independent :
 forall n,
  program ListQueue n = program DListQueue n.
intro n.
apply option_nat_R_equal.
apply program_R.
apply bisim_list_dlist.
apply equal_nat_R.
reflexivity.
Defined.
Print program.
Print program_R.


(*  Replaced some proofs with Stdlib's *)

Require Import Coq.Lists.List.

Section List_Remove.

Variable A : Set.
Hypothesis Aeq_dec : forall a b : A, {a = b} + {a <> b}.

Lemma in_remove_neq:
 forall (a b : A) (l : list A), In a (List.remove Aeq_dec b l) -> a <> b.
Proof.
  intros a b l H; now destruct (in_remove _ _ _ _ H).
Qed.

End List_Remove.

#[deprecated(note="use ListExt.in_remove_neq instead")]
 Notation In_list_remove2 := in_remove_neq (only parsing).


(* typing derivations carry their terms with them *)
Inductive type : nat -> Type :=
| type_top : type 0
| type_var : forall n, type (S n)
| type_abs : forall n, type (S n) -> type n
| type_fix : forall n, type (S n) -> type n
| type_arrow : forall n, type n -> type n -> type n
| type_prod : forall n, type n -> type n -> type n
| type_sum : forall n, type n -> type n -> type n
| type_weak : forall n, type n -> type (S n).

Implicit Arguments type_abs [n].
Implicit Arguments type_fix [n].
Implicit Arguments type_arrow [n].
Implicit Arguments type_prod [n].
Implicit Arguments type_sum [n].
Implicit Arguments type_weak [n].
Coercion type_var : nat >-> type.
Infix "-->" := type_arrow (at level 55, right associativity).
Infix "**" := type_prod (at level 50).
Infix "-|-" := type_sum (at level 55).
Notation "#/\ E" := (type_abs E) (at level 55).
Notation "#\ E" := (type_fix E) (at level 55).
Notation "^ E" := (type_weak E) (at level 45).

Require Import Arith.
Infix "===" := eq_nat_dec (at level 50).

Inductive type_eq : forall n n', type n -> type n' -> Prop :=
| type_eq_top : type_eq 0 0 type_top type_top
| type_eq_var : forall n n',
  n = n' ->
  type_eq (S n) (S n') (type_var n) (type_var n')
| type_eq_abs : forall n n' T1 T2,
  type_eq (S n) (S n') T1 T2 ->
  type_eq n n' (type_abs T1) (type_abs T2)
| type_eq_fix : forall n n' T1 T2,
  type_eq (S n) (S n') T1 T2 ->
  type_eq n n' (type_fix T1) (type_fix T2)
| type_eq_arrow : forall n n' T1 T1' T2 T2',
  type_eq n n' T1 T1' ->
  type_eq n n' T2 T2' ->
  type_eq n n' (type_arrow T1 T2) (type_arrow T1' T2')
| type_eq_prod : forall n n' T1 T1' T2 T2',
  type_eq n n' T1 T1' ->
  type_eq n n' T2 T2' ->
  type_eq n n' (type_prod T1 T2) (type_prod T1' T2')
| type_eq_sum : forall n n' T1 T1' T2 T2',
  type_eq n n' T1 T1' ->
  type_eq n n' T2 T2' ->
  type_eq n n' (type_sum T1 T2) (type_sum T1' T2')
| type_eq_weak : forall n n' T1 T2,
  type_eq n n' T1 T2 ->
  type_eq (S n) (S n') (type_weak T1) (type_weak T2).
Implicit Arguments type_eq [n n'].
Hint Constructors type_eq.

Theorem type_eq_impl_context : forall n n' (A:type n) (B:type n'), type_eq A B -> n = n'.
Proof.
  intros n n' A B. induction 1 ; subst ; auto.
Defined.

Require Import JMeq.

Ltac jmeq_solve :=
  match goal with
    | H : JMeq ?T1 ?T2 |- _ => apply JMeq_eq in H ; subst ; auto ; try jmeq_solve
    | H : ?x = ?x |- _ => idtac
    | H1 : type (S ?n), H2 : type (S ?n0) |- _ => assert (n = n0) ; [ eapply type_eq_impl_context ; eauto | subst ] ; jmeq_solve
    | H1 : type ?n, H2 : type ?n0 |- _ => assert (n = n0) ; [ eapply type_eq_impl_context ; eauto | subst ] ; jmeq_solve
  end.

Lemma type_eq_jmeq : forall n n' (T1 : type n) (T2 : type n'), type_eq T1 T2 -> JMeq T1 T2.
Proof.
  induction 1 ; subst ; auto with arith ; try jmeq_solve.
Defined.
Implicit Arguments type_eq_jmeq [n n'].

Lemma type_eq_eq : forall n (T1 T2: type n), type_eq T1 T2 -> T1 = T2.
Proof.
  intros. apply type_eq_jmeq in H. apply JMeq_eq in H. auto.
Defined.
Implicit Arguments type_eq_eq [n].
Hint Resolve type_eq_eq.

Lemma type_eq_refl : forall n (T : type n), type_eq T T.
Proof.
  induction T ; auto.
Defined.

Ltac type_eq_sync_ns :=
  match goal with
    | H : type_eq ?P ?Q |- _ => assert (type_eq P Q) ; auto ; apply type_eq_impl_context in H ; subst
  end.

Ltac type_eq_conv :=
  match goal with
    | H : type_eq ?P ?Q |- _ => apply type_eq_eq in H ; rewrite H in *
  end.

Ltac type_eq_dep :=
  match goal with
    | H : existT ?P ?n ?T3 = existT ?P ?n ?T1 |- type_eq ?T1 ?T2 =>
      change (match existT P n T1 with
                | existT pf t => type_eq t T2
              end) ; rewrite <- H
    | H : existT ?P ?n ?T3 = existT ?P ?n ?T2 |- type_eq ?T1 ?T2 =>
      change (match existT P n T2 with
                | existT pf t => type_eq T1 t
              end) ; rewrite <- H
  end.

Ltac type_eq_dec_case :=
  intros ; right ; unfold not in *; intro Heq ;
    (match goal with
       | H : _ -> False |- False => apply H
     end) ; type_eq_sync_ns ;
    (match goal with
       | H : type_eq ?P ?Q |- _ => inversion H ; subst ; clear H
     end) ; type_eq_conv ; repeat progress type_eq_dep ; try (apply type_eq_refl) ; auto.

Ltac type_eq_dec_solver :=
  try (intros ; left ; auto ; fail) ;
    try (intros ; right ; unfold not ; intros Heq ; inversion Heq ; fail).

Lemma type_eq_dec : forall n n' (T1 : type n) (T2 : type n'), {type_eq T1 T2} + {~ type_eq T1 T2}.
Proof.
  refine (fix type_eq_dec n n' (T1 : type n) (T2 : type n') {struct T1} := _).
  destruct T1 ; destruct T2 ; type_eq_dec_solver.
  (* var *)
  case (n === n0). intros Heq. rewrite Heq. left ; auto.
  intros. right. unfold not. intros. inversion H. subst. apply type_eq_eq in H. congruence.
  (* abs *)
  case (type_eq_dec (S n) (S n0) T1 T2) ; type_eq_dec_solver ; type_eq_dec_case.
  (* fix *)
  case (type_eq_dec (S n) (S n0) T1 T2) ; type_eq_dec_solver ; type_eq_dec_case.
  (* arrow *)
  case (type_eq_dec n n0 T1_1 T2_1) ; case (type_eq_dec n n0 T1_2 T2_2) ; type_eq_dec_solver ; type_eq_dec_case.
  (* prod *)
  case (type_eq_dec n n0 T1_1 T2_1) ; case (type_eq_dec n n0 T1_2 T2_2) ; type_eq_dec_solver ; type_eq_dec_case.
  (* sum *)
  case (type_eq_dec n n0 T1_1 T2_1) ; case (type_eq_dec n n0 T1_2 T2_2) ; type_eq_dec_solver ; type_eq_dec_case.
  (* weak *)
  case (type_eq_dec n n0 T1 T2) ; type_eq_dec_solver. intros.
  right. unfold not in *. intros. apply n1. inversion H. subst. repeat progress type_eq_dep. auto.
Defined.
Implicit Arguments type_eq_dec [n n'].

Lemma eq_type_dec : forall n (T1 T2 : type n), {T1 = T2} + {~ T1 = T2}.
Proof.
  intros ; case (type_eq_dec T1 T2) ; intros ; type_eq_dec_solver.
  intros. unfold not in *. right. intros Heq. apply n0. rewrite Heq. apply type_eq_refl.
Defined.

Lemma le_n_O_eq_transparent : forall n, n <= 0 -> 0 = n.
Proof.
  induction n; auto with arith.
Defined.

Definition weaken_type : forall n n', n' <= n -> type n' -> type n.
Proof.
  induction n. intros.
  apply le_n_O_eq_transparent in H. subst. auto.
  intros. case_eq (le_le_S_dec n' n). intros.
  apply type_weak ; apply (IHn n') ; auto.
  intros. cut (n' = (S n)). intros. subst. auto.
  apply le_antisym ; auto.
Defined.

Theorem le_S_n_transparent : forall n m, S n <= S m -> n <= m.
Proof.
  induction m; auto with arith.
Defined.

Lemma le_Sn_n_absurd : forall k, ~ S k <= k.
Proof.
  induction k. unfold not.  intros. inversion H.
  unfold not. intros. apply le_S_n_transparent in H. auto.
Defined.

Definition open_type_rec : forall (k n l:nat), n <= k -> l = (S k) -> type n -> type l -> type k.
Proof.
  refine
    (fix open_type_rec (k n l:nat) (H: n <= k) (Hs: l = (S k)) (u:type n) (t : type l) {struct t}: type k :=
      (match t in type m return (m = l -> type k) with
         | type_top =>
           (fun _ => weaken_type k 0 _ type_top)
         | type_var n' =>
           (fun (H0:(S n')=l) => _)
         | type_abs n' T =>
           (fun (H0:n'=l) => type_abs _)
         | type_fix n' T =>
           (fun (H0:n'=l) => type_fix _)
         | type_arrow n' T1 T2 =>
           (fun (H0:n'=l) => type_arrow (open_type_rec k n _ _ _ u T1) (open_type_rec k n _ _ _ u T2))
         | type_prod n' T1 T2 =>
           (fun (H0:n'=l) => type_prod (open_type_rec k n _ _ _ u T1) (open_type_rec k n _ _ _ u T2))
         | type_sum n' T1 T2 =>
           (fun (H0:n'=l) => type_sum (open_type_rec k n _ _ _ u T1) (open_type_rec k n _ _ _ u T2))
         | type_weak n' T =>
           (fun (H0:(S n')=l) =>
             match le_lt_eq_dec n' k _ with
               | left Hl => (open_type_rec k n _ _ _ u T)
               | right Hr => _
             end)
       end) (refl_equal l)).
  (* top, we never reach here since the type isn't even correct to descend... *)
  subst. inversion _H.
  (* var *)
  apply (weaken_type k n H). exact u.
  (* abs *)
  cut (n <= n'). intros H1.
  rewrite <- H0 in *. rewrite <- Hs. apply (open_type_rec n' n (S n')). auto. auto. auto. auto. subst.
  apply le_S. auto.
  (* fix *)
  cut (n <= n'). intros H1.
  rewrite <- H0 in *. rewrite <- Hs. apply (open_type_rec n' n (S n')). auto. auto. auto. auto. subst.
  apply le_S. auto.
  (* arrow *)
  auto. subst. auto. auto. subst. auto.
  (* prod *)
  auto. subst. auto. auto. subst. auto.
  (* sum *)
  auto. subst. auto. auto. subst. auto.
  (* weak *)
  subst. inversion H0. auto. unfold lt in Hl. subst. auto. unfold lt in Hl. rewrite H0 in Hl. rewrite Hs in Hl.
  apply le_Sn_n_absurd in Hl. inversion Hl. subst. auto.
Defined.
Extraction open_type_rec.
Print open_type_rec.

Definition open_type : forall (n:nat), type (S n) -> type n -> type n.
Proof.
  intros. apply (open_type_rec n n (S n)) ; auto.
Defined.
Implicit Arguments open_type [n].

Definition id := (#/\ 0).

(* sanity checks *)
Eval compute in open_type (#/\ (#/\ (^(^0 --> 1) --> 2))) id.

Eval compute in open_type (#/\((^0 --> 1) --> ^(^id))) id.

Eval compute in open_type ((0 --> ^(id)) --> ^(id)) id.

Require Import List.

Definition typ := type 0.
Definition context := list typ.

Inductive term : context -> typ -> Type :=
| unit : term nil type_top
| var : forall G T, term G T
| abs : forall GR G T1, GR=T1::G -> term G T1
| app : forall G T1 T2, term G (T1-->T2) -> term G T1 -> term G T2
(* type application *)
| apt : forall G T1 T2, term G (#/\ T1) -> term G T2 -> term G (open_type T1 T2)
(* algebraic *)
| prod : forall G T1 T2, term G T1 -> term G T2 -> term G (T1**T2)
(* Not sure if we want this instead of fst/snd
| splt : forall G T1 T2 T3, term n G (T1**T2) -> term n G (T1 --> (T2 --> T3)) -> term n G T3
*)
| fst : forall G T1 T2, term G (T1**T2) -> term G T1
| snd : forall G T1 T2, term G (T1**T2) -> term G T2
| inl : forall G T1 T2, term G T1 -> term G (T1 -|- T2)
| inr : forall G T1 T2, term G T2 -> term G (T1 -|- T2)
| cas : forall G T1 T2 T3, term G (T1-|-T2) -> term G (T1 --> T3) -> term G (T2 --> T3) -> term G T3
(* rec types *)
| unr : forall G T, term G (#\ T) -> term G (open_type T (#\ T))
| rol : forall G T, term G (open_type T (#\ T)) -> term G (#\ T)
(* structural *)
| weak : forall G T T1, term G T -> term (T1::G) T.
Notation "G |- x ;; T" := (term G x T) (at level 55).

Definition Suffix (A:Type) (m l : list A) := {l' | l = l'++m}.
Implicit Arguments Suffix [A].

Definition context_eq_dec (n:nat) G G' := list_eq_dec (eq_type_dec n) G G'.
Implicit Arguments context_eq_dec [n].

Definition weaken_context : forall G G' T, Suffix G' G -> term G' T -> term G T.
Proof.
  refine
    (fix weaken_context (G G' : context) (T:typ) (H:Suffix G' G) (t : term G' T) : term G T :=
      match context_eq_dec G' G with
        | left Hl => _
        | right Hr =>
          (match G as x return (G = x -> term G T) with
             | nil => (fun (Heq : G = nil) => _)
             | cons ht Gtail =>
               (fun (Heq : G = cons ht Gtail) =>
                 let H := weaken_context Gtail G' T _ t in
                   _)
           end) (refl_equal G)
      end). subst. auto.
  intros. subst. inversion H. apply sym_eq in H0. apply app_eq_nil in H0. inversion H0. subst. auto.
  inversion H. rewrite H0 in Heq.
  destruct x. simpl in H0. congruence. unfold Suffix.
  inversion Heq. exists x. auto. auto.
  apply (weak Gtail T ht) in H0. subst. auto.
Defined.

Definition open_term_rec : forall (k:nat) G G' G'' T T', length G <= k -> Suffix G' G -> G' = (T'::G'') -> term G T' -> term G' T -> term G'' T.
Proof.
  refine
    (fix open_term_rec (k:nat) (G G' G'' : context) (T T':typ)
      (Hl: length G <= k) (Hs: Suffix G' G) (H0: G' = (T'::G'')) (u: term G T') (t:term G' T) {struct t}
      : term G'' T :=
      (match t in term G'0 T0 return (G'0 = G' -> term G'' T) with
         | unit => _
         | var G T => _
         | abs GR G H T => _
         | app G T1 T2 t1 t2 => _
         | apt G T1 T2 t1 t2 => _
         | prod G T1 T2 t1 t2 => _
         | fst G T1 T2 t => _
         | snd G T1 T2 t => _
         | inl G T1 T2 t => _
         | inr G T1 T2 t => _
         | cas G T1 T2 T3 s f g => _
         | unr G T t => _
         | rol G T t => _
         | weak G T T1 t => _
       end) (refl_equal G')).
  (* unit *)
  intros. subst. inversion H.
  (* var *)
  intros. subst. eapply (weaken_context G'' G'). unfold Suffix. exists

Definition open_term_rec : forall (k n l:nat), n <= k -> l = (S k) -> type n -> type l -> type k.

Definition open_type_rec : forall (k n l:nat), n <= k -> l = (S k) -> type n -> type l -> type k.


From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import eqtype ssrnat order seq path.
From ipcssr Require Import prelude.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import Order.POrderTheory.
Import Order.TotalTheory.
Open Scope order_scope.

Module Map.
Structure Map (K : eqType) (V : Type) : Type :=
  make {tp :> Type;
        empty : tp;
        update : K -> (V -> V) -> V -> tp -> tp * option V;
        delete : K -> tp -> tp * option V;
        lookup : tp -> K -> option V;

        invar : tp -> bool;

        _ : invar empty;
        _ : lookup empty =1 fun => None;

        _ : forall k f v s, invar s -> invar (update k f v s).1;
        _ : forall k f v s, invar s ->
            let tv := update k f v s in
            (lookup tv.1 =1 [eta (lookup s) with k |->
                              oapp (Some \o f) (Some v) (lookup s k)])
            *
            (tv.2 = lookup s k);

        _ : forall k s, invar s -> invar (delete k s).1;
        _ : forall k s, invar s ->
            let tv := delete k s in
            (lookup tv.1 =1 [eta (lookup s) with k |-> None])
            *
            (tv.2 = lookup s k)
        }.
End Map.

Section Cmp.
Context {disp : unit} {T : orderType disp}.

Variant cmp_val := LT | EQ | GT.

Definition cmp (x y : T) : cmp_val :=
  if x < y then LT else if x == y then EQ else GT.

Lemma cmpxx x : cmp x x = EQ.
Proof. by rewrite /cmp eqxx ltxx. Qed.

Variant cmp_spec (x y : T) : cmp_val -> cmp_val -> bool -> bool -> bool -> bool -> Set :=
  | CmpLt of x < y : cmp_spec x y LT GT true  false false false
  | CmpEq of x = y : cmp_spec x y EQ EQ false true  true  false
  | CmpGt of x > y : cmp_spec x y GT LT false false false true.

Lemma cmpE (x y : T) : cmp_spec x y (cmp x y) (cmp y x) (x < y) (x == y) (y == x) (y < x).
Proof. by rewrite /cmp; case: ltgtP=>H; constructor. Qed.

End Cmp.

Section KVList.
Context {disp : unit} {K : orderType disp} {V : Type}.

Fixpoint find_list (xs : seq (K*V)) (k : K) : option V :=
  if xs is (k0,v)::xs' then
    match cmp k k0 with
    | LT => None
    | EQ => Some v
    | GT => find_list xs' k
    end
  else None.

Fixpoint ins_list (k : K) (f : V -> V) (v : V) (xs : seq (K*V)) : seq (K*V) * option V :=
  if xs is (k0,v0)::xs' then
    match cmp k k0 with
    | LT => ((k,v) :: (k0,v0) :: xs', None)
    | EQ => ((k,f v0) :: xs', Some v0)
    | GT => let '(xs1, ov) := ins_list k f v xs' in
            ((k0,v0) :: xs1, ov)
    end
  else ([::(k,v)], None).

Fixpoint del_list (k : K) (xs : seq (K*V)) : seq (K*V) * option V :=
  if xs is (k0,v0) :: xs' then
    match cmp k k0 with
    | LT => ((k0,v0) :: xs', None)
    | EQ => (xs', Some v0)
    | GT => let '(xs1, ov) := del_list k xs' in
            ((k0,v0) :: xs1, ov)
    end
  else ([::], None).

Definition keys : seq (K*V) -> seq K := map fst.
Definition values : seq (K*V) -> seq V := map snd.

Lemma findlist_empty : find_list [::] =1 (fun=> None).
Proof. by []. Qed.

Lemma findlist_path k xs : path <%O k (keys xs) -> find_list xs k = None.
Proof.
rewrite /keys; case: xs=>//=; case=>k0 v0 xs /=; case/andP=>H1 _.
by case: cmpE H1.
Qed.

Lemma findlist_sorted_cat_cons_cat (xs ys : seq (K*V)) k k' v' :
  sorted <%O (keys (xs ++ (k',v') :: ys)) ->
  find_list (xs ++ (k',v') :: ys) k = if k < k'
                                       then find_list xs k
                                       else find_list ((k',v') :: ys) k.
Proof.
rewrite /keys; elim: xs=>/=; first by move=>H; case: cmpE.
case=>k0 v0 xs /= + H; rewrite map_cat /= in H.
move: (H); move/(order_path_min lt_trans).
rewrite map_cat all_cat /= =>/and3P [Hxs Hya Hys].
case: cmpE=>Hk.
- case: cmpE (lt_trans Hya Hk)=>// Hk0 _; apply.
  by move/path_sorted: H.
- rewrite -Hk; case: cmpE Hya=>// Hya _; apply.
  by move/path_sorted: H.
case: cmpE=>// H0; apply.
by move/path_sorted: H.
Qed.

Lemma inorder_ins_list k f v xs :
  sorted <%O (keys xs) ->
  perm_eq (keys (ins_list k f v xs).1)
          (if k \in keys xs then keys xs else k :: keys xs).
Proof.
elim: xs=>//=[[k0 v0]] xs IH /= Hp.
case E: (ins_list k f v xs)=>[xs1 ov]; rewrite E /= in IH.
rewrite inE; case: cmpE=>/= Hk.
- move/path_sorted: Hp=>/IH; case: ifP=>H; first by rewrite perm_cons.
  by move=>H1; rewrite perm_sym -cat1s -(cat1s k0) perm_catCA /= perm_cons perm_sym.
- by rewrite Hk.
case: ifP=>//; move: (order_path_min lt_trans Hp)=>/allP/[apply].
by rewrite ltNge le_eqVlt Hk orbT.
Qed.

Lemma inslist_sorted_cat_cons_cat (xs ys : seq (K*V)) k f v k' v' :
  sorted <%O (keys (xs ++ [::(k',v')])) ->
  ins_list k f v (xs ++ (k',v') :: ys) =
    if k < k'
      then
        let '(xs1, ov) := ins_list k f v xs in
        (xs1 ++ (k',v') :: ys, ov)
      else
        let '(ys1, ov) := ins_list k f v ((k',v') :: ys) in
        (xs ++ ys1, ov).
Proof.
rewrite /keys; elim: xs=>/=.
- move=>_; case: (cmpE k k')=>// Hk.
  by case: (ins_list k f v ys).
move=>[k0 v0] /= xs + H; rewrite map_cat /= in H.
move: (H); move/(order_path_min lt_trans).
rewrite map_cat all_cat /= andbT =>/andP [Hxs Hya].
case: (cmpE k k')=>H'.
- case E: (ins_list k f v (xs ++ (k', v') :: ys))=>[xs1 ov] /=.
  case E0: (ins_list k f v xs)=>[xs0 ov0] /=.
  case: (cmpE k k0)=>//= H0.
  by move/path_sorted: H=>/[swap]/[apply]; case=>->->.
- case E: (ins_list k' f v (xs ++ (k', v') :: ys))=>[xs1 ov] /=.
  rewrite {k}H'; case: (cmpE k' k0) Hya=>// Hya _ -> //.
  by apply: (path_sorted H).
case E: (ins_list k f v (xs ++ (k', v') :: ys))=>[ys1 ov] /=.
case E0: (ins_list k f v ys)=>[ys0 ov0] /=.
case: (cmpE k k0) (lt_trans Hya H')=>// H0 _.
by move/path_sorted: H=>/[swap]/[apply]; case=>->->.
Qed.

Lemma del_nop k xs :
  path <%O k (keys xs) -> del_list k xs = (xs, None).
Proof.
elim: xs=>//= [[k0 v0]] xs IH /= /andP [H1 H2].
by case: cmpE H1.
Qed.

Lemma inorder_del_list k xs :
  sorted <%O (keys xs) ->
  perm_eq (keys (del_list k xs).1)
          (filter (predC1 k) (keys xs)).
Proof.
rewrite /keys; elim: xs=>// [[k0 v0]] /= xs IH Hp.
move/path_sorted: (Hp)=>/IH /= {IH}H.
case Ed: (del_list k xs)=>[xs1 ov]; rewrite Ed /= in H.
case: cmpE=>/=.
- move=>Hk; rewrite perm_cons.
  suff : all (predC1 k) (keys xs) by move/all_filterP->.
  apply (sub_all (a1:=> k)).
  - by move=>z /=; rewrite lt_neqAle eq_sym; case/andP.
  by apply/(path_all lt_trans)/(path_le lt_trans)/Hp.
- move=>E; rewrite -{k0}E in Hp.
  suff : all (predC1 k) (keys xs) by move/all_filterP->.
  apply (sub_all (a1:=> k)).
  - by move=>z /=; rewrite lt_neqAle eq_sym; case/andP.
  by apply/(path_all lt_trans).
by move=>Hk; rewrite perm_cons.
Qed.

Lemma dellist_sorted_cat_cons_cat (xs ys : seq (K*V)) k k' v' :
  sorted <%O (keys (xs ++ (k',v') :: ys)) ->
  del_list k (xs ++ (k',v') :: ys) =
    if k < k'
      then
        let '(xs1, ov) := del_list k xs in
        (xs1 ++ (k',v') :: ys, ov)
      else
        let '(ys1, ov) := del_list k ((k',v') :: ys) in
        (xs ++ ys1, ov).
Proof.
rewrite /keys; elim: xs=>/=.
- move=>H; case: cmpE=>// Hk.
  by case E: (del_list k ys).
case=>k0 v0 xs /= + H; rewrite map_cat /= in H.
move: (H); move/(order_path_min lt_trans).
rewrite map_cat all_cat /= =>/and3P [Hxs Hya Hys].
case: (cmpE k k')=>H'.
- case E: (del_list k (xs ++ (k', v') :: ys))=>[xs1 ov] /=.
  case E0: (del_list k xs)=>[xs0 ov0] /=.
  case: (cmpE k k0)=>//= H0.
  by move/path_sorted: H=>/[swap]/[apply]; case=>->->.
- case E: (del_list k' (xs ++ (k', v') :: ys))=>[xs1 ov] /=.
  rewrite {k}H'; case: (cmpE k' k0) Hya=>// Hya _ -> //.
  by apply: (path_sorted H).
case E: (del_list k (xs ++ (k', v') :: ys))=>[ys1 ov] /=.
case E0: (del_list k ys)=>[ys0 ov0] /=.
case: (cmpE k k0) (lt_trans Hya H')=>// H0 _.
by move/path_sorted: H=>/[swap]/[apply]; case=>->->.
Qed.

Definition kvlist xs := sorted <%O (keys xs) && uniq (keys xs).

Lemma del_list_keys k xs :
  kvlist xs ->
  subseq (keys (del_list k xs).1) (keys xs).
Proof.
rewrite /kvlist; elim: xs=>// [[k0 v0]] /= xs IH.
case/and3P=>Hp N U.
case E0: (del_list k xs)=>[xs0 ov0] /=; rewrite E0 /= in IH.
move/path_sorted: (Hp)=>Hs; rewrite Hs U in IH; move: (IH erefl)=>{}IH.
case: cmpE=>/= Hk.
- by rewrite eqxx.
- rewrite {k0}Hk in Hp N *.
  case Exs: (keys xs) IH=>[|kx kxs] //; case: eqP=>[E|] //.
  by move: N; rewrite -E Exs inE eqxx.
by rewrite eqxx.
Qed.

Lemma kvlist_empty : kvlist [::].
Proof. by []. Qed.

Lemma kvlist_ins_list k f v xs :
  kvlist xs -> kvlist (ins_list k f v xs).1.
Proof.
rewrite /kvlist; case/andP; elim: xs=>//=[[k0 v0]] xs /= IH Hp /andP [N0 U].
case: cmpE=>Hk /=; first last.
- rewrite inE negb_or -!andbA; apply/and6P; split=>//; first by case: ltgtP Hk.
  by apply: (path_notin lt_trans)=>//; apply/(path_le lt_trans)/Hp.
- by rewrite -Hk Hp N0.
case E0: (ins_list k f v xs)=>[xs0 ov0] /=; rewrite E0 /= in IH.
move: Hp; rewrite !(path_sortedE lt_trans) -andbA.
case/andP=>H1 H2; case/andP: (IH H2 U)=>->-> /=; rewrite andbT.
have Hi := inorder_ins_list k f v H2; rewrite E0 /= in Hi.
apply/andP; split.
- by rewrite (perm_all _ Hi); case: ifP=>//= _; rewrite Hk.
rewrite (perm_mem Hi); case: ifP=>// _.
rewrite inE negb_or N0 andbT.
by case: ltgtP Hk.
Qed.

Lemma find_ins_list k f v xs :
  let sv := ins_list k f v xs in
  (find_list sv.1 =1 [eta (find_list xs) with k |->
                      oapp (Some \o f) (Some v) (find_list xs k)])
  * (sv.2 = find_list xs k).
Proof.
move; elim: xs=>/=; first by split=>// q /=; case: cmpE.
case=>k0 v0 xs.
case E0: (ins_list k f v xs)=>[xs0 ov0] /=.
case=>IH1 IH2; case: (cmpE k k0)=>Hk /=; split=>// q /=.
- by case: cmpE=>// Hq; case: cmpE (lt_trans Hq Hk).
- by rewrite Hk; case: cmpE.
case: (cmpE q k0)=>Hq0.
- by move: (lt_trans Hq0 Hk); rewrite lt_neqAle; case/andP=>/negbTE->.
by rewrite Hq0; move: Hk; rewrite lt_neqAle; case/andP=>/negbTE->.
by apply: IH1.
Qed.

Lemma kvlist_del_list k xs :
  kvlist xs -> kvlist (del_list k xs).1.
Proof.
rewrite /kvlist; case/andP.
elim: xs=>// [[k0 v0]] xs /=.
case E0: (del_list k xs)=>[xs0 ov0] /= IH /= Hp /andP [N0 U].
move/path_sorted: (Hp)=>H1; case/andP: (IH H1 U)=>{IH}H2 {}U1.
have S: subseq (keys xs0) (keys xs).
- by move: (@del_list_keys k xs); rewrite E0 /=; apply; apply/andP.
case: cmpE=>/= Hk; first last.
- by apply/and3P.
- by apply/andP.
apply/and3P; split=>//.
- by apply/(subseq_path lt_trans)/Hp.
by apply: contra N0; move/mem_subseq: S; apply.
Qed.

Lemma find_del_list k xs :
  kvlist xs ->
  let sv := del_list k xs in
  (find_list sv.1 =1 [eta find_list xs with k |-> None])
  * (sv.2 = find_list xs k).
Proof.
rewrite /kvlist /=; case/andP.
elim: xs=>//; first by move=>_ _; split=>// q /=; rewrite if_same.
case=>k0 v0 xs.
case E0: (del_list k xs)=>[xs0 ov0] /= IH /= /[dup] H /path_sorted H' /andP [N0 U].
move: (IH H' U)=>{IH}[IH1 IH2].
rewrite E0; case: (cmpE k k0)=>/= Hk; split=>// q /=.
- by case: eqP=>// ->; case: cmpE Hk.
- rewrite -Hk; case: cmpE=>//.
  - by move=><-; apply: findlist_path; rewrite Hk.
  move=>Hq; apply/findlist_path/(path_le lt_trans)/H.
  by rewrite -Hk.
move: (IH1 q)=>/= {}IH1.
case: cmpE=>// Hq.
- case: cmpE (lt_trans Hk Hq)=>// _ _; rewrite IH1.
  by move: Hq; rewrite lt_neqAle eq_sym; case/andP=>/negbTE->.
- rewrite -Hq in IH1 *; case: cmpE Hk=>// _ _.
  by rewrite IH1 eqxx.
case: cmpE=>// Hq0; rewrite IH1.
by move: Hq; rewrite lt_neqAle eq_sym; case/andP=>/negbTE->.
Qed.

Definition KVLMap :=
  Map.make kvlist_empty findlist_empty
           kvlist_ins_list (fun k f v s _ => find_ins_list k f v s)
           kvlist_del_list find_del_list.

End KVList.

Section KVListEqSeq.
Context {disp : unit} {K : orderType disp} {V : eqType}.

Lemma perm_flatten_values_cons k v (xs : seq (K * seq V)) :
  sorted <%O (keys xs) ->
  perm_eq (flatten (values (ins_list k (cons v) [::v] xs).1))
          (v :: flatten (values xs)).
Proof.
elim: xs=>//=[[k0 v0]] xs.
case E0: (ins_list k (cons v) [:: v] xs)=>[xs0 ov0] /= IH /= Hp.
case: cmpE=>Hk //=.
move/path_sorted: Hp=>/IH H1.
by rewrite perm_sym -cat1s perm_catCA /= perm_sym (perm_catl _ H1).
Qed.

Lemma perm_flatten_lookup_del k (xs : seq (K * seq V)) :
  sorted <%O (keys xs) ->
  perm_eq (flatten (values xs))
          (odflt [::] (find_list xs k) ++ flatten (values (del_list k xs).1)).
Proof.
elim: xs=>//=[[k0 v0]] xs.
case E0: (del_list k xs)=>[xs0 ov0] /= IH /= Hp.
case: cmpE=>Hk //=.
move/path_sorted: Hp=>/IH H1.
by rewrite perm_sym perm_catCA /= perm_sym (perm_catl _ H1).
Qed.

End KVListEqSeq.

Section AVLMap.
Context {disp : unit} {K : orderType disp} {V : Type}.

Variant bal := Lh | Bal | Rh.

Definition eqbal (b1 b2 : bal) :=
  match b1, b2 with
  | Lh, Lh => true
  | Bal, Bal => true
  | Rh, Rh => true
  | _, _ => false
  end.

Lemma eqbalP : Equality.axiom eqbal.
Proof. by move; case; case; constructor. Qed.

Canonical bal_eqMixin := EqMixin eqbalP.
Canonical bal_eqType := Eval hnf in EqType bal bal_eqMixin.

Inductive kvtree K V := Leaf | Node of (kvtree K V) & K & V & bal & (kvtree K V).

Definition leaf : kvtree K V := @Leaf K V.

Definition is_node (t : kvtree K V) :=
  if t is Node _ _ _ _ _ then true else false.

Fixpoint height (t : kvtree K V) : nat :=
  if t is Node l _ _ _ r
    then maxn (height l) (height r) + 1
  else 0.

Lemma heightE (t : kvtree K V) : reflect (t = leaf) (height t == 0).
Proof.
apply: (iffP idP); last by move=>->.
by case: t=>//= l k v b r; rewrite addn1 => /eqP.
Qed.

Definition bal_inv (x : nat) (b : bal) (y : nat) : bool :=
  match b with
  | Lh => x == y + 1
  | Bal => y == x
  | Rh => y == x + 1
  end.

Fixpoint avl (t : kvtree K V) : bool :=
  if t is Node l _ _ b r then
    [&& bal_inv (height l) b (height r), avl l & avl r]
    else true.

Lemma avl_ind (P : kvtree K V -> Prop) :
  P (Leaf K V) ->
  (forall l k v b r,
   bal_inv (height l) b (height r) ->
   avl l -> avl r ->
   P l -> P r ->
   P (Node l k v b r)) ->
  forall t, avl t -> P t.
Proof.
move=>Pl Pn; elim=>//= l IHl k v b r IHr /and3P [H Hal Har].
by apply: Pn=>//; [apply: IHl| apply: IHr].
Qed.

Arguments avl_ind [P].

Definition is_bal (t : kvtree K V) : bool :=
  if t is Node _ _ _ b _ then b == Bal else false.

Definition incr (t t' : kvtree K V) : bool :=
  ~~ is_node t || (is_bal t && ~~ is_bal t').

Lemma incr_refl t : incr t t = ~~ is_node t.
Proof. by rewrite /incr andbN orbF. Qed.

(* leaf cases are essentially placeholders for totality *)

Definition rot2 (a : kvtree K V) (xk : K) (xv : V)
                (b : kvtree K V) (zk : K) (zv : V)
                (c : kvtree K V) : kvtree K V :=
  match b with
  | Node b1 yk yv bb b2 =>
      let bb1 := if bb == Rh then Lh else Bal in
      let bb2 := if bb == Lh then Rh else Bal in
      Node (Node a xk xv bb1 b1) yk yv Bal (Node b2 zk zv bb2 c)
  | Leaf => Node a xk xv Bal (Node leaf zk zv Bal c)
  end.

Definition balL (ab : kvtree K V) (zk : K) (zv : V) (bb : bal) (c : kvtree K V) : kvtree K V :=
  match bb with
  | Lh  => match ab with
           | Node a xk xv Lh  b => Node a xk xv Bal (Node b zk zv Bal c)
           | Node a xk xv Bal b => Node a xk xv Rh  (Node b zk zv Lh  c)
           | Node a xk xv Rh  b => rot2 a xk xv b           zk zv c
           | Leaf               => Node leaf zk zv Bal c
           end
  | Bal => Node ab zk zv Lh  c
  | Rh  => Node ab zk zv Bal c
  end.

Definition balR (a : kvtree K V) (xk : K) (xv : V) (bb : bal) (bc : kvtree K V) : kvtree K V :=
  match bb with
  | Lh  => Node a xk xv Bal bc
  | Bal => Node a xk xv Rh  bc
  | Rh  => match bc with
           | Node b zk zv Lh  c => rot2 a xk xv b zk zv c
           | Node b zk zv Bal c => Node (Node a xk xv Rh  b) zk zv Lh  c
           | Node b zk zv Rh  c => Node (Node a xk xv Bal b) zk zv Bal c
           | Leaf               => Node a xk xv Bal leaf
           end
  end.

Fixpoint lookup (t : kvtree K V) (k : K) : option V :=
  if t is Node l k0 v0 _ r
    then match cmp k k0 with
           | LT => lookup l k
           | EQ => Some v0
           | GT => lookup r k
         end
  else None.

Lemma lookup_node t k : lookup t k -> is_node t.
Proof. by case: t. Qed.

Fixpoint upsert (k : K) (f : V -> V) (v : V) (t : kvtree K V) : kvtree K V * option V :=
  if t is Node l k0 v0 b r
    then match cmp k k0 with
         | LT => let '(l', ov) := upsert k f v l in
                 (if incr l l' then balL l' k0 v0 b r else Node l' k0 v0 b r, ov)
         | EQ => (Node l k (f v0) b r, Some v0)
         | GT => let '(r', ov) := upsert k f v r in
                 (if incr r r' then balR l k0 v0 b r' else Node l k0 v0 b r', ov)
         end
    else (Node leaf k v Bal leaf, None).

Lemma avl_upsert k f v t :
  avl t ->
  avl (upsert k f v t).1 &&
    (height (upsert k f v t).1 == height t + incr t (upsert k f v t).1).
Proof.
elim/avl_ind=>//= l k0 v0 b r E Hl Hr.
case El: (upsert k f v l)=>[l0 ovl] /=.
case Er: (upsert k f v r)=>[r0 ovr] /=.
move=>/andP [Hal Hhl] /andP [Har Hhr].
case: (cmp k k0)=>/=.
- (* k < k0 *)
  case: ifP=>/= Hi; last first.
  - case: b E=>/=; move/eqP: Hhl=>->/eqP->;
    by rewrite Hi !addn0 Hal Hr !eq_refl.
  (* incr l insert *)
  rewrite Hi /= in Hhl.
  case: b E=>/eqP E /=.
  - (* b = Lh *)
    case E': l0 Hi => [|li ki vi bi ri]/=.
    - (* insert = Leaf, impossible *)
      by rewrite E' addn1 in Hhl.
    (* insert = Node *)
    move: Hal Hhl; rewrite {}E' E /= maxn_addl addn0; case: bi=>/=.
    - (* bi = Lh *)
      case/and3P=>/eqP->->->/=.
      by rewrite maxn_addl !eqn_add2r=>/eqP<-; rewrite !maxnn Hr !eqxx.
    - (* bi = Bal *)
      case: {El Hl}l E; rewrite /incr /=; first by rewrite addn1.
      by move=>????; rewrite andbF.
    (* bi = Rh *)
    case/and3P; case: ri=>/=; first by rewrite addn1; move/eqP.
    move=>lri kri vri bri rri /=; rewrite eqn_add2r /bal_inv =>/eqP <- ->.
    case: bri=>/= /and3P [/eqP->->->] /=.
    - (* bri = Lh *)
      rewrite -!addn_maxl maxn_addl -addn_maxl maxn_addr !eqn_add2r =>/eqP <-.
      by rewrite maxn_addr !maxnn Hr !eq_refl.
    - (* bri = Bal *)
      by rewrite !maxnn maxn_addr !eqn_add2r=>/eqP<-; rewrite !maxnn Hr !eq_refl.
    (* bri = Rh *)
    by rewrite !maxn_addr maxn_addl !eqn_add2r=>/eqP<-; rewrite !maxnn Hr !eq_refl.
  - (* b = Bal *)
    by rewrite Hal Hr; move/eqP: Hhl=>->; rewrite E maxnn maxn_addl !eq_refl.
  (* b = Rh *)
  by rewrite Hal Hr; move/eqP: Hhl=>->; rewrite E maxnn addn0 maxn_addr !eq_refl.
- (* k == k0 *)
  by rewrite Hl Hr /= andbT; case: b E=>/= /eqP->; rewrite addn0 !eq_refl.
(* k > k0 *)
case: ifP=>/=; last first.
- move=>Hi; case: b E=>/=; move/eqP: Hhr=>->/eqP->;
  by rewrite Hi !addn0 Har Hl !eq_refl.
(* incr r insert *)
move=>Hi; case: b E=>/eqP E /=.
- (* b = Lh *)
  by rewrite Har Hl; move/eqP: Hhr=>->; rewrite Hi E maxnn addn0 maxn_addl !eq_refl.
- (* b = Bal *)
  by rewrite Har Hl; move/eqP: Hhr=>->; rewrite Hi E maxnn maxn_addr !eq_refl.
(* b = Rh *)
case E': r0=> [|li ki vi bi ri]/=.
- (* insert = Leaf, impossible *)
  move: Hhr; rewrite E' /=; case: (incr _ _)=>/= /eqP; first by rewrite addn1.
  by rewrite addn0 E addn1.
(* insert = Node *)
move: Hi Har Hhr; rewrite {}E' E=>/=.
rewrite maxn_addr addn0; case: bi=>/=.
- (* bi = Lh *)
  move=>->; case/and3P; case: li=>/=; first by rewrite addn1; move/eqP.
  move=>lli kli vli bli rli /=; rewrite eqn_add2r /bal_inv =>/eqP <- /[swap] ->.
  case: bli=>/= /and3P [/eqP->->->] /=.
  - (* bli = Lh *)
    by rewrite !maxn_addl maxn_addr -addn_maxl !eqn_add2r =>/eqP=><-; rewrite !maxnn Hl !eq_refl.
  - (* bli = Bal *)
    by rewrite !maxnn maxn_addl !eqn_add2r =>/eqP<-; rewrite !maxnn Hl !eq_refl.
  (* bli = Rh *)
  rewrite maxn_addl maxn_addr -!addn_maxl !eqn_add2r=>/eqP<-.
  by rewrite maxn_addl !maxnn Hl !eq_refl.
- (* bi = Bal, impossible *)
  case: {Er Hr}r E; rewrite /incr /=; first by rewrite addn1.
  by move=>????; rewrite andbF.
(* bi = Rh *)
move=>->; case/and3P=>/eqP->->->/=.
by rewrite !eqn_add2r maxn_addr eqn_add2r=>/eqP<-; rewrite !maxnn Hl !eq_refl.
Qed.

Definition decr (t t' : kvtree K V) : bool :=
  is_node t && (~~ is_node t' || ((~~ is_bal t) && is_bal t')).

Fixpoint split_max (l : kvtree K V) (k : K) (v : V) (ba : bal) (r : kvtree K V) : kvtree K V * K * V :=
  if r is Node lr kr vr br rr
    then let: (r', k', v') := split_max lr kr vr br rr in
         let t' := if decr r r' then balL l k v ba r' else Node l k v ba r' in
         (t', k', v')
    else (l, k, v).

Fixpoint delete (k : K) (t : kvtree K V) : kvtree K V * option V :=
  if t is Node l k0 v0 ba r
    then match cmp k k0 with
         | LT => let '(l',ov) := delete k l in
                 (if decr l l' then balR l' k0 v0 ba r else Node l' k0 v0 ba r, ov)
         | EQ => (if l is Node ll kl vl bl rl then
                   let: (l', k', v') := split_max ll kl vl bl rl in
                   if decr l l' then balR l' k' v' ba r
                                else Node l' k' v' ba r
                   else r, Some v0)
         | GT => let '(r',ov) := delete k r in
                 (if decr r r' then balL l k0 v0 ba r' else Node l k0 v0 ba r', ov)
         end
    else (leaf, None).

Lemma avl_balL_decr (l : kvtree K V) k v b r t :
  avl l -> avl r -> bal_inv (height l) b (height r + 1) ->
  avl (balL l k v b r) && (maxn (height l) (height r + 1) + 1 == height (balL l k v b r) +
                                                                 decr (Node l k v b t) (balL l k v b r)).
Proof.
move=>Hl Hr; case: b=>/=.
- case: l Hl=>/=; first by move=>_ /eqP; rewrite addn1.
  move=>ll kl vl bl rl /and3P [Hbl Hall Harl].
  rewrite eqn_add2r => /[dup] H' /eqP ->; rewrite -addn_maxl maxn_addl.
  case: bl Hbl=>/=; move: (H')=>/[swap]/eqP->.
  - rewrite maxn_addl !eqn_add2r=>/eqP->.
    by rewrite !maxnn !eq_refl Hall Harl Hr.
  - rewrite maxnn addn0 !eqn_add2r=>/eqP->.
    by rewrite -addn_maxl maxn_addl maxn_addr !eq_refl Hall Harl Hr.
  rewrite maxn_addr eqn_add2r =>/eqP H''.
  case: rl Harl H'=>/=.
  - by move=>_; rewrite maxn0 H'' -{1}(addn0 (height _)) eqn_add2l.
  move=>lrl krl vrl brl rrl=>/= /and3P [Hlrl -> ->].
  case: brl Hlrl=>/=.
  - move/eqP->; rewrite maxn_addl H''.
    case: (ltngtP (height r) (height rrl + 1 + 1))=>_;
      try by rewrite -{1}(addn0 (height _)) eqn_add2l.
    by rewrite eqn_add2r=>/eqP<-; rewrite maxn_addr !maxnn !eq_refl Hall Hr.
  - move/eqP->; rewrite maxnn H''.
    case: (ltngtP (height r) (height lrl + 1))=>_;
      try by rewrite -{1}(addn0 (height _)) eqn_add2l.
    by rewrite eqn_add2r=>/eqP->; rewrite !maxnn !eq_refl Hall Hr.
  move/eqP->; rewrite maxn_addr H''.
  case: (ltngtP (height r) (height lrl + 1 + 1))=>_;
    try by rewrite -{1}(addn0 (height _)) eqn_add2l.
  by rewrite eqn_add2r=>/eqP<-; rewrite maxn_addl !maxnn !eq_refl Hall Hr.
- by move/eqP <-; rewrite maxn_addl maxnn addn0 !eq_refl Hl Hr.
by rewrite eqn_add2r=>/eqP->; rewrite maxn_addr maxnn !eq_refl Hl Hr.
Qed.

Lemma avl_split_max (l : kvtree K V) k v b r t k' v' :
  split_max l k v b r = (t, k', v') ->
  bal_inv (height l) b (height r) -> avl l -> avl r ->
  avl t && (maxn (height l) (height r) + 1 == height t + decr (Node l k v b r) t).
Proof.
elim: r=>/= [|lr _ kr vr br rr IHr] in l k v b t *.
- case=><- _ _; rewrite maxn0 => H /[dup] E -> _ /=.
  case: b H=>/=; rewrite /decr /=.
  - rewrite add0n=>/[dup] H /eqP ->; rewrite eqn_add2l eq_sym eqb1.
    case: l E H=>//= l zk zv b r.
    rewrite -{2}(add0n 1%N) eqn_add2r; case: b=>//=; case/and3P=>/eqP->_ _.
    - by rewrite maxn_addl addn1=>/eqP.
    by rewrite maxn_addr addn1=>/eqP.
  - by rewrite eq_sym=>/heightE->.
  by rewrite addn1=>/eqP.
case Hsm: (split_max lr kr vr br rr)=>[[r' kr'] vr']; case=><- Ek Ev;
  rewrite {kr'}Ek {vr'}Ev in Hsm.
move=>H Hl /and3P [Hbr Hlr Hrr].
case/andP: (IHr _ _ _ _ _ Hsm Hbr Hlr Hrr)=>Har' Hh.
case: ifP=>/= Hd; rewrite Hd /= in Hh.
- rewrite /bal_inv /= in H; rewrite (eqP Hh) in H *.
  by apply: avl_balL_decr.
by case: b H=>/=; rewrite (eqP Hh) addn0=>/eqP->; rewrite addn0 !eq_refl Hl Har'.
Qed.

Lemma avl_delete k t :
  avl t ->
  avl (delete k t).1 &&
    (height t == height (delete k t).1 + decr t (delete k t).1).
Proof.
elim/avl_ind=>//=l k0 v0 b r E Hl Hr.
case El: (delete k l)=>[l0 ovl] /=.
case Er: (delete k r)=>[r0 ovr] /=.
move=>/andP [Hal Hhl] /andP [Har Hhr].
case: (cmp k k0)=>/=.
- (* k < k0 *)
  case: ifP=>/=; last first.
  - by move=>Hi; case: b E=>/=; move/eqP: Hhl=>->;
    rewrite Hi !addn0=>/eqP->; rewrite Hal Hr !eq_refl.
  (* decr l delete *)
  move=>Hi; rewrite Hi /= in Hhl; case: b E=>E /=.
  - (* b = Lh *)
    rewrite Hal Hr; move: Hhl; rewrite (eqP E) eqn_add2r=>/eqP<-.
    by rewrite maxnn maxn_addl !eq_refl.
  - (* b = Bal *)
    rewrite Hal Hr; move: Hhl; rewrite (eqP E) maxnn =>/eqP->.
    by rewrite maxn_addr addn0 !eq_refl.
  (* b = Rh *)
  case: {Er Har Hhr}r Hr E=>/=; first by rewrite addn1.
  move=>lr kr vr br rr /=; case/and3P; case: br=>/=.
  - case: lr=>/=; first by rewrite addn1=>/eqP.
    move=>llr klr vlr blr rlr /=; rewrite eqn_add2r=>Hrr; case: blr=>/=.
    - rewrite -(eqP Hrr); case/and3P =>/eqP-> Hallr Harlr Harr; move/eqP: Hhl=>->.
      rewrite !maxn_addl !eqn_add2r=>/eqP <-.
      by rewrite !maxn_addr !maxnn !eq_refl Hal Hallr Harlr Harr.
    - rewrite -(eqP Hrr); case/and3P=>/eqP-> Hallr Harlr Harr; move/eqP: Hhl=>->.
      rewrite maxn_addl !maxnn !eqn_add2r=>/eqP <-.
      by rewrite maxn_addr !maxnn !eq_refl Hal Hallr Harlr Harr.
    rewrite -(eqP Hrr); case/and3P =>/eqP-> Hallr Harlr Harr; move/eqP: Hhl=>->.
    rewrite !maxn_addl !maxn_addr !eqn_add2r=>/eqP <-.
    by rewrite !maxn_addr !maxn_addl !maxnn !eq_refl Hal Hallr Harlr Harr.
  - move/eqP=>-> Halr Harr; rewrite (eqP Hhl) maxnn !eqn_add2r =>/eqP->.
    by rewrite !maxn_addr maxn_addl addn0 !eq_refl Hal Halr Harr.
  move/eqP=>-> Halr Harr; rewrite (eqP Hhl) maxn_addr !eqn_add2r =>/eqP <-.
  by rewrite !maxnn maxn_addr !eq_refl Hal Halr Harr.
- (* k == k0 *)
  case: {El Hal Hhl} l Hl E=>/=.
  - move=>_; case: b=>/=; rewrite /decr /=.
    - by rewrite addn1 => /eqP.
    - by move/heightE=>->.
    rewrite add0n max0n Hr => H /=; rewrite eqn_add2l.
    case: {Er Har Hhr}r Hr H=>//=lr kr vr br rr /=.
    rewrite -{2}(add0n 1%N) eqn_add2r; case: br=>//=; case/and3P=>/eqP=>->_ _.
    - by rewrite maxn_addl addn1=>/eqP.
    by rewrite maxn_addr addn1=>/eqP.
  move=>ll kl vl bl rl=>/and3P [Hb Hall Harl] Hbl.
  case Hsm: (split_max ll kl vl bl rl)=>[[l' k'] v'].
  case/andP: (avl_split_max Hsm Hb Hall Harl)=>Hal'; case: ifP=>/= Hd.
  - rewrite eqn_add2r => /eqP E'; move: Hbl; rewrite E'; case: b=>/=.
    - by rewrite eqn_add2r=>/eqP->; rewrite maxn_addl maxnn !eq_refl Hal' Hr.
    - by move/eqP=>->; rewrite maxn_addr maxnn addn0 !eq_refl Hal' Hr.
    case: {Er Har Hhr}r Hr=>/=; first by rewrite addn1=>/eqP.
    move=>lr kr vr br rr; rewrite eqn_add2r=>/and3P [H'' Halr Harr] E''.
    case: br H'' =>/=.
    - case: lr Halr E''=>/=; first by move=>_ _; rewrite addn1=>/eqP.
      move=>llr klr vlr blr rlr; case: blr=>/= /and3P [/eqP-> Hallr Harlr].
      - rewrite maxn_addl !eqn_add2r=>/[swap]/eqP<-.
        rewrite maxn_addl eqn_add2r=>/eqP<-.
        by rewrite !maxn_addr !maxnn !eq_refl Hal' Hallr Harlr Harr.
      - rewrite maxnn !eqn_add2r=>/[swap]/eqP->.
        rewrite maxn_addl maxnn eqn_add2r=>/eqP->.
        by rewrite !maxnn maxn_addr !eq_refl Hal' Hallr Harlr Harr.
      rewrite maxn_addr !eqn_add2r=>/[swap]/eqP<-.
      rewrite maxn_addl eqn_add2r=>/eqP<-.
      by rewrite maxn_addl maxn_addr !maxnn !eq_refl Hal' Hallr Harlr Harr.
    - move: E''=>/[swap]/eqP->; rewrite maxnn=>/eqP->.
      by rewrite !maxn_addr maxn_addl addn0 !eq_refl Hal' Halr Harr.
    move: E''=>/[swap]/eqP->; rewrite maxn_addr !eqn_add2r=>/eqP->.
    by rewrite !maxnn maxn_addr !eq_refl Hal' Halr Harr.
  by rewrite addn0 Hal' Hr; move: Hbl=>/[swap]/eqP->-> /=; case: b=>/=; rewrite addn0.
(* k > k0 *)
case: ifP=>/=; last first.
- by move=>Hi; case: b E=>/=; move/eqP: Hhr=>->;
  rewrite Hi !addn0=>/eqP->; rewrite Har Hl !eq_refl.
(* decr l delete *)
move=>Hi; rewrite Hi /= in Hhr; case: b E=>E /=.
- (* b = Lh *)
  case: {El Hal Hhl}l Hl E=>/=; first by rewrite addn1.
  move=>ll kl vl bl rl /=; case/and3P; case: bl=>/=.
  - move/eqP=>-> Hall Harl; rewrite (eqP Hhr) maxn_addl !eqn_add2r =>/eqP <-.
    by rewrite !maxnn maxn_addl !eq_refl Har Hall Harl.
  - move/eqP=>-> Hall Harl; rewrite (eqP Hhr) maxnn !eqn_add2r =>/eqP->.
    by rewrite !maxn_addl maxn_addr addn0 !eq_refl Har Hall Harl.
  case: rl=>/=; first by rewrite addn1=>/eqP.
  move=>lrl krl vrl brl rrl /=; rewrite eqn_add2r=>Hll Hall; case: brl=>/=.
  - rewrite -(eqP Hll); case/and3P=>/eqP-> Halrl Harrl.
    rewrite maxn_addl maxn_addr !eqn_add2r; move/eqP: Hhr=>->.
    rewrite !eqn_add2r =>/eqP <-.
    by rewrite !maxn_addr maxn_addl !maxnn !eq_refl Hall Halrl Harrl Har.
  - rewrite -(eqP Hll); case/and3P=>/eqP-> Halrl Harrl.
    rewrite maxnn maxn_addr !eqn_add2r; move/eqP: Hhr=>->.
    rewrite !eqn_add2r =>/eqP <-.
    by rewrite maxn_addl !maxnn !eq_refl Hall Halrl Harrl Har.
  rewrite -(eqP Hll); case/and3P=>/eqP-> Halrl Harrl.
  rewrite !maxn_addr maxn_addl !eqn_add2r; move/eqP: Hhr=>->.
  rewrite !eqn_add2r =>/eqP <-.
  by rewrite maxn_addl !maxnn !eq_refl Hall Halrl Harrl Har.
- (* b = Bal *)
  rewrite Har Hl; move: Hhr; rewrite (eqP E) maxnn =>/eqP->.
  by rewrite maxn_addl addn0 !eq_refl.
(* b = Rh *)
rewrite Har Hl; move: Hhr; rewrite (eqP E) eqn_add2r=>/eqP<-.
by rewrite maxnn maxn_addr !eq_refl.
Qed.

Fixpoint inorder_kv (t : kvtree K V) : seq (K*V) :=
  if t is Node l k v _ r
    then inorder_kv l ++ (k,v) :: inorder_kv r
  else [::].

(* correctness via sorted lists *)

Lemma inorder_rot2 (l : kvtree K V) ak av m bk bv r :
  inorder_kv (rot2 l ak av m bk bv r) =
  inorder_kv l ++ (ak,av) :: inorder_kv m ++ (bk,bv) :: inorder_kv r.
Proof.
rewrite /rot2; case: m=>//= ml kl vl bl rl /=.
by rewrite -!catA.
Qed.

Lemma inorder_balL (l : kvtree K V) k v b r :
  inorder_kv (balL l k v b r) = inorder_kv l ++ (k,v) :: inorder_kv r.
Proof.
rewrite /balL; case: b=>//.
case: l=>//= ll kl vl bl lr.
case: bl=>/=; rewrite -catA //.
by apply: inorder_rot2.
Qed.

Lemma inorder_balR (l : kvtree K V) k v b r :
  inorder_kv (balR l k v b r) = inorder_kv l ++ (k,v) :: inorder_kv r.
Proof.
rewrite /balR; case: b=>//.
case: r=>//= rl kr vr br rr.
case: br=>/=; try by rewrite -catA.
by apply: inorder_rot2.
Qed.

Definition kv_inorder t : bool := kvlist (inorder_kv t).

Theorem inorder_lookup k t :
  kv_inorder t ->
  lookup t k = find_list (inorder_kv t) k.
Proof.
rewrite /kv_inorder /kvlist /keys; elim: t=>//=l IHl k0 v0 b r IHr /andP [H1 H2].
rewrite findlist_sorted_cat_cons_cat //=.
move: H1 H2; rewrite map_cat /= sorted_cat_cons_cat cat_uniq /=.
case/andP=> /= H1 H2 /and4P [U1 _ _ U2].
case: cmpE=>// Hk.
- by apply: IHr; rewrite (path_sorted H2).
by apply: IHl; rewrite (cat_sorted2 H1).
Qed.

Theorem inorder_upsert k f v t :
  kv_inorder t ->
  (inorder_kv (upsert k f v t).1 = (ins_list k f v (inorder_kv t)).1)
  * ((upsert k f v t).2 = (ins_list k f v (inorder_kv t)).2).
Proof.
rewrite /kv_inorder /kvlist /keys; elim: t=>//= l IHl k0 v0 b r IHr.
case El: (upsert k f v l)=>[l0 ovl] /=; rewrite El /= in IHl.
case Er: (upsert k f v r)=>[r0 ovr] /=; rewrite Er /= in IHr.
rewrite !map_cat /= sorted_cat_cons_cat -andbA => /and3P [H1 H2]; rewrite -cat1s in H2.
rewrite cat_uniq /= =>/and4P [U1 _ _ U2].
rewrite (cat_sorted2 H1) U1 /= in IHl.
case: IHl=>//=>IHl1 IHl2.
rewrite (cat_sorted2 H2) U2 /= in IHr.
case: IHr=>//=>IHr1 IHr2.
rewrite inslist_sorted_cat_cons_cat /keys; last by rewrite map_cat.
case: cmpE=>Hx /=.
- case: cmpE Hx=>// _ _.
  case Er1: (ins_list k f v (inorder_kv r))=>[r1 ovr1] /=.
  by case: ifP=>/=_; rewrite ?inorder_balR /= IHr1 IHr2 Er1.
- by rewrite Hx cmpxx /=.
case El1: (ins_list k f v (inorder_kv l))=>[l1 ovl1] /=.
by case: ifP=>/=_; rewrite ?inorder_balL /= IHl1 IHl2 El1.
Qed.

Lemma inorder_split_max (l : kvtree K V) k v b r t k' v' :
  split_max l k v b r = (t, k', v') ->
  inorder_kv t ++ [:: (k',v')] = inorder_kv l ++ (k,v) :: inorder_kv r.
Proof.
elim: r l k v b t =>/= [|lr _ kr vr br rr IHr] l k v b t; first by case=>->->->.
case Hsm: (split_max lr kr vr br rr)=>[[r' k0] v0][<- Hk Hv] /=; rewrite {k0}Hk {v0}Hv in Hsm.
by case: ifP=>/= _; rewrite ?inorder_balL /= -(IHr _ _ _ _ _ Hsm) -catA.
Qed.

Theorem inorder_delete k t :
  kv_inorder t ->
  (inorder_kv (delete k t).1 = (del_list k (inorder_kv t)).1)
  * ((delete k t).2 = (del_list k (inorder_kv t)).2).
Proof.
rewrite /kv_inorder /kvlist /keys /=; elim: t=>//=l IHl k0 v0 c r IHr /andP [] /[dup] H.
case El: (delete k l)=>[l0 ovl] /=; rewrite El /= in IHl.
case Er: (delete k r)=>[r0 ovr] /=; rewrite Er /= in IHr.
rewrite map_cat /= sorted_cat_cons_cat -(cat1s _ (map _ _)) =>/andP [H1 H2].
rewrite cat_uniq /= =>/and4P [U1 _ _ U2].
rewrite (cat_sorted2 H1) U1 /= in IHl.
case: IHl=>//=>IHl1 IHl2.
rewrite (cat_sorted2 H2) U2 /= in IHr.
case: IHr=>//=>IHr1 IHr2.
rewrite dellist_sorted_cat_cons_cat //=.
case: cmpE=>Hxa /=.
- rewrite -cat1s in H2.
  case Er1: (del_list k (inorder_kv r))=>[r1 ovr1] /=.
  by case: ifP=>/=_; rewrite ?inorder_balL IHr1 IHr2 Er1.
- case: {H H1 U1 IHl1 IHl2 El}l=>//= ll kl vl bl rl.
  case Hsm: (split_max ll kl vl bl rl)=>[[a' rk'] rv'] /=.
  move: (inorder_split_max Hsm)=>/= Esm.
  by case: ifP=>/=_; rewrite ?inorder_balR -Esm -catA.
case El1: (del_list k (inorder_kv l))=>[l1 ovl1] /=.
by case: ifP=>/=_; rewrite ?inorder_balR IHl1 IHl2 El1.
Qed.

Definition invariant (t : kvtree K V) := kv_inorder t && avl t.

Theorem invariant_empty : invariant leaf.
Proof. by []. Qed.

Theorem lookup_empty : lookup leaf =1 fun => None.
Proof. by []. Qed.

Corollary invariant_upsert k f v t :
  invariant t -> invariant (upsert k f v t).1.
Proof.
rewrite /invariant /kv_inorder /kvlist => /andP [H1 H2].
case: (inorder_upsert k f v H1)=>-> _.
apply/andP; split; last by case/andP: (avl_upsert k f v H2).
by apply: kvlist_ins_list.
Qed.

Corollary lookup_upsert k f v t :
  invariant t ->
  let tv := upsert k f v t in
  (lookup tv.1 =1 [eta (lookup t) with k |->
                   oapp (Some \o f) (Some v) (lookup t k)])
  * (tv.2 = lookup t k).
Proof.
move/[dup] => H; rewrite /invariant /kvlist => /andP [H1 _].
case E: (upsert k f v t)=>[t0 ov] /=.
move: E; rewrite (surjective_pairing (upsert _ _ _ _)); case=>E1 E2.
case: (find_ins_list k f v (inorder_kv t))=>L1 L2.
case: (inorder_upsert k f v H1)=>I1 I2.
split.
- move=>q /=; rewrite -E1 !inorder_lookup //; last first.
  - by case/(invariant_upsert k f v)/andP: H.
  by rewrite I1 (L1 q) //= -I2 E2.
by rewrite -E2 I2 inorder_lookup.
Qed.

Corollary invariant_delete k t :
  invariant t -> invariant (delete k t).1.
Proof.
rewrite /invariant /kv_inorder /kvlist => /andP [H1 H2].
case: (inorder_delete k H1)=>-> _.
apply/andP; split; last by case/andP: (avl_delete k H2).
by apply: kvlist_del_list.
Qed.

Corollary lookup_delete k t :
  invariant t ->
  let tv := delete k t in
  (lookup tv.1 =1 [eta (lookup t) with k |-> None])
  * (tv.2 = lookup t k).
Proof.
move/[dup] => H; rewrite /invariant /kv_inorder /kvlist => /andP [H1 H2].
case E: (delete k t)=>[t0 ov] /=.
move: E; rewrite (surjective_pairing (delete _ _)); case=>E1 E2.
case: (find_del_list k (xs:=inorder_kv t))=>// L1 L2.
case: (inorder_delete k H1)=>I1 I2.
split.
- move=>x /=; rewrite -E1 !inorder_lookup //; last first.
  - by case/(invariant_delete k)/andP: H.
  by rewrite I1 (L1 x) //= -I2 E2.
by rewrite -E2 I2 inorder_lookup.
Qed.

Definition AVLMap :=
  Map.make invariant_empty lookup_empty
           invariant_upsert lookup_upsert
           invariant_delete lookup_delete.

(* extra operations and properties *)
Fixpoint foldr_v {T} (f : V -> T -> T) (x0 : T) (t : kvtree K V) : T :=
  if t is Node l _ v _ r
    then foldr_v f (f v (foldr_v f x0 r)) l
  else x0.

Lemma foldr_inorder {T} (f : V -> T -> T) x0 t :
  foldr_v f x0 t = foldr (fun kv => f kv.2) x0 (inorder_kv t).
Proof.
elim: t x0=>//= l IHl k v _ r IHr x0.
by rewrite foldr_cat /= -IHr IHl.
Qed.

Lemma upsert_const t k f v :
  (forall x, f x = v) ->
  lookup t k = Some v ->
  (upsert k f v t).1 = t.
Proof.
move=>H; elim: t=>//= l1 IHl k1 v1 b1 r1 IHr.
case El: (upsert k f v l1)=>[l0 ovl] /=.
case Er: (upsert k f v r1)=>[r0 ovr] /=.
case: cmpE=>H1.
- move=>L; move: Er.
  rewrite (surjective_pairing (upsert _ _ _ _)); case=>Er1 _; rewrite Er1 in IHr.
  rewrite (IHr L) incr_refl (@lookup_node _ k) //.
  by apply/optP; exists v.
- by case=>->; rewrite H1 H.
move=>L; move: El.
rewrite (surjective_pairing (upsert _ _ _ _)); case=>El1 _; rewrite El1 in IHl.
rewrite (IHl L) incr_refl (@lookup_node _ k) //.
by apply/optP; exists v.
Qed.

End AVLMap.

Section AVLMapEq.
Context {disp : unit} {K : orderType disp} {V : eqType}.

Fixpoint eqkvtree (t1 t2 : kvtree K V) :=
  match t1, t2 with
  | Leaf, Leaf => true
  | Node l1 k1 v1 b1 r1, Node l2 k2 v2 b2 r2 =>
      [&& k1 == k2, v1 == v2, b1 == b2, eqkvtree l1 l2 & eqkvtree r1 r2 ]
  | _, _ => false
  end.

Lemma eqkvtreeP : Equality.axiom eqkvtree.
Proof.
elim=> [|l1 IHl k1 v1 b1 r1 IHr] [|l2 k2 v2 b2 r2] /=; try by constructor.
have [<-/=|Nk] := k1 =P k2; last by apply: ReflectF; case.
have [<-/=|Nv] := v1 =P v2; last by apply: ReflectF; case.
have [<-/=|Nb] := b1 =P b2; last by apply: ReflectF; case.
apply: (iffP andP).
- by case=>/IHl->/IHr->.
by case=><-<-; split; [apply/IHl|apply/IHr].
Qed.

Canonical kvtree_eqMixin := EqMixin eqkvtreeP.
Canonical kvtree_eqType := Eval hnf in EqType (kvtree K V) kvtree_eqMixin.

End AVLMapEq.

(* maps for seq don't have empty values *)
(* TODO generalize to arbitrary predicates? *)
Section Regular.
Context {disp : unit} {K : orderType disp} {V : Type}.

Definition regular (t : kvtree K (seq V)) :=
  forall k, oapp (negb \o nilp (T:=V)) true (lookup t k).

Remark regular_leaf : regular leaf.
Proof. by []. Qed.

Lemma regular_del k t :
  invariant t -> regular t ->
  regular (delete k t).1.
Proof.
rewrite /regular=>H R l.
by rewrite lookup_delete //=; case: eqP.
Qed.

Lemma regular_ins k v t :
  invariant t -> regular t ->
  regular (upsert k (cons v) [::v] t).1.
Proof.
rewrite /regular=>H R l.
rewrite lookup_upsert //=; case: eqP=>//= {l}_.
by case: (lookup t k).
Qed.

End Regular.

(*
From Coq Require Extraction ExtrOcamlBasic ExtrOcamlNatInt.

Set Extraction Flag 522.
Extract Inlined Constant negb => "not".
Extract Inlined Constant idP => "".
Extract Inlined Constant eqn => "equal".  (* ints! *)
Extract Inlined Constant size => "List.length".
Extract Inlined Constant cat => "List.append".
Extract Inductive reflect => bool [ true false ].
Extract Inductive alt_spec => bool [ true false ].
Extract Inductive eq_xor_neq => bool [ true false ].
Extract Inductive leq_xor_gtn => bool [ true false ].
Extract Inductive ltn_xor_geq => bool [ true false ].

Extract Inductive Derivable2 => "( * )" [ "" ].

Extraction "ext.ml" lookup upsert delete foldr_v.
*)


(* Views. reflect-predicate. Multi-rewrite rules *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* reflect-predicate *)
Lemma all_filter T (p : pred T) (s : seq T) :
    all p s -> filter p s = s.
Proof.
Print pred.
Check all.
Locate "[ 'seq' x <- s | C ]".
Print filter.
Check all p s : bool.
Check all p s : Type. (* implicit coercions *)

Set Printing Coercions.
Print is_true.
Locate "^~".
rewrite /is_true.
Unset Printing Coercions.
elim: s=> //= x s IHs.
move=> /andP.
case.
move=> ->.
move /IHs.
move=> ->.
done.

Restart.
by elim: s=> //= x s IHs /andP [-> /IHs ->].
Qed.

About andP.
Print reflect.
Print Bool.reflect.

Goal forall P, reflect P true -> P.
move=> P.
exact: (
    fun r : reflect P true =>
        ((match
            r in reflect _ b
            return (b = true -> P)
        with
        | ReflectT p => fun E => p
        | ReflectF np => fun E => ltac:(done)
        end) erefl)
).
Undo.
case.
Undo.

move=> R.

case E: true / R.
- done.
done.

Restart.
by move=> R; case E: true /.

Restart.
by move=> P; case E: _ /.
Qed.

Lemma introT_by (P : Prop) (b : bool) :
    reflect P b -> (P -> b).
Proof.
case.
done.
by move=> /[apply].
(* by move=> nP /nP. *)
Qed.

Lemma elimT_my (P : Prop) (b : bool) :
    reflect P b -> (b -> P).
Proof.
case=> //.
Qed.
(* Connection of P and b *)
Lemma reflect_property (P : Prop) (b : bool) :
    reflect P b -> (P <-> b).
Proof.
by split ; [apply introT_by | apply elimT_my].
Qed.

Lemma reflect_lem P b :
    reflect P b -> P \/ ~ P.
Proof.
move /reflect_property.
case: b; move=> pp.
by left ; apply pp.
by right=> /pp.
Qed.

Lemma andP_my (b c : bool) :
    reflect (b /\ c) (b && c).
Proof.
case: b.
- case: c.
  - by apply ReflectT.
constructor.
by case.
case: c.
constructor.
by case.
constructor.
by case.

Restart.
by case: b; case: c; constructor=> // ; case.
Qed.

Lemma nandP_my b c :
    reflect (~~ b \/ ~~ c) (~~ (b && c)).
case b; case c; constructor.
by case.
by right.
by left.
by left.

Restart.
by case: b; case c; constructor; intuition.

Qed.

Lemma idP_my (b : bool) :
    reflect b b.
by case: b; constructor.
Qed.

Lemma special_support_for_reflect_predicates b c :
    b && c -> b /\ c.
Proof.
move /andP.
Show Proof.
About elimTF.
Restart.
move=> Hb.
Check @elimTF (b /\ c) (b && c) true (@andP b c) Hb.
move: Hb.
move /(@elimTF (b /\ c) (b && c) true (@andP b c)).
exact: id.

Restart.
move=> Hb.
exact: elimT_my andP Hb.

Qed.

Lemma special_support_for_reflect_predicates' b c :
    (b && c) = false -> ~ (b /\ c).
Proof.
move/andP.
Restart.
move=> Hb.
Check @elimTF (b /\ c) (b && c) false (@andP b c) Hb.
exact: @elimTF (b /\ c) (b && c) false (@andP b c) Hb.
Qed.

Lemma special_support_for_reflect_predicates'' (b c : bool) :
    b /\ c -> b && c.
Proof.
move=> /andP.
Show Proof.
About introT.
Restart.
move=> Hb.
exact: @introT (b /\ c) (b && c) (@andP b c) Hb.
Qed.

Lemma special_support_for_reflect_predicates''' (b c : bool) :
    b /\ c -> b && c.
Proof.
move=> bc.
apply/andP.
done.
Qed.

Lemma special_support_for_reflect_predicates'''' (b c : bool) :
    ~ (b /\ c) -> b && c = false.
Proof.
move=> ab.
apply/andP.
done.
Qed.

Lemma eqnP_my (n m : nat) :
    reflect (n = m) (eqn n m).
Proof.
apply: (iffP idP).
by elim: n m => [| n IHn] [|m] //= /IHn ->.
by move=> -> ; elim: m.
Qed.

Lemma nseqP (T : eqType) n (x y : T) :
    reflect (y = x /\ n > 0) (y \in nseq n x).
Proof.
rewrite mem_nseq.
rewrite andbC.
apply: (iffP andP).
case.
by move/eqP.
by case=> ->.

Restart.
by rewrite mem_nseq andbC ; apply: (iffP andP) => [[/eqP] | [/eqP]].

Restart.
by rewrite mem_nseq andbC ; apply: (iffP andP) => -[/eqP].
Qed.

About maxn_idPl.
Lemma leq_max m n1 n2 :
    (m <= maxn n1 n2) = (m <= n1) || (m <= n2).
Proof.
without loss le_n21: n1 n2 / n2 <= n1.
by case/orP : (leq_total n2 n1) => le ; last rewrite maxnC orbC ; apply.
rewrite (maxn_idPl le_n21).
Search leq.
case: ltngtP=> _ //.

case/orP.
Admitted.

About allP.

Example for_ltngtP m n :
    (m <= n) && (n <= m) ->
    (m == n) || (m > n) || (m + n == 0).
by case: ltngtP.
About ltngtP.
About compare_nat.

Restart.
case: ltngtP => //.
Qed.

Variant compare_nat m n :
    bool -> bool -> bool -> bool -> bool -> bool -> Type :=
| CompareNatLt of m < n :
    compare_nat m n false false false true false true
| CompareNatGt of m > n :
    compare_nat m n false false true false true false
| CompareNatEq of m = n :
    compare_nat m n true true true true false false.

Lemma ltngtP m n :
    compare_nat m n (n == m) (m == n) (n <= m)
                    (m <= n) (n < m) (m < n).
Proof.
Admitted.


(*
Copyright © 2006-2008 Russell O’Connor

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

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

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

Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Export CoRN.reals.fast.CRFieldOps.
Require Export CoRN.model.rings.CRring.
Require Export CoRN.algebra.CFields.
Require Import CoRN.reals.fast.CRcorrect.
Require Import CoRN.tactics.CornTac.

(**
** Example of a field: $\langle$#⟨#[CR],[+],[*]$\rangle$#⟩#
*)

Local Open Scope uc_scope.

Lemma CRisCField : is_CField CRasCRing CRinvT.
Proof.
 intros x x_.
 split.
  change (x*(CRinvT x x_)==1)%CR.
  rewrite <- CR_eq_as_Cauchy_IR_eq.
  stepl ((CRasCauchy_IR x)[*](CRasCauchy_IR (CRinvT x x_))); [| now apply CR_mult_as_Cauchy_IR_mult].
  stepl ((CRasCauchy_IR x)[*](f_rcpcl (CRasCauchy_IR x) (CR_nonZero_as_Cauchy_IR_nonZero_1 _ x_))); [| now
    apply bin_op_is_wd_un_op_rht; apply CR_inv_as_Cauchy_IR_inv].
  eapply eq_transitive.
   apply field_mult_inv.
  apply: CR_inject_Q_as_Cauchy_IR_inject_Q.
 change ((CRinvT x x_)*x==1)%CR.
 rewrite <- CR_eq_as_Cauchy_IR_eq.
 stepl ((CRasCauchy_IR (CRinvT x x_))[*](CRasCauchy_IR x)); [| now apply CR_mult_as_Cauchy_IR_mult].
 stepl ((f_rcpcl (CRasCauchy_IR x) (CR_nonZero_as_Cauchy_IR_nonZero_1 _ x_))[*](CRasCauchy_IR x)); [| now
   apply bin_op_is_wd_un_op_lft; apply CR_inv_as_Cauchy_IR_inv].
 eapply eq_transitive.
  apply field_mult_inv_op.
 apply: CR_inject_Q_as_Cauchy_IR_inject_Q.
Qed.

Lemma CRinv_strext : forall x y x_ y_, CRapartT (CRinvT x x_) (CRinvT y y_) -> CRapartT x y.
Proof.
 intros x y x_ y_ H.
 apply CR_ap_as_Cauchy_IR_ap_2.
 apply cf_rcpsx with
   (CR_nonZero_as_Cauchy_IR_nonZero_1 _ x_) (CR_nonZero_as_Cauchy_IR_nonZero_1 _ y_).
 stepl (CRasCauchy_IR (CRinvT x x_)%CR); [| now
   apply eq_symmetric; apply (CR_inv_as_Cauchy_IR_inv_short x x_)].
 stepr (CRasCauchy_IR (CRinvT y y_)%CR); [| now
   apply eq_symmetric; apply (CR_inv_as_Cauchy_IR_inv_short y y_)].
 apply CR_ap_as_Cauchy_IR_ap_1.
 apply H.
Qed.

Definition CRasCField : CField :=
Build_CField CRasCRing CRinvT CRisCField CRinv_strext.

Canonical Structure CRasCField.