(* $Id: CPoly_ApZero.v,v 1.14 2003/03/11 13:36:15 lcf Exp $ *)

Require Export CReals1.
Require Export CPoly_Degree.

(* Tex_Prose
\chapter{Polynomials apart from zero}
*)

(* Begin_Tex_Verb *)
Definition distinct1 :=
  [A:CSetoid; f:nat->A](i,j:nat)(~i=j) -> ((f i) [#] (f j)).
(* End_Tex_Verb *)

Implicits distinct1 [1].

Section Poly_Representation.
(* Tex_Prose
\section{Representation of polynomials}
\begin{convention}
Let \verb!R! be a field, \verb!a_ : nat->R! with
\verb!(distinct1 a_)! and \verb!f : (cpoly_cring R)! and
\verb!n : nat! with \verb!(degree_le n f)!.
\end{convention}
*)

Variable R : CField.
Variable a_ : nat->R.
Hypothesis distinct_a_ : (distinct1 a_).
Variable f : (cpoly_cring R).
Variable n : nat.
Hypothesis degree_f : (degree_le n f).

Load Transparent_algebra.

(* Begin_Tex_Verb *)
Lemma poly_linear_shifted :
  (a:R)(f:(cpoly_cring R))
    {f':(cpoly_cring R) & {f'':R | f [=] (_X_[-](_C_ a))[*]f'[+](_C_ f'')}}.
(* End_Tex_Verb *)
Intros.
Induction f0; Intros.
Exists (cpoly_zero R).
Exists (Zero::R).
Simpl.
Algebra.
Elim Hrecf0. Intro g'. Intros H.
Elim H. Intro g''. Intros H0.
Exists _X_[*]g'[+](_C_ g'').
Exists a[*]g''[+]s.
Step _X_[*]f0[+](_C_ s).
Step _X_[*]((_X_[-](_C_ a))[*]g'[+](_C_ g''))[+](_C_ s).
Apply eq_symmetric_unfolded.
Cut (_C_ a[*]g''[+]s) [=] (_C_ a)[*](_C_ g'')[+](_C_ s). Intro.
Step (_X_[-](_C_ a))[*](_X_[*]g'[+](_C_ g''))[+]
  ((_C_ a)[*](_C_ g'')[+](_C_ s)).
Rational.
Step_final (_C_ a[*]g'')[+](_C_ s).
Qed.
Load Opaque_algebra.

(* Begin_Tex_Verb *)
Lemma poly_linear_factor :
  (f:(cpoly_cring R))(a:R)(f!a [=] Zero) ->
    {f':(cpoly_cring R) | f [=] (_X_[-](_C_ a))[*]f'}.
(* End_Tex_Verb *)
Intros.
Elim (poly_linear_shifted a f0). Intro f'. Intros H0.
Elim H0. Intro f''. Intros H1.
Exists f'.
Cut (_C_ f'') [=] Zero. Intro.
Step (_X_[-](_C_ a))[*]f'[+](_C_ f'').
Step_final (_X_[-](_C_ a))[*]f'[+]Zero.
Step_rht (_C_ (Zero::R)).
Apply cpoly_const_eq.
Step Zero[+]f''.
Step Zero[*]f'!a[+]f''.
Step (a[-]a)[*]f'!a[+]f''.
Step (_X_!a[-](_C_ a)!a)[*]f'!a[+]f''.
Step (_X_[-](_C_ a))!a[*]f'!a[+]f''.
Step ((_X_[-](_C_ a))[*]f')!a[+]f''.
Step ((_X_[-](_C_ a))[*]f')!a[+](_C_ f'')!a.
Step ((_X_[-](_C_ a))[*]f'[+](_C_ f''))!a.
Step_final f0!a.
Qed.

(* Begin_Tex_Verb *)
Lemma zero_poly :
  (n:nat)
  (f:(cpoly_cring R))(degree_le n f) ->
  ((i:nat)(le i n) -> (f!(a_ i) [=] Zero)) ->
    (f [=] Zero).
(* End_Tex_Verb *)
Intro.
Induction n0; Intros.
Elim (degree_le_zero ? ? H). Intros.
Step (_C_ x).
Step_rht (_C_ (Zero::R)).
Apply cpoly_const_eq.
Apply eq_transitive_unfolded with f0!(a_ (0)).
Step_final (_C_ x)!(a_ (0)).
Apply H0.
Auto.
Cut f0!(a_ (S n0)) [=] Zero. Intro.
Elim (poly_linear_factor f0 (a_ (S n0)) H1). Intro f'. Intros.
Step (_X_[-](_C_ (a_ (S n0))))[*]f'.
Cut f' [=] Zero. Intro.
Step_final (_X_[-](_C_ (a_ (S n0))))[*]Zero.
Apply Hrecn0.
Apply degree_le_mult_imp with (1) (_X_[-](_C_ (a_ (S n0)))).
Apply degree_invus_lft with (0).
Apply degree_le_c_.
Apply degree_x_.
Auto.
Apply degree_le_wd with f0.
Auto.
Auto.
Intros.
Apply mult_cancel_lft with ((a_ i)[-](a_ (S n0))).
Apply minus_ap_zero.
Apply distinct_a_.
Intro; Rewrite H3 in H2; Exact (le_Sn_n ? H2).
Step_rht (Zero::R).
Cut (a_ i)[-](a_ (S n0)) [=] (_X_[-](_C_ (a_ (S n0))))!(a_ i). Intro.
Step (_X_[-](_C_ (a_ (S n0))))!(a_ i)[*]f'!(a_ i).
Step ((_X_[-](_C_ (a_ (S n0))))[*]f')!(a_ i).
Step f0!(a_ i).
Apply H0.
Auto with arith.
Step_final (_X_!(a_ i))[-]((_C_ (a_ (S n0)))!(a_ i)).
Apply H0.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma identical_poly :
  (f,g:(cpoly_cring R))(degree_le n f) -> (degree_le n g) ->
  ((i:nat)(le i n) -> (f!(a_ i) [=] g!(a_ i))) ->
    (f [=] g).
(* End_Tex_Verb *)
Intros.
Apply cg_inv_unique_2.
Apply zero_poly with n.
Apply degree_le_invus; Auto.
Intros.
Step f0!(a_ i)[-]g!(a_ i).
Step_final f0!(a_ i)[-]f0!(a_ i).
Qed.

(* Begin_Tex_Verb *)
Definition poly_01_factor' := [n:nat](_X_[-](_C_ (a_ n))).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma poly_01_factor'_degree :
  (n:nat)(degree_le (1) (poly_01_factor' n)).
(* End_Tex_Verb *)
Intros.
Unfold poly_01_factor'.
Apply degree_imp_degree_le.
Apply degree_invus_lft with (0).
Apply degree_le_c_.
Apply degree_x_.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma poly_01_factor'_zero :
  (n:nat)((poly_01_factor' n)!(a_ n) [=] Zero).
(* End_Tex_Verb *)
Intros.
Unfold poly_01_factor'.
Step (_X_!(a_ n0))[-]((_C_ (a_ n0))!(a_ n0)).
Step_final (a_ n0)[-](a_ n0).
Qed.

(* Begin_Tex_Verb *)
Lemma poly_01_factor'_apzero :
  (n,i:nat)(~i = n) -> ((poly_01_factor' n)!(a_ i) [#] Zero).
(* End_Tex_Verb *)
Intros.
Unfold poly_01_factor'.
Step (_X_!(a_ i))[-]((_C_ (a_ n0))!(a_ i)).
Step (a_ i)[-](a_ n0).
Qed.

Hints Resolve poly_01_factor'_zero.

(* Begin_Tex_Verb *)
Definition poly_01_factor :=
  [n,i:nat; H:(~i = n)]
    (poly_01_factor' n)[*](_C_ One[/]((poly_01_factor' n)!(a_ i))[//]
      (poly_01_factor'_apzero n i H)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma poly_01_factor_degree :
  (n,i:nat; H:(~i = n))(degree_le (1) (poly_01_factor n i H)).
(* End_Tex_Verb *)
Intros.
Unfold poly_01_factor.
Replace (1) with (plus (1) (0)).
Apply degree_le_mult.
Apply poly_01_factor'_degree.
Apply degree_le_c_.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma poly_01_factor_zero :
  (n,i:nat; H:(~i = n))((poly_01_factor n i H)!(a_ n) [=] Zero).
(* End_Tex_Verb *)
Intros.
Unfold poly_01_factor.
Step ((poly_01_factor' n0)!(a_ n0))[*]
  ((_C_ One[/](poly_01_factor' n0)!(a_ i)[//]
    (poly_01_factor'_apzero n0 i H))!(a_ n0)).
Step_final Zero[*]((_C_ One[/](poly_01_factor' n0)!(a_ i)[//]
  (poly_01_factor'_apzero n0 i H))!(a_ n0)).
Qed.

(* Begin_Tex_Verb *)
Lemma poly_01_factor_one :
  (n,i:nat; H:(~i = n))((poly_01_factor n i H)!(a_ i) [=] One).
(* End_Tex_Verb *)
Intros.
Unfold poly_01_factor.
Step ((poly_01_factor' n0)!(a_ i))[*]
  ((_C_ One[/](poly_01_factor' n0)!(a_ i)[//]
    (poly_01_factor'_apzero n0 i H))!(a_ i)).
Step ((poly_01_factor' n0)!(a_ i))[*]
  (One[/](poly_01_factor' n0)!(a_ i)[//](poly_01_factor'_apzero n0 i H)).
Rational.
Qed.

Hints Resolve poly_01_factor_zero poly_01_factor_one : algebra.

(* Begin_Tex_Verb *)
Fixpoint poly_01 [i,n:nat] : (cpoly_cring R) :=
    Cases (eq_nat_dec i n) of
      (left _) => One
    | (right ne) => (poly_01_factor n i ne)
    end
  [*]
    Cases n of
      O => One
    | (S m) => (poly_01 i m)
    end.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma poly_01_degree' :
  (n,i:nat)(degree_le (S n) (poly_01 i n)).
(* End_Tex_Verb *)
Intros.
Induction n0. Intros.
Simpl.
Elim (eq_nat_dec i (0)); Intro y.
Apply degree_le_wd with (_C_ (One::R)).
Step_final (One::(cpoly_cring R)).
Apply degree_le_mon with (0).
Auto with arith.
Apply degree_le_c_.
Apply degree_le_wd with (poly_01_factor (0) i y).
Algebra.
Apply poly_01_factor_degree.
Simpl.
Elim (eq_nat_dec i (S n0)); Intro.
Apply degree_le_mon with (S n0).
Auto.
Apply degree_le_wd with (poly_01 i n0).
Algebra.
Auto.
Replace (S (S n0)) with (plus (1) (S n0)).
Apply degree_le_mult.
Apply poly_01_factor_degree.
Auto.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma poly_01_degree :
  (n,i:nat)(le i n) -> (degree_le n (poly_01 i n)).
(* End_Tex_Verb *)
Intros.
Induction n0; Intros.
Simpl.
Elim (eq_nat_dec i (0)); Intro y.
Apply degree_le_wd with (_C_ (One::R)).
Step_final (One::(cpoly_cring R)).
Apply degree_le_c_.
Cut i=(0). Intro.
Elim (y H0).
Auto with arith.
Simpl.
Elim (eq_nat_dec i (S n0)); Intro.
Apply degree_le_wd with (poly_01 i n0).
Algebra.
Apply poly_01_degree'.
Pattern 1 (S n0).
Replace (S n0) with (plus (1) n0).
Apply degree_le_mult.
Apply poly_01_factor_degree.
Apply Hrecn0.
Elim (le_lt_eq_dec ?? H); Auto with arith.
Intro; Elim (b b0).
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma poly_01_zero :
  (n,i,j:nat)(le j n) -> (~j = i) -> ((poly_01 i n)!(a_ j) [=] Zero).
(* End_Tex_Verb *)
Intros.
Induction n0; Intros.
Rewrite <- (le_n_O_eq j H).
Rewrite <- (le_n_O_eq j H) in H0.
Simpl.
Elim (eq_nat_dec i (0)); Intro y.
Rewrite y in H0.
Elim (H0 (refl_equal ? (0))).
Step ((poly_01_factor (0) i y)!(a_ (0)))[*](One!(a_ (0))).
Step ((poly_01_factor (0) i y)!(a_ (0)))[*]One.
Step ((poly_01_factor (0) i y)!(a_ (0))).
Apply poly_01_factor_zero.
Elim (eq_nat_dec j (S n0)); Intro y.
Simpl.
Rewrite <- y.
Elim (eq_nat_dec i j); Intro y0.
Rewrite y0 in H0.
Elim (H0 (refl_equal ? j)).
Step ((poly_01_factor j i y0)!(a_ j))[*]((poly_01 i n0)!(a_ j)).
Step_final Zero[*]((poly_01 i n0)!(a_ j)).
Cut (le j n0). Intro.
Simpl.
Elim (eq_nat_dec i (S n0)); Intro y0.
Step (One!(a_ j))[*]((poly_01 i n0)!(a_ j)).
Step_final (One!(a_ j))[*]Zero.
Step ((poly_01_factor (S n0) i y0)!(a_ j))[*]((poly_01 i n0)!(a_ j)).
Step_final ((poly_01_factor (S n0) i y0)!(a_ j))[*]Zero.
Elim (le_lt_eq_dec ?? H); Auto with arith.
Intro; Elim (y b).
Qed.

(* Begin_Tex_Verb *)
Lemma poly_01_one :
  (n,i:nat)(poly_01 i n)!(a_ i) [=] One.
(* End_Tex_Verb *)
Intros.
Induction n0; Intros.
Simpl.
Elim (eq_nat_dec i (0)); Intro y.
Step (One!(a_ i))[*](One!(a_ i)).
Step_final One[*](One::R).
Step ((poly_01_factor (0) i y)!(a_ i))[*](One!(a_ i)).
Step ((poly_01_factor (0) i y)!(a_ i))[*]One.
Step (poly_01_factor (0) i y)!(a_ i).
Apply poly_01_factor_one.
Simpl.
Elim (eq_nat_dec i (S n0)); Intro y.
Step (One!(a_ i))[*]((poly_01 i n0)!(a_ i)).
Step One[*]((poly_01 i n0)!(a_ i)).
Step_final One[*](One::R).
Step ((poly_01_factor (S n0) i y)!(a_ i))[*]((poly_01 i n0)!(a_ i)).
Step ((poly_01_factor (S n0) i y)!(a_ i))[*]One.
Step (poly_01_factor (S n0) i y)!(a_ i).
Apply poly_01_factor_one.
Qed.

Hints Resolve poly_01_zero poly_01_one : algebra.

(* Begin_Tex_Verb *)
Lemma poly_representation'' :
  (a:nat->R)(i:nat)(le i n) ->
  ((j:nat)(~j = i) -> (a j) [=] Zero) ->
    (Sum (0) n a) [=] (a i).
(* End_Tex_Verb *)
Intro. Intro.
Elim i.
Intros.
Step (a (0))[+](Sum (1) n a).
Step_rht (a (0))[+]Zero.
Apply bin_op_wd_unfolded.
Algebra.
Apply Sum_zero.
Auto with arith.
Intros.
Apply H0.
Intro; Rewrite H3 in H1; Inversion H1.
Intro i'.
Intros.
Step (Sum (0) i' a)[+](Sum (S i') n a).
Step_rht Zero[+](a (S i')).
Apply bin_op_wd_unfolded.
Apply Sum_zero.
Auto with arith.
Intros.
Apply H1.
Intro; Rewrite H4 in H3; Exact (le_Sn_n ? H3).
Step (a (S i'))[+](Sum (S (S i')) n a).
Step_rht (a (S i'))[+]Zero.
Apply bin_op_wd_unfolded.
Algebra.
Apply Sum_zero.
Auto with arith.
Intros.
Apply H1.
Intro; Rewrite H4 in H2; Exact (le_Sn_n ? H2).
Qed.

(* Begin_Tex_Verb *)
Lemma poly_representation' :
  (f_:nat->(cpoly_cring R))(k:nat)(le k n) ->
    (Sum (0) n [i:nat]((f_ i)[*](poly_01 i n)))!(a_ k) [=] (f_ k)!(a_ k).
(* End_Tex_Verb *)
Intros.
Apply eq_transitive_unfolded with
  (Sum (0) n [i:nat]((f_ i)[*](poly_01 i n))!(a_ k)).
Apply Sum_cpoly_ap with f := [i:nat](f_ i)[*](poly_01 i n).
Step (Sum (0) n [i:nat](f_ i)!(a_ k)[*](poly_01 i n)!(a_ k)).
Step_rht (f_ k)!(a_ k)[*]One.
Step_rht (f_ k)!(a_ k)[*](poly_01 k n)!(a_ k).
Apply poly_representation'' with
  a := [i:nat](f_ i)!(a_ k)[*](poly_01 i n)!(a_ k).
Auto.
Intros.
Step_final (f_ j)!(a_ k)[*]Zero.
Qed.

(* Begin_Tex_Verb *)
Lemma poly_representation :
  f [=] (Sum (0) n [i:nat](_C_ f!(a_ i))[*](poly_01 i n)).
(* End_Tex_Verb *)
Apply identical_poly.
Auto.
Apply Sum_degree_le. Auto with arith. Intros.
Replace n with (plus (0) n).
Apply degree_le_mult.
Apply degree_le_c_.
Apply poly_01_degree.
Auto.
Auto with arith.
Intros.
Apply eq_symmetric_unfolded.
Step_rht (_C_ f!(a_ i))!(a_ i).
Apply poly_representation' with f_ := [i:nat](_C_ f!(a_ i)).
Auto.
Qed.

Hints Resolve poly_representation : algebra.

(* Begin_Tex_Verb *)
Lemma Cpoly_choose_apzero :
  (f [#] Zero) -> { i:nat | (le i n) & (f!(a_ i) [#] Zero)}.
(* End_Tex_Verb *)
Intros.
Cut (Sum (0) n [i:nat](_C_ f!(a_ i))[*](poly_01 i n)) [#] Zero. Intros.
Elim (Sum_apzero ? [i:nat](_C_ f!(a_ i))[*](poly_01 i n) (0) n (le_O_n n) H0).
Intro i. Intro H1.
Elim H1. Intros H2 H3. Intro H4.
Exists i.
Auto.
Apply poly_c_apzero.
Apply cring_mult_ap_zero with (poly_01 i n).
Auto.
Step f.
Qed.

End Poly_Representation.

(* Tex_Prose
\section{Polynomials are nonzero on any interval}
*)
Section Poly_ApZero_Interval.

Variable R: COrdField.

(* Begin_Tex_Verb *)
Lemma Cpoly_apzero_interval :
  (f:(cpoly_cring R))(f [#] Zero) ->
  (a,b:R)(a [<] b) ->
    { c:R | (a [<=] c) /\ (c [<=] b) & (f!c [#] Zero)}.
(* End_Tex_Verb *)
Intros.
Elim (Cpoly_ex_degree ? f). Intro n. Intro H1.
Cut Zero [<] ((nring (plus n (2)))::R). Intros.
Cut (nring (plus n (2))) [#] (Zero::R). Intros.
Cut (distinct1
  [i:nat](((nring (plus i (1)))[*]a[+]
    ((nring (plus n (2)))[-](nring (plus i (1))))[*]b)[/]
    (nring (plus n (2)))[//]H3)).
Intro.
Elim (Cpoly_choose_apzero ?
  [i:nat](((nring (plus i (1)))[*]a[+]
    ((nring (plus n (2)))[-](nring (plus i (1))))[*]b)[/]
    (nring (plus n (2)))[//]H3)
  H4 f n H1 H).
Intro i. Intros H6 H7.
Exists (((nring (plus i (1)))[*]a[+]
  ((nring (plus n (2)))[-](nring (plus i (1))))[*]b)[/]
    (nring (plus n (2)))[//]H3).
Split.
Apply less_leEq.
Apply shift_less_div.
Auto.
Apply less_wdl with (nring (plus i (1)))[*]a[+]
  ((nring (plus n (2)))[-](nring (plus i (1))))[*]a.
Apply plus_resp_less_lft.
Apply mult_resp_less_lft.
Auto.
Apply shift_zero_less_minus.
Apply nring_less.
Omega.
Rational.
Apply less_leEq.
Apply shift_div_less.
Auto.
Apply less_wdr with (nring (plus i (1)))[*]b[+]
  ((nring (plus n (2)))[-](nring (plus i (1))))[*]b.
Apply plus_resp_less_rht.
Apply mult_resp_less_lft.
Auto.
Step ((nring (0))::R).
Apply nring_less.
Auto with arith.
Rational.
Auto.
Unfold distinct1.
Intros.
Apply zero_minus_apart.
RStep (((nring (plus i (1)))[-](nring (plus j (1))))[*](a[-]b))[/]
  (nring (plus n (2)))[//]H3.
Apply div_resp_ap_zero_rev.
Apply mult_resp_ap_zero.
Apply minus_ap_zero.
Apply nring_apart.
Repeat Rewrite <- plus_n_Sm; Repeat Rewrite <- plus_n_O.
Apply not_eq_S; Auto.
Apply minus_ap_zero.
Apply less_imp_ap.
Auto.
Apply ap_symmetric_unfolded.
Apply less_imp_ap.
Auto.
Step ((nring (0))::R).
Apply nring_less.
Auto with arith.
Qed.

End Poly_ApZero_Interval.


(**Parameter int : Type.
(**Extract Inlined Constant int => "int".*)

Parameter Abs : int -> Z.
Axiom Abs_inj: forall (n m : int), Abs n = Abs m -> n = m.

Parameter ltb: int -> int -> bool.
Extract Inlined Constant ltb => "( < )".
Axiom ltb_lt : forall (n m : int), ltb n m = true <-> Abs n < Abs m.
Parameter leb: int \u2192 int \u2192 bool.
Extract Inlined Constant leb \u21d2 "( <= )".
Axiom leb_le : \u2200 (n m : int), leb n m = true \u2194 Abs n \u2264 Abs m.
**)

From Coq Require Import String.
From Coq Require Export Arith.
From Coq Require Export Lia.

Notation  "a >=? b" := (Nat.leb b a) (at level 70) : nat_scope.
Notation  "a >? b"  := (Nat.ltb b a) (at level 70) : nat_scope.

Definition key := nat.

Inductive color := Red | Black.

Inductive tree (V : Type) : Type :=
| E : tree V
| T : color -> tree V -> key -> V -> tree V -> tree V.

Arguments E {V}.
Arguments T {V}.

Definition empty_tree (V : Type) : tree V :=
  E.

Fixpoint lookup {V : Type} (d : V) (x: key) (t : tree V) : V :=
  match t with
  | E => d
  | T _ tl k v tr => if k >? x then lookup d x tl
                    else if x >? k then lookup d x tr
                         else v
  end.

Definition balance
           {V : Type} (c : color) (t1 : tree V) (k : key) (vk : V)
           (t2 : tree V) : tree V :=
  match c with
  | Red => T Red t1 k vk t2
  | _ => match t1 with
        | T Red (T Red a x vx b) y vy c =>
            T Red (T Black a x vx b) y vy (T Black c k vk t2)
        | T Red a x vx (T Red b y vy c) =>
            T Red (T Black a x vx b) y vy (T Black c k vk t2)
        | _ => match t2 with
              | T Red (T Red b y vy c) z vz d =>
                  T Red (T Black t1 k vk b) y vy (T Black c z vz d)
              | T Red b y vy (T Red c z vz d) =>
                  T Red (T Black t1 k vk b) y vy (T Black c z vz d)
              | _ => T Black t1 k vk t2
              end
        end
  end.

Fixpoint ins {V : Type} (x : key) (vx : V) (t : tree V) : tree V :=
  match t with
  | E => T Red E x vx E
  | T c a y vy b => if y >? x then balance c (ins x vx a) y vy b
                   else if x >? y then balance c a y vy (ins x vx b)
                        else T c a x vx b
  end.

Definition make_black {V : Type} (t : tree V) : tree V :=
  match t with
  | E => E
  | T _ a x vx b => T Black a x vx b
  end.

Definition insert {V : Type} (x : key) (vx : V) (t : tree V) :=
  make_black (ins x vx t).

Fixpoint elements_aux {V : Type} (t : tree V) (acc: list (key * V))
  : list (key * V) :=
  match t with
  | E => acc
  | T _ l k v r => elements_aux l ((k, v) :: elements_aux r acc)
  end.

Notation "[ ]" := nil.

Definition elements {V : Type} (t : tree V) : list (key * V) :=
  elements_aux t [].

Lemma ins_not_E : forall (V : Type) (x : key) (vx : V) (t : tree V),
    not (ins x vx t = E).
Proof.
   intros. destruct t; simpl.
  - discriminate.
  - unfold balance.
    repeat
      match goal with
      | |- (if ?x then _ else _) <> _ => destruct x
      | |- match ?c with Red => _ | Black => _ end <> _=> destruct c
      | |- match ?t with E => _ | T _ _ _ _ _ => _ end <> _=> destruct t
      | |- T _ _ _ _ _ <> E => discriminate
      end.
Qed.

Fixpoint ForallT {V : Type} (P: nat -> V -> Prop) (t : tree V) : Prop :=
  match t with
  | E => True
  | T c l k v r => P k v /\ ForallT P l /\ ForallT P r
  end.

Lemma balanceP : forall (V : Type) (P : key -> V -> Prop) (c : color) (l r : tree V)
                   (k : key) (v : V),
    ForallT P l ->
    ForallT P r ->
    P k v ->
    ForallT P (balance c l k v r).
Proof.
  intros. unfold balance.
    repeat
      match goal with
      | |- match ?c with Red => _ | Black => _ end => destruct c
      | |- match ?l with E => _ | T _ _ _ _ _ => _ end => destruct l
      | |- T _ _ _ _ _ => repeat split
      | |- P k v => auto
      | |- ForallT _ _ => auto
      end.
  Admitted.

Inductive reflect (P : Prop) : bool -> Set :=
  | reflectT :   P -> reflect P true
  | reflectF : ~ P -> reflect P false.

Theorem iff_reflect : forall P b, (P <-> b = true) -> reflect P b.
Proof.
  intros P b H. destruct b.
  - inversion H. apply reflectT. simpl in H1. rewrite H. reflexivity.
  - inversion H. apply reflectF. unfold not. rewrite H. intros. discriminate H2.
Qed.

Theorem reflect_iff : forall P b, reflect P b -> (P <-> b = true).
Proof.
  intros P b H. split.
  - inversion H.
    * intros. reflexivity.
    * intros. unfold not in H0. apply H0 in H2. contradiction.
  - intros. subst. inversion H. apply H0.
Qed.

Lemma eqb_reflect : forall x y, reflect (x = y) (x =? y).
Proof.
  intros. apply iff_reflect. symmetry. apply Nat.eqb_eq.
Qed.

Lemma ltb_reflect : forall x y, reflect (x < y) (x <? y).
Proof.
  intros. apply iff_reflect. symmetry. apply Nat.ltb_lt.
Qed.

Lemma leb_reflect : forall x y, reflect (x <= y) (x <=? y).
Proof.
  intros. apply iff_reflect. symmetry. apply Nat.leb_le.
Qed.

Hint Resolve ltb_reflect leb_reflect eqb_reflect : bdestruct.

Ltac bdestruct X :=
  let H := fresh in let e := fresh "e" in
   evar (e: Prop);
   assert (H: reflect e X); subst e;
    [eauto with bdestruct
    | destruct H as [H|H];
       [ | try first [apply not_lt in H | apply not_le in H]]].

Lemma insP : forall (V : Type) (P : key -> V -> Prop) (t : tree V) (k : key) (v : V),
    ForallT P t ->
    P k v ->
    ForallT P (ins k v t).
Proof.
  intros. induction t.
    - simpl. repeat split.
      * apply H0.
    - simpl. bdestruct (k0 >? k).
      * apply balanceP.
        ++ inversion H. destruct H3. apply IHt1 in H3. apply H3.
        ++ inversion H. destruct H3. apply H4.
        ++ inversion H. apply H2.
      * bdestruct (k >? k0).
        ++ apply balanceP.
          ** inversion H. destruct H4. apply H4.
          ** inversion H. destruct H4. apply IHt2 in H5. apply H5.
          ** inversion H. apply H3.
        ++ assert (k0 = k). lia. simpl. repeat split.
          ** apply H0.
          ** inversion H. destruct H5. apply H5.
          ** inversion H. destruct H5. apply H6.
Qed.

Inductive BST {V : Type} : tree V -> Prop :=
| ST_E : BST E
| ST_T : forall (c : color) (l : tree V) (k : key) (v : V) (r : tree V),
    ForallT (fun k' _ => k'< k) l ->
    ForallT (fun k' _ => k'> k) r ->
    BST l ->
    BST r ->
    BST (T c l k v r).

Lemma ForallT_imp : forall (V : Type) (P Q : nat -> V -> Prop) t,
    ForallT P t ->
    (forall k v, P k v -> Q k v) ->
    ForallT Q t.
Proof.
  induction t; intros.
  - auto.
  - destruct H as [? [? ?]]. repeat split; auto.
Qed.
Lemma ForallT_greater : forall (V : Type) (t : tree V) (k k0 : key),
    ForallT (fun k' _ => k' > k) t ->
    k > k0 ->
    ForallT (fun k' _ => k' > k0) t.
Proof.
  intros. eapply ForallT_imp; eauto.
  intros. simpl in H1. lia.
Qed.
Lemma ForallT_less : forall (V : Type) (t : tree V) (k k0 : key),
    ForallT (fun k' _ => k' < k) t ->
    k < k0 ->
    ForallT (fun k' _ => k' < k0) t.
Proof.
  intros; eapply ForallT_imp; eauto.
  intros. simpl in H1. lia.
Qed.

Lemma balance_BST: forall (V : Type) (c : color) (l : tree V) (k : key)
                     (v : V) (r : tree V),
    ForallT (fun k' _ => k' < k) l ->
    ForallT (fun k' _ => k' > k) r ->
    BST l ->
    BST r ->
    BST (balance c l k v r).
Proof.
  intros. unfold balance.
  repeat
    match goal with
    | H: ForallT _ (T _ _ _ _ _) |- _ => destruct H as [? [? ?] ]
    | H: BST (T _ _ _ _ _) |- _ => inversion H; clear H; subst
    | |- BST (T _ _ _ _ _) => constructor
    | |- BST (match ?c with Red => _ | Black => _ end) => destruct c
    | |- BST (match ?t with E => _ | T _ _ _ _ _ => _ end) => destruct t
    | |- ForallT _ (T _ _ _ _ _) => repeat split
    end;
    auto; try lia.
  all: try eapply ForallT_greater; try eapply ForallT_less; eauto; try lia.
Qed.

Lemma ins_BST : forall (V : Type) (t : tree V) (k : key) (v : V),
    BST t ->
    BST (ins k v t).
Proof.
  intros. induction t.
  - simpl. apply ST_T.
    * reflexivity.
    * reflexivity.
    * apply H.
    * apply ST_E.
  - simpl. bdestruct (k0 >? k).
    * apply balance_BST.
      ** apply insP.
        + inversion H. apply H5.
        + apply H0.
      ** inversion H. apply H7.
      ** inversion H. apply IHt1 in H8. apply H8.
      ** inversion H. apply H9.
    * bdestruct (k >? k0).
      ** apply balance_BST.
         + inversion H. apply H6.
         + apply insP. inversion H.
           ++ apply H8.
           ++ apply H1.
         + inversion H. apply H9.
         + inversion H. apply IHt2 in H10. apply H10.
      ** apply ST_T. inversion H. assert (k = k0). lia.
          + rewrite H11. apply H6.
          + inversion H. assert (k = k0). lia. rewrite H11. apply H8.
          + inversion H. apply H9.
          + inversion H. apply H10.
Qed.

Theorem helper : forall (V: Type) (t : tree V) (v : V) (k : key),
    BST t ->
    BST (make_black t).
  intros. unfold make_black. induction t.
    - apply ST_E.
    - apply ST_T. inversion H.
      * apply H4.
      * inversion H. apply H6.
      * inversion H. apply H7.
      * inversion H. apply H8.
Qed.

Theorem insert_BST : forall (V : Type) (t : tree V) (v : V) (k : key),
    BST t ->
    BST (insert k v t).
Proof.
  intros. unfold insert. apply helper.
    - apply v.
    - apply k.
      - apply ins_BST. apply H.
Qed.

Lemma balance_lookup: forall (V : Type) (d : V) (c : color) (k k' : key) (v : V)
                        (l r : tree V),
    BST l ->
    BST r ->
    ForallT (fun k' _ => k' < k) l ->
    ForallT (fun k' _ => k' > k) r ->
    lookup d k' (balance c l k v r) =
      if k' <? k
      then lookup d k' l
      else if k' >? k
           then lookup d k' r
           else v.
Proof.
  (* FILL IN HERE *) Admitted.

Lemma lookup_ins_eq: forall (V : Type) (d : V) (t : tree V) (k : key) (v : V),
    BST t ->
    lookup d k (ins k v t) = v.
Proof.

  intros. induction H.
  - simpl. bdestruct (k >? k).
    * lia.
    * reflexivity.
  - simpl. bdestruct (k0 >? k).
    * rewrite balance_lookup.
      + bdestruct (k0 >? k).
        ++ apply IHBST1.
        ++ lia.
      + apply ins_BST. apply H1.
      + apply H2.
      + apply insP.
        ++ apply H.
        ++ lia.
      + apply H0.
    * bdestruct (k >? k0).
      + rewrite balance_lookup.
        ++ bdestruct (k0 >? k). lia. bdestruct (k >? k0). apply IHBST2. lia.
        ++ apply H1.
        ++ apply ins_BST. apply H2.
        ++ apply H.
        ++ apply insP. apply H0. apply H4.
      + assert (k = k0). lia. simpl. bdestruct (k >? k).
        ++ lia.
        ++ reflexivity.
Qed.

Theorem lookup_ins_neq: forall (V : Type) (d : V) (t : tree V) (k k' : key)
                          (v : V),
    BST t ->
    not (k = k') ->
    lookup d k' (ins k v t) = lookup d k' t.
Proof.
  intros. induction H.
  - simpl. bdestruct (k >? k'). reflexivity. bdestruct (k' >? k). reflexivity. lia.
  - simpl. bdestruct (k0 >? k).
    * rewrite balance_lookup.
      ** bdestruct (k0 >? k').
        + apply IHBST1.
        + bdestruct (k' >? k0). reflexivity. reflexivity.
      ** apply ins_BST. apply H2.
      ** apply H3.
      ** apply insP. apply H. apply H4.
      ** apply H1.
     * bdestruct (k >? k0).
      ** rewrite balance_lookup.
        + bdestruct (k0 >? k'). reflexivity.
        bdestruct (k' >? k0). apply IHBST2. reflexivity.
        + apply H2.
        + apply ins_BST. apply H3.
        + apply H.
        + apply insP. apply H1. apply H5.
      ** bdestruct (k0 >? k').
        + simpl. bdestruct (k >? k'). reflexivity. bdestruct (k' >? k). lia. lia.
        + bdestruct (k' >? k0).
          ++ simpl. bdestruct (k >? k'). lia. bdestruct (k' >? k). reflexivity.
          lia.
          ++ simpl. bdestruct (k >? k'). lia. bdestruct (k' >? k). lia. lia.
Qed.

Theorem helper_lookup : forall (V: Type) (d: V) (t : tree V) (k : key) (v : V) ,
    lookup d k t = v ->
    lookup d k (make_black t) = v.
Proof.
  intros. unfold make_black. induction t.
   - apply H.
   - apply H.
Qed.

Theorem helper_lookup2 : forall (V: Type) (d: V) (t2 : tree V) (t : tree V) (k : key) (v : V) ,
    lookup d k t = lookup d k t2  ->
    lookup d k (make_black t) = lookup d k t2.
Proof.
  intros. unfold make_black. induction t.
   - apply H.
   - apply H.
Qed.

Theorem lookup_insert_eq : forall (V : Type) (d : V) (t : tree V) (k : key)
                             (v : V),
    BST t ->
    lookup d k (insert k v t) = v.
Proof.
  intros. unfold insert. rewrite helper_lookup with (V) (d) ((ins k v t)) (k) (v).
  - reflexivity.
  - apply lookup_ins_eq. apply H.
Qed.

Theorem lookup_insert_neq: forall (V : Type) (d : V) (t : tree V) (k k' : key)
                             (v : V),
    BST t ->
    not (k = k') ->
    lookup d k' (insert k v t) = lookup d k' t.
Proof.
  intros. unfold insert. apply helper_lookup2.
  - apply v.
  - apply lookup_ins_neq.
    * apply H.
    * apply H0.
Qed.

Inductive RB {V : Type} : tree V -> color -> nat -> Prop :=
| RB_leaf: forall (c : color), RB E c 0
| RB_r: forall (l r : tree V) (k : key) (v : V) (n : nat),
    RB l Red n ->
    RB r Red n ->
    RB (T Red l k v r) Black n
| RB_b: forall (c : color) (l r : tree V) (k : key) (v : V) (n : nat),
    RB l Black n ->
    RB r Black n ->
    RB (T Black l k v r) c (S n).

Lemma RB_blacken_parent : forall (V : Type) (t : tree V) (n : nat),
    RB t Red n -> RB t Black n.
Proof.
  intros. induction H.
  - apply RB_leaf.
  - apply RB_r.
   * apply H.
   * apply H0.
  - apply RB_b.
   * apply H.
   * apply H0.
Qed.

Inductive NearlyRB {V : Type} : tree V -> nat -> Prop :=
| NearlyRB_r : forall (l r : tree V) (k : key) (v : V) (n : nat),
    RB l Black n ->
    RB r Black n ->
    NearlyRB (T Red l k v r) n
| NearlyRB_b : forall (l r : tree V) (k : key) (v : V) (n : nat),
    RB l Black n ->
    RB r Black n ->
    NearlyRB (T Black l k v r) (S n).

Ltac prove_RB := admit.
Lemma ins_RB : forall (V : Type) (k : key) (v : V) (t : tree V) (n : nat),
    (RB t Black n -> NearlyRB (ins k v t) n) /\
      (RB t Red n -> RB (ins k v t) Black n).
Proof.
  induction t; split; intros; inversion H; repeat constructor; simpl.
  - (* Instantiate the inductive hypotheses. *)
    specialize (IHt1 n). specialize (IHt2 n).
    (* Derive what propositional facts we can from the hypotheses. *)
    intuition.
    (* Get rid of some extraneous hypotheses. *)
    clear H H1.
    (* Finish with automation. *)
    prove_RB.
  - specialize (IHt1 n0). specialize (IHt2 n0). intuition.
    clear H0 H2.
    prove_RB.
  - specialize (IHt1 n0). specialize (IHt2 n0). intuition.
    clear H0 H2.
    prove_RB.
    (* FILL IN HERE *) Admitted.

Lemma RB_blacken_root : forall (V : Type) (t : tree V) (n : nat),
    RB t Black n ->
    exists (n' : nat), RB (make_black t) Red n'.
Proof.
   intros. induction H.
    - simpl. exists 0. apply RB_leaf.
    - simpl. exists (S n). apply RB_b.
      * apply RB_blacken_parent. apply H.
      * apply RB_blacken_parent. apply H0.
    - simpl. exists (S n). apply RB_b.
      * apply H.
      * apply H0.
Qed.

Lemma insert_RB : forall (V : Type) (t : tree V) (k : key) (v : V) (n : nat),
    RB t Red n ->
    exists (n' : nat), RB (insert k v t) Red n'.
Proof.
  intros. unfold insert. apply RB_blacken_root with n. apply ins_RB. apply H.
Qed.


  (** Pierre Castéran, Univ. Bordeaux and LaBRI *)

From hydras Require Import Hydra_Lemmas  Epsilon0_Needed_Free
     Epsilon0_Needed_Std  Hydra_Termination L_alpha Battle_length Ack.
Import E0 Large_Sets Hprime Paths MoreLists  O2H Hydra_Definitions Iterates.
Export Hydra_Definitions.

(** ** Liveness

  If the hydra is not reduced to one  head, then Hercules can chop off
  some head
 *)

(* begin snippet AliveThms *)
Corollary Alive_free : Alive free. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  red;intros.
  destruct (next_round i h).
  -  destruct s as [h' H'];  exists h'; now  exists i.
  - tauto.
Qed.
(*||*)

Corollary Alive_standard : Alive standard. (* .no-out *)
(*|
.. coq:: none
|*)
Proof.
  red;intros.
  destruct (next_round i h).
  -  destruct s as [h' H'];  exists h'.
     assumption.
  - now destruct H.
Qed.
(*||*)

(* end snippet AliveThms *)

(** ** Termination of free battles
 *)

Theorem Variant_LT_free_0 :  @Hvariant  _ _ T1_wf free Hydra_Termination.m.
Proof. split; intros; now apply round_decr. Qed.

Theorem Variant_lt_free:  @Hvariant _ _ E0lt_wf free Hydra_Termination.var.
Proof. split; intros; now apply round_decr. Qed.

Theorem Variant_LT_standard : @Hvariant _ _ T1_wf standard Hydra_Termination.m.
Proof.
 split; intros i h h' H H0; apply round_decr; now exists i.
Qed.

Theorem Variant_lt_standard : @Hvariant _ _ E0lt_wf standard Hydra_Termination.var.
Proof.
  split; intros i h h' H H0;  apply round_decr; now exists i.
Qed.

(*

Print Assumptions Variant_lt_standard.
 *)

(** ** Impossibility theorems

  Termination of free battles cannot be proven with a variant from hydras into a segment $[0, alpha]$ with $alpha < \_epsilon0$

*)

(**  Impossiblity to define a variant bounded by some ordinal less than
     [epsilon0] *)

Check Impossibility_free.
(*
Impossibility_free
     : BoundedVariant free -> False
 *)

About  battle_length_std.

Open Scope nat_scope.

(* begin snippet battleLengthStdHardy *)

(*| .. coq:: no-out |*)
Theorem battle_length_std_Hardy (alpha : E0) :
  alpha <> E0zero ->
  forall k , 1 <= k ->
             exists l: nat,
               H'_ alpha k - k <= l /\
               battle_length standard k (iota (cnf alpha)) l.
Proof.
  intros H k  H0; exists (L_ alpha (S k) - k); split.
  - generalize (H'_L_ alpha k); lia.
  - now apply battle_length_std.
Qed.
(*||*)
(* end snippet battleLengthStdHardy *)

(*
Print Assumptions battle_length_std.
 *)

(** ** Battle length is not PR *)

Require Import primRec F_alpha  AckNotPR PrimRecExamples.
Require Import F_omega.
Import E0.

(* begin snippet battleLengthNotPRa *)

Section battle_length_notPR.

  Hypothesis H: forall alpha, isPR 1 (l_std alpha).

  (* end snippet battleLengthNotPRa *)

  (** A counter example *)

  (* begin snippet battleLengthNotPRb *)

  Let alpha := E0phi0 E0omega.
  Let h := iota (cnf alpha).

   (* end snippet battleLengthNotPRb *)

  (** let us get rid of the substraction ... *)

  (* begin snippet battleLengthNotPRc *)

  Let m k := L_ alpha (S k).

  Remark m_eqn : forall k, m k = (l_std alpha k + k)%nat. (* .no-out *)
  (* end snippet battleLengthNotPRc *)

  Proof.
    intro k; assert (k <= L_ alpha (S k)).
    { assert (S k < L_ alpha (S k)).
      { apply L_ge_S; unfold alpha; intro H0; injection H0.
        intro; discriminate.
      }
      lia.
    }
    unfold m,l_std ; lia.
  Qed.

  (* begin snippet battleLengthNotPRd *)

  Remark mIsPR : isPR 1 m. (* .no-out *)

   (* end snippet battleLengthNotPRd *)
  Proof.
    destruct (H alpha) as [x Hx].
    apply isPR_extEqual_trans with (fun k => (l_std alpha  k + k)%nat).
    - apply compose1_2IsPR; auto.
      + apply idIsPR.
      + apply plusIsPR.
    - intro k; unfold m, l_std; assert (k <=  L_ alpha (S k))%nat.
      transitivity (S k).
      + auto with arith.
      + apply Nat.lt_le_incl.
        apply L_ge_S.
        unfold alpha; intro H0; injection H0; discriminate.
      + now replace (L_ alpha ( S k) -k + k)%nat with (L_ alpha (S k))
          by lia.
  Qed.

  (* begin snippet mGeFOmega *)

  Remark m_ge_F_omega k: F_ E0omega (S k) <= m (S k). (* .no-out *)
  (* end snippet mGeFOmega *)

  Proof.
    rewrite m_eqn; transitivity (H'_ alpha (S k)).
    - apply H'_F.
    - unfold l_std;  generalize (H'_L_ alpha (S k)); lia.
  Qed.

  (** We compare [m] with the Ackermann function *)

  Remark m_ge_Ack:  forall n, 2 <= n -> Ack (S n) (S n) <= m (S n).
  Proof.
    intros n H0; transitivity (F_ E0omega (S n)).
    - apply F_vs_Ack; auto.
    - apply m_ge_F_omega.
  Qed.

  Remark m_dominates_Ack_from_3 : forall n, 3 <= n -> Ack n n <= m n.
  Proof.
    destruct n.
    - lia.
    - intro; apply m_ge_Ack; auto with arith.
  Qed.

  (* begin snippet mDominatesAck *)

  Remark m_dominates_Ack :
    dominates (fun n =>  S (m n)) (fun n => Ack.Ack n n). (* .no-out *)

    (* end snippet mDominatesAck *)

  Proof.
    exists 3; red; intros.
    apply Nat.le_lt_trans with (m p).
    - apply m_dominates_Ack_from_3; auto.
    - auto with arith.
  Qed.

  (* begin snippet SmNotPR *)

  Remark SmNotPR : isPR 1 (fun n => S (m n)) -> False. (* .no-out *)
 (* end snippet SmNotPR *)

  Proof.
    intro; eapply dom_AckNotPR; eauto.
    apply m_dominates_Ack; auto.
  Qed.

  (* begin snippet LNotPR *)

  (*|
.. coq:: no-out
|*)

  Theorem LNotPR : False.
  Proof.
    apply SmNotPR, compose1_1IsPR.
    - apply mIsPR.
    - apply succIsPR.
  Qed.

End battle_length_notPR.

(*||*)
Check l_std_ok.

Check LNotPR.

Search L_ F_.
(* end snippet LNotPR *)


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This file collects theorems, definitions, tactics, related to propositions
with a decidable equality. Such propositions are collected by the [Decision]
type class. *)
From prelude Require Export proof_irrel.

Hint Extern 200 (Decision _) => progress (lazy beta) : typeclass_instances.

Lemma dec_stable `{Decision P} : ¬¬P → P.
Proof. firstorder. Qed.

Lemma Is_true_reflect (b : bool) : reflect b b.
Proof. destruct b. left; constructor. right. intros []. Qed.
Instance: Inj (=) (↔) Is_true.
Proof. intros [] []; simpl; intuition. Qed.

(** We introduce [decide_rel] to avoid inefficienct computation due to eager
evaluation of propositions by [vm_compute]. This inefficiency occurs if
[(x = y) := (f x = f y)] as [decide (x = y)] evaluates to [decide (f x = f y)]
which then might lead to evaluation of [f x] and [f y]. Using [decide_rel]
we hide [f] under a lambda abstraction to avoid this unnecessary evaluation. *)
Definition decide_rel {A B} (R : A → B → Prop) {dec : ∀ x y, Decision (R x y)}
  (x : A) (y : B) : Decision (R x y) := dec x y.
Lemma decide_rel_correct {A B} (R : A → B → Prop) `{∀ x y, Decision (R x y)}
  (x : A) (y : B) : decide_rel R x y = decide (R x y).
Proof. reflexivity. Qed.

Lemma decide_True {A} `{Decision P} (x y : A) :
  P → (if decide P then x else y) = x.
Proof. destruct (decide P); tauto. Qed.
Lemma decide_False {A} `{Decision P} (x y : A) :
  ¬P → (if decide P then x else y) = y.
Proof. destruct (decide P); tauto. Qed.
Lemma decide_iff {A} P Q `{Decision P, Decision Q} (x y : A) :
  (P ↔ Q) → (if decide P then x else y) = (if decide Q then x else y).
Proof. intros [??]. destruct (decide P), (decide Q); tauto. Qed.

(** The tactic [destruct_decide] destructs a sumbool [dec]. If one of the
components is double negated, it will try to remove the double negation. *)
Tactic Notation "destruct_decide" constr(dec) "as" ident(H) :=
  destruct dec as [H|H];
  try match type of H with
  | ¬¬_ => apply dec_stable in H
  end.
Tactic Notation "destruct_decide" constr(dec) :=
  let H := fresh in destruct_decide dec as H.

(** The tactic [case_decide] performs case analysis on an arbitrary occurrence
of [decide] or [decide_rel] in the conclusion or hypotheses. *)
Tactic Notation "case_decide" "as" ident(Hd) :=
  match goal with
  | H : context [@decide ?P ?dec] |- _ =>
    destruct_decide (@decide P dec) as Hd
  | H : context [@decide_rel _ _ ?R ?x ?y ?dec] |- _ =>
    destruct_decide (@decide_rel _ _ R x y dec) as Hd
  | |- context [@decide ?P ?dec] =>
    destruct_decide (@decide P dec) as Hd
  | |- context [@decide_rel _ _ ?R ?x ?y ?dec] =>
    destruct_decide (@decide_rel _ _ R x y dec) as Hd
  end.
Tactic Notation "case_decide" :=
  let H := fresh in case_decide as H.

(** The tactic [solve_decision] uses Coq's [decide equality] tactic together
with instance resolution to automatically generate decision procedures. *)
Ltac solve_trivial_decision :=
  match goal with
  | |- Decision (?P) => apply _
  | |- sumbool ?P (¬?P) => change (Decision P); apply _
  end.
Ltac solve_decision := intros; first
  [ solve_trivial_decision
  | unfold Decision; decide equality; solve_trivial_decision ].

(** The following combinators are useful to create Decision proofs in
combination with the [refine] tactic. *)
Notation swap_if S := (match S with left H => right H | right H => left H end).
Notation cast_if S := (if S then left _ else right _).
Notation cast_if_and S1 S2 := (if S1 then cast_if S2 else right _).
Notation cast_if_and3 S1 S2 S3 := (if S1 then cast_if_and S2 S3 else right _).
Notation cast_if_and4 S1 S2 S3 S4 :=
  (if S1 then cast_if_and3 S2 S3 S4 else right _).
Notation cast_if_and5 S1 S2 S3 S4 S5 :=
  (if S1 then cast_if_and4 S2 S3 S4 S5 else right _).
Notation cast_if_and6 S1 S2 S3 S4 S5 S6 :=
  (if S1 then cast_if_and5 S2 S3 S4 S5 S6 else right _).
Notation cast_if_or S1 S2 := (if S1 then left _ else cast_if S2).
Notation cast_if_or3 S1 S2 S3 := (if S1 then left _ else cast_if_or S2 S3).
Notation cast_if_not_or S1 S2 := (if S1 then cast_if S2 else left _).
Notation cast_if_not S := (if S then right _ else left _).

(** We can convert decidable propositions to booleans. *)
Definition bool_decide (P : Prop) {dec : Decision P} : bool :=
  if dec then true else false.

Lemma bool_decide_reflect P `{dec : Decision P} : reflect P (bool_decide P).
Proof. unfold bool_decide. destruct dec; [left|right]; assumption. Qed.

Tactic Notation "case_bool_decide" "as" ident (Hd) :=
  match goal with
  | H : context [@bool_decide ?P ?dec] |- _ =>
    destruct_decide (@bool_decide_reflect P dec) as Hd
  | |- context [@bool_decide ?P ?dec] =>
    destruct_decide (@bool_decide_reflect P dec) as Hd
  end.
Tactic Notation "case_bool_decide" :=
  let H := fresh in case_bool_decide as H.

Lemma bool_decide_spec (P : Prop) {dec : Decision P} : bool_decide P ↔ P.
Proof. unfold bool_decide. destruct dec; simpl; tauto. Qed.
Lemma bool_decide_unpack (P : Prop) {dec : Decision P} : bool_decide P → P.
Proof. rewrite bool_decide_spec; trivial. Qed.
Lemma bool_decide_pack (P : Prop) {dec : Decision P} : P → bool_decide P.
Proof. rewrite bool_decide_spec; trivial. Qed.
Lemma bool_decide_true (P : Prop) `{Decision P} : P → bool_decide P = true.
Proof. case_bool_decide; tauto. Qed.
Lemma bool_decide_false (P : Prop) `{Decision P} : ¬P → bool_decide P = false.
Proof. case_bool_decide; tauto. Qed.
Lemma bool_decide_iff (P Q : Prop) `{Decision P, Decision Q} :
  (P ↔ Q) → bool_decide P = bool_decide Q.
Proof. repeat case_bool_decide; tauto. Qed.

(** * Decidable Sigma types *)
(** Leibniz equality on Sigma types requires the equipped proofs to be
equal as Coq does not support proof irrelevance. For decidable we
propositions we define the type [dsig P] whose Leibniz equality is proof
irrelevant. That is [∀ x y : dsig P, x = y ↔ `x = `y]. *)
Definition dsig `(P : A → Prop) `{∀ x : A, Decision (P x)} :=
  { x | bool_decide (P x) }.

Definition proj2_dsig `{∀ x : A, Decision (P x)} (x : dsig P) : P (`x) :=
  bool_decide_unpack _ (proj2_sig x).
Definition dexist `{∀ x : A, Decision (P x)} (x : A) (p : P x) : dsig P :=
  x↾bool_decide_pack _ p.
Lemma dsig_eq `(P : A → Prop) `{∀ x, Decision (P x)}
  (x y : dsig P) : x = y ↔ `x = `y.
Proof. apply (sig_eq_pi _). Qed.
Lemma dexists_proj1 `(P : A → Prop) `{∀ x, Decision (P x)} (x : dsig P) p :
  dexist (`x) p = x.
Proof. apply dsig_eq; reflexivity. Qed.

(** * Instances of Decision *)
(** Instances of [Decision] for operators of propositional logic. *)
Instance True_dec: Decision True := left I.
Instance False_dec: Decision False := right (False_rect False).
Instance Is_true_dec b : Decision (Is_true b).
Proof. destruct b; apply _. Defined.

Section prop_dec.
  Context `(P_dec : Decision P) `(Q_dec : Decision Q).

  Global Instance not_dec: Decision (¬P).
  Proof. refine (cast_if_not P_dec); intuition. Defined.
  Global Instance and_dec: Decision (P ∧ Q).
  Proof. refine (cast_if_and P_dec Q_dec); intuition. Defined.
  Global Instance or_dec: Decision (P ∨ Q).
  Proof. refine (cast_if_or P_dec Q_dec); intuition. Defined.
  Global Instance impl_dec: Decision (P → Q).
  Proof. refine (if P_dec then cast_if Q_dec else left _); intuition. Defined.
End prop_dec.
Instance iff_dec `(P_dec : Decision P) `(Q_dec : Decision Q) :
  Decision (P ↔ Q) := and_dec _ _.

(** Instances of [Decision] for common data types. *)
Instance bool_eq_dec (x y : bool) : Decision (x = y).
Proof. solve_decision. Defined.
Instance unit_eq_dec (x y : unit) : Decision (x = y).
Proof. solve_decision. Defined.
Instance prod_eq_dec `(A_dec : ∀ x y : A, Decision (x = y))
  `(B_dec : ∀ x y : B, Decision (x = y)) (x y : A * B) : Decision (x = y).
Proof. solve_decision. Defined.
Instance sum_eq_dec `(A_dec : ∀ x y : A, Decision (x = y))
  `(B_dec : ∀ x y : B, Decision (x = y)) (x y : A + B) : Decision (x = y).
Proof. solve_decision. Defined.

Instance curry_dec `(P_dec : ∀ (x : A) (y : B), Decision (P x y)) p :
    Decision (curry P p) :=
  match p as p return Decision (curry P p) with
  | (x,y) => P_dec x y
  end.
Instance uncurry_dec `(P_dec : ∀ (p : A * B), Decision (P p)) x y :
  Decision (uncurry P x y) := P_dec (x,y).

Instance sig_eq_dec `(P : A → Prop) `{∀ x, ProofIrrel (P x)}
  `{∀ x y : A, Decision (x = y)} (x y : sig P) : Decision (x = y).
Proof. refine (cast_if (decide (`x = `y))); rewrite sig_eq_pi; trivial. Defined.

(** Some laws for decidable propositions *)
Lemma not_and_l {P Q : Prop} `{Decision P} : ¬(P ∧ Q) ↔ ¬P ∨ ¬Q.
Proof. destruct (decide P); tauto. Qed.
Lemma not_and_r {P Q : Prop} `{Decision Q} : ¬(P ∧ Q) ↔ ¬P ∨ ¬Q.
Proof. destruct (decide Q); tauto. Qed.
Lemma not_and_l_alt {P Q : Prop} `{Decision P} : ¬(P ∧ Q) ↔ ¬P ∨ (¬Q ∧ P).
Proof. destruct (decide P); tauto. Qed.
Lemma not_and_r_alt {P Q : Prop} `{Decision Q} : ¬(P ∧ Q) ↔ (¬P ∧ Q) ∨ ¬Q.
Proof. destruct (decide Q); tauto. Qed.


Set Implicit Arguments.
Set Contextual Implicit.
Set Primitive Projections.

From Equations Require Import Equations.

From OGS Require Import CatD Utils EventD.

Section itree.

  Context {I : Type} {E : event I I} {R : I -> Type}.

  Variant itreeF (ind : I -> Type) (i : I) :=
  | RetF (r : R i)
  | TauF (t : ind i)
  | VisF (e : E.(qry) i) (k : forall r : E.(rsp) e, ind (E.(nxt) e r))
  .

  CoInductive itree (i : I) : Type := go
  { _observe : itreeF itree i }.

End itree.

Bind Scope itree_scope with itree.
Delimit Scope itree_scope with itree.
Local Open Scope itree_scope.

Arguments itree {_} _ _ _.
Arguments itreeF {_} _ _ _ _.

Notation itree' E R := (itreeF E R (itree E R)).

Definition observe {I E R i} (t : @itree I E R i) : itree' E R i :=
  @_observe I E R i t.

Notation Ret x := (go (RetF x)).
Notation Tau t := (go (TauF t)).
Notation Vis e k := (go (VisF e k)).

Section a.
Context {I} {E : event I I} {R : I -> Type}.
Definition ret {i} x : itree E R i := Ret x.
Definition tau {i} t : itree E R i := Tau t.
Definition vis {i} e k : itree E R i := Vis e k.
Definition vis'' : ⟦ E ⟧ (itree E R) ⇒ᵢ itree E R := fun _ x => Vis _ (projT2 x).
End a.

Definition vis' {I} (E : event I I) {R i} e k : itree E R i := @vis I E R i e k.
Arguments vis' : clear implicits.
Arguments vis' {I} E {R i} e k.

Definition fmap {I} {E : event I I} {X Y} (f : X ⇒ᵢ Y) : itree E X ⇒ᵢ itree E Y :=
  cofix _fmap _ u :=
    match (observe u) with
    | RetF r => Ret (f _ r)
    | TauF t => Tau (_fmap _ t)
    | VisF e k => Vis e (fun r => _fmap _ (k r))
    end.

Definition subst {I} {E : event I I} {X Y} (f : X ⇒ᵢ itree E Y)
                 : itree E X ⇒ᵢ itree E Y :=
  cofix _subst _ u :=
    match observe u with
    | RetF r => f _ r
    | TauF t => Tau (_subst _ t)
    | VisF e k => Vis e (fun r => _subst _ (k r))
    end.

(* McBride's "daemonic" bind: [f] has to be defined at every state [i] *)
Definition bind {I E X Y i} x f := @subst I E X Y f i x.
(*Notation "x ?>= f" := (bind x f) (at level 20).*)

Instance FunctorItree {I} (E : event I I) : Functor (itree E) :=
  Build_Functor _ (fun X Y => @fmap I E X Y).

Instance MonadItree {I} (E : event I I) : Monad (itree E) :=
  Build_Monad _ (fun X => @ret I E X) (fun X Y => @subst I E X Y).


Require Import floyd.proofauto.
Require Import progs.message.

Local Open Scope Z.
Local Open Scope logic.

(*   mf_assert msgfmt sh buf len data  := the [data] is formatted into a message
         at most [len] bytes,  stored starting at address [buf] with share [sh] *)

Definition natural_alignment := 8.

Lemma natural_alignment_enough: forall t, type_is_by_value t = true -> legal_alignas_type t = true -> (alignof t | 8).
Proof.
  intros.
  assert (1 | 8). exists 8. reflexivity.
  assert (2 | 8). exists 4. reflexivity.
  assert (4 | 8). exists 2. reflexivity.
  assert (8 | 8). exists 1. reflexivity.
  destruct t; try inversion H; simpl;
  unfold legal_alignas_type in H0; simpl in H0;
  destruct (attr_alignas a); inversion H0; [destruct i| | destruct f|]; assumption.
Qed.

Definition natural_align_compatible p :=
  match p with
  | Vptr b ofs => (natural_alignment | Int.unsigned ofs)
  | _ => True
  end.

Record message_format (t: type) : Type :=
mf_build {
   mf_size: Z;
   mf_data_assert: forall (data: reptype t), Prop;
   mf_assert: forall (sh: share) (buf: val) (len: Z) (data: reptype t), mpred;
   mf_size_range:  0 <= mf_size <= Int.max_signed;
   mf_bufprop: forall sh buf len data,
           mf_assert sh buf len data |--
                 !!(0 <= len <= mf_size) && memory_block sh (Int.repr len) buf;
   mf_restbuf := fun (sh: share) (buf: val) (len: Z) =>
          memory_block sh (Int.repr (mf_size-len)) (offset_val (Int.repr len) buf)
}.

Implicit Arguments mf_build [[t]].
Implicit Arguments mf_size [[t]].
Implicit Arguments mf_data_assert [[t]].
Implicit Arguments mf_assert [[t]].
Implicit Arguments mf_bufprop [[t]].
Implicit Arguments mf_size_range [[t]].
Implicit Arguments mf_restbuf [[t]].
(* need to add a proof to message_format, that the
     representation of a  buf implies the data_at_ of the bufsize array *)

Program Definition intpair_message: message_format t_struct_intpair :=
  mf_build 8 (fun data => is_int I32 Signed (fst data) /\ is_int I32 Signed (snd data))
             (fun sh buf len data => !!(len=8/\ is_int I32 Signed (fst data) /\ is_int I32 Signed (snd data))
                           && data_at sh (tarray tint 2) [fst data; snd data] buf)
      _ _.
Next Obligation.
compute; split; congruence.
Qed.
Next Obligation.
  normalize.
  eapply derives_trans; [apply data_at_data_at_; reflexivity|].
  rewrite data_at__memory_block by reflexivity.
  apply andp_right; [apply prop_right; omega|].
  simpl.
  apply andp_left2.
  apply derives_refl.
Qed.

(* align_compatible requirement is neccesary in precondition *)
Definition serialize_spec {t: type} (format: message_format t) :=
  WITH data: reptype t, p: val, buf: val, sh: share, sh': share
  PRE [ _p OF (tptr tvoid), _buf OF (tptr tuchar) ]
          PROP (writable_share sh';
                mf_data_assert format data;
                natural_align_compatible buf)
          LOCAL (temp _p p; temp _buf buf)
          SEP (`(data_at sh t data p);
               `(memory_block sh' (Int.repr (mf_size format)) buf))
  POST [ tint ]
         EX len: Z,
          local (`(eq (Vint (Int.repr len))) retval) &&
         `(data_at sh t data p)
            * `(mf_assert format sh' buf len data) * `(mf_restbuf format sh' buf len).

Definition deserialize_spec {t: type} (format: message_format t) :=
  WITH data: reptype t, p: val, buf: val, shs: share*share, len: Z
  PRE [ _p OF (tptr tvoid), _buf OF (tptr tuchar), _length OF tint ]
          PROP (writable_share (fst shs);
                0 <= len <= mf_size format)
          LOCAL (temp _p p;
                 temp _buf buf;
                 temp _length (Vint (Int.repr len)))
          SEP (`(mf_assert format (snd shs) buf len data);
               `(data_at_ (fst shs) t p))
  POST [ tvoid ]
          PROP (mf_data_assert format data)  LOCAL ()
          SEP (`(mf_assert format (snd shs) buf len data);
                 `(data_at (fst shs) t data p)).

Definition intpair_serialize_spec :=
 DECLARE _intpair_serialize (serialize_spec intpair_message).

Definition intpair_deserialize_spec :=
 DECLARE _intpair_deserialize (deserialize_spec intpair_message).

Definition main_spec :=
 DECLARE _main
  WITH u : unit
  PRE  [] main_pre prog nil u
  POST [ tint ] main_post prog nil u.

Definition Vprog : varspecs := (_intpair_message, t_struct_message)::nil.

Definition message (sh: share) {t: type} (format: message_format t) (m: val) : mpred :=
  EX fg: val*val,
          func_ptr (serialize_spec format) (fst fg) &&
          func_ptr (deserialize_spec format) (snd fg) &&
       data_at sh t_struct_message (Vint (Int.repr (mf_size format)), (fst fg, snd fg)) m.

Definition Gprog : funspecs :=   ltac:(with_library prog [
    intpair_serialize_spec; intpair_deserialize_spec; main_spec]).

Lemma body_intpair_serialize: semax_body Vprog Gprog f_intpair_serialize intpair_serialize_spec.
Proof.
unfold intpair_serialize_spec.
unfold serialize_spec.
start_function.
name p0 _p.
name buf0 _buf.
name x _x.
name y _y.
destruct H0 as [Dx Dy].
destruct data as [[|x1 | | | | ] [|y1 | | | | ]]; try contradiction. clear Dx Dy.

unfold_data_at 1%nat.
change (mf_size intpair_message) with (sizeof (tarray tint 2)).
rewrite memory_block_data_at_; try reflexivity.
Focus 2. {
  unfold natural_align_compatible in H1.
  unfold align_compatible.
  destruct buf; auto.
  eapply Z.divide_trans; [| exact H1].
  exists 2.
  cbv.
  reflexivity.
} Unfocus.

forward. (* x = p->x; *)
forward. (* y = p->y; *)
forward. (*  ((int * )buf)[0]=x; *)
forward. (*  ((int * )buf)[1]=y; *)
forward. (* return 8; *)
apply exp_right with 8.
entailer.

unfold_data_at 2%nat.
cancel.
unfold mf_restbuf. simpl.
destruct buf0; inv Pbuf0.
simpl. rewrite memory_block_zero.
entailer!.
Qed.

Lemma body_intpair_deserialize: semax_body Vprog Gprog f_intpair_deserialize intpair_deserialize_spec.
Proof.
unfold intpair_deserialize_spec, deserialize_spec.
start_function. destruct shs as (sh,sh'). simpl @fst; simpl @snd.
name p0 _p.
name buf0 _buf.
name x _x.
name y _y.
name len0 _length.
destruct data as (x1,y1); simpl in *.
normalize.
destruct x1 as [|x1| | | |]; try contradiction.
destruct y1 as [|y1| | | |]; try contradiction.
clear H2 H3.

forward. (* x = ((int * )buf)[0]; *)
forward. (* y = ((int * )buf)[1]; *)
forward. (* p->x = x; *)
forward. (*  p->y = y; *)
forward.  (* return; *)
Qed.

Ltac simpl_stackframe_of :=
  unfold stackframe_of, fn_vars; simpl map; unfold fold_right; rewrite sepcon_emp;
  repeat rewrite var_block_data_at_ by reflexivity.

Ltac get_global_function id :=
  eapply (call_lemmas.semax_fun_id' id); [ reflexivity | simpl; reflexivity | ].

Lemma slide_func_ptr:
  forall f e R1 R,
  SEPx (`(func_ptr' f) e :: R1 :: R) = SEPx ((`(func_ptr f) e && R1)::R).
Proof.
 intros. unfold SEPx; unfold_lift.
extensionality rho.
simpl.
rewrite <- sepcon_assoc.
 f_equal.
unfold func_ptr'.
rewrite corable_andp_sepcon1 by apply corable_func_ptr.
rewrite emp_sepcon; auto.
Qed.

Ltac get_global_function' id :=
  eapply (call_lemmas.semax_fun_id' id); [ reflexivity | reflexivity | simpl; reflexivity | rewrite slide_func_ptr ].

Lemma  create_message_object:
 forall t (msg: message_format t) objid serid desid
 (Vobj: (var_types (func_tycontext f_main Vprog Gprog)) ! objid = None)
 (Gobj: (glob_types (func_tycontext f_main Vprog Gprog)) ! objid = Some (t_struct_message))
 (Vser: (var_types (func_tycontext f_main Vprog Gprog)) ! serid = None)
 (Gser: (glob_types (func_tycontext f_main Vprog Gprog)) ! serid =
                                   Some (type_of_funspec (serialize_spec msg)))
 (Vdes: (var_types (func_tycontext f_main Vprog Gprog)) ! desid = None)
 (Gdes: (glob_types (func_tycontext f_main Vprog Gprog)) ! desid =
                                   Some (type_of_funspec (deserialize_spec msg))),
PROP  ()
LOCAL (tc_environ (func_tycontext f_main Vprog Gprog))
SEP
   (`(func_ptr (serialize_spec msg))
      (eval_var serid
         (type_of_funspec (serialize_spec msg))) &&
    (`(func_ptr (deserialize_spec msg))
       (eval_var desid
          (type_of_funspec  (deserialize_spec msg))) &&
  (id2pred_star (func_tycontext f_main Vprog Gprog) Ews t_struct_message
    (eval_var objid t_struct_message) 0
    (Init_int32 (Int.repr (mf_size msg))
     :: Init_addrof serid (Int.repr 0)
        :: Init_addrof desid (Int.repr 0) :: nil))))
  |-- PROP()  LOCAL() SEP (`(message Ews msg)  (eval_var objid t_struct_message)).
Proof.
intros.
unfold id2pred_star, init_data2pred'.
 rewrite Vser,Vdes. rewrite Gser,Gdes.
go_lower.
normalize.
 unfold message.
 apply exp_right with
 (eval_var serid
     (Tfunction (Tcons (tptr tvoid) (Tcons (tptr tuchar) Tnil)) tint cc_default) rho,
 eval_var desid
      (Tfunction (Tcons (tptr tvoid) (Tcons (tptr tuchar) (Tcons tint Tnil)))
         tvoid cc_default) rho).
rewrite andp_assoc.
apply andp_derives; auto.
apply andp_derives; auto.
 simpl_data_at.
 simpl.
 normalize.
    rewrite mapsto_tuint_tint.
 destruct (globvar_eval_var _ _ objid _ H Vobj Gobj) as [b1 [Eobj _]].
 simpl in Eobj; rewrite Eobj. clear dependent objid.
 destruct (globvar_eval_var _ _ serid _ H Vser Gser) as [b2 [Eser _]].
 simpl in Eser; rewrite Eser; clear dependent serid.
 destruct (globvar_eval_var _ _ desid _ H Vdes Gdes) as [b3 [Edes _]].
 simpl in Edes; rewrite Edes; clear dependent desid.
 apply andp_right.
 + apply prop_right.
   unfold size_compatible, align_compatible.
   split; simpl.
   cbv; intros; inversion H0.
   change (Int.unsigned Int.zero) with 0.
   split3.
   apply Z.divide_0_r.  reflexivity. reflexivity.
 + repeat apply sepcon_derives.
   normalize.
   simpl offset_val.
   rewrite  int_add_repr_0_r.
   normalize.
   simpl offset_val.
   rewrite int_add_repr_0_r.
   normalize.
Qed.

Definition serialize_A {t}  (msg: message_format t) : Type :=
  match serialize_spec msg with mk_funspec _ A _ _ => A  end.

Definition serialize_pre {t} (msg: message_format t)  :=
match serialize_spec msg as f
     return match f with mk_funspec _ A _ _ => A -> environ->mpred end
with mk_funspec f A P Q => P end.

Definition serialize_post {t} (msg: message_format t)  :=
match serialize_spec msg as f
     return match f with mk_funspec _ A _ _ => A -> environ->mpred end
with mk_funspec f A P Q => Q end.

Definition serialize_fsig {t} (msg: message_format t)  : funsig :=
match serialize_spec msg with mk_funspec f A P Q => f end.

Fixpoint list2idset'  (l: list ident) : idset :=
 match l with nil => idset0  | x::l' => insert_idset x (list2idset' l') end.

Definition list2idset  (l: list ident) (id: ident)  :=
  isSome ((list2idset' l) ! id).

Definition temp_type_is (Delta: tycontext) (id: ident) (t: type) :=
   match (temp_types Delta) ! id with
    Some (t',_) => t' = t
   | _ => False
  end.

Lemma subst_make_args'x
     : forall (id : ident) (v : environ -> val)
         (fsig : list (ident * type) * type) (tl : list type)
         (el : list expr),
       length tl = length el ->
       length (fst fsig) = length el ->
       subst id v (make_args' fsig (eval_exprlist tl el)) =
        make_args' fsig (subst id v (eval_exprlist tl el)).
Proof.
intros. unfold_lift. extensionality rho; unfold subst.
unfold make_args'.
revert tl el H H0; induction (fst fsig); destruct tl,el; simpl; unfold lift; intros; inv H; inv H0.
reflexivity.
specialize (IHl _ _ H2 H1).
unfold_lift; rewrite IHl. auto.
Qed.
Hint Rewrite subst_make_args'x using (solve[reflexivity]) : subst.

Lemma func_ptr_isptr:
 forall spec f, func_ptr spec f |-- !! isptr f.
Proof.
Admitted.  (* needs to go in veric *)
Hint Resolve func_ptr_isptr: saturate_local.

Section HINTS.
Hint Resolve closed_wrt_eval_expr : closed.
Hint Resolve closed_wrt_lvalue : closed.

Lemma call_serialize:
 forall Espec (Delta: tycontext) (ser id x: ident)
           (sh_obj : share) (e_obj: expr) (d_obj: environ -> val)
           (sh_p: share) (e_p: expr) (d_p: environ -> val)
           (sh_buf: share) (e_buf: expr) (d_buf: environ -> val)
           (t: type) (msg: message_format t)
             (v: reptype t),
 eval_lvalue e_obj = d_obj ->
 eval_expr e_p = d_p ->
 eval_lvalue e_buf = d_buf ->
 typeof e_obj = t_struct_message ->
 (temp_type_is Delta ser (tptr (Tfunction (Tcons (tptr tvoid) (Tcons (tptr tuchar) Tnil)) tint cc_default)) /\
  temp_type_is Delta x tint /\ temp_type_is Delta id tint ) ->
 writable_share sh_buf ->
 x <> ser /\ x <> id /\ id <> ser ->
 forall
  (AM_buf: access_mode (typeof e_buf) = By_reference)
  (CL_obj: closed_wrt_vars (list2idset(ser::x::id::nil)) (eval_lvalue e_obj))
  (CL_p: closed_wrt_vars (list2idset(ser::x::id::nil)) (eval_expr e_p))
  (CL_buf: closed_wrt_vars (list2idset(ser::x::id::nil)) (eval_expr e_buf))
  (H6: local (tc_environ Delta) |-- local (tc_lvalue Delta e_obj)),
 @semax Espec Delta
   (PROP ()
    (LOCAL (tc_exprlist Delta (tptr tvoid :: tptr tuchar :: nil) (e_p :: e_buf :: nil))
     SEP (`(message sh_obj msg) d_obj ;
               `(data_at sh_p t v) d_p;
               `(data_at_ sh_buf (tarray tuchar (mf_size msg))) d_buf)))
   (Ssequence
    (Sset ser
     (Efield e_obj _serialize
        (tptr (Tfunction (Tcons (tptr tvoid) (Tcons (tptr tuchar) Tnil)) tint cc_default))))
      (Ssequence
           (Scall (Some x)
              (Etempvar ser (tptr (Tfunction (Tcons (tptr tvoid) (Tcons (tptr tuchar) Tnil)) tint cc_default)))
              (e_p :: e_buf :: nil))
           (Sset id (Etempvar x tint))))
    (normal_ret_assert (PROP () LOCAL()
      SEP (`(message sh_obj msg) d_obj;
               `(data_at sh_p t v) d_p;
               `(mf_assert msg sh_buf) d_buf (`Int.signed (`force_int (eval_id id))) `v;
               `(mf_restbuf msg sh_buf) d_buf (`Int.signed (`force_int (eval_id id)))))).
Proof.
intros.
destruct H5 as [H5a [H5b H5c]].
subst.
assert (CLser: included (eq ser) (list2idset(ser::x::id::nil))) by admit.
assert (CLx: included (eq x) (list2idset(ser::x::id::nil))) by admit.
assert (CLid: included (eq id) (list2idset(ser::x::id::nil))) by admit.
eapply semax_pre with
 (PROP()
  LOCAL (tc_lvalue Delta e_obj ; tc_exprlist Delta (tptr tvoid :: tptr tuchar :: nil) (e_p :: e_buf :: nil))
  SEP (`(message sh_obj msg) (eval_lvalue e_obj);
        `(data_at sh_p t v) (eval_expr e_p);
        `(data_at_ sh_buf (tarray tuchar (mf_size msg))) (eval_lvalue e_buf))).
go_lowerx.
normalize. rewrite prop_and.
repeat apply andp_right; auto.
eapply derives_trans; [ |  apply H6].
apply prop_right; auto.
apply prop_right; auto.
clear H6.
unfold message at 1.
replace_SEP 0%Z (EX fg: val*val,
            `(func_ptr (serialize_spec msg) (fst fg)) &&
            `(func_ptr (deserialize_spec msg) (snd fg)) &&
            `(data_at sh_obj t_struct_message ((Vint (Int.repr (mf_size msg)), (fst fg, snd fg))))
                  (eval_lvalue e_obj)).
entailer. apply exp_right with x0. entailer.
extract_exists_in_SEP. intros [f g].
simpl @fst; simpl @ snd.
match goal with |- semax _ (PROPx nil ?QR) _ _ =>
 apply semax_pre with (PROP (isptr f) QR)
end.
go_lowerx. entailer.
repeat rewrite sepcon_assoc.
eapply derives_trans. apply sepcon_derives.
apply andp_left1. apply func_ptr_isptr.
apply TT_right.
rewrite sepcon_prop_prop. apply prop_derives; intuition.
normalize.
apply semax_pre with
  (EX p:val, EX buf:val, |>(PROP()
     LOCAL(tc_lvalue Delta e_obj; `(eq p) (eval_expr e_p);
                     `(eq buf) (eval_lvalue e_buf);
                     (tc_exprlist Delta (tptr tvoid :: tptr tuchar :: nil) (e_p :: e_buf :: nil)))
      SEP
  (`(field_at sh_obj t_struct_message [StructField _serialize] f) (eval_lvalue e_obj);
      `(func_ptr' (serialize_spec msg)) `f;
    `(field_at sh_obj t_struct_message [StructField _bufsize] (Vint (Int.repr (mf_size msg))))
                            (eval_lvalue e_obj);
     `(serialize_pre msg (v,p,buf,sh_p,sh_buf))
       (make_args' (serialize_fsig msg)
         (eval_exprlist (snd (split (fst (serialize_fsig msg)))) (e_p :: e_buf :: nil)));
      `(field_at sh_obj t_struct_message [StructField _deserialize] g) (eval_lvalue e_obj)))).
admit.  (* might work *)
apply extract_exists_pre; intro p.
apply extract_exists_pre; intro buf.
destruct H3 as [H3 [H3x H3id]]; unfold temp_type_is in H3;
revert H3; case_eq ((temp_types Delta) ! ser); intros; try contradiction.
destruct p0.
subst t0.

eapply semax_seq'.
{
  change (Efield e_obj _serialize
           (tptr
              (Tfunction (Tcons (tptr tvoid) (Tcons (tptr tuchar) Tnil)) tint
                 cc_default))) with
  (nested_efield e_obj (eStructField _serialize :: nil) ((tptr
              (Tfunction (Tcons (tptr tvoid) (Tcons (tptr tuchar) Tnil)) tint
                 cc_default)) :: nil)).
Admitted.
(*
  apply semax_max_path_field_load_37'
   with (t0 := (tptr
          (Tfunction (Tcons (tptr tvoid) (Tcons (tptr tuchar) Tnil)) tint
             cc_default)))
     (e:= PTree.empty _)(sh := sh_obj) (v':= valinject (nested_field_type (typeof e_obj) (StructField _serialize :: @nil gfield)) f) (*t:= t_struct_message*);
    try assumption; try rewrite H2; try reflexivity.
  admit.  (* closed...  should be fine *)
   admit.  (* closed...  should be fine *)
 unfold typeof_temp; rewrite H0. reflexivity.
 go_lowerx; entailer.
 simpl. cancel.
 entailer!.
 hnf. simpl. repeat rewrite denote_tc_assert_andp; repeat split; auto.
 rewrite H2. simpl. hnf; auto.
}
rename H into H'.
focus_SEP 3 1.
   apply semax_pre with
     (P':=PROP () LOCAL (tc_expr (initialized ser Delta)
                (Etempvar ser
                   (tptr
                      (Tfunction
                         (Tcons (tptr tvoid) (Tcons (tptr tuchar) Tnil)) tint cc_default)));
              tc_exprlist  (initialized ser Delta) (snd (split (fst (serialize_fsig msg))))   (e_p :: e_buf :: nil);
              `eq (eval_id ser) `f;
              `(eq p) (eval_expr e_p);  `(eq buf) (eval_lvalue e_buf))
       (SEP (`(serialize_pre msg (v, p, buf, sh_p, sh_buf))
              (make_args'  (fst (serialize_fsig msg), snd (serialize_fsig msg))
                 (eval_exprlist (snd (split (fst (serialize_fsig msg))))
                    (e_p :: e_buf :: nil)));
            `(func_ptr' (serialize_spec msg))
                      (eval_expr
                         (Etempvar ser
                            (tptr
                               (Tfunction
                                  (Tcons (tptr tvoid)
                                     (Tcons (tptr tuchar) Tnil)) tint cc_default))));
             `(field_at sh_obj t_struct_message [_serialize])  (eval_id ser)
                            (eval_lvalue e_obj);
              `(field_at sh_obj t_struct_message [_bufsize] (Vint (Int.repr (mf_size msg))))
                       (eval_lvalue e_obj);
               `(field_at sh_obj t_struct_message [_deserialize] g)
                            (eval_lvalue e_obj)))).
go_lowerx. subst.
apply andp_right; auto.
apply prop_right.
repeat split; auto.
hnf. unfold typecheck_expr.
simpl negb. cbv iota.
rewrite (temp_types_init_same _ _ _ _ H0).
apply I.
hnf in H8|-*.
unfold typecheck_exprlist in H8|-*.
repeat rewrite denote_tc_assert_andp in H8|-*.
destruct H8 as [? [? _]]; repeat split; auto.
apply tc_expr_init; auto.
apply tc_expr_init; auto.
eapply semax_seq'.
apply (call_lemmas.semax_call' Espec (initialized ser Delta) (serialize_A msg) (serialize_pre msg) (serialize_post msg)
   (v,p,buf,sh_p,sh_buf)  (Some x) (fst (serialize_fsig msg)) (snd (serialize_fsig msg))
   (Etempvar ser (tptr (Tfunction (Tcons (tptr tvoid) (Tcons (tptr tuchar) Tnil)) tint cc_default)))
   (e_p :: e_buf :: nil)).
reflexivity. simpl. auto.
hnf.
rewrite <- (expr_lemmas.initialized_ne Delta x ser)
 by auto.
hnf in H3x. destruct ((temp_types Delta) ! x); try contradiction.
destruct p0; subst. reflexivity.
apply extract_exists_pre; intro old'.
change (@substopt Prop (Some x)) with (@subst Prop x).
change (@substopt mpred (Some x)) with (@subst mpred x).
assert (C1:=closed_wrt_subset _ _ CLx).
assert (C2:=closed_wrt_Forall_subset _ _ CLx).
autorewrite with subst.
clear C1 C2.
simpl update_tycon.
eapply semax_post_flipped.
apply forward_lemmas.forward_setx.
apply andp_right; intro rho; apply prop_right.
hnf.
clear - H3x.
admit. (* straightforward *)
clear - H3id.
admit. (* straightforward *)
intros.
unfold normal_ret_assert.
repeat rewrite exp_andp2. apply exp_left; intro old''.
assert (C1:=closed_wrt_subset _ _ CLid).
assert (C2:=closed_wrt_Forall_subset _ _ CLid).
autorewrite with subst.
normalize.
unfold SeparationLogic.maybe_retval.
change (fun rho : environ =>
    serialize_post msg (v, p, buf, sh_p, sh_buf) (get_result1 x rho))
 with (`(serialize_post msg (v, p, buf, sh_p, sh_buf)) (get_result1 x)).
simpl @snd.
change(maybe_retval (serialize_post msg (v, p, buf, sh_p, sh_buf)) tint (Some x))
  with (`(serialize_post msg (v, p, buf, sh_p, sh_buf)) (get_result1 x)).
autorewrite with subst.
go_lowerx. normalize.
unfold serialize_post, serialize_spec.
normalize. rename x0 into len.
subst.

rewrite H3;
rewrite <- H9.
simpl force_int.
cancel.
apply derives_trans with
((!!(0 <= len <= mf_size msg) &&
  mf_assert msg sh_buf (eval_lvalue e_buf rho) len v ) *
mf_restbuf msg sh_buf (eval_lvalue e_buf rho) len *
field_at sh_obj t_struct_message [_serialize]
    (eval_id ser rho) (eval_lvalue e_obj rho)
  *
field_at sh_obj t_struct_message [_bufsize]
    (Vint (Int.repr (mf_size msg))) (eval_lvalue e_obj rho)
  *
field_at sh_obj t_struct_message [_deserialize] g (eval_lvalue e_obj rho)).
repeat apply sepcon_derives; auto.
apply andp_right; auto.
eapply derives_trans; [ apply mf_bufprop | ].
apply andp_left1; auto.
repeat rewrite sepcon_assoc.
rewrite sepcon_andp_prop'.
apply derives_extract_prop; intro.
assert (MMM: mf_size msg <= Int.max_signed).
apply mf_size_range.
rewrite Int.signed_repr by repable_signed.
cancel.
unfold message.
apply exp_right with (eval_id ser rho, g).
apply andp_right.
admit.  (* need to preserve these from above *)
rename H into HYP. (*remove when simpl_data_at is fixed (explanation in verif_queue)*)
simpl_data_at; try reflexivity.
simpl.
normalize.
unfold at_offset.
normalize.
cancel.
Qed.
*)

Lemma call_deserialize:
 forall Espec (Delta: tycontext) P Q R (ser: ident)
           (sh_obj : share) (e_obj: expr) (d_obj: environ -> val)
           (sh_p: share) (e_p: expr) (d_p: environ -> val)
           (sh_buf: share) (e_buf: expr) (d_buf: environ -> val)
           (e_len: expr)  (d_len: environ -> Z) (t: type) (msg: message_format t)   (v: reptype t),
 eval_lvalue e_obj = d_obj ->
 eval_expr e_p = d_p ->
 eval_expr e_buf = d_buf ->
 writable_share sh_p ->
  (PROPx P (LOCALx Q
     (SEPx (`(message sh_obj msg) d_obj ::
               `(data_at_ sh_p t) d_p::
               `(mf_assert msg sh_buf) d_buf d_len `v ::
                R)))) |-- local (`((fun n => 0 <= n <= mf_size msg) : Z->Prop) d_len) &&
                             local (`eq d_len (`Int.signed (`force_int (eval_expr e_len)))) ->
 closed_wrt_vars (eq ser)
             (PROPx P (LOCALx Q
     (SEPx (`(message sh_obj msg) d_obj ::
               `(data_at_ sh_p t) d_p::
               `(mf_assert msg sh_buf) d_buf d_len `v ::
                R)))) ->
 @semax Espec Delta
   (PROPx P (LOCALx Q
     (SEPx (`(message sh_obj msg) d_obj ::
               `(data_at_ sh_p t) d_p::
               `(mf_assert msg sh_buf) d_buf d_len`v ::
                R))))
   (Ssequence
    (Sset ser
     (Efield e_obj _deserialize
        (tptr  (Tfunction (Tcons (tptr tvoid) (Tcons (tptr tuchar) (Tcons tint Tnil))) tvoid cc_default))))
      (Scall None
        (Etempvar ser (tptr  (Tfunction (Tcons (tptr tvoid) (Tcons (tptr tuchar) (Tcons tint Tnil))) tvoid cc_default)))
          (e_p :: e_buf :: e_len :: nil)))
    (normal_ret_assert (PROPx P (LOCALx Q
     (SEPx (`(message sh_obj msg) d_obj ::
               `(data_at sh_p t v) d_p::
               `(mf_assert msg sh_buf) d_buf d_len`v::
                R))))).
Admitted.

End HINTS.

Lemma intpair_message_length:
  forall sh p (len: environ -> Z) v P Q R,
    (PROPx P (LOCALx Q (SEPx
       (`(mf_assert intpair_message sh) p len v :: R)))) |--
   (PROPx P
        (LOCALx (`(eq (mf_size intpair_message)) len :: Q)
         (SEPx (`(mf_assert intpair_message sh) p len v :: R)))).
Proof.
intros.
unfold PROPx, LOCALx, SEPx, local; intro rho; simpl.
apply andp_derives; auto.
unfold_lift.
normalize.
Qed.

Lemma body_main: semax_body Vprog Gprog f_main main_spec.
Proof.
start_function. unfold MORE_COMMANDS, abbreviate.
simpl_stackframe_of.
name len _len.
name x _x.
name y _y.
name ser _ser.
name des _des.
normalize.
repeat flatten_sepcon_in_SEP.
focus_SEP 3 1.
get_global_function' _intpair_deserialize.
get_global_function' _intpair_serialize.
eapply semax_pre.
frame_SEP' (0::nil).
unfold main_pre, globvars2pred, prog_vars. simpl map.
apply create_message_object; reflexivity.
unfold app.

apply (remember_value (eval_var _p t_struct_intpair)); intros p.
apply (remember_value (eval_var _q t_struct_intpair)); intros q.
apply (remember_value (eval_var _intpair_message t_struct_message)); intros ipm.
apply (remember_value (eval_var _buf (tarray tuchar 8))); intros buf.
eapply semax_pre with
(P' := (PROP  ()
      LOCAL  (`(eq buf) (eval_var _buf (tarray tuchar 8));
      `(eq ipm) (eval_var _intpair_message t_struct_message);
      `(eq q) (eval_var _q t_struct_intpair);
      `(eq p) (eval_var _p t_struct_intpair))
      SEP
      (`(message Ews intpair_message ipm);
      `(data_at_ Tsh (tarray tuchar 8) buf);
      `(data_at_ Tsh t_struct_intpair q);
      `(data_at_ Tsh t_struct_intpair p)))); [entailer! |].

forward. (*  p.x = 1; *)
forward. (* p.y = 2; *)
(*
entailer!.
unfold replace_nth.
simpl update_tycon.
apply derives_refl.  (* SHOULD NOT NEED THIS LINE *)

Ltac gather_SEP' L :=
   grab_indexes_SEP L; (*handles lifting better than the one in client_lemmas *)
 match goal with |- context [SEPx ?R] =>
   rewrite <- (firstn_skipn (length L) R);
   unfold firstn, skipn; simpl length; cbv beta iota; rewrite gather_SEP;
   unfold app, fold_right; try  rewrite sepcon_emp
 end.

gather_SEP' (0::1::nil).
replace_SEP 0 (`(data_at Tsh t_struct_intpair (Vint (Int.repr 1), Vint (Int.repr 2)))
                      (eval_var _p t_struct_intpair) ).
unfold_data_at 1%nat.
entailer.
rewrite -> seq_assoc. simpl.
eapply semax_seq'.
frame_SEP 1 0 2.
replace_in_pre (nil: list (environ -> Prop)) (tc_exprlist Delta (tptr tvoid :: tptr tuchar :: nil)
          ((Eaddrof (Evar _p t_struct_intpair) (tptr t_struct_intpair)
            :: Evar _buf (tarray tuchar 8) ::  nil))::nil).
entailer.
try (apply prop_right; apply I). (* temporary, should soon not be needed *)
simpl update_tycon.
unfold_abbrev.
abbreviate_semax.
unfold POSTCONDITION, MORE_COMMANDS, abbreviate.
simpl update_tycon.
replace_in_pre (tc_environ Delta ::
   tc_exprlist Delta (tptr tvoid :: tptr tuchar :: nil)
     (Eaddrof (Evar _p t_struct_intpair) (tptr t_struct_intpair)
      :: Evar _buf (tarray tuchar 8) :: nil) :: nil)
  (tc_exprlist Delta (tptr tvoid :: tptr tuchar :: nil)
     (Eaddrof (Evar _p t_struct_intpair) (tptr t_struct_intpair)
      :: Evar _buf (tarray tuchar 8) :: nil) :: nil).
rewrite <- insert_local.
apply andp_left2.
rewrite <- insert_local.
apply andp_left2.
 apply derives_refl.
*)
Abort.
(*
apply call_serialize; repeat split; simpl; auto 50 with closed; auto.
intro rho. apply prop_right. hnf. auto.
simpl update_tycon. unfold app.
focus_SEP 2.
eapply semax_pre0; [apply intpair_message_length | ].
focus_SEP 1 4.
rewrite -> seq_assoc.
eapply semax_seq'.
apply call_deserialize; try reflexivity; auto.
entailer.
apply closed_wrt_PROPx.
apply closed_wrt_LOCALx; [ auto 50 with closed | ].
apply closed_wrt_SEPx.
assert (CLX: closed_wrt_vars (eq _des)
  (`(mf_assert intpair_message Tsh) (eval_var _buf (tarray tuchar 8))
     (`Int.signed (`force_int (eval_id _len))) `((Vint (Int.repr 1), Vint (Int.repr 2)))))
  by admit.
assert (CLY: closed_wrt_vars (eq _des)
  (`(data_at Tsh t_struct_intpair (Vint (Int.repr 1), Vint (Int.repr 2)))
     (eval_var _p t_struct_intpair)))
 by admit.
auto 50 with closed.
focus_SEP 1.
replace_SEP 0
  ((`( field_at Tsh t_struct_intpair [_x] (Vint (Int.repr 1))) (eval_var _q t_struct_intpair) *
   `( field_at Tsh t_struct_intpair [_y] (Vint (Int.repr 2))) (eval_var _q t_struct_intpair))
    ).
unfold_data_at 1%nat.
entailer!.
normalize.
forward. (* x = q.x; *)
forward. (* y = q.y; *)
forward. (* return x+y; *)
 unfold frame_ret_assert; simpl.  (* shouldn't need this *)
 unfold main_post.
 entailer.
 unfold mf_restbuf.
 change (mf_size intpair_message) with 8.
 assert (isptr (eval_var _buf(tarray tuchar 8) rho)).
 apply eval_var_isptr with Delta; auto.
 rewrite <- H1; clear len H1.
 simpl.
 replace (memory_block Tsh (Int.repr 0)
      (offset_val (Int.repr 8) (eval_var _buf (tarray tuchar 8) rho)))
  with (@emp mpred _ _).
 rewrite sepcon_emp.
2: symmetry; destruct (eval_var _buf (tarray tuchar 8) rho); inv H3;
 apply memory_block_zero.
unfold stackframe_of.
simpl.
repeat rewrite var_block_data_at_ by reflexivity.
unfold id.
entailer.

assert (data_at_ Tsh t_struct_intpair (eval_var _buf (tarray tuchar 8) rho) |--
   data_at_ Tsh (tarray tuchar 8) (eval_var _buf (tarray tuchar 8) rho)).
  rewrite <- !memory_block_data_at_ by reflexivity.
  unfold align_compatible; simpl.
  destruct (eval_var _buf (tarray tuchar 8) rho); entailer!.
  eapply Zdivides_trans; [exists 4; reflexivity | exact H1].
rename H into HYP. (*remove when simpl_data_at is fixed (explanation in verif_queue)*)
unfold data_at_ at 2.
unfold_data_at 3%nat.
change (field_at Tsh t_struct_intpair [_x] Vundef
          (eval_var _q t_struct_intpair rho)) with
  (field_at_ Tsh t_struct_intpair [_x]
          (eval_var _q t_struct_intpair rho)).
change (field_at Tsh t_struct_intpair [_y] Vundef
          (eval_var _q t_struct_intpair rho)) with
  (field_at_ Tsh t_struct_intpair [_y]
          (eval_var _q t_struct_intpair rho)).
cancel.
apply sepcon_derives; [cancel |].
eapply derives_trans; [apply data_at_data_at_; reflexivity | exact H1].
Qed.
*)


Require Import Logic.lib.Ensembles_ext.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.ShallowEmbedded.MonoPredicateAsLang.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ShallowEmbedded.MonoPredicatePropositionalLogic.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.TheoryOfSeparationAxioms.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Model.OSAGenerators.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.
Require Import Logic.SeparationLogic.Semantics.WeakSemantics.
Require Import Logic.SeparationLogic.Sound.Sound_Flat.

Instance MonoPred_sepconL (A: Type) {R: Relation A} {po_R: PreOrder Krelation} {J: Join A} {SA: SeparationAlgebra A} {uSA: UpwardsClosedSeparationAlgebra A} {dSA: DownwardsClosedSeparationAlgebra A}: SepconLanguage (MonoPred_L A) :=
  Build_SepconLanguage (MonoPred_L A) WeakSemanticsMono.sepcon.

Instance MonoPred_wandL (A: Type) {R: Relation A} {po_R: PreOrder Krelation} {J: Join A} {SA: SeparationAlgebra A} {uSA: UpwardsClosedSeparationAlgebra A} {dSA: DownwardsClosedSeparationAlgebra A}: WandLanguage (MonoPred_L A) :=
  Build_WandLanguage (MonoPred_L A) WeakSemanticsMono.wand.

Instance MonoPred_empL (A: Type) {R: Relation A} {po_R: PreOrder Krelation} {J: Join A} {SA: SeparationAlgebra A} {uSA: UpwardsClosedSeparationAlgebra A} {dSA: DownwardsClosedSeparationAlgebra A}: EmpLanguage (MonoPred_L A) :=
  Build_EmpLanguage (MonoPred_L A) WeakSemanticsMono.emp.

Instance MonoPred_fsepconSM (A: Type) {R: Relation A} {po_R: PreOrder Krelation} {J: Join A} {SA: SeparationAlgebra A} {uSA: UpwardsClosedSeparationAlgebra A} {dSA: DownwardsClosedSeparationAlgebra A}: @FlatSemantics.SepconSemantics (MonoPred_L A) (MonoPred_sepconL A) (Build_Model A) (unit_kMD _) tt R J (MonoPred_SM A).
Proof.
  hnf; intros; apply Same_set_refl.
Qed.

Instance MonoPred_fwandSM (A: Type) {R: Relation A} {po_R: PreOrder Krelation} {J: Join A} {SA: SeparationAlgebra A} {uSA: UpwardsClosedSeparationAlgebra A} {dSA: DownwardsClosedSeparationAlgebra A}: @FlatSemantics.WandSemantics (MonoPred_L A) (MonoPred_wandL A) (Build_Model A) (unit_kMD _) tt R J (MonoPred_SM A).
Proof.
  hnf; intros; apply Same_set_refl.
Qed.

Instance MonoPred_fempSM (A: Type) {R: Relation A} {po_R: PreOrder Krelation} {J: Join A} {SA: SeparationAlgebra A} {uSA: UpwardsClosedSeparationAlgebra A} {dSA: DownwardsClosedSeparationAlgebra A} {USA: UnitalSeparationAlgebra A}: @FlatSemantics.EmpSemantics (MonoPred_L A) (MonoPred_empL A) (Build_Model A) (unit_kMD _) tt R J (MonoPred_SM A).
Proof.
  apply Same_set_refl.
Qed.

Instance MonoPred_sepconAX_weak (A: Type) {R: Relation A} {po_R: PreOrder Krelation} {J: Join A} {SA: SeparationAlgebra A} {uSA: UpwardsClosedSeparationAlgebra A} {dSA: DownwardsClosedSeparationAlgebra A}: SepconAxiomatization_weak (MonoPred_L A) (MonoPred_Gamma A).
Proof.
  constructor.
  + intros x y.
    exact (@sound_sepcon_comm (MonoPred_L A) _ _ (Build_Model A) (unit_kMD _) tt R J SA (MonoPred_SM A) (MonoPred_kminSM A) (MonoPred_fsepconSM A) x y).
  + intros x y.
    exact (@sound_sepcon_assoc1 (MonoPred_L A) _ _ (Build_Model A) (unit_kMD _) tt R J SA (MonoPred_SM A) (MonoPred_kminSM A) (MonoPred_fsepconSM A) x y).
Qed.

Instance MonoPred_wandAX (A: Type) {R: Relation A} {po_R: PreOrder Krelation} {J: Join A} {SA: SeparationAlgebra A} {uSA: UpwardsClosedSeparationAlgebra A} {dSA: DownwardsClosedSeparationAlgebra A}: WandAxiomatization (MonoPred_L A) (MonoPred_Gamma A).
Proof.
  constructor.
  intros x y z.
  exact (@sound_wand_sepcon_adjoint (MonoPred_L A) _ _ _ (Build_Model A) (unit_kMD _) tt  R po_R J (MonoPred_SM A) (MonoPred_kminSM A) (MonoPred_fsepconSM A) (MonoPred_fwandSM A) x y z).
Qed.

Instance MonoPred_sepconAX (A: Type) {R: Relation A} {po_R: PreOrder Krelation} {J: Join A} {SA: SeparationAlgebra A} {uSA: UpwardsClosedSeparationAlgebra A} {dSA: DownwardsClosedSeparationAlgebra A}: SepconAxiomatization (MonoPred_L A) (MonoPred_Gamma A).
Proof.
  eapply @SepconAxiomatizationWeak2SepconAxiomatization;
  try typeclasses eauto.
  eapply @Adj2SepconMono;
  try typeclasses eauto.
Qed.

Instance MonoPred_empAX (A: Type) {R: Relation A} {po_R: PreOrder Krelation} {J: Join A} {SA: SeparationAlgebra A} {uSA: UpwardsClosedSeparationAlgebra A} {dSA: DownwardsClosedSeparationAlgebra A} {USA: UnitalSeparationAlgebra A}: EmpAxiomatization (MonoPred_L A) (MonoPred_Gamma A).
Proof.
  constructor.
  + intros x.
    exact (@sound_sepcon_emp1 (MonoPred_L A) _ _ (Build_Model A) (unit_kMD _) tt R J SA (MonoPred_SM A) (MonoPred_kiSM A) (MonoPred_kminSM A) (MonoPred_fsepconSM A) _ (MonoPred_fempSM A) _ x).
  + intros x.
    exact (@sound_sepcon_emp2 (MonoPred_L A) _ _ (Build_Model A) (unit_kMD _) tt R J SA (MonoPred_SM A) (MonoPred_kiSM A) (MonoPred_kminSM A) (MonoPred_fsepconSM A) _ (MonoPred_fempSM A) _ x).
Qed.

Instance MonoPred_gcsGamma (A: Type) {R: Relation A} {po_R: PreOrder Krelation} {J: Join A} {SA: SeparationAlgebra A} {uSA: UpwardsClosedSeparationAlgebra A} {dSA: DownwardsClosedSeparationAlgebra A} {incrSA: IncreasingSeparationAlgebra A}: GarbageCollectSeparationLogic (MonoPred_L A) (MonoPred_Gamma A).
Proof.
  intros.
  constructor.
  intros x y.
  exact (@sound_sepcon_elim1 (MonoPred_L A) _ _ (Build_Model A) (unit_kMD _) tt R J SA (MonoPred_SM A) (MonoPred_kiSM A) (MonoPred_kminSM A) (MonoPred_fsepconSM A) incrSA x y).
Qed.


Require Export Iron.Language.SimpleData.ExpBase.

(* Get the data constructor of an alternative. *)
Fixpoint dcOfAlt (aa: alt) : datacon :=
 match aa with
 | AAlt dc _ _ => dc
 end.
Hint Unfold dcOfAlt.

(* Get the alternative body that matches a given constructor. *)
Fixpoint getAlt (dc: datacon) (alts: list alt) {struct alts}
                : option alt :=
 match alts with
 |  nil  => None

 |  AAlt dc' tsArgs x :: alts'
 => if datacon_beq dc dc'
     then Some (AAlt dc' tsArgs x)
     else getAlt dc alts'
 end.

(* If we get a single alternative from a list,
   then that alternative was in the list. *)
Lemma getAlt_in
 :  forall dc alt alts
 ,  getAlt dc alts = Some alt
 -> In alt alts.
Proof.
 intros.
 induction alts.
  false.
  destruct a as [dc' tsArgs x].
  simpl in H.
  breaka (datacon_beq dc dc').
   inverts H.
   apply datacon_beq_eq in HeqX; auto.
Qed.

(* Given a data constructor, if one of the alternatives in a
   list matches that data constructor then we can get the other
   information about the alternative from the list. *)
Lemma getAlt_exists
 :  forall d alts
 ,  In d (map dcOfAlt alts)
 -> (exists tsArgs x, getAlt d alts = Some (AAlt d tsArgs x)).
Proof.
 intros.
 induction alts.
  simpl in H. false.
  simpl in H. inverts H.
   destruct a. simpl.
   breaka (datacon_beq d d).
    exists l. exists e. auto.
    apply datacon_beq_false in HeqX. false.
   lets D: IHalts H0.
   destruct a. simpl.
    breaka (datacon_beq d d0).
     apply datacon_beq_eq in HeqX. subst. auto.
     exists l. exists e. auto.
Qed.


From Equations Require Import Equations.
From Undecidability.Shared Require Import Dec ListAutomation.
From FOL Require Import FullSyntax.

Require Import List Arith.PeanoNat Eqdep_dec.

Import ListAutomationNotations ListAutomationFacts ListAutomationHints ListAutomationInstances.

Local Notation vec := Vector.t.

Section Theories.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {ff : falsity_flag}.

  Definition theory := form -> Prop.
  Definition in_theory (T : theory) phi := T phi.

End Theories.

Notation "phi t∈ T" := (in_theory T phi) (at level 70).
Notation "A ⊏ T" := (forall phi, List.In phi A -> phi t∈ T) (at level 70).
Definition tprv {sig1 sig2 ff p} T phi := (exists A, A ⊏ T /\ @prv sig1 sig2 ff p A phi).

Notation "T ⊩ phi" := (tprv T phi) (at level 30).
Notation "T ⊩C phi" := (@tprv _ _ _ class T phi) (at level 30).
Notation "T ⊩I phi" := (@tprv _ _ _ intu T phi) (at level 60).

Definition subset_T `{funcs_signature, preds_signature, falsity_flag} (T1 T2 : theory) := forall (phi : form), phi t∈ T1 -> phi t∈ T2.
Infix "⊑" := subset_T (at level 20).

Definition extend `{funcs_signature, preds_signature, falsity_flag} T (phi : form) := fun psi => T psi \/ psi = phi.
Infix "⋄" := extend (at level 20).

Section Theories.

Context {Σ_funcs : funcs_signature}.
Context {Σ_preds : preds_signature}.
Context {ff : falsity_flag}.
Context {p : peirce}.

Definition mapT (f : form -> form) (T : theory) : theory := fun phi => exists psi, T psi /\ f psi = phi.

Context {eq_dec_Funcs : eq_dec syms}.
Context {eq_dec_Preds : eq_dec preds}.
Context {eq_dec_binop : eq_dec binop}.
Context {eq_dec_quantop : eq_dec quantop}.

Definition rem := @remove form (dec_form _ _ _ _).

Theorem WeakT A B phi :
  A ⊩ phi -> A ⊑ B -> B ⊩ phi.
Proof.
  intros H. revert B.
  induction H; intros B HB; try unshelve (solve [econstructor; intuition]); try now econstructor.
Qed.

Lemma contains_nil T :
  List.nil ⊏ T.
Proof. intuition. Qed.

Lemma contains_cons a A T :
  a t∈ T -> A ⊏ T -> (a :: A) ⊏ T.
Proof. intros ? ? ? []; subst; intuition. Qed.

Lemma contains_cons2 a A T :
  (a :: A) ⊏ T -> A ⊏ T.
Proof. firstorder. Qed.

Lemma contains_app A B T :
  A ⊏ T -> B ⊏ T -> (A ++ B) ⊏ T.
Proof. intros ? ? ? [] % in_app_or; intuition. Qed.

Lemma contains_extend1 phi T :
  phi t∈ (T ⋄ phi).
Proof. now right. Qed.

Lemma contains_extend2 phi psi T :
  phi t∈ T -> phi t∈ (T ⋄ psi).
Proof. intros ?. now left. Qed.

Lemma contains_extend3 A T phi :
  A ⊏ T -> A ⊏ (T ⋄ phi).
Proof.
  intros ? ? ?. left. intuition.
Qed.

Lemma subset_refl T :
  T ⊑ T.
Proof.
  firstorder.
Qed.

Lemma subset_trans T1 T2 T3 :
  T1 ⊑ T2 -> T2 ⊑ T3 -> T1 ⊑ T3.
Proof.
  firstorder.
Qed.

Lemma contains_rem A T phi :
  A ⊏ T ⋄ phi -> rem phi A ⊏ T.
Proof.
  intros H1. induction A. firstorder. cbn. destruct dec_form as [->|H2].
  - apply IHA. eapply contains_cons2, H1.
  - apply contains_cons. destruct (H1 a) as [| ->]; firstorder.
    apply IHA. eapply contains_cons2, H1.
Qed.

Lemma incl_rem1 A phi :
  rem phi A <<= A.
Proof.
  induction A. firstorder. cbn. destruct dec_form as [-> |]; firstorder.
Qed.

Lemma incl_rem2 A phi :
  A <<= phi :: rem phi A.
Proof.
  induction A. firstorder. cbn. destruct dec_form as [-> |]; firstorder.
Qed.

Definition shift_down := fun n => match n with 0 => $0 | S n => $n end.

Lemma map_shift_up_down_contains A T :
  (A ⊏ mapT (subst_form ↑) T) -> map (subst_form shift_down) A ⊏ T.
Proof.
  intros H1. induction A. easy. intros f H. destruct H as [<-|].
  - destruct (H1 a) as [f [H2 <-]]. now left. change (f[↑][shift_down] t∈ T).
    enough (f[↑][shift_down] = f) as -> by easy.
    rewrite subst_comp. now apply subst_id.
  - firstorder.
Qed.

Lemma map_shift_up_down_eq A T :
  A ⊏ mapT (subst_form ↑) T -> map (subst_form ↑) (map (subst_form shift_down) A) = A.
Proof.
  intros H1. induction A. reflexivity. cbn. f_equal.
  - destruct (H1 a) as [f [H2 <-]]. now left.
    enough (f[↑ >> subst_term shift_down][↑] = f[↑]) as X by now rewrite <- subst_comp in X.
    f_equal. now apply subst_id.
  - firstorder.
Qed.

(* Prv translations *)

Lemma T_II T phi psi :
  T ⋄ phi ⊩ psi -> T ⊩ (phi → psi).
Proof.
  intros [A[H1 H2]]. exists (rem phi A). split.
  intros ? ?%in_remove. firstorder.
  apply II. eapply Weak. apply H2. apply incl_rem2.
Qed.

Lemma T_IE T phi psi :
  T ⊩ (phi → psi) -> T ⊩ phi -> T ⊩ psi.
Proof.
  intros [A[A1 A2]] [B[B1 B2]]. exists (A++B). split.
  now apply contains_app. apply IE with phi.
  eapply Weak. apply A2. now apply incl_appl.
  eapply Weak. apply B2. now apply incl_appr.
Qed.

Lemma T_AllI T phi :
  mapT (subst_form ↑) T ⊩ phi -> T ⊩ ∀ phi.
Proof.
  intros [A[H1 H2]].
  exists (map (subst_form shift_down) A). split.
  - now apply map_shift_up_down_contains.
  - apply AllI. erewrite map_shift_up_down_eq; auto.
Qed.

Lemma T_AllE T t phi :
  (T ⊩ ∀ phi) -> T ⊩ phi[t..].
Proof.
  intros [A[H1 H2]]. exists A. split. firstorder. now apply AllE.
Qed.

Lemma T_ExI T t phi :
  T ⊩ phi[t..] -> T ⊩ ∃ phi.
Proof.
  intros [A[A1 A2]]. exists A. split. firstorder. now apply ExI with t.
Qed.

Lemma T_ExE T phi psi :
  (T ⊩ ∃ phi) -> (mapT (subst_form ↑) T) ⋄ phi ⊩ psi[↑] -> T ⊩ psi.
Proof.
  intros [A[A1 A2]] [B[B1 B2]].
  exists (A ++ map (subst_form shift_down) (rem phi B)). split.
  - apply contains_app. assumption. apply map_shift_up_down_contains.
    now apply contains_rem.
  - eapply ExE.
    + eapply Weak. apply A2. now apply incl_appl.
    + eapply Weak. apply B2. rewrite map_app. erewrite map_shift_up_down_eq with (T := T).
      eapply incl_tran with (m := phi :: rem phi B). apply incl_rem2.
      apply incl_cons. now left. apply incl_tl. now apply incl_appr.
      clear B2. induction B. firstorder. cbn. destruct dec_form as [-> |].
      * firstorder.
      * apply contains_cons. destruct (B1 a) as [| ->]. now left. assumption.
        apply IHB. eapply contains_cons2, B1. easy. firstorder.
Qed.

Lemma T_Exp T phi :
  T ⊩ ⊥ -> T ⊩ phi.
Proof.
  intros [A[H1 H2]]. exists A. split. firstorder. now apply Exp.
Qed.

Lemma T_Ctx T phi :
  phi t∈ T -> T ⊩ phi.
Proof.
  intros H. exists (phi::nil). split.
  intros psi H2. now assert (phi = psi) as -> by firstorder.
  apply Ctx. now left.
Qed.

Lemma T_CI T phi psi :
  T ⊩ phi -> T ⊩ psi -> T ⊩ (phi ∧ psi).
Proof.
  intros [A[A1 A2]] [B[B1 B2]]. exists (A++B). split.
  now apply contains_app. apply CI.
  eapply Weak. apply A2. now apply incl_appl.
  eapply Weak. apply B2. now apply incl_appr.
Qed.

Lemma T_CE1 T phi psi :
  T ⊩ (phi ∧ psi) -> T ⊩ phi.
Proof.
  intros [A[H1 H2]]. exists A. split. assumption. eapply CE1. apply H2.
Qed.

Lemma T_CE2 T phi psi :
  T ⊩ (phi ∧ psi) -> T ⊩ psi.
Proof.
  intros [A[H1 H2]]. exists A. split. assumption. eapply CE2. apply H2.
Qed.

Lemma T_DI1 T phi psi :
  T ⊩ phi -> T ⊩ (phi ∨ psi).
Proof.
  intros [A[H1 H2]]. exists A. split. assumption. eapply DI1. apply H2.
Qed.

Lemma T_DI2 T phi psi :
  T ⊩ psi -> T ⊩ (phi ∨ psi).
Proof.
  intros [A[H1 H2]]. exists A. split. assumption. eapply DI2. apply H2.
Qed.

Lemma T_DE T phi psi theta :
  T ⊩ (phi ∨ psi) -> T ⋄ phi ⊩ theta -> T ⋄ psi ⊩ theta -> T ⊩ theta.
Proof.
  intros [A[A1 A2]] [B[B1 B2]] [C[C1 C2]].
  exists (A ++ (rem phi B) ++ (rem psi C)). split.
  - apply contains_app. assumption. apply contains_app.
    intros ? ?%in_remove. firstorder. intros ? ?%in_remove. firstorder.
  - eapply DE. eapply Weak. apply A2. now apply incl_appl.
    + eapply Weak. apply B2. apply incl_tran with (m := phi::rem phi B).
      apply incl_rem2. apply incl_cons. now left.
      now apply incl_tl, incl_appr, incl_appl.
    + eapply Weak. apply C2. apply incl_tran with (m := psi::rem psi C).
      apply incl_rem2. apply incl_cons. now left.
      now apply incl_tl, incl_appr, incl_appr.
Qed.

Lemma T_Pc T phi psi :
  T ⊩C (((phi → psi) → phi) → phi).
Proof.
  exists nil. split. firstorder. apply Pc.
Qed.

Lemma switch_imp_T T alpha phi : T ⊩ (alpha → phi) <-> (T ⋄ alpha) ⊩ phi.
Proof.
  split.
  - intros H. eapply T_IE. 2: apply T_Ctx. eapply WeakT.
    exact H. all : firstorder.
  - apply T_II.
Qed.

End Theories.


Require Import Category.Lib.
Require Import Category.Instance.Lambda.Ltac.
Require Import Category.Instance.Lambda.Ty.
Require Import Category.Instance.Lambda.Exp.
Require Import Category.Instance.Lambda.Sub.

From Equations Require Import Equations.
Set Equations With UIP.

Generalizable All Variables.

Section Log.

Context {A : Type}.
Context `{L : HostExprs A}.
Context {Γ : Env}.

Variable P : ∀ {τ}, Exp Γ τ → Type.

(** [ExpP] is a logical predicate that permits type-directed induction on
    expressions. *)
Equations ExpP `(e : Exp Γ τ) : Type :=
  ExpP (τ:=_ ⟶ _) e := P e ∧ (∀ x, ExpP x → ExpP (APP e x));
  ExpP (τ:=_ × _) e := P e ∧ ExpP (Fst e) ∧ ExpP (Snd e);
  ExpP e := P e.

Inductive SubP : ∀ {Γ'}, Sub Γ Γ' → Type :=
  | NoSubP : SubP (NoSub (Γ:=Γ))
  | PushP {Γ' τ} (e : Exp Γ τ) (s : Sub Γ Γ') :
    ExpP e → SubP s → SubP (Push e s).

Derive Signature for SubP.

Lemma ExpP_P {τ} {e : Γ ⊢ τ} : ExpP e → P e.
Proof. intros; induction τ; simpl in *; simp ExpP in X; now reduce. Qed.

Variable R : ∀ {τ}, Exp Γ τ → Exp Γ τ → Type.

(** [ExpR] is a logical predicate that permits type-directed induction on
    expressions. *)
Equations ExpR {τ} (e1 e2 : Exp Γ τ) : Type :=
  ExpR (τ:=_ ⟶ _) f1 f2 :=
    R f1 f2 ∧ (∀ x1 x2, ExpR x1 x2 → ExpR (APP f1 x1) (APP f1 x2));
  ExpR (τ:=_ × _) e1 e2 :=
    R e1 e2 ∧ ExpR (Fst e1) (Fst e2) ∧ ExpR (Snd e1) (Snd e2);
  ExpR e1 e2 := R e1 e2.

Lemma ExpR_R {τ} {e1 e2 : Γ ⊢ τ} : ExpR e1 e2 → R e1 e2.
Proof. intros; induction τ; simpl in *; simp ExpR in X; now reduce. Qed.

Inductive SubR : ∀ {Γ'}, Sub Γ Γ' → Type :=
  | NoSubR : SubR (NoSub (Γ:=Γ))
  | PushR {Γ' τ} (e e' : Exp Γ τ) (s : Sub Γ Γ') :
    ExpR e e' → SubR s → SubR (Push e s).

Derive Signature for SubR.

End Log.