Require Import Coq.Unicode.Utf8 Arith FunctionalExtensionality String Coq.Program.Equality.

Set Implicit Arguments.

(** * BEGIN BLACK MAGIC (Ltac details beyond the scope of this lecture, to define some tactics that will be handy, extending built-in tactics) *)

(** * Here lies some black magic to define a smarter version of the normal [induction] tactic.
    * Details are beyond the scope of the lecture! *)
Ltac inductN n :=
  match goal with
    | [ |- forall x : ?E, _ ] =>
      match type of E with
        | Prop =>
          let H := fresh in intro H;
            match n with
              | 1 => dependent induction H
              | S ?n' => inductN n'
            end
        | _ => intro; inductN n
      end
  end.

Ltac induct e := inductN e || dependent induction e.

Ltac invert' H := inversion H; clear H; subst.

Ltac invertN n :=
  match goal with
    | [ |- forall x : ?E, _ ] =>
      match type of E with
        | Prop =>
          let H := fresh in intro H;
            match n with
              | 1 => invert' H
              | S ?n' => invertN n'
            end
        | _ => intro; invertN n
      end
  end.

Ltac invert e := invertN e || invert' e.
Ltac invert1 e := invert e; [].

(** * END BLACK MAGIC *)

(** * Transitive-reflexive closure of a relation, from last time *)

Inductive star A (R : A -> A -> Prop) : A -> A -> Prop :=
| StarRefl : forall x,
  star R x x
| StarStep : forall x1 x2 x3,
  R x1 x2
  -> star R x2 x3
  -> star R x1 x3.

(** Difference here? *)
Inductive star'' A (R : A -> A -> Prop) : A -> A -> Prop :=
| StarRefl'' : forall x x',
  x = x' -> star'' R x x'
| StarStep'' : forall x1 x2 x3,
  R x1 x2
  -> star'' R x2 x3
  -> star'' R x1 x3.

(** * Arithmetic expressions *)
Module Arithmetic.
  (** As a warm-up, let's prove type safety for simple arihmetic expresions with naturals and Booleans. *)

  (** Here's the language of terms. *)
  Inductive exp : Set :=
  | Number : nat -> exp
  | Plus : exp -> exp -> exp
  | Minus : exp -> exp -> exp
  | Boolean : bool -> exp
  | Equal : exp -> exp -> exp
  | If : exp -> exp -> exp -> exp.

  (** This next relation identifies which subset of terms are *values*, meaning they need not be evaluated further to produce a final result. *)
  Inductive value : exp -> Prop :=
  | VNumber : forall n, value (Number n)
  | VBoolean : forall b, value (Boolean b).

  (** Here's a simple small-step semantics, not taking advantage of evaluation contexts. *)

  Reserved Notation " a ==> b " (at level 60, right associativity).

  Inductive step : exp -> exp -> Prop :=
  | StepPlus : forall n1 n2,
    (Plus (Number n1) (Number n2)) ==> (Number (n1 + n2))
  | StepPlus1 : forall e1 e1' e2,
    e1 ==> e1'
    -> (Plus e1 e2) ==> (Plus e1' e2)
  | StepPlus2 : forall e1 e2 e2',
    value e1
    -> e2 ==> e2'
    -> (Plus e1 e2) ==> (Plus e1 e2')
  | StepMinus : forall n1 n2,
                  (Minus (Number n1) (Number n2)) ==> (Number (n1 - n2))
  | StepMinus1 : forall e1 e1' e2,
                   e1 ==> e1' ->
                   (Minus e1 e2) ==> (Minus e1' e2)
  | StepMinus2 : forall e1 e2 e2',
                   value e1 ->
                   e2 ==> e2' ->
                   (Minus e1 e2) ==> (Minus e1 e2')
  | StepEqual : forall n1 n2,
    (Equal (Number n1) (Number n2)) ==> (Boolean (beq_nat n1 n2))
  | StepEqual1 : forall e1 e1' e2,
    e1 ==> e1'
    -> (Equal e1 e2) ==> (Equal e1' e2)
  | StepEqual2 : forall e1 e2 e2',
    value e1
    -> e2 ==> e2'
    -> (Equal e1 e2) ==> (Equal e1 e2')
  | StepIfTrue : forall e2 e3,
    (If (Boolean true) e2 e3) ==> e2
  | StepIfFalse : forall e2 e3,
    (If (Boolean false) e2 e3) ==> e3
  | StepIf1 : forall e1 e1' e2 e3,
    e1 ==> e1'
    -> (If e1 e2 e3) ==> (If e1' e2 e3)
  where " a ==> b " := (step a b).

  (** Our simple set of two types helps us classify expressions. *)
  Inductive ty : Set :=
  | Nat : ty
  | Bool : ty.

  (** Here's the typing judgment, relating expressions and their types.
      A :: B is read as "A has type B" *)
  Inductive hasType : exp -> ty -> Prop :=
  | HtNumber : forall n, (Number n) :: Nat
  | HtPlus : forall e1 e2, e1 :: Nat
    -> e2 :: Nat
    -> (Plus e1 e2) :: Nat
  | HTMinus : forall e1 e2, e1 :: Nat
    -> e2 :: Nat
    -> (Minus e1 e2) :: Nat
  | HtBoolean : forall b, (Boolean b) :: Bool
  | HtEqual : forall e1 e2, e1 :: Nat
    -> e2 :: Nat
    -> (Equal e1 e2) :: Bool
  | HtIf : forall e1 e2 e3 t, e1 :: Bool
    -> e2 :: t
    -> e3 :: t
    -> (If e1 e2 e3) :: t
  where "a :: b" := (hasType a b).

  (** Next, some hints and tactic definitions whose details are beyond the scope of this lecture, but which will help us do nice automated proofs below *)

  Hint Constructors step value hasType.

  Ltac t0 := match goal with
             | [ H : ex _ |- _ ] => destruct H
             | [ H : _ /\ _ |- _ ] => destruct H

             | [ |- context[step (If (Boolean ?x) _ _) _] ] => is_var x; destruct x
             | [ H : hasType ?e _, H' : value ?e |- _ ] => invert H'; invert H
             | [ H : hasType _ _ |- _ ] => invert1 H
             end; subst.

  Ltac t := simpl; intuition; repeat t0; eauto.

  (** We are going to prove that "has type t" is an invariant, during the small-step evaluation of a term of that type.  The *progress* property is one half of the invariant proof: a term satisfying the invariant is either already a value or can take a step. *)
  Lemma progress : forall e t, e :: t
    -> value e
       \/ (exists e', e ==> e').
  Proof.
    induction 1; t.
  Qed.

  (** Here's the other half of the inavriant proof: *preservation* says that the invariant is closed under taking a step. *)
  Lemma preservation : forall e1 e2, e1 ==> e2
    -> forall t, e1 :: t
    -> e2 :: t.
  Proof.
    induction 1; t.
  Qed.

  Hint Resolve progress preservation.

  (** Together, they imply this key property: any term reachable by stepping from a well-typed term is *not stuck*, meaning that either it's a value or it can take a step. *)
  Theorem safety : forall e1 e2, star step e1 e2
    -> forall t, e1 :: t
    -> value e2 \/ (exists e3, e2 ==> e3).
  Proof.
    induct 1; t.
  Qed.

  (** Note that this style of type safety adapts very naturally to a broad range of languages, including those whose step relations are nondeterministic, though we won't look at any such examples in these lectures. *)
End Arithmetic.

(** * Simply typed lambda calculus *)
Module Stlc.
  (** Now we come to one of the classic examples for type soundness proofs: simply typed lambda calculus, where we have one distinguished base type (natural numbers here) and build up function types on top of it. *)

  (** Expression syntax *)
  Inductive exp : Set :=
  | Var : string -> exp
  | Const : nat -> exp
  | Plus : exp -> exp -> exp
  | Abs : string -> exp -> exp
  | App : exp -> exp -> exp.

  (** Values (final results of evaluation) *)
  Inductive value : exp -> Prop :=
  | VConst : forall n, value (Const n)
  | VAbs : forall x e1, value (Abs x e1).

  (** Substitution (not applicable when [e1] isn't closed, as before, to avoid some complexity that we don't need) *)

  Reserved Notation "e' [ x |-> a ]" (at level 10).

  Fixpoint subst (e1 : exp) (x : string) (e2 : exp) : exp :=
    match e2 with
      | Var y => if string_dec y x then e1 else Var y
      | Const n => Const n
      | Plus e2' e2'' => Plus (subst e1 x e2') (subst e1 x e2'')
      | Abs y e2' => Abs y (if string_dec y x then e2' else subst e1 x e2')
      | App e2' e2'' => App (subst e1 x e2') (subst e1 x e2'')
    end where "e' [ x |-> e ]" := (subst e x e').

  (** Evaluation contexts *)
  Inductive context : Set :=
  | Hole : context
  | Plus1 : context -> exp -> context
  | Plus2 : exp -> context -> context
  | App1 : context -> exp -> context
  | App2 : exp -> context -> context.

  (** Plugging an expression into a context *)

  Reserved Notation " E [ e ] == X " (at level 10).

  Inductive plug : context -> exp -> exp -> Prop :=
  | PlugHole : forall e, Hole[e] == e
  | PlugPlus1 : forall e e' C e2,
    C[e] == e'
    -> (Plus1 C e2)[e] == (Plus e' e2)
  | PlugPlus2 : forall e e' v1 C,
    value v1
    -> C[e] == e'
    -> (Plus2 v1 C)[e] == (Plus v1 e')
  | PlugApp1 : forall e e' C e2,
    C[e] == e'
    -> (App1 C e2)[e] == (App e' e2)
  | PlugApp2 : forall e e' v1 C,
    value v1
    -> C[e] == e'
    -> (App2 v1 C)[e] == (App v1 e')
  where " E [ e ] == X " := (plug E e X).

  (** Small-step, call-by-value evaluation.  In contrast to the way we did contextual semantics for basic untyped lambda calculus, here we stage the small-step relation as two relations, one capturing primitive steps and the other lifting them to apply inside of contexts. *)

  Reserved Notation "e ==>r e'" (at level 10).

  Inductive step0 : exp -> exp -> Prop :=
  | Beta : forall x e v,
    value v
    -> (App (Abs x e) v) ==>r (subst v x e)
  | Add : forall n1 n2,
    (Plus (Const n1) (Const n2)) ==>r (Const (n1 + n2))
  where "e ==>r e'" := (step0 e e').

  Inductive step : exp -> exp -> Prop :=
  | Step : forall C e1 e2 e1' e2',
    C[e1] == e1'
    -> C[e2] == e2'
    -> e1 ==>r e2
    -> step e1' e2'.

  Notation "e ==> e'" := (step e e') (at level 10).

  (** Syntax of types *)
  Inductive type : Set :=
  | Nat : type
  | Fun : type -> type -> type.

  (** Our typing judgment uses *typing contexts* (not to be confused with evaluation contexts) to map free variables to their types.  This notation is a convenient way to indicate a typing context that covers no variables. *)
  Notation empty := (fun _ => None).

  (** Here's a function to add a new binding to a typing context, setting the type of variable [x] to be [t]. *)
  Definition override (G : string -> option type) (x : string) (t : type) : string -> option type :=
    fun y => if string_dec y x then Some t else G y.

  (** Expression typing relation *)
  Inductive hasType : (string -> option type) -> exp -> type -> Prop :=
  | HtVar : forall G x t,
    G x = Some t
    -> hasType G (Var x) t
  | HtConst : forall G n,
    hasType G (Const n) Nat
  | HtPlus : forall G e1 e2,
    hasType G e1 Nat
    -> hasType G e2 Nat
    -> hasType G (Plus e1 e2) Nat
  | HtAbs : forall G x e1 t1 t2,
    hasType (override G x t1) e1 t2
    -> hasType G (Abs x e1) (Fun t1 t2)
  | HtApp : forall G e1 e2 t1 t2,
    hasType G e1 (Fun t1 t2)
    -> hasType G e2 t1
    -> hasType G (App e1 e2) t2.

  Hint Constructors value plug step0 step hasType.

  (** Two useful facts about [override] *)
  Lemma override_eq : forall G t x t',
    override G x t' x = Some t
    -> t = t'.
  Proof.
    unfold override; intros; destruct (string_dec x x); congruence.
  Qed.

  Lemma override_neq : forall G t x y t',
    override G x t' y = Some t
    -> x <> y
    -> G y = Some t.
  Proof.
    unfold override; intros; destruct (string_dec y x); try congruence.
  Qed.

  (** Some automation *)

  Ltac t0 := match goal with
             | [ H : ex _ |- _ ] => destruct H
             | [ H : _ /\ _ |- _ ] => destruct H
             | [ |- context[string_dec ?x ?y] ] => destruct (string_dec x y)
             | [ H : override _ _ _ _ = Some _ |- _ ] => apply override_eq in H
             | [ H : override _ _ _ _ = Some _ |- _ ] => apply override_neq in H; [ | congruence ]

             | [ H : step _ _ |- _ ] => invert H
             | [ H : step0 _ _ |- _ ] => invert1 H
             | [ H : hasType _ ?e _, H' : value ?e |- _ ] => invert H'; invert H
             | [ H : hasType _ _ _ |- _ ] => invert1 H
             | [ H : plug _ _ _ |- _ ] => invert1 H
             end; subst.

  Ltac t := simpl; intuition subst; repeat t0; try congruence; eauto 6.

  (** Now we're ready for the first of the two key properties, to show that "has type t in the empty typing context" is an invariant. *)
  Lemma progress : forall e t,
    hasType empty e t
    -> value e \/ (exists e' : exp, e ==> e').
  Proof.
    induct 1; t.
    (** Here I use [induct] instead of [induction] because the [hasType] premise includes an argument [empty] that isn't just a variable.  Try using [induction] instead to see how information is dropped, counterproductively. *)
  Qed.

  (** Inclusion between typing contexts is preserved by adding the same new mapping to both. *)
  Lemma weakening_override : forall G G' x t,
    (forall x' t', G x' = Some t' -> G' x' = Some t')
    -> (forall x' t', override G x t x' = Some t'
                      -> override G' x t x' = Some t').
  Proof.
    unfold override; t.
  Qed.

  Hint Resolve weakening_override.

  (** Raising a typing derivation to a larger typing context *)
  Lemma weakening : forall G e t,
    hasType G e t
    -> forall G', (forall x t, G x = Some t -> G' x = Some t)
      -> hasType G' e t.
  Proof.
    induct 1; t.
  Qed.

  Hint Resolve weakening.

  Hint Extern 1 (_ = Some _) => cbv beta in *; congruence.

  (** Replacing a typing context with an equal one has no effect (useful to guide proof search). *)
  Lemma hasType_change : forall G e t,
    hasType G e t
    -> forall G', G' = G
      -> hasType G' e t.
  Proof.
    t.
  Qed.

  Hint Resolve hasType_change.

  Hint Extern 2 (override _ _ _ = _) =>
    unfold override; let x := fresh "x" in extensionality x;
      repeat match goal with
             | [ |- context[string_dec ?x ?y] ] => destruct (string_dec x y)
             end.

  (** Replacing a variable with a properly typed term preserves typing. *)
  Lemma substitution : forall G x t' e t e',
    hasType (override G x t') e t
    -> hasType empty e' t'
    -> hasType G (subst e' x e) t.
  Proof.
    induct 1; t.
  Qed.

  Hint Resolve substitution.

  (** We're almost ready for the main preservation property.  Let's prove it first for the more basic [step0] relation. *)
  Lemma preservation0 : forall e1 e2,
    e1 ==>r e2
    -> forall t, hasType empty e1 t
      -> hasType empty e2 t.
  Proof.
    invert 1; t.
  Qed.

  Hint Resolve preservation0.

  (** We also need this key property, essentially saying that, if [e1] and [e2] are "type-equivalent," then they remain "type-equivalent" after wrapping the same context around both. *)
  Lemma generalize_plug : forall e1 C e1',
    C[e1] == e1'
    -> forall e2 e2', C[e2] == e2'
      -> (forall t, hasType empty e1 t -> hasType empty e2 t)
      -> (forall t, hasType empty e1' t -> hasType empty e2' t).
  Proof.
    induct 1; t.
  Qed.

  Hint Resolve generalize_plug.

  (** From here, the proof proceeds almost identically to the one for the arithmetic language. *)
  Lemma preservation : forall e1 e2,
    e1 ==> e2
    -> forall t, hasType empty e1 t
      -> hasType empty e2 t.
  Proof.
    invert 1; t.
  Qed.

  Hint Resolve progress preservation.

  Theorem safety : forall e1 e2, star step e1 e2
    -> forall t, hasType empty e1 t
    -> value e2 \/ (exists e3, step e2 e3).
  Proof.
    induct 1; t.
  Qed.

End Stlc.


(*This file contains two main theorems: forward and mixed error bounds for
  the fused muliply add dot product of two floating point lists;
  the functional model for the fma dot product is defined in dotprod_model.v.*)

Require Import vcfloat.VCFloat.
Require Import List.
Import ListNotations.
Require Import common op_defs dotprod_model sum_model.
Require Import dot_acc float_acc_lems list_lemmas.
Require Import gem_defs mv_mathcomp.
From mathcomp.analysis Require Import Rstruct.
From mathcomp Require Import all_ssreflect ssralg ssrnum.

From Coq Require Import ZArith Reals Psatz.
From Coq Require Import Arith.Arith.

Section MixedErrorList.
(* mixed error bounds over lists *)
Context {NAN: Nans} {t : type}.

Notation g := (@common.g t).
Notation g1 := (@common.g1 t).

Variable (A: @matrix (ftype t)).
Variable (v: @vector (ftype t)).

Notation n := (length v).
Notation m := (length A).
Notation Ar := (map_mat FT2R A).
Notation vr := (map FT2R v).

Hypothesis Hfin : is_finite_vec (A *f v).
Hypothesis Hlen: forall row, In row A -> length row = length v.

Lemma mat_vec_mul_mixed_error:
  exists (E : matrix) (eta : vector),
    A *fr v =  (Ar +m E) *r vr +v eta
    /\ (forall i j, (i < m)%nat -> (j < n)%nat ->
      Rabs (E _(i,j)) <= g n * Rabs (Ar _(i,j)))
    /\ (forall k, In k eta -> Rabs k <= g1 n n)
    /\ eq_size E A
    /\ length eta = m.
Proof.
revert Hfin Hlen.
elim: A => /= [ Hfin Hlen | a l IH Hfin' Hlen].
(*case A is nil*)
{ exists (zero_matrix 0 0 0%R), []; repeat split => /= //. }
have Hfin2 : is_finite_vec (l *f v).
  revert Hfin'. rewrite /is_finite_vec => Hf x Hin'.
  apply Hf; right => //.
have Hin2  : (forall row : list (ftype t), In row l -> length row = length v) by
  move => row Hrow; apply Hlen; right => //.
destruct (IH Hfin2 Hin2) as (E & eta & IH1 & IH2 & IH3 & IH4 & IH5);
  clear IH; rewrite IH1; clear IH1.
have Hlen': length a = n by apply Hlen; left => //.
have Hfin1 : Binary.is_finite (fprec t) (femax t) (dotprod a v) = true by
  revert Hfin'; rewrite /is_finite_vec => Hfin'; apply Hfin'; left => /= //.
destruct (dotprod_mixed_error' a v Hlen' Hfin1) as (u & ueta & X & Y & Z1 & Z2).
set (A':= (map FT2R a :: map_mat FT2R l) : matrix).
have Ha: (length u = length (map FT2R a)) by rewrite map_length; lia.
have : (length l = 0)%nat \/ (0 < length l)%nat by lia. move => [Hl | Hl].
{  apply length_zero_iff_nil in Hl; subst => /=.
exists (vec_sum u (map FT2R a) Rminus :: []) , ([ueta]); repeat split.
{
have Hav: (FT2R (dotprod a v) = dotprodR u (map FT2R v) + ueta)%R by
  rewrite Y; nra. rewrite Hav; clear Hav => /=.
rewrite !CommonSSR.map_map_equiv.
rewrite CommonSSR.map_map_equiv map_length in Ha.
suff Hs: map2 Rplus (List.map FT2R a)
         (u -v List.map FT2R a) = u.
rewrite Hs vec_sumR_bounds => /= //.
fold (@vec_sum R (List.map FT2R a) (u -v List.map FT2R a) Rplus).
fold (vec_sumR (List.map FT2R a) (u -v List.map FT2R a)).
rewrite vec_sumR_comm. rewrite vec_sumR_opp => //.
fold (@vec_sumR u (List.map Ropp (List.map FT2R a))).
rewrite vec_sumR_assoc. rewrite vec_sumR_minus.
rewrite /vec_sumR map_length -Ha vec_sum_zeroR => //.
1, 2, 3 : by rewrite !map_length => //.
rewrite /vec_sum/map2 !map_length
  combine_length map_length Ha; lia. }
{ move =>  i j Hi Hj.
rewrite !CommonSSR.map_map_equiv; rewrite /vec_sum/map2 /= in IH2.
assert (i = 0)%nat by lia; subst.
subst A'. rewrite /matrix_index => /=.
rewrite nth_vec_sum => /= //; [|nra].
have Hj' : (j < n)%coq_nat by lia.
destruct (Z1 j Hj') as (x & HB & HC); rewrite HB.
have H1 : (FT2R (List.nth j a neg_zero) = List.nth j (List.map FT2R a) 0%R) by
pose proof @map_nth (ftype t) R (FT2R) a neg_zero j.
rewrite H1; apply /RleP; field_simplify_Rabs.
rewrite Rabs_mult Rmult_comm.
by apply Rmult_le_compat_r => //; apply Rabs_pos => /= . }
move => k /= [H | H] //. subst; apply /RleP => //.
rewrite !CommonSSR.map_map_equiv => /=.
move => x y [Hx|Hx] [Hy|Hy]; subst => //.
rewrite /vec_sum/map2 map_length combine_length Ha
  CommonSSR.map_map_equiv map_length; lia. }
exists (vec_sum u (map FT2R a) Rminus :: E) , (ueta::eta); repeat split.
{
rewrite CommonSSR.map_map_equiv map_length in Ha.
have Hav: (FT2R (dotprod a v) = dotprodR u (map FT2R v) + ueta)%R by
  rewrite Y; nra. rewrite Hav; clear Hav => /=.
rewrite !CommonSSR.map_map_equiv => /=.
suff: map2 Rplus (List.map FT2R a) (u -v List.map FT2R a) =  u.
move => Hs. rewrite Hs vec_sumR_bounds => //.
fold (@vec_sum R (List.map FT2R a) (u -v List.map FT2R a) Rplus).
fold (vec_sumR (List.map FT2R a) (u -v List.map FT2R a)).
rewrite vec_sumR_comm. rewrite vec_sumR_opp => //.
fold (@vec_sumR u (List.map Ropp (List.map FT2R a))).
rewrite vec_sumR_assoc. rewrite vec_sumR_minus.
rewrite map_length -Ha /vec_sumR vec_sum_zeroR => //.
1, 2, 3: rewrite !map_length => //.
rewrite /vec_sum/map2 !map_length
  combine_length map_length Ha; lia. }
{ revert Ha. rewrite CommonSSR.map_map_equiv map_length.
destruct u => /=.
{ move => Ha i j Hi Hj; symmetry in Ha; rewrite length_zero_iff_nil in Ha;
subst => /=; rewrite /matrix_index => /=.
destruct i; destruct j => /= //.
1, 2: rewrite Rabs_R0 -RmultE Rmult_0_r; apply /RleP; nra.
1, 2: apply IH2; lia. }
{ move => Ha i j Hi Hj. revert Ha.
rewrite vec_sumR_opp. destruct a => /= //.
subst A' => /= Ha.
have H1 : (j < n)%coq_nat by lia.
destruct (Z1 j H1) as (d & Hd1 & Hd2).
destruct i; rewrite /matrix_index; destruct j => /= //.
revert Hd1 => /= Hd1; rewrite Hd1.
  apply /RleP; field_simplify_Rabs; rewrite Rabs_mult Rmult_comm.
  apply Rmult_le_compat;
  [ apply Rabs_pos | apply Rabs_pos | | apply Req_le ] => //.
{ fold (map2 Rplus u (List.map Ropp (List.map FT2R a))).
fold (vec_sum u (List.map Ropp (List.map FT2R a)) Rplus).
fold (vec_sumR u (List.map Ropp (List.map FT2R a))).
rewrite /vec_sumR -(vec_sumR_opp) => //.
rewrite -(vec_sumR_nth); revert Hd1 => /= Hd1. rewrite Hd1.
suff: List.nth j (List.map FT2R a) 0 =
 (List.nth j (List.map FT2R a) (@FT2R t neg_zero)).
move => Hs; rewrite Hs map_nth; apply /RleP; field_simplify_Rabs.
rewrite Rabs_mult Rmult_comm; apply Rmult_le_compat;
  [ apply Rabs_pos | apply Rabs_pos | apply Hd2 | apply Req_le; auto].
f_equal.
1, 2 : rewrite map_length; simpl in Ha; lia. }
1, 2 : by unfold matrix_index in IH2; apply IH2.
rewrite X map_length. lia. } }
move => k /=. move => [Hk | Hk].
  subst. apply /RleP; apply Z2.
  apply IH3 => //.
by rewrite CommonSSR.map_map_equiv /vec_sum /=;
  destruct IH4; lia.
move => x y /=.
  rewrite CommonSSR.map_map_equiv. move => [Hx | Hx] [Hy | Hy] /= .
  subst; rewrite /vec_sum/map2 map_length combine_length.
  rewrite CommonSSR.map_map_equiv in Ha. rewrite Ha map_length; lia.
  subst; rewrite /vec_sum/map2 map_length combine_length.
  rewrite CommonSSR.map_map_equiv in Ha. rewrite Ha map_length.
  rewrite (Hin2 y) => //; rewrite Hlen' ; lia.
  destruct IH4. rewrite (Hlen y); [|left] => //.
set (l0 := List.nth 0 l [neg_zero]).
assert (In l0 l). apply nth_In; lia.
specialize (H0 x l0 Hx H1). rewrite H0.
apply Hin2 => //.
destruct IH4.
specialize (H0 x y Hx Hy). rewrite H0 => //.
simpl; lia.
Qed.

End MixedErrorList.

Section MixedErrorMath.

From mathcomp Require Import matrix all_algebra bigop.

Require Import VST.floyd.functional_base.

Open Scope R_scope.
Open Scope ring_scope.

Delimit Scope ring_scope with Ri.
Delimit Scope R_scope with Re.

Context {NAN: Nans} {t : type}.

Notation g := (@common.g t).
Notation g1 := (@common.g1 t).

Variable (A: @gem_defs.matrix (ftype t)).
Variable (v: @gem_defs.vector (ftype t)).

Let m := (length A).
Let n := (length v).

Notation Ar := (matrix_to_mx m n (map_mat FT2R A)).
Notation vr := (vector_to_vc n (map FT2R v)).

Hypothesis Hfin : is_finite_vec (A *f v).
Hypothesis Hlen : forall x, In x A -> length x = n.

Notation " i ' " := (Ordinal i) (at level 40).

From mathcomp.algebra_tactics Require Import ring.

Lemma mat_vec_mul_mixed_error':
  exists (E : 'M[R]_(m,n)) (eta : 'cV[R]_m),
    A *fr' v =  (Ar + E) *m vr + eta
    /\ (forall i j (Hi : (i < m)%nat) (Hj : (j < n)%nat),
      Rabs (E  (Hi ') (Hj ')) <= g n * Rabs (Ar  (Hi ') (Hj ')))
    /\ forall i (Hi: (i < m)%nat), Rabs (eta (Hi ')  0) <= g1 n n .
Proof.
destruct (mat_vec_mul_mixed_error A v Hfin Hlen) as
  (E & eta & H1 & H2 & H3 & H4 & H5).
exists (matrix_to_mx m n E), (vector_to_vc m eta);
  split. rewrite H1.
pose proof @vector_to_vc_plus ((map_mat FT2R A +m E) *r map FT2R v) eta.
  rewrite H5 in H. rewrite H. clear H.
f_equal.
have Hlen2: length (map_mat FT2R A +m E) = length A.
  destruct H4.
  rewrite /map_mat map_length combine_length H !map_length; lia.
have Hin1 :
(forall x : seq.seq R,
      In x (map_mat FT2R A +m E) -> Datatypes.length x = Datatypes.length (List.map FT2R v)).
apply matrix_sum_preserves_length'.
destruct H4. intros.
rewrite map_length.
assert ((length A = 0)%nat \/ (0 < length A)%nat) by lia.
destruct H6.
apply length_zero_iff_nil in H6; subst.
simpl in H. apply length_zero_iff_nil in H; subst.
simpl in H4; auto.
set (y := nth 0 A []).
have Hy : In y A. subst y; apply nth_In; lia.
specialize (H0 x y H4 Hy); rewrite H0.
apply Hlen; auto.
move => x Hx.
apply list_in_map_inv in Hx.
destruct Hx as (x0 & Hx0 & Hx0').
subst.
rewrite !map_length.
apply Hlen; auto.
pose proof vector_to_vc_mulmx Hin1.
rewrite Hlen2 in H. rewrite H. clear H.
rewrite map_length.
f_equal.
pose proof @matrix_to_mx_plus' (map_mat FT2R A) E (length v).
unfold map_mat in H. rewrite map_length in H.
rewrite H. clear H. f_equal.
destruct H4; lia.
move => a e Ha He; split.
apply list_in_map_inv in Ha.
destruct Ha as (x0 & Hx0 & Hx0').
subst. rewrite map_length. apply Hlen; auto.
destruct H4.
apply list_in_map_inv in Ha.
destruct Ha as (x0 & Hx0 & Hx0').
subst. pose proof (H4 e x0 He Hx0').
rewrite H6. apply Hlen; auto.
destruct H4.
rewrite /map_mat/mat_sumR/mat_sum/map2 !map_length combine_length
  map_length; lia.
split.
{ move => i j Hi Hj.
 rewrite -(matrix_to_mx_index E Hi Hj).
 rewrite -(matrix_to_mx_index (map_mat FT2R A) Hi Hj).
specialize (H2 i j Hi Hj).
subst n => /= //. }
move => i Hi.
rewrite vector_to_vc_index => /= //.
apply H3. apply nth_In. lia.
Qed.

End MixedErrorMath.


Require Import
  Coq.ZArith.ZArith
  Pact.Lib
  Pact.Ty
  Pact.Bltn
  Pact.Exp
  Pact.Value.

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

Set Equations With UIP.

Generalizable All Variables.
Set Primitive Projections.

Import ListNotations.

Open Scope Ty_scope.

Section Exp.

Open Scope Ty_scope.

Variable Γ : Ty → Type.

Inductive Exp : Ty → Type :=
  | VAR {τ}        : Γ τ → Exp τ
  | LAM {dom cod}  : (Γ dom → Exp cod) → Exp (dom ⟶ cod)
  | APP {dom cod}  : Exp (dom ⟶ cod) → Exp dom → Exp cod

  | Lit {ty}       : Literal ty → Exp (TyPrim ty)

  | If {τ}         : Exp 𝔹 → Exp τ → Exp τ → Exp τ

  | Pair {τ1 τ2}   : Exp τ1 → Exp τ2 → Exp (TyPair τ1 τ2)
  | Fst {τ1 τ2}    : Exp (TyPair τ1 τ2) → Exp τ1
  | Snd {τ1 τ2}    : Exp (TyPair τ1 τ2) → Exp τ2

  | Seq {τ τ'}     : Exp τ' → Exp τ → Exp τ.

Derive Signature NoConfusionHom Subterm for Exp.

End Exp.

Inductive Simp (Γ : Ty → Type) : Ty → Type :=
  | SVAR {τ}        : Γ τ → Simp Γ τ
  | SLAM {dom cod}  : (Γ dom → ANF Γ cod) → Simp Γ (dom ⟶ cod)

  | SLit {ty}       : Literal ty → Simp Γ (TyPrim ty)
  (* | SBltn {τ}       : Builtin τ → Simp Γ τ *)

  (* | SSymbol         : string → Simp Γ TySym *)

  | SPair {τ1 τ2}   : Simp Γ τ1 → Simp Γ τ2 → Simp Γ (TyPair τ1 τ2)
  | SFst {τ1 τ2}    : Simp Γ (TyPair τ1 τ2) → Simp Γ τ1
  | SSnd {τ1 τ2}    : Simp Γ (TyPair τ1 τ2) → Simp Γ τ2

  (* | SInl {τ1 τ2}    : Simp Γ τ1 → Simp Γ (TySum τ1 τ2) *)
  (* | SInr {τ1 τ2}    : Simp Γ τ2 → Simp Γ (TySum τ1 τ2) *)
  (* | SCase {τ1 τ2 τ} : Simp Γ (TySum τ1 τ2) → *)
  (*                     Simp Γ (τ1 ⟶ τ) → Simp Γ (τ2 ⟶ τ) → Simp Γ τ *)

  (* | SNil {τ}        : Simp Γ (TyList τ) *)
  (* | SCons {τ}       : Simp Γ τ → Simp Γ (TyList τ) → Simp Γ (TyList τ) *)
  (* | SCar {τ}        : Simp Γ (TyList τ) → Simp Γ τ *)
  (* | SCdr {τ}        : Simp Γ (TyList τ) → Simp Γ (TyList τ) *)
  (* | SIsNil {τ}      : Simp Γ (TyList τ) → Simp Γ 𝔹 *)

  (* | SCapability {p v} : *)
  (*     ConcreteP p → *)
  (*     ConcreteP v → *)
  (*     Simp Γ TySym → *)
  (*     Simp Γ p → *)
  (*     Simp Γ v → *)
  (*     Simp Γ (TyCap p v) *)

with ANF (Γ : Ty → Type) : Ty → Type :=
  | AReturn {τ} : Simp Γ τ → ANF Γ τ
  | ALetApp {τ dom cod} :
      Simp Γ (dom ⟶ cod) →
      Simp Γ dom →
      (Γ cod → ANF Γ τ) →
      ANF Γ τ
  | ATailApp {dom cod} :
      Simp Γ (dom ⟶ cod) →
      Simp Γ dom →
      ANF Γ cod
  | AThunk {τ τ'} :
      (Γ 𝕌 → ANF Γ τ') →
      (Γ (𝕌 ⟶ τ') → ANF Γ τ) →
      ANF Γ τ
  | ALet {τ τ'} :
      ANF Γ τ' →
      (Γ τ' → ANF Γ τ) →
      ANF Γ τ
  | ALetCont {τ τ' τ''} :
      ANF Γ τ' →
      (Γ τ' → ANF Γ τ) →
      (Γ τ → ANF Γ τ'') →
      ANF Γ τ''

  (* | AError {τ} : ANF Γ τ *)
  (* | ACatch {τ} : ANF Γ τ → ANF Γ (TySum 𝕌 τ) *)

  | AIf {τ} :
      Simp Γ 𝔹 →
      ANF Γ τ →
      ANF Γ τ →
      ANF Γ τ

  (* | ACase {τ1 τ2 τ} : *)
  (*     Simp Γ (TySum τ1 τ2) → *)
  (*     ANF Γ (τ1 ⟶ τ) → *)
  (*     ANF Γ (τ2 ⟶ τ) → *)
  (*     ANF Γ τ *)

  (** Capabilities *)

  (* | AWithCapability {p v τ} : *)
  (*     ConcreteP v → *)
  (*     Simp Γ TySym → *)
  (*     Simp Γ (TyCap p v ⟶ 𝕌) → *)
  (*     Simp Γ (v × v ⟶ v) → *)
  (*     Simp Γ (TyCap p v) → *)
  (*     ANF Γ τ → *)
  (*     ANF Γ τ *)
  (* | AComposeCapability {p v} : *)
  (*     ConcreteP v → *)
  (*     Simp Γ TySym → *)
  (*     Simp Γ (TyCap p v ⟶ 𝕌) → *)
  (*     Simp Γ (v × v ⟶ v) → *)
  (*     Simp Γ (TyCap p v) → *)
  (*   ANF Γ 𝕌 *)
  (* | AInstallCapability {p v} : *)
  (*     Simp Γ (TyCap p v) → *)
  (*     ANF Γ 𝕌 *)
  (* | ARequireCapability {p v} : *)
  (*     Simp Γ (TyCap p v) → *)
  (*     ANF Γ 𝕌 *)
.

Derive Signature NoConfusionHom Subterm for Simp ANF.

Notation "( x ';T' y )" := (@existT _ _ x y).
Notation "( x ';T' y ';T' z )" := (@existT _ _ x (@existT _ _ y z)).
Notation "( x ; y )" := (@exist _ _ x y).
Notation "( x ; y ; z )" := (@exist _ _ x (@exist _ _ y z)).

Arguments SVAR {Γ τ} _.
Arguments Lit {Γ ty} _.
Arguments SLit {Γ ty} _.
(* Arguments SBltn {Γ τ} _. *)
(* Arguments SSymbol {Γ} _. *)
(* Arguments SNil {Γ τ}. *)

#[local] Obligation Tactic := auto.

Equations anf `(e : Exp Γ τ) : ANF Γ τ := {
  anf (VAR v)      := AReturn (SVAR v);
  anf (LAM e)      := AReturn (SLAM (λ x, anf (e x)));
  anf (APP f x)    := anfk f (λ f', anfk x (λ x', ATailApp f' x'));

  (* anf (Let x body) := ALet (anf x) (λ x, anf (body x)); *)

  anf (Lit l)      := AReturn (SLit l);
  (* anf (Bltn b)     := AReturn (SBltn b); *)

  (* anf Error        := AError _; *)
  (* anf (Catch e)    := ACatch (anf e); *)

  (* anf (Symbol s)   := AReturn (SSymbol s); *)

  anf (If b t e)   := anfk b (λ b', AIf b' (anf t) (anf e));

  anf (Pair x y)   := anfk x (λ x', anfk y (λ y', AReturn (SPair x' y')));
  anf (Fst p)      := anfk p (λ p', AReturn (SFst p'));
  anf (Snd p)      := anfk p (λ p', AReturn (SSnd p'));

  (* anf (Inl x)      := anfk x (λ x', AReturn (SInl x')); *)
  (* anf (Inr y)      := anfk y (λ y', AReturn (SInr y')); *)
  (* anf (Case p g h) := anfk p (λ p', ACase p' (anf g) (anf h)); *)

  (* anf Nil          := AReturn SNil; *)

  (* anf (Cons x xs)  := anfk x (λ x', anfk xs (λ xs', AReturn (SCons x' xs'))); *)
  (* anf (Car xs)     := anfk xs (λ xs', AReturn (SCar xs')); *)
  (* anf (Cdr xs)     := anfk xs (λ xs', AReturn (SCdr xs')); *)
  (* anf (IsNil xs)   := anfk xs (λ xs', AReturn (SIsNil xs')); *)

  anf (Seq e1 e2)  := ALet (anf e1) (λ _, anf e2);

  (* anf (Capability (p:=tp) (v:=tv) Hp Hv nm arg val) := *)
  (*   anfk nm (λ nm', *)
  (*     anfk arg (λ arg', *)
  (*       anfk val (λ val', *)
  (*         AReturn (SCapability Hp Hv nm' arg' val')))); *)

  (* anf (WithCapability (p:=tp) (v:=tv) Hv modname prd mng c e) := *)
  (*   anfk modname (λ modname', *)
  (*     anfk prd (λ prd', *)
  (*       anfk mng (λ mng', *)
  (*         anfk c (λ c', *)
  (*           AWithCapability Hv modname' prd' mng' c' (anf e))))); *)

  (* anf (ComposeCapability (p:=tp) (v:=tv) Hv modname prd mng c) := *)
  (*   anfk modname (λ modname', *)
  (*     anfk prd (λ prd', *)
  (*       anfk mng (λ mng', *)
  (*         anfk c (λ c', *)
  (*           AComposeCapability Hv modname' prd' mng' c')))); *)

  (* anf (InstallCapability c) := anfk c (λ c', AInstallCapability c'); *)
  (* anf (RequireCapability c) := anfk c (λ c', ARequireCapability c'); *)
}
with anfk `(e : Exp Γ τ) {τ'} (k : Simp Γ τ → ANF Γ τ') : ANF Γ τ' := {
  anfk (VAR v)      k := k (SVAR v);
  anfk (LAM e)      k := k (SLAM (λ x, anf (e x)));
  anfk (APP f x)    k :=
    anfk f (λ f', anfk x (λ x', ALetApp f' x' (λ x, k (SVAR x))));

  (* anfk (Let x body) k := *)
  (*   ALetCont (anf x) (λ x, anf (body x)) (λ x, k (SVAR x)); *)

  anfk (Lit l)      k := k (SLit l);
  (* anfk (Bltn b)     k := k (SBltn b); *)

  (* anfk Error        k := AError _; *)
  (* anfk (Catch e)    k := ACatch (anf e); *)

  (* anfk (Symbol s)   k := k (SSymbol s); *)

  (* anfk (If (Lit (LitBool true)) t e) k := anfk t k; *)

  anfk (If b t e)   k :=
    anfk b (λ b',
      AThunk (λ _, anf t) (λ t',
        AThunk (λ _, anf e) (λ e',
          AIf b'
            (ALetApp (SVAR t') (SLit LitUnit) (λ x, k (SVAR x)))
            (ALetApp (SVAR e') (SLit LitUnit) (λ x, k (SVAR x))))));

  anfk (Pair x y)   k := anfk x (λ x', anfk y (λ y', k (SPair x' y')));
  anfk (Fst p)      k := anfk p (λ p', k (SFst p'));
  anfk (Snd p)      k := anfk p (λ p', k (SSnd p'));

  (* anfk (Inl x)      k := anfk x (λ x', k (SInl x')); *)
  (* anfk (Inr y)      k := anfk y (λ y', k (SInr y')); *)
  (* anfk (Case p g h) k := _; *)

  (* anfk Nil          k := k SNil; *)

  (* anfk (Cons x xs)  k := anfk x (λ x', anfk xs (λ xs', k (SCons x' xs'))); *)
  (* anfk (Car xs)     k := anfk xs (λ xs', k (SCar xs')); *)
  (* anfk (Cdr xs)     k := anfk xs (λ xs', k (SCdr xs')); *)
  (* anfk (IsNil xs)   k := anfk xs (λ xs', k (SIsNil xs')); *)

  anfk (Seq e1 e2)  k := ALetCont (anf e1) (λ _, anf e2) (λ x, k (SVAR x));

  (* anfk (Capability (p:=tp) (v:=tv) Hp Hv nm arg val) k := *)
  (*   anfk nm (λ nm', *)
  (*     anfk arg (λ arg', *)
  (*       anfk val (λ val', *)
  (*         k (SCapability Hp Hv nm' arg' val')))); *)

  (* anfk (WithCapability (p:=tp) (v:=tv) Hv modname prd mng c e) k := _; *)
  (* anfk (ComposeCapability (p:=tp) (v:=tv) Hv modname prd mng c) k := _; *)
  (* anfk (InstallCapability c) k := _; *)
  (* anfk (RequireCapability c) k := _; *)
}.

Definition sample Γ (add : Exp Γ (ℤ ⟶ ℤ ⟶ ℤ)) : Exp Γ (ℤ × ℤ) :=
  Pair (APP (APP add (Lit (LitInteger 2))) (Lit (LitInteger 3)))
       (APP (APP add (Lit (LitInteger 7))) (Lit (LitInteger 8))).

Compute sample.
Goal True.
  enough (Exp (λ _, nat) (ℤ ⟶ ℤ ⟶ ℤ)) as add.
    pose (f := anf (sample add)).
    cbv [ anf anfk sample anf_functional anfk_functional ] in f.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Heaps: finite maps from keys to values                                  *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibReflect LibList LibSet.
Generalizable Variable K V.

(***********************************************************)
(***********************************************************)
(***********************************************************)
(* Abstract interface of a heap *)

Module Type HeapSpec.

Parameter heap : Type -> Type -> Type.

(***********************************************************)
(** Operations *)

Section HeapDef.
Variables K V : Type.

Parameter empty : heap K V.
Parameter dom : heap K V -> set K. (* LATER: should be a finite set *)
Parameter binds : heap K V -> K -> V -> Prop.
Parameter write : heap K V -> K -> V -> heap K V.
Parameter to_list : heap K V -> list (K * V).
Definition indom h r :=	(r \in dom h).

End HeapDef.

Parameter read : forall `{Comparable K} `{Inhab V}, heap K V -> K -> V.
Parameter read_option : forall `{Comparable K} V, heap K V -> K -> option V.
Parameter rem : forall `{Comparable K} V, heap K V -> K -> heap K V.

Implicit Arguments empty [[K] [V]].

(***********************************************************)
(** Properties *)

Section HeapParameters.
Context `{Comparable K} `{Inhab V}.
Implicit Types h : heap K V.

Parameter indom_equiv_binds : forall h k,
  indom h k = (exists v, binds h k v).

Parameter dom_empty :
  dom (@empty K V) = \{}.

Parameter binds_equiv_read : forall h k,
  indom h k -> (forall v, (binds h k v) = (read h k = v)).

Parameter dom_write : forall h r v,
  dom (write h r v) = dom h \u \{r}.

Parameter binds_write_eq : forall h k v,
  binds (write h k v) k v.

Parameter binds_write_neq : forall h k v k' v',
  binds h k v -> k <> k' ->
  binds (write h k' v') k v.

Parameter binds_write_inv : forall h k v k' v',
  binds (write h k' v') k v ->
  (k = k' /\ v = v') \/ (k <> k' /\ binds h k v).

Parameter binds_rem : forall h k k' v,
  binds h k v -> k <> k' -> binds (rem h k') k v.

Parameter binds_rem_inv : forall h k v k',
  binds (rem h k') k v -> k <> k' /\ binds h k v.

(* TODO: need to add the instance BagRemove to LibSet
Parameter dom_rem : forall h k,
  dom (rem h k) = (dom h) \- k.
For now, we used this derived form:
*)

Parameter not_indom_rem : forall h k,
  ~ indom (rem h k) k.

Parameter binds_equiv_read_option : forall h k v,
  (binds h k v) = (read_option h k = Some v).

Parameter not_indom_equiv_read_option : forall h k,
  (~ indom h k) = (read_option h k = None).

Parameter read_option_def : forall h k,
  read_option h k = (If indom h k then Some (read h k) else None).

End HeapParameters.

Parameter indom_decidable : forall `{Comparable K} V (h:heap K V) k,
  Decidable (indom h k).
Existing Instance indom_decidable.

End HeapSpec.

(***********************************************************)
(***********************************************************)
(***********************************************************)
(** Implementation of heaps as lists *)

Module HeapList : HeapSpec.

Definition heap K V := list (K*V).

Section HeapDefs.
(*Variables K V : Type.*)
Context `{Comparable K} `{Inhab V}.
Definition empty : heap K V := nil.
Definition dom (l : heap K V) : set K :=
  fold_right (fun p acc => acc \u \{fst p}) \{} l.
Definition binds (l : heap K V) k v :=
  Assoc k v l.
Definition to_list (l : heap K V) := l.

(* TODO: move *)
Generalizable Variable A B.
Fixpoint assoc `{Comparable A} `{Inhab B} k (l:list (A*B)) : B :=
  match l with
  | nil => arbitrary
  | (x, v) :: l' => ifb x = k then v else assoc k l'
  end.
Definition read (l : heap K V) k :=
  assoc k l.
Definition write (l : heap K V) k v :=
  (k, v) :: l.
Definition rem K `{Comparable K} V (l : heap K V) k :=
  LibList.filter (fun p => ifb (fst p) = k then false else true) l.
Definition indom h r := (r \in dom h).
Fixpoint read_option (l : heap K V) k :=
  match l with
  | nil => None
  | (x, v) :: l' => ifb x = k then Some v else read_option l' k
  end.

End HeapDefs.

Implicit Arguments empty [[K] [V]].

Section HeapParameters.
Context `{HK: Comparable K} `{IV: Inhab V}.
Implicit Types h : heap K V.
(* TODO: do the right proof using *)

Lemma indom_equiv_binds : forall h k,
  indom h k = (exists v, binds h k v).
Proof using.
Admitted. (* File will be soon deprecated *)

Lemma dom_empty :
  dom (@empty K V) = \{}.
Proof using. auto. Qed.

Lemma binds_equiv_read : forall h k,
  indom h k -> (forall v, (binds h k v) = (read h k = v)).
Proof using HK IV.
Admitted. (* File will be soon deprecated *)

Lemma dom_write : forall h r v,
  dom (write h r v) = dom h \u \{r}.
Proof. intros. unfold dom, write. rew_list. auto. Qed.

Lemma binds_write_eq : forall h k v,
  binds (write h k v) k v.
Proof. unfolds @binds, @write. intros. constructors. Qed.

Lemma binds_write_neq : forall h k v k' v',
  binds h k v -> k <> k' ->
  binds (write h k' v') k v.
Proof. unfolds @binds, @write. intros. constructors~. Qed.

Lemma binds_write_inv : forall h k v k' v',
  binds (write h k' v') k v ->
  (k = k' /\ v = v') \/ (k <> k' /\ binds h k v).
Proof. unfolds @binds, @write. introv M. inverts* M. Qed.

Lemma binds_rem : forall h k k' v,
  binds h k v -> k <> k' -> binds (rem h k') k v.
Proof using HK.
Admitted. (* File will be soon deprecated *)

Lemma binds_rem_inv : forall h k v k',
  binds (rem h k') k v -> k <> k' /\ binds h k v.
Proof using HK.
Admitted. (* File will be soon deprecated *)

(* TODO: need to add the instance BagRemove to LibSet
Lemma dom_rem : forall h k,
  dom (rem h k) = (dom h) \- k.
For now, we used this derived form:
*)

Lemma not_indom_rem : forall h k,
  ~ indom (rem h k) k.
Proof using HK.
Admitted. (* TODO: prove *)

Lemma binds_equiv_read_option : forall h k v,
  (binds h k v) = (read_option h k = Some v).
Proof using.
  unfolds @binds. introv. extens.
  induction h as [|(x&v0)].
   splits ; intro N ; invert* N.
   simpl. case_if.
     subst. splits ; intro N ; inverts* N. constructors.
     splits ; intro N.
      inverts* N.
      constructors*.
Qed.

Lemma not_indom_equiv_read_option : forall h k,
  (~ indom h k) = (read_option h k = None).
Proof using.
  introv. apply* not_cancel. rew_logic. rewrite indom_equiv_binds.
  splits ; intro N.
   lets (v & B): rm N.
    rewrite binds_equiv_read_option in B. rewrite* B. discriminate.
   asserts (v & E): (exists v, read_option h k = Some v).
     destruct* @read_option.
    rewrite* <- binds_equiv_read_option in E.
Qed.

Lemma read_option_def : forall h k,
  read_option h k = (If indom h k then Some (read h k) else None).
Proof using.
(* TODO
  introv. cases_if.
   rewrite* <- binds_equiv_read_option.
    rewrites* binds_equiv_read.
   rewrite* <- @not_indom_equiv_read_option.
*)
Admitted.

(* TODO: move *)
Generalizable Variable A.
Fixpoint mem_assoc B `{Comparable A} k (l : list (A * B)) : bool :=
  match l with
  | nil => false
  | (x, _) :: l' => decide (x = k) || mem_assoc k l'
  end.

Definition indom_dec `{Comparable K} V (h:heap K V) (k:K) : bool :=
  mem_assoc k h.

Lemma indom_dec_spec : forall `{Comparable K} V (h:heap K V) k,
  indom_dec h k = isTrue (indom h k).
Proof.
  intros. unfold indom, dom, indom_dec.
  induction h as [|[k' v'] h]; simpl.
  rewrite in_empty_eq. rew_refl~.
  rewrite in_union_eq. rewrite in_single_eq. rewrite IHh.
   extens. rew_refl*.
Qed.

End HeapParameters.

Lemma indom_decidable : forall `{Comparable K} V (h:heap K V) k,
  Decidable (indom h k).
Proof.
  intros. applys decidable_make (indom_dec h k).
  applys indom_dec_spec.
Qed.

End HeapList.

Export HeapList.

(***********************************************************)
(** Facts *)

Global Instance heap_inhab : forall (K V : Type), Inhab (heap K V).
Proof using. introv. apply (prove_Inhab empty). Qed.

Section HeapFacts.
Context `{HK:Comparable K} `{HV:Inhab V}.
Implicit Types h : heap K V.

(** indom *)

Lemma indom_binds : forall h k,
  indom h k -> exists v, binds h k v.
Proof using. introv H. rewrite~ @indom_equiv_binds in H. Qed.

Lemma binds_indom : forall h k v,
  binds h k v -> indom h k.
Proof using. introv H. rewrite* @indom_equiv_binds. Qed.

(** binds-func *)

Lemma binds_func : forall h k v v',
  binds h k v -> binds h k v' -> v = v'.
Proof using HK HV.
  introv B1 B2. forwards: binds_indom B1. forwards: binds_indom B2.
  rewrite binds_equiv_read in B1,B2; congruence.
Qed.

(** read--binds *)

Lemma binds_read : forall h k v,
  binds h k v -> read h k = v.
Proof using. introv H. rewrite~ <- binds_equiv_read. apply* binds_indom. Qed.

Lemma read_binds : forall h k v,
  read h k = v -> indom h k -> binds h k v.
Proof using. introv H D. rewrite~ binds_equiv_read. Qed.

(** read-write *)

Lemma read_write_eq : forall h k v,
  read (write h k v) k = v.
Proof using. introv. apply binds_read. apply binds_write_eq. Qed.

Lemma read_write_neq : forall h k k' v',
  indom h k -> k <> k' -> read (write h k' v') k = read h k.
Proof using.
  introv. rewrite indom_equiv_binds. introv [v B] N.
  rewrite (binds_read B).
  forwards B': @binds_write_neq B N. rewrite~ (binds_read B').
Qed.

(** indom-write *)

Lemma indom_write_eq : forall h k v,
  indom (write h k v) k.
Proof using.
  intros. rewrite indom_equiv_binds. exists v.
  apply* @binds_write_eq.
Qed.

Lemma indom_write : forall h k k' v',
  indom h k -> indom (write h k' v') k.
Proof using.
  introv. do 2 rewrite indom_equiv_binds.
  introv [v B]. tests: (k = k').
    subst. exists v'. apply* @binds_write_eq.
    exists v. apply* @binds_write_neq.
Qed.

Lemma indom_write_inv : forall h k k' v',
  indom (write h k' v') k -> k <> k' -> indom h k.
Proof using.
  introv. do 2 rewrite indom_equiv_binds.
  introv [v B] N. lets [[? ?]|[? ?]]: @binds_write_inv B.
  false. eauto.
Qed.

(** binds-write *)

Lemma binds_write_eq_inv : forall h k v v',
  binds (write h k v') k v -> v = v'.
Proof using.
  introv B. lets [[? ?]|[? ?]]: @binds_write_inv B; auto_false.
Qed.

Lemma binds_write_neq_inv : forall h k v k' v',
  binds (write h k' v') k v -> k <> k' -> binds h k v.
Proof using.
  introv B. lets [[? ?]|[? ?]]: @binds_write_inv B; auto_false.
Qed.

(** indom-rem *)

Lemma indom_rem : forall h k k',
  indom h k -> k <> k' -> indom (rem h k') k.
Proof using.
  introv. do 2 rewrite indom_equiv_binds.
  introv [v B] N. exists v. apply* @binds_rem.
Qed.

Lemma indom_rem_inv : forall h k k',
  indom (rem h k) k' -> k <> k' /\ indom h k'.
Proof using.
  introv. do 2 rewrite indom_equiv_binds.
  introv [v B]. lets [? ?]: @binds_rem_inv B. eauto.
Qed.

(** read-rem *)

Lemma read_rem_neq : forall h k k',
  indom h k -> k <> k' -> read (rem h k') k = read h k.
Proof using HK HV.
  introv. rewrite indom_equiv_binds. introv [v B] N.
  rewrite (binds_read B).
  forwards B': @binds_rem B N. rewrite~ (binds_read B').
Qed.

(** indom-empty, binds-empty *)

Lemma not_indom_empty : forall k,
  ~ indom (@empty K V) k.
Proof using HV. introv H. unfold indom in H. rewrite dom_empty in H.
  admit. (* TODO: add an instance for in_empty_eq in LibSet.
  apply* in_empty_eq. *)
Qed.

Lemma not_binds_empty : forall k v,
  ~ binds (@empty K V) k v.
Proof using HV. introv H. eapply not_indom_empty. apply* binds_indom. Qed.

(** binds--read_option **)

Lemma binds_read_option : forall h k v,
  binds h k v -> read_option h k = Some v.
Proof using. introv. rewrite* <- @binds_equiv_read_option. Qed.

Lemma read_option_binds : forall h k v,
  read_option h k = Some v -> binds h k v.
Proof using. introv R. rewrite* <- @binds_equiv_read_option in R. Qed.

(** indom--read_option **)

Lemma not_indom_read_option : forall h k,
  ~ indom h k -> read_option h k = None.
Proof using. introv. rewrite not_indom_equiv_read_option. autos*. Qed.

Lemma read_option_not_indom : forall h k,
  read_option h k = None -> ~ indom h k.
Proof using. introv. rewrite not_indom_equiv_read_option. autos*. Qed.

End HeapFacts.


From VST Require Import floyd.proofauto.
From VeriFFI Require Import c.int63.
#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

From VeriFFI Require Import library.modelled.

(*

Definition encode_Z (x: Z): Z := x * 2 + 1.

Module encode_Z.
    Definition min_signed: Z := - 2^62.
    Definition max_signed: Z := 2^62 - 1.

    Lemma bound_iff (x: Z):
        Int64.min_signed <= encode_Z x <= Int64.max_signed <-> min_signed <= x <= max_signed.
    Proof.
        unfold encode_Z.
        unfold min_signed.
        unfold max_signed.
        assert (E: Int64.min_signed = - 2^63). { reflexivity. } rewrite E in * ; clear E.
        assert (E: Int64.max_signed = 2^63 - 1). { reflexivity. } rewrite E in * ; clear E.
        constructor ; lia.
    Qed.

    Lemma bitwise (x: Z):
        encode_Z x = Z.lor 1 (Z.shiftl x 1).
    Proof.
        unfold encode_Z.
        rewrite Z.shiftl_mul_pow2 ; try lia.
        assert (E: 2 ^ 1 = 2). { lia. } rewrite E ; clear E.
        assert (E: x * 2 = 2 * x). { lia. } repeat rewrite E ; clear E.
        assert (E: 2 * x + 1 = 1 + 2 * x). { lia. } repeat rewrite E ; clear E.
        destruct x as [ | x' | x' ] ; try reflexivity.
        destruct x' ; try reflexivity.
    Qed.

    Lemma bound (x: Z) (H: Int64.min_signed <= encode_Z x <= Int64.max_signed):
        Int64.min_signed <= x <= Int64.max_signed.
    Proof.
        unfold encode_Z in *.
        unfold Int64.min_signed in *.
        unfold Int64.max_signed in *.
        constructor ; try lia.
    Qed.

    Lemma tight_bound (x: Z) (Hx: Int64.min_signed <= encode_Z x <= Int64.max_signed):
        Int64.min_signed < encode_Z x <= Int64.max_signed.
    Proof.
        constructor ; try lia.

        destruct Hx as [ Hx_l Hx_h ]. clear Hx_h.
        assert (Hx_l': Int64.min_signed < encode_Z x \/ Int64.min_signed = encode_Z x). { lia. } clear Hx_l. rename Hx_l' into Hx_l.
        destruct Hx_l as [ Hx_l | Hx_l ] ; try assumption.
        unfold encode_Z in *.

        assert (E: x * 2 + 1 = 1 + 2 * x). { lia. } rewrite E in * ; clear E.
        assert (F: Z.even Int64.min_signed = Z.even (1 + 2 * x)). {  congruence. } clear Hx_l.
        rewrite Z.even_add_mul_2 in F.
        inversion F.
    Qed.
End encode_Z.

Definition certicoq_encode_int63_spec: ident * funspec :=
    DECLARE _certicoq_encode_int63
    WITH x: Z, gv: globals
    PRE [ tlong ]
        PROP ( )
        PARAMS (Vlong (Int64.repr x))
        GLOBALS(gv)
        SEP ( )
    POST [ tlong ]
        PROP ( )
        RETURN (Vlong (Int64.repr (encode_Z x)))
        SEP ( ).

Definition certicoq_decode_int63_spec: ident * funspec :=
    DECLARE _certicoq_decode_int63
    WITH x: Z, gv: globals
    PRE [ tlong ]
        PROP (Int64.min_signed <= encode_Z x <= Int64.max_signed)
        PARAMS (Vlong (Int64.repr (encode_Z x)))
        GLOBALS(gv)
        SEP ( )
    POST [ tlong ]
        PROP ( )
        RETURN (Vlong (Int64.repr x))
        SEP ( ).
*)

Definition tvalue := Tlong Signed noattr.
Definition threadinfo := Tstruct _thread_info noattr.

(*
Definition certicoq_prim__int63_zero_spec: ident * funspec :=
    DECLARE _certicoq_prim__int63_zero
    WITH tinfo: val
    PRE [ tptr threadinfo ]
        PROP ()
        PARAMS ( tinfo )
        GLOBALS()
        SEP ( )
    POST [ tlong ]
        PROP ( )
        RETURN (Vlong (Int64.repr 0))
        SEP ( ).

Definition certicoq_prim__int63_one_spec: ident * funspec :=
    DECLARE _certicoq_prim__int63_one
    WITH tinfo: val
    PRE [ tptr threadinfo ]
        PROP ()
        PARAMS ( tinfo )
        GLOBALS()
        SEP ( )
    POST [ tlong ]
        PROP ( )
        RETURN (Vlong (Int64.repr 1))
        SEP ( ).

Definition certicoq_prim__int63_neg_spec: ident * funspec :=
    DECLARE _certicoq_prim__int63_neg
    WITH x: Z, gv: globals
    PRE [ tlong ]
        PROP (
            Int64.min_signed <= encode_Z x <= Int64.max_signed;
            Int64.min_signed <= encode_Z (- x) <= Int64.max_signed
        )
        PARAMS (Vlong (Int64.repr (encode_Z x)))
        GLOBALS(gv)
        SEP ( )
    POST [ tlong ]
        PROP ( )
        RETURN (Vlong (Int64.repr (encode_Z (- x))))
        SEP ( ).

Definition certicoq_prim__int63_abs_spec: ident * funspec :=
    DECLARE _certicoq_prim__int63_abs
    WITH x: Z, gv: globals
    PRE [ tlong ]
        PROP (
            Int64.min_signed <= encode_Z x <= Int64.max_signed;
            Int64.min_signed <= encode_Z (- x) <= Int64.max_signed
        )
        PARAMS (Vlong (Int64.repr (encode_Z x)))
        GLOBALS(gv)
        SEP ( )
    POST [ tlong ]
        PROP ( )
        RETURN (Vlong (Int64.repr (encode_Z (Z.abs x))))
        SEP ( ).
*)

Import IntVerification.

Definition tag63 (x: FM.t) := Vlong (Int64.repr (2*(proj1_sig x)+1)).

Definition certicoq_prim__int63_add_spec: ident * funspec :=
    DECLARE _certicoq_prim__int63_add
    WITH tinfo: val, x: FM.t, y:FM.t
    PRE [ tptr threadinfo, tlong, tlong ]
        PROP ()
        PARAMS (tinfo; tag63 x; tag63 y)
        GLOBALS()
        SEP ( )
    POST [ tlong ]
        PROP ( )
        RETURN (tag63 (FM.add x y))
        SEP ( ).

(*
Definition certicoq_prim__int63_sub_spec: ident * funspec :=
    DECLARE _certicoq_prim__int63_add
    WITH x: FM.t, y:FM.t
    PRE [ tlong, tlong ]
        PROP ()
        PARAMS (tag63 x; tag63 y)
        GLOBALS()
        SEP ( )
    POST [ tlong ]
        PROP ( )
        RETURN (tag63 (FMs.sub x y))
        SEP ( ).
*)

Definition certicoq_prim__int63_mul_spec: ident * funspec :=
    DECLARE _certicoq_prim__int63_mul
    WITH tinfo: val, x: FM.t, y:FM.t
    PRE [ tptr threadinfo, tlong, tlong ]
        PROP ()
        PARAMS (tinfo; tag63 x; tag63 y)
        GLOBALS()
        SEP ( )
    POST [ tlong ]
        PROP ( )
        RETURN (tag63 (FM.mul x y))
        SEP ( ).
(*

Definition certicoq_prim__int63_div_spec: ident * funspec :=
    DECLARE _certicoq_prim__int63_div
    WITH x: Z, y: Z, gv: globals
    PRE [ tlong, tlong ]
        PROP (
            Int64.min_signed <= encode_Z x <= Int64.max_signed;
            Int64.min_signed <= encode_Z y <= Int64.max_signed;
            y <> 0
        )
        PARAMS (
            Vlong (Int64.repr (encode_Z x));
            Vlong (Int64.repr (encode_Z y))
        )
        GLOBALS(gv)
        SEP ( )
    POST [ tlong ]
        PROP ( )
        RETURN (Vlong (Int64.repr (encode_Z (Z.quot x y))))
        SEP ( ).

Definition certicoq_prim__int63_rem_spec: ident * funspec :=
    DECLARE _certicoq_prim__int63_rem
    WITH x: Z, y: Z, gv: globals
    PRE [ tlong, tlong ]
        PROP (
            Int64.min_signed <= encode_Z x <= Int64.max_signed;
            Int64.min_signed <= encode_Z y <= Int64.max_signed;
            y <> 0
        )
        PARAMS (
            Vlong (Int64.repr (encode_Z x));
            Vlong (Int64.repr (encode_Z y))
        )
        GLOBALS(gv)
        SEP ( )
    POST [ tlong ]
        PROP ( )
        RETURN (Vlong (Int64.repr (encode_Z (Z.rem x y))))
        SEP ( ).

Definition certicoq_prim__int63_shiftl_spec: ident * funspec :=
    DECLARE _certicoq_prim__int63_shiftl
    WITH x: Z, y: Z, gv: globals
    PRE [ tlong, tlong ]
        PROP (
            Int64.min_signed <= encode_Z x <= Int64.max_signed;
            Int64.min_signed <= encode_Z y <= Int64.max_signed;
            0 <= x;
            0 <= y < Int64.zwordsize
        )
        PARAMS (
            Vlong (Int64.repr (encode_Z x));
            Vlong (Int64.repr (encode_Z y))
        )
        GLOBALS(gv)
        SEP ( )
    POST [ tlong ]
        PROP ( )
        RETURN (Vlong (Int64.repr (encode_Z (Z.shiftl x y))))
        SEP ( ).

Definition certicoq_prim__int63_shiftr_spec: ident * funspec :=
    DECLARE _certicoq_prim__int63_shiftr
    WITH x: Z, y: Z, gv: globals
    PRE [ tlong, tlong ]
        PROP (
            Int64.min_signed <= encode_Z x <= Int64.max_signed;
            Int64.min_signed <= encode_Z y <= Int64.max_signed;
            0 <= y < Int64.zwordsize
        )
        PARAMS (
            Vlong (Int64.repr (encode_Z x));
            Vlong (Int64.repr (encode_Z y))
        )
        GLOBALS(gv)
        SEP ( )
    POST [ tlong ]
        PROP ( )
        RETURN (Vlong (Int64.repr (encode_Z (Z.shiftr x y))))
        SEP ( ).

Definition certicoq_prim__int63_or_spec: ident * funspec :=
    DECLARE _certicoq_prim__int63_or
    WITH x: Z, y: Z, gv: globals
    PRE [ tlong, tlong ]
        PROP (
            Int64.min_signed <= encode_Z x <= Int64.max_signed;
            Int64.min_signed <= encode_Z y <= Int64.max_signed
        )
        PARAMS (
            Vlong (Int64.repr (encode_Z x));
            Vlong (Int64.repr (encode_Z y))
        )
        GLOBALS(gv)
        SEP ( )
    POST [ tlong ]
        PROP ( )
        RETURN (Vlong (Int64.repr (encode_Z (Z.lor x y))))
        SEP ( ).

Definition certicoq_prim__int63_and_spec: ident * funspec :=
    DECLARE _certicoq_prim__int63_and
    WITH x: Z, y: Z, gv: globals
    PRE [ tlong, tlong ]
        PROP (
            Int64.min_signed <= encode_Z x <= Int64.max_signed;
            Int64.min_signed <= encode_Z y <= Int64.max_signed
        )
        PARAMS (
            Vlong (Int64.repr (encode_Z x));
            Vlong (Int64.repr (encode_Z y))
        )
        GLOBALS(gv)
        SEP ( )
    POST [ tlong ]
        PROP ( )
        RETURN (Vlong (Int64.repr (encode_Z (Z.land x y))))
        SEP ( ).

Definition certicoq_prim__int63_xor_spec: ident * funspec :=
    DECLARE _certicoq_prim__int63_xor
    WITH x: Z, y: Z, gv: globals
    PRE [ tlong, tlong ]
        PROP (
            Int64.min_signed <= encode_Z x <= Int64.max_signed;
            Int64.min_signed <= encode_Z y <= Int64.max_signed
        )
        PARAMS (
            Vlong (Int64.repr (encode_Z x));
            Vlong (Int64.repr (encode_Z y))
        )
        GLOBALS(gv)
        SEP ( )
    POST [ tlong ]
        PROP ( )
        RETURN (Vlong (Int64.repr (encode_Z (Z.lxor x y))))
        SEP ( ).

Definition certicoq_prim__int63_not_spec: ident * funspec :=
    DECLARE _certicoq_prim__int63_not
    WITH x: Z, gv: globals
    PRE [ tlong ]
        PROP (Int64.min_signed <= encode_Z x <= Int64.max_signed)
        PARAMS (Vlong (Int64.repr (encode_Z x)))
        GLOBALS(gv)
        SEP ( )
    POST [ tlong ]
        PROP ( )
        RETURN (Vlong (Int64.repr (encode_Z (Z.lnot x))))
        SEP ( ).
*)

Definition ASI: funspecs := [
(*
    certicoq_decode_int63_spec;
    certicoq_encode_int63_spec;
    certicoq_prim__int63_zero_spec;
    certicoq_prim__int63_one_spec;
    certicoq_prim__int63_neg_spec;
    certicoq_prim__int63_abs_spec;
*)
    certicoq_prim__int63_add_spec;
(*
    certicoq_prim__int63_sub_spec;
*)
    certicoq_prim__int63_mul_spec
(*
    certicoq_prim__int63_div_spec;
    certicoq_prim__int63_rem_spec;
    certicoq_prim__int63_shiftl_spec;
    certicoq_prim__int63_shiftr_spec;
    certicoq_prim__int63_or_spec;
    certicoq_prim__int63_and_spec;
    certicoq_prim__int63_xor_spec;
    certicoq_prim__int63_not_spec
*)
].


Require Import stdpp.list.
Require Import ssreflect.
From Tweetnacl Require Import Libs.Export.
From Tweetnacl Require Import ListsOp.Export.
From Tweetnacl Require Export Mid.SumList.

Open Scope Z.

Section Integer.

Variable n:Z.
Hypothesis Hn: n > 0.

Notation "ℤ.lst A" := (ZofList n A) (at level 65, right associativity).

Lemma ZsumList_correct_impl : forall a b o, a ⊕ b = o -> (ℤ.lst a) + (ℤ.lst b) = ℤ.lst o.
Proof.
  induction a , b.
  - intros o HSum ; go.
  - intros o HSum ; go.
  - intros o HSum ; go.
  - intros o HSum.
    destruct o ; go.
    simpl in HSum.
    assert(Hh:= HSum).
    simplify_list_eq.
    rewrite <- Z.add_shuffle2.
    rewrite Zred_factor4.
    apply Zplus_eq_compat.
    f_equal.
    rewrite Z.add_comm.
    erewrite IHa ; eauto.
Qed.

Corollary ZsumList_correct: forall a b, (ℤ.lst a ⊕ b) = (ℤ.lst a) + (ℤ.lst b).
Proof.
  intros a b.
  assert(exists o, o = a ⊕ b) by (exists (a ⊕ b) ; go) ; destruct H.
  symmetry; subst x ; apply ZsumList_correct_impl ; go.
Qed.

Lemma ZsumList_bound_lt: forall m1 n1 m2 n2 a b,
  (fun x => m1 < x < n1) 0 ->
  (fun x => m2 < x < n2) 0 ->
  Forall (fun x => m1 < x < n1) a ->
  Forall (fun x => m2 < x < n2) b ->
  Forall (fun x => m1 + m2 < x < n1 + n2) (a ⊕ b).
Proof.
  introv Hmn1 Hmn2 Ha Hb.
  rewrite ZsumList_Zipp_eq.
  eapply (Forall_Zipp_0 _ (fun x : ℤ => m1 < x < n1) (fun x : ℤ => m2 < x < n2)) ; go.
Qed.

Lemma ZsumList_bound_le: forall m1 n1 m2 n2 a b,
  (fun x => m1 <= x <= n1) 0 ->
  (fun x => m2 <= x <= n2) 0 ->
  Forall (fun x => m1 <= x <= n1) a ->
  Forall (fun x => m2 <= x <= n2) b ->
  Forall (fun x => m1 + m2 <= x <= n1 + n2) (a ⊕ b).
Proof.
  introv Hmn1 Hmn2 Ha Hb.
  rewrite ZsumList_Zipp_eq.
  eapply (Forall_Zipp_0 _ (fun x : ℤ => m1 <= x <= n1) (fun x : ℤ => m2 <= x <= n2)) ; go.
Qed.

Lemma ZsumList_bound_lenght_lt: forall m1 n1 m2 n2 a b,
  length a = length b ->
  Forall (fun x => m1 < x < n1) a ->
  Forall (fun x => m2 < x < n2) b ->
  Forall (fun x => m1 + m2 < x < n1 + n2) (a ⊕ b).
Proof.
  introv Hl Ha Hb.
  rewrite ZsumList_Zipp_eq.
  eapply (Forall_Zipp_length _ (fun x : ℤ => m1 < x < n1) (fun x : ℤ => m2 < x < n2)) ; go.
Qed.

Lemma ZsumList_bound_Zlength_lt: forall m1 n1 m2 n2 a b,
  Zlength a = Zlength b ->
  Forall (fun x => m1 < x < n1) a ->
  Forall (fun x => m2 < x < n2) b ->
  Forall (fun x => m1 + m2 < x < n1 + n2) (a ⊕ b).
Proof. convert_length_to_Zlength ZsumList_bound_lenght_lt. Qed.

Lemma ZsumList_bound_length_le: forall m1 n1 m2 n2 a b,
  length a = length b ->
  Forall (fun x => m1 <= x <= n1) a ->
  Forall (fun x => m2 <= x <= n2) b ->
  Forall (fun x => m1 + m2 <= x <= n1 + n2) (a ⊕ b).
Proof.
  introv Hl Ha Hb.
  rewrite ZsumList_Zipp_eq.
  eapply (Forall_Zipp_length _ (fun x : ℤ => m1 <= x <= n1) (fun x : ℤ => m2 <= x <= n2)) ; go.
Qed.

Lemma ZsumList_bound_Zlength_le: forall m1 n1 m2 n2 a b,
  Zlength a = Zlength b ->
  Forall (fun x => m1 <= x <= n1) a ->
  Forall (fun x => m2 <= x <= n2) b ->
  Forall (fun x => m1 + m2 <= x <= n1 + n2) (a ⊕ b).
Proof. convert_length_to_Zlength ZsumList_bound_length_le. Qed.

End Integer.

Close Scope Z.

Module Low.

Definition A a b := ZsumList a b.

End Low.

Lemma A_length : forall a b,
  length a = 16 ->
  length b = 16 ->
  length (Low.A a b) = 16.
Proof. intros; rewrite ZsumList_length_max H H0 //. Qed.

Open Scope Z.

Lemma A_correct: forall n a b, ZofList n (Low.A a b) = (ZofList n a) + (ZofList n b).
Proof.
  intros n a b.
  rewrite /A.
  apply ZsumList_correct.
Qed.

Lemma A_Zlength : forall a b,
  Zlength a = 16 ->
  Zlength b = 16 ->
  Zlength (Low.A a b) = 16.
Proof. intros; rewrite ZsumList_Zlength_max H H0 //. Qed.

Lemma A_bound_length_le : forall m1 n1 m2 n2 a b,
  length a = length b ->
  Forall (fun x => m1 <= x <= n1) a ->
  Forall (fun x => m2 <= x <= n2) b ->
  Forall (fun x => m1 + m2 <= x <= n1 + n2) (Low.A a b).
Proof. intros; apply ZsumList_bound_length_le ; auto. Qed.

Lemma A_bound_Zlength_le : forall m1 n1 m2 n2 a b,
  Zlength a = Zlength b ->
  Forall (fun x => m1 <= x <= n1) a ->
  Forall (fun x => m2 <= x <= n2) b ->
  Forall (fun x => m1 + m2 <= x <= n1 + n2) (Low.A a b).
Proof. intros; apply ZsumList_bound_Zlength_le ; auto. Qed.

Lemma A_bound_Zlength_lt : forall m1 n1 m2 n2 a b,
  Zlength a = Zlength b ->
  Forall (fun x => m1 < x < n1) a ->
  Forall (fun x => m2 < x < n2) b ->
  Forall (fun x => m1 + m2 < x < n1 + n2) (Low.A a b).
Proof. intros; apply ZsumList_bound_Zlength_lt ; auto. Qed.

Close Scope Z.


Set Implicit Arguments.
Require Export PQSig.
Require Export skewBinaryHeap.

Module SBHeapVerify (OO:Order) <: PQVerify.

Module PQS := SkewBinaryHeap(OO).
Export PQS.

Definition check (same:DER LEQ) (x y:A) :=
  match same with
    | exist f _ => f x y
  end.

Fixpoint countTree (same:A -> A -> bool) x l :=
  match l with
    | Node v _ c =>
      let r := fold_right plus 0 (map (countTree same x) c)
        in if same x v
          then S r
          else r
  end.

Fixpoint size (l:preT) :=
  match l with
    | Node _ _ c =>
      S (fold_right plus 0 (map size c))
  end.

Lemma sizePos :
  forall x, size x > 0.
Proof.
  intros; destruct x; simpl; auto with arith.
Qed.
Hint Resolve sizePos.

Lemma preT_nest_ind :
  forall P : preT -> Prop,
    (forall a n, P (Node _ a n [])) ->
    (forall a n x l, P (Node _ a n l) -> P x -> P (Node _ a n (x::l))) ->
    forall v, P v.
Proof.
  intros P emp ful v.
  generalize dependent P.
  pose well_founded_ind as i.
  pose (i _ (ltof preT size)) as j.
  pose (j (well_founded_ltof _ _)) as k.
  intros; apply k.
  clear k j i. intros.
  unfold ltof in H.
  destruct x.
  destruct l.
  auto.
  apply ful.
  apply H.
  simpl.
  assert (size p > 0); auto.
  omega.
  apply H.
  simpl. omega.
Qed.

Lemma countTreeSAME :
  forall same x y,
    DERP LEQ same ->
    same x y = true ->
    forall inp, countTree same x inp = countTree same y inp.
Proof.
  intros f x y d ST.
  destruct d as [leq [refl [symm trans]]].
  apply preT_nest_ind.
  simpl. intros a n.
  remember (f x a) as xa; remember (f y a) as ya;
    destruct xa; destruct ya; auto.
  assert False as fa.
  assert (true = f y a).
  eapply trans. symmetry. rewrite symm. eauto.
  auto.
  rewrite <- H in Heqya. inversion Heqya. inversion fa.
  assert False as fa.
  assert (true = f x a).
  eapply trans. symmetry. eauto.
  auto.
  rewrite <- H in Heqxa. inversion Heqxa. inversion fa.
  intros.
  simpl.
  simpl in H.
  remember (f x a) as xa; remember (f y a) as ya;
    destruct xa; destruct ya; auto.
  rewrite H0. rewrite <- H.
  omega.
  rewrite H0.
  rewrite H.
  omega.
Qed.

Definition preCount f x l :=
  fold_right plus 0 (map (countTree f x) l).
Hint Unfold preCount.

Definition count (same:DER LEQ) x (l:PQ) :=
  match same, l with
    | exist f _, exist v _ => preCount f x v
  end.

Lemma countSAME :
  forall same x y,
    check same x y = true ->
    forall inp, count same x inp = count same y inp.
Proof.
  intros same x y xy inp.
  destruct same; simpl in *.
  destruct inp; simpl in *.
  clear p; induction x1.
  simpl. auto.
  unfold preCount in *. simpl.
  erewrite countTreeSAME. Focus 3. eauto.
  omega. auto.
Qed.

Lemma emptyCount :
  forall same x, count same x empty = 0.
Proof.
  simpl; intros.
  unfold empty. simpl.
  unfold count. simpl.
  destruct same; simpl; auto.
Qed.

Lemma preInsertCount :
  forall f x p y,
    preCount f x (preInsert y p) =
    (let old := preCount f x p in
      if f x y
        then S old
        else old).
Proof.
  intros.
  destruct p.
  simpl.
  unfold preCount.
  remember (f x y) as fxy; destruct fxy; simpl.
  rewrite <- Heqfxy; auto.
  rewrite <- Heqfxy; auto.
  unfold preCount.
  unfold preInsert.
  destruct p0.
  simpl.
  remember (f x y) as fxy; destruct fxy; simpl; auto.
  simpl.
  destruct p; destruct p0; simpl.
  remember (beq_nat n n0) as nn0; destruct nn0; simpl; auto; try omega;
  remember (LEQ y a) as ya; destruct ya; simpl; auto; try omega;
  remember (LEQ y a0) as ya0; destruct ya0; simpl; auto; try omega;
  remember (LEQ a a0) as aa0; destruct aa0; simpl; auto; try omega;
  remember (f x y) as xy; destruct xy; simpl; auto; try omega;
  remember (f x a) as xa; destruct xa; simpl; auto; try omega;
  remember (f x a0) as xa0; destruct xa0; simpl; auto; try omega.
Qed.

Lemma insertCount :
  forall same x inp y,
    count same x (insert y inp) =
    let oldCount := count same x inp in
      if check same x y
        then S oldCount
        else oldCount.
Proof.
  intros.
  destruct same; destruct inp.
  unfold count; simpl.
  apply preInsertCount.
Qed.

(*
Lemma insertCount :
  forall same x inp,
    let oldCount := count same x inp in
      forall y,
        count same x (insert y inp) =
        if check same x y
          then S oldCount
          else oldCount.
Proof.
  intros.
  destruct inp.
  destruct same.
  simpl in *. unfold preCount in *; simpl in *.
  unfold preInsert. simpl.
  destruct x0; simpl in *.
  destruct (x1 x y); auto.
  destruct x0; simpl in *.
  destruct (x1 x y); auto.
  destruct p0; destruct p1; simpl in *.
  unfold oldCount;
  remember (beq_nat n n0) as nn0; destruct nn0; simpl; auto; try omega;
  remember (LEQ y a) as ya; destruct ya; simpl; auto; try omega;
  remember (LEQ y a0) as ya0; destruct ya0; simpl; auto; try omega;
  remember (LEQ a a0) as aa0; destruct aa0; simpl; auto; try omega;
  remember (x1 x y) as xy; destruct xy; simpl; auto; try omega;
  remember (x1 x a) as xa; destruct xa; simpl; auto; try omega;
  remember (x1 x a0) as xa0; destruct xa0; simpl; auto; try omega.
Qed.
*)

Lemma minHeapCount :
  forall x,
    minHeap x ->
    forall same y,
      DERP LEQ same ->
      countTree same y x > 0 ->
      LEQ (root x) y = true.
Proof.

  pose preT_nest_ind as i.
  pose (fun z => minHeap z -> forall same y, DERP LEQ same -> countTree same y z > 0 -> LEQ (root z) y = true) as P.
  pose (i P) as j.
  unfold P in j.
  apply j; unfold P. intros; clear i P j.
  simpl in *.
  remember (same y a) as ya; destruct ya.
  destruct H0. symmetry.
  replace true with (LEQ a a).
  apply H0; auto. destruct H2. destruct H3. rewrite H3. auto.
  symmetry.
  apply leqRefl.
  inversion H1.
  clear i P j.
  simpl. intros.
  remember (same y a) as ya; destruct ya.
  destruct H2.
  replace true with (LEQ a a).
  apply H2; auto.
  symmetry.
  apply leqRefl.
  remember (countTree same y x) as yx; destruct yx.
  eapply H.
  inversion_clear H1; subst; auto.
  inversion_clear H4; subst; eauto.
  eauto.
  rewrite <- Heqya. omega.
  inversion H1; subst.
  symmetry.
  eapply leqTransTrue with (y := w).
  auto.
  symmetry.
  eapply H0.
  inversion H10; subst; eauto. eauto.
  omega.
Qed.

Lemma preFindFirst :
  forall v i c a ps,
    true = LEQ v (preFindMinHelp a ps) ->
    v = preFindMinHelp (Node _ v i c) ps.
Proof.
  intros.
  induction ps.
  simpl. auto.
  simpl.
  rename a0 into z.
  simpl in H.
  remember (LEQ (root a) (preFindMinHelp z ps)) as azps; destruct azps;
  remember (LEQ v (preFindMinHelp z ps)) as vzps; destruct vzps.
  auto.
  Focus 2. auto.
  Focus 2. inversion H.
  assert (true = LEQ v (preFindMinHelp z ps)).
  eapply leqTransTrue; eauto.
  rewrite <-H0 in Heqvzps. inversion Heqvzps.
Qed.

Lemma findMinHelpCount :
  forall ps, All minHeap ps ->
    forall p, minHeap p ->
    let x := preFindMinHelp p ps in
      forall f (D:DERP LEQ f) y,
        if check (exist _ f D) y x
          then fold_right plus 0 (map (countTree f y) (p::ps)) > 0
          else fold_right plus 0 (map (countTree f y) (p::ps)) > 0 ->
            LEQ x y = true.
Proof.
  induction ps; simpl; intros.
  destruct p; simpl.
  remember (f y a) as ya; destruct ya.
  auto with arith.
  intros.
  replace a with (root (Node _ a n l)) by auto.
  eapply minHeapCount. auto. eauto.
  simpl. rewrite <- Heqya. omega.
  destruct p as [v i c]; simpl.
  remember (countTree f y (Node _ v i c)) as yvic. destruct yvic.
  remember (LEQ v (preFindMinHelp a ps)) as vaps; destruct vaps.
  remember (f y v) as yv; destruct yv.
  auto with arith.
  intros.
  simpl in IHps.
  inversion H; subst.
  remember (f y (preFindMinHelp a ps)) as yaps; destruct yaps.
  symmetry.
  eapply leqTransTrue. eauto.
  destruct D as [E [F [G I]]].
  replace true with (LEQ y y).
  apply E. auto.
  symmetry.
  apply leqRefl.
  remember (f y (preFindMinHelp (Node _ v i c) ps)) as yvps; destruct yvps.
  pose (@IHps H5 _ H0 _ D y) as j.
  rewrite <- Heqyvps in j.
  assert (v = preFindMinHelp (Node _ v i c) ps) as T.
  eapply preFindFirst. eauto.
  rewrite <- T in Heqyvps.
  destruct D as [E [F [G I]]].
  symmetry.
  replace true with (LEQ y y).
  apply E. auto.
  symmetry. apply leqRefl.
  pose (@IHps H5 _ H4 _ D y) as j.
  rewrite <- Heqyaps in j.
  symmetry.
  eapply leqTransTrue.
  eauto.
  symmetry.
  apply j. simpl in Heqyvic.
  rewrite <- Heqyv in Heqyvic. omega.
  remember (f y (preFindMinHelp a ps)) as yaps; destruct yaps;
    remember (f y v) as yv; destruct yv.
  auto with arith.
  inversion H; subst.
  pose (@IHps H4 _ H3 _ D y) as j.
  simpl in j.
  rewrite <- Heqyaps in j.
  omega.
  intros.
  symmetry.
  eapply leqSymm.

  Focus 2.

  simpl in Heqyvic.
  rewrite <- Heqyv in Heqyvic.
  rewrite <- Heqyvic. simpl.
  intros.
  inversion H; subst.
  pose (@IHps H5 _ H4 _ D y) as j.
  simpl in j.
  rewrite <- Heqyaps in j.
  apply j. auto.

  Focus 2.

  remember (LEQ v (preFindMinHelp a ps)) as vaps; destruct vaps.
  remember (f y v) as yv; destruct yv.
  auto with arith.
  intros.
  simpl in IHps.
  inversion H; subst.
  remember (f y (preFindMinHelp a ps)) as yaps; destruct yaps.
  symmetry.
  eapply leqTransTrue. eauto.
  destruct D as [E [F [G I]]].
  replace true with (LEQ y y).
  apply E. auto.
  symmetry. apply leqRefl.
  remember (f y (preFindMinHelp (Node _ v i c) ps)) as yvps; destruct yvps.
  pose (@IHps H5 _ H0 _ D y) as j.
  rewrite <- Heqyvps in j.
  assert (v = preFindMinHelp (Node _ v i c) ps) as T.
  eapply preFindFirst. eauto.
  rewrite <- T in Heqyvps.
  destruct D as [E [F [G I]]].
  symmetry.
  replace true with (LEQ y y).
  apply E. auto.
  symmetry. apply leqRefl.
  replace v with (root (Node _ v i c)) by auto.
  eapply minHeapCount. auto. eauto. omega.
  remember (f y (preFindMinHelp a ps)) as yaps; destruct yaps;
    remember (f y v) as yv; destruct yv.
  auto with arith.
  simpl in Heqyvic. rewrite <- Heqyv in Heqyvic.
  rewrite <- Heqyvic. auto with arith.
  intros.
  symmetry.
  eapply leqTransTrue.
  eapply leqSymm. eauto.
  replace v with (root (Node _ v i c)) by auto.
  symmetry.
  eapply minHeapCount. auto. eauto. omega.
  intros.
  symmetry.
  eapply leqTransTrue.
  eapply leqSymm. eauto.
  replace v with (root (Node _ v i c)) by auto.
  symmetry.
  eapply minHeapCount. auto. eauto. omega.

  destruct D as [E [F [G I]]].
  replace false with (LEQ v (preFindMinHelp a ps)).
  apply E.
  rewrite G. auto.
Qed.

Lemma findMinCount :
  forall inp,
    match findMin inp with
      | None => forall same x, count same x inp = 0
      | Some x =>
        forall same y,
          if check same y x
            then count same y inp > 0
            else count same y inp > 0 ->
              LEQ x y = true
    end.
Proof.
  intros p.
  destruct p.
  destruct p.
  destruct x.
  simpl.
  intros.
  destruct same.
  simpl. auto.
  simpl.
  intros.
  destruct same.
  eapply findMinHelpCount.
  inversion a; subst. auto.
  inversion a; subst. auto.
Qed.

Lemma linkCount :
  forall f x p q,
    countTree f x (link p q)
    = countTree f x p
    + countTree f x q.
Proof.
  intros; unfold link.
  destruct p; destruct q.
  remember (LEQ a a0) as aa0; destruct aa0; simpl; auto.
  remember (f x a) as xa; destruct xa;
    remember (f x a0) as xa0; destruct xa0;
      simpl; auto; try omega.
  remember (f x a) as xa; destruct xa;
    remember (f x a0) as xa0; destruct xa0;
      simpl; auto; try omega.
Qed.

Lemma insCount :
  forall f x p ps,
    preCount f x (ins p ps)
    = countTree f x p
    + preCount f x ps.
Proof.
  intros f x p ps.
  generalize dependent p.
  induction ps; simpl; auto.
  intros.
  remember (nat_compare (rank p) (rank a)) as pa; destruct pa.
  rewrite IHps.
  rewrite linkCount. unfold preCount; simpl; omega.
  unfold preCount; simpl; omega.
  rewrite IHps.
  rewrite linkCount. unfold preCount; simpl; omega.
Qed.

Lemma meldUniqCount :
  forall p q x f,
    preCount f x (meldUniq (p,q))
    = preCount f x p
    + preCount f x q.
Proof.
  pose (fun (xy:preQ*preQ) r =>
    let (x,y) := xy in
      forall z f,
        preCount f z r
        = preCount f z x
        + preCount f z y) as P.
  assert (forall xy, P xy (meldUniq xy)) as ans.
  eapply meldUniq_ind; unfold P; clear P; simpl; intros; auto.
  unfold preCount in *; simpl in *.
  rewrite H.
  omega.
  unfold preCount in *; simpl in *.
  rewrite H.
  omega.
  rewrite insCount.
  rewrite H.
  rewrite linkCount.
  unfold preCount; simpl; omega.
  unfold P in ans; clear P; intros.
  eapply (ans (p,q)).
Qed.

Lemma insNotNil :
  forall x xs,
    ins x xs <> [].
Proof.
  unfold not; intros; generalize dependent x; induction xs; intros.
  simpl in H. inversion H.
  simpl in H.
  remember (nat_compare (rank x) (rank a)) as xa; destruct xa.
  eapply IHxs. eauto.
  inversion H.
  eapply IHxs. eauto.
Qed.

Lemma preMeldCount :
  forall f p q x,
    preCount f x (preMeld p q)
    = preCount f x p
    + preCount f x q.
Proof.
  intros.
  unfold preMeld.
  unfold uniqify.
  destruct p; destruct q; simpl.
  rewrite meldUniq_equation; auto.
  rewrite meldUniq_equation. rewrite insCount; unfold preCount; simpl.
  auto.
  rewrite meldUniq_equation.
  remember (ins p p0) as px; destruct px.
  assert False as ff.
  eapply insNotNil. eauto.
  inversion ff.
  rewrite Heqpx.
  rewrite insCount.
  unfold preCount; simpl; auto.
  rewrite meldUniqCount.
  rewrite insCount.
  rewrite insCount.
  unfold preCount; simpl; omega.
Qed.

Lemma meldCount :
  forall same inp inq x,
    count same x (meld inp inq) = count same x inp
                                + count same x inq.
Proof.
  intros; destruct same; destruct inp; destruct inq;
    unfold count; unfold meld; simpl.
  apply preMeldCount.
Qed.

Lemma getFindMin :
  forall xs x y z,
    (y,z) = getMin x xs ->
    root y = preFindMinHelp x xs.
Proof.
  induction xs; simpl; intros.
  inversion H; subst; auto.
  remember (getMin a xs) as gaxs; destruct gaxs.
  assert (root p = preFindMinHelp a xs). eapply IHxs. eauto.
  rewrite <- H0.
  remember (LEQ (root x) (root p)) as xp; destruct xp.
  inversion H; auto.
  inversion H; auto.
Qed.

Lemma getMinCount :
  forall xs x y z,
    (y,z) = getMin x xs ->
    forall f a,
      countTree f a x + preCount f a xs =
      countTree f a y + preCount f a z.
Proof.
  induction xs; simpl; intros.
  inversion_clear H; subst. auto.
  remember (getMin a xs) as tts; destruct tts.
  remember (LEQ (root x) (root p)) as xp; destruct xp;
    inversion_clear H; subst; unfold preCount; simpl.
  auto.
  pose (IHxs _ _ _ Heqtts) as I.
  unfold preCount in I.
  rewrite I. omega.
Qed.

Fixpoint countList (f:A -> A -> bool) x l :=
  match l with
    | [] => 0
    | y::ys =>
      if f x y
        then S (countList f x ys)
        else countList f x ys
  end.

Lemma splitCount :
  forall c,
    All rankP c ->
    forall a b d e,
      (d,e) = split a b c ->
        forall f x,
          preCount f x d +
          countList f x e =
          preCount f x a +
          countList f x b +
          preCount f x c.
Proof.
  induction c; simpl; intros.
  inversion_clear H0; subst.
  unfold preCount at 3.
  simpl. auto.
  destruct a; simpl in H0.
  destruct n.
  inversion_clear H; subst.
  pose (IHc H2 _ _ _ _ H0) as I.
  rewrite I.
  unfold rankP in H1.
  simpl in H1.
  inversion H1; subst.
  simpl in H1.
  unfold countList at 1.
  fold (countList f x b).
  unfold preCount at 4.
  simpl.
  remember (f x a) as xa; destruct xa; try omega.
  unfold preCount at 2. omega.
  unfold preCount at 2. omega.
  inversion_clear H; subst.
  pose (IHc H2 _ _ _ _ H0) as I.
  rewrite I.
  unfold preCount at 1.
  simpl.
  unfold preCount at 3.
  simpl.
  remember (f x a) as xa; destruct xa; try omega.
  unfold preCount; simpl; omega.
  unfold preCount; simpl; omega.
Qed.

Lemma foldInsertCount :
  forall l f x q,
    preCount f x (fold_right preInsert q l)
    = preCount f x q
    + countList f x l.
Proof.
  induction l; intros; simpl.
  auto.
  rewrite preInsertCount.
  simpl.
  rewrite IHl.
  remember (f x a) as fxa; destruct fxa; auto.
Qed.

Lemma rankChildren :
  forall n v c,
    rankP (Node _ v n c) ->
    All rankP c.
Proof.
  induction n; unfold rankP; simpl; intros.
  inversion_clear H; subst; simpl; auto.
  inversion H; subst.
  apply Cons. destruct y. simpl.
  inversion H; subst.
  assert (n0 = n). eapply rankDestruct. eauto.
  subst. auto.
  assert (n0 = n). eapply rankDestruct. eauto.
  subst. auto.
  auto.
  fold rankP.
  eapply IHn.
  eauto.
  fold rankP.
  destruct x; destruct z.
  assert (n0 = n). eapply rankDestruct. eauto.
  subst.
  assert (n1 = n). eapply rankDestruct. eauto.
  subst.
  repeat (apply Cons); unfold rankP; simpl; auto.
  inversion H; subst.
  apply Cons. auto.
  eapply IHn; auto. eauto.
  repeat (apply Cons).
  auto.
  destruct y.
  assert (n0 = n). eapply rankDestruct. eauto.
  subst. auto.
  auto.
  apply Cons. auto.
  apply Cons. destruct y.
  assert (n0 = n). eapply rankDestruct. eauto.
  subst. auto.
  eapply IHn. eauto.
Qed.

Lemma deleteMinCount :
  forall inp,
    match findMin inp with
      | None => forall same x, count same x (deleteMin inp) = 0
      | Some x =>
        forall same y,
          let newCount := count same y (deleteMin inp) in
            count same y inp =
            if check same y x
              then S newCount
              else newCount
    end.
Proof.
  intros p.
  destruct p.
  unfold findMin; simpl.
  destruct x; unfold preFindMin.
  simpl; intros.
  unfold count. destruct same; simpl.
  unfold preCount; simpl. auto.
  remember (getMin p0 x) as pox; destruct pox.
  destruct p1; simpl.
  remember (split [] [] l0) as sl; destruct sl.
  unfold deleteMin.
  unfold preDeleteMin. simpl.
  erewrite <- getFindMin. Focus 2. eauto.
  simpl. unfold count; simpl.
  intros.
  destruct same.
  unfold check; simpl.
  unfold preCount. simpl.
  rewrite <- Heqpox.
  rewrite <- Heqsl.

  simpl.
  pose foldInsertCount as fic.
  unfold preCount in fic.
  rewrite fic.
  pose preMeldCount as pmc.
  unfold preCount in pmc.
  rewrite pmc.
  remember (x0 y a) as ya; destruct ya.
  pose (getMinCount _ _ Heqpox) as gmc.
  unfold preCount in gmc.
  rewrite gmc.
  pose Heqpox as oth.
  apply getMinTRank in oth.
  assert (All rankP l0) as J.
  eapply rankChildren.
  eapply getMinTRank. Focus 2. eauto.
  destruct p; auto.
  pose (splitCount J _ _ Heqsl) as sc.
  simpl in sc.
  unfold countTree at 1.
  fold countTree. simpl.
  unfold preCount in sc.
  rewrite <- sc.
  rewrite <- Heqya. omega.
  destruct p; auto.
  pose (getMinCount _ _ Heqpox) as gmc.
  unfold preCount in gmc.
  rewrite gmc.
  pose Heqpox as oth.
  apply getMinTRank in oth.
  assert (All rankP l0) as J.
  eapply rankChildren.
  eapply getMinTRank. Focus 2. eauto.
  destruct p; auto.
  pose (splitCount J _ _ Heqsl) as sc.
  simpl in sc.
  unfold countTree at 1.
  fold countTree. simpl.
  unfold preCount in sc.
  rewrite <- sc.
  rewrite <- Heqya. omega.
  destruct p; auto.
Qed.

Lemma extractMinCount :
  forall inp,
    match findMin inp with
      | None => None = extractMin inp
      | Some x => exists z,
        Some (x,z) = extractMin inp
        /\ forall same y,
          count same y z = count same y (deleteMin inp)
    end.
Proof.
  intros p.
  destruct p.
  unfold findMin.
  simpl. fold (extractMin (exist _ x p)).
  destruct x; unfold preFindMin.
  unfold extractMin. simpl. auto.
  remember (extractMin (exist PQP (p0::x) p)) as pppp.
  destruct pppp.
  destruct p1.
  exists p1.
  split.
  destruct p1.
  eapply extractMin_equality in Heqpppp.
  f_equal.
  unfold preExtractMin in Heqpppp.
  remember (getMin p0 x) as pox; destruct pox.
  destruct p2.
  apply getFindMin in Heqpox.
  simpl in Heqpox.
  rewrite <- Heqpox.
  inversion Heqpppp.
  auto.
  destruct p1.
  eapply extractMin_equality in Heqpppp.
  unfold count; simpl.
  intros.
  destruct same.
  unfold preExtractMin in Heqpppp.
  remember (getMin p0 x) as pox; destruct pox.
  destruct p2.
  inversion Heqpppp.
  auto.
  apply extractMin_none in Heqpppp.
  unfold extractMin in Heqpppp.
  unfold preExtractMin in Heqpppp.
  simpl in Heqpppp.
  inversion Heqpppp.
Qed.

End SBHeapVerify.


(* Written by Sosuke Moriguchi (chiguri), Kwansei Gakuin University *)

(** * Network sample : half-line topology (unbound) *)

Require Import List.
Import ListNotations.

Require CCNTopology.

Module CCN_Line <: CCNTopology.CCN_Network.

Definition Node := nat.

Definition Node_eq_dec : forall v1 v2 : Node, {v1 = v2} + {v1 <> v2}.
intros; decide equality.
Qed.

Definition Connected_list (v : Node) : list Node :=
match v with
| O => [ 1 ]
| S v' => [v'; S v]
end.

Definition Connected v1 v2 := In v2 (Connected_list v1).

Lemma Connected_sym : forall v1 v2 : Node, Connected v1 v2 -> Connected v2 v1.
unfold Connected; intros; destruct v1; simpl in *.
 destruct H as [ H | [] ]; subst.
  simpl; auto.
 destruct H as [ H | [ H | [] ] ]; subst.
  unfold Connected_list; destruct v2; simpl; auto.
  unfold Connected_list; destruct v1; simpl; auto.
Qed.

Definition Content_Name := nat.

Lemma Content_Name_eq_dec : forall c1 c2 : Content_Name, {c1 = c2} + {c1 <> c2}.
decide equality.
Qed.

(** Content body : we do not care what it is. *)
Variable Content : Content_Name -> Set.

(** The end point has all contents *)
Definition InitCS (v : Node) (c : Content_Name) := v = 0.

Lemma InitCS_dec : forall (v : Node) (c : Content_Name), {InitCS v c} + {~ InitCS v c}.
intros; unfold InitCS; apply Node_eq_dec.
Qed.

Axiom InitContent_Data : forall (v : Node) (c : Content_Name), InitCS v c -> Content c.

Definition FIB_list (v : Node) (c : Content_Name) : list Node :=
match v with
| O => nil
| S v' => [ v' ]
end.

Definition FIB (v1 : Node) (c : Content_Name) (v2 : Node) := In v2 (FIB_list v1 c).

Lemma FIB_Connected : forall (v1 v2 : Node) (c : Content_Name), FIB v1 c v2 -> Connected v1 v2.
unfold FIB; intros.
destruct v1; simpl in H.
 elim H.
 destruct H as [ H | [] ].
  rewrite H; unfold Connected.
   simpl; auto.
Qed.

Inductive FIBreachable : Node -> Content_Name -> Prop :=
| cs_flag : forall (v : Node) (c : Content_Name), InitCS v c -> FIBreachable v c
| fib_flag : forall (v1 v2 : Node) (c : Content_Name), FIB v1 c v2 -> FIBreachable v2 c -> FIBreachable v1 c.

End CCN_Line.

Require CCNVerification.

Module CCN_Line_Verification := CCNVerification.CCN_Protocol_Verification CCN_Line.
Import CCN_Line_Verification.


Load "Hilbert1.v".

Section ORDERING.

(* Les axiomes d'ordre sont verifies. *)

(* B1 : If B is between A and C, then A, B, C are distinct points on a line, and also B is between C and A. *)

Lemma B1a : forall A B C, Between A B C -> A <> B.
Proof.
	intros; immediate.
Qed.

Lemma B1b : forall A B C, Between A B C -> B <> C.
Proof.
	intros; immediate.
Qed.

Lemma B1c : forall A B C, Between A B C -> C <> A.
Proof.
	intros; immediate.
Qed.

Lemma B1d : forall A B C, Between A B C -> Collinear A B C.
Proof.
	intros; immediate.
Qed.

Lemma B1e : forall A B C, Between A B C -> Between C B A.
Proof.
	intros; immediate.
Qed.

(* B2 : For any two distinct points A, B, there exists a points C such that B is between A and C. *)

Lemma B2 : forall A B, A <> B -> exists C : Point, Between A B C.
Proof.
	intros.
	setSymmetric A B ipattern:C.
	answerIs C.
Qed.

(* B3 : Given three distinct points on a line, one and only one of them is between the other two. *)

Lemma B3a : forall A B C, A <> B -> B <> C ->  C <> A -> Collinear A B C ->
	Between A B C \/ Between B C A \/ Between C A B.
Proof.
	intros.
	by3SegmentCases H2.
	step H3.
	 step H4.
	step H4.
Qed.

Lemma B3b : forall A B C, Between A B C -> ~Between B A C.
Proof.
	intros A B C H H0.
	from H0 (Between C A C).
	since (C <> C).
	absurdHyp H2.
Qed.

Lemma B3c : forall A B C, Between A B C -> ~Between A C B.
Proof.
	intros A B C H H0.
	from H (Between A B A).
	since (A <> A).
	absurdHyp H2.
Qed.

(* B4 : (Pasch). Let A, B, C be three noncollinear points, and let L be a line not containing any of A, B, C. If L contains a point D lying between A and B,
then it must contain either a point lying between A and C or a point lying between B and C, but not both. *)

Lemma B4a : forall A B C M N,
	~Collinear A B C -> Between A M B -> ~Collinear A M N ->
	~Collinear B M N -> ~Collinear C M N ->
	(exists P : Point, Collinear M N P /\ Between A P C) \/
	(exists P : Point, Collinear M N P /\ Between B P C).
Proof.
	intros.
	setLine M N ipattern:d.
	byPaschCases A B C M d ipattern:P.
	 contrapose H1; step H1.
	 contrapose H2; step H2.
	 contrapose H3; step H3.
	 left; answerIs P; from H10 (Collinear M N P).
	 right; answerIs P; from H10 (Collinear M N P).
Qed.

Lemma B4b : forall A B C M N P Q,
	~Collinear A B C -> Between A M B -> ~Collinear A M N -> ~Collinear B M N ->
	~Collinear C M N -> Collinear M N P -> Between A P C -> Collinear M N Q ->
	Between B Q C -> False.
Proof.
	intros.
	since (M <> P).
	 contrapose H.
	   since (Collinear A P C).
	   since (A <> P).
	   step H8.
	   step H.
	 since (M <> Q).
	  contrapose H.
	    since (B <> Q).
	    asWeHave (Collinear B Q C).
	    step H.
	  since (P <> Q).
	   contrapose H.
	     since (C <> Q).
	     asWeHave (Collinear B Q C).
	     step H.
	   destruct (B3a M P Q); try immediate.
	    since (M <> N).
	      step H6.
	    elim H; split; intro.
	     since (Clockwise A C B).
	      step H7.
	       step H5.
	       step H11.
	       step H0.
	       step H5.
	      contradict H12 H13.
	     since (Clockwise A B C).
	      step H5.
	       step H0.
	       step H11.
	       step H5.
	       step H7.
	      contradict H12 H13.
	    destruct H11.
	     elim H; split; intro.
	      since (Clockwise A C B).
	       step H5.
	        step H7.
	         right; step H11.
	        step H7.
	        step H0.
	       contradict H12 H13.
	      since (Clockwise A B C).
	       step H0.
	        step H7.
	        step H11.
	        step H7.
	         right; step H5.
	       contradict H12 H13.
	     elim H; split; intro.
	      since (Clockwise A C B).
	       step H0.
	        step H5.
	        step H11.
	        step H0.
	        step H7.
	       contradict H12 H13.
	      since (Clockwise A B C).
	       step H7.
	        step H0.
	        step H11.
	        step H5.
	        step H0.
	       contradict H12 H13.
Qed.

End ORDERING.