Require Import refocusing_substitutions.
Require Import Setoid.

Module Arith_Lang <: RED_LANG.

  Parameter var_name : Set.

  Inductive term' : Set :=
  | num  : nat -> term'
  | plus : term' -> term' -> term'
  | times: term' -> term' -> term'
  | var  : var_name -> term'.
  Definition term := term'.

  Inductive value' : Set :=
  | v_num : nat -> value'.
  Definition value := value'.

  Inductive redex' : Set :=
  | r_plus  : value -> value -> redex'
  | r_times : value -> value -> redex'
  | r_var   : var_name -> redex'.
  Definition redex := redex'.

  Definition value_to_term (v : value) : term :=
  match v with
  | v_num v' => num v'
  end.
  Coercion value_to_term : value >-> term.

  Lemma value_to_term_injective : forall v v', value_to_term v = value_to_term v' -> v = v'.
  Proof.
  intros v v0; case v; case v0; simpl; intros; try discriminate; injection H;
  intros; subst; auto.
  Qed.

  Definition redex_to_term (r : redex) : term :=
  match r with
  | r_plus m n => plus (m:term) (n:term)
  | r_times m n => times (m:term) (n:term)
  | r_var x => var x
  end.
  Coercion redex_to_term : redex >-> term.

  Lemma redex_to_term_injective : forall r r', redex_to_term r = redex_to_term r' -> r = r'.
  Proof with auto.
  intros r r0; case r; case r0; intros; try discriminate; injection H; intros;
  try (rewrite (value_to_term_injective _ _ H1); rewrite (value_to_term_injective _ _ H0))...
  rewrite H0...
  Qed.

  Parameter env : var_name -> nat.

  Inductive elem_context' : Set :=
  | plus_r : term -> elem_context'
  | plus_l : value -> elem_context'
  | times_r : term -> elem_context'
  | times_l : value -> elem_context'.
  Definition elem_context := elem_context'.
  Definition context := list elem_context.
  Definition empty : context := nil.

  Definition atom_plug (t : term) (ec : elem_context) :=
  match ec with
  | plus_r t' => plus t t'
  | plus_l v => plus (v:term) t
  | times_r t' =>times t t'
  | times_l v => times (v:term) t
  end.
  Definition compose (c0 c1 : context) : context := app c0 c1.
  Definition plug (t : term) (c : context) : term := fold_left atom_plug c t.

  Lemma plug_compose : forall c1 c2 r, plug r (compose c1 c2) = plug (plug r c1) c2.
  Proof.
  induction c1; simpl; auto.
  Qed.

  Definition contract (r : redex) : option term :=
  match r with
  | r_plus (v_num n) (v_num m) => Some (num (n+m))
  | r_times (v_num n) (v_num m) => Some (num (n*m))
  | r_var x => Some (num (env x))
  end.

  Lemma decompose : forall t : term, (exists v : value, t = v) \/
                      (exists r : redex, exists c : context, plug r c = t).
  Proof with auto.
    induction t; simpl.
    left; exists (v_num n); auto.
    right; elim IHt1; intros.
    destruct H as [v1 H]; subst.
    elim IHt2; intros.
    destruct H as [v2 H]; subst.
    exists (r_plus v1 v2); exists empty; simpl...
    destruct H as [r [c H]]; exists r; exists (compose c (plus_l v1 :: empty)); rewrite plug_compose; simpl; subst; auto.
    destruct H as [r [c H]]; exists r; exists (compose c (plus_r t2 :: empty)); rewrite plug_compose; simpl; subst; auto.
    right; elim IHt1; intros.
    destruct H as [v1 H]; subst.
    elim IHt2; intros.
    destruct H as [v2 H]; subst.
    exists (r_times v1 v2); exists empty; simpl...
    destruct H as [r [c H]]; exists r; exists (compose c (times_l v1 :: empty)); rewrite plug_compose; simpl; subst; auto.
    destruct H as [r [c H]]; exists r; exists (compose c (times_r t2 :: empty)); rewrite plug_compose; simpl; subst; auto.
    right; exists (r_var v); exists empty; simpl...
  Qed.

  Inductive decomp : Set :=
  | d_val : value -> decomp
  | d_red : redex -> context -> decomp.

  Inductive interm_dec : Set :=
  | in_red : redex -> interm_dec
  | in_val : value -> interm_dec
  | in_term: term -> elem_context -> interm_dec.

  Definition decomp_to_term (d : decomp) : term :=
  match d with
    | d_val v => value_to_term v
    | d_red r c0 => plug (redex_to_term r) c0
  end.
  Definition only_empty (t : term) : Prop := forall t' c, plug t' c = t -> c = empty.
  Definition only_trivial (t : term) : Prop := forall t' c, plug t' c = t -> c = empty \/ exists v, t' = value_to_term v.

  Lemma value_trivial : forall v : value, only_trivial (value_to_term v).
  Proof.
    intros v t c; left; generalize dependent t; induction c; simpl in *; auto;
    destruct v; destruct a; destruct c; intros; simpl in *; try discriminate H; discriminate (IHc _ H).
  Qed.
  Lemma redex_trivial : forall r : redex, only_trivial (redex_to_term r).
  Proof.
    intros r t c; generalize dependent t; induction c; intros; [left; auto | right]; destruct a;( simpl in *;
    destruct (IHc _ H) as [H0 | [v0 H0]]; subst;[ destruct r; inversion H; subst;
    match goal with [ |- exists u, _ ?v = _ u ] => exists v; reflexivity end | destruct v0; discriminate]).
  Qed.
  Lemma value_redex : forall (v : value) (r : redex), value_to_term v <> redex_to_term r.
  Proof.
    destruct v; destruct r; intro; discriminate.
  Qed.

  Lemma ot_subt : forall t t0 ec, only_trivial t -> atom_plug t0 ec = t -> exists v, t0 = value_to_term v.
  Proof with auto.
    intros; destruct (H t0 (ec :: nil)) as [H1 | [v H1]]...
    discriminate.
    exists v...
  Qed.

  Ltac ot_v t ec :=
  match goal with
  | [Hot : (only_trivial ?H1) |- _] => destruct (ot_subt _ t ec Hot) as [?v HV]; [auto | subst t]
  end.

  Ltac mlr rv :=
  match goal with [ |- (exists v, ?H1 = value_to_term v) \/ (exists r, ?H1 = redex_to_term r)] =>
    match rv with
    | (?v : value) => left; exists v
    | (?r : redex) => right; exists r
    end; simpl; auto
  end.

  Lemma trivial_val_red : forall t : term, only_trivial t ->
    (exists v : value, t = value_to_term v) \/ (exists r : redex, t = redex_to_term r).
  Proof with auto.
    destruct t; intros.
    mlr (v_num n).
    ot_v t1 (plus_r t2); ot_v t2 (plus_l v); mlr (r_plus v v0).
    ot_v t1 (times_r t2); ot_v t2 (times_l v); mlr (r_times v v0).
    mlr (r_var v).
  Qed.

End Arith_Lang.

Module Arith_Sem <: RED_SEM Arith_Lang.

  Definition term := Arith_Lang.term.
  Definition value := Arith_Lang.value.
  Definition redex := Arith_Lang.redex.
  Definition context := Arith_Lang.context.
  Definition empty := Arith_Lang.empty.
  Definition decomp := Arith_Lang.decomp.
  Definition d_val := Arith_Lang.d_val.
  Definition d_red := Arith_Lang.d_red.
  Definition value_to_term : value -> term := Arith_Lang.value_to_term.
  Definition redex_to_term : redex -> term := Arith_Lang.redex_to_term.
  Definition decomp_to_term : (decomp -> term) := Arith_Lang.decomp_to_term.
  Definition plug : term -> context -> term := Arith_Lang.plug.
  Definition compose : context -> context -> context := Arith_Lang.compose.
  Definition contract : redex -> option term := Arith_Lang.contract.
  Definition interm_dec := Arith_Lang.interm_dec.
  Definition in_red := Arith_Lang.in_red.
  Definition in_val := Arith_Lang.in_val.
  Definition in_term := Arith_Lang.in_term.
  Definition r_var := Arith_Lang.r_var.
  Definition num := Arith_Lang.num.
  Definition var := Arith_Lang.var.
  Definition var_name := Arith_Lang.var_name.
  Definition plus_r := Arith_Lang.plus_r.
  Definition plus_l := Arith_Lang.plus_l.
  Definition plus := Arith_Lang.plus.
  Definition v_num := Arith_Lang.v_num.
  Definition times := Arith_Lang.times.
  Definition times_r := Arith_Lang.times_r.
  Definition times_l := Arith_Lang.times_l.
  Definition r_plus := Arith_Lang.r_plus.
  Definition r_times := Arith_Lang.r_times.

  Coercion value_to_term : value >-> term.
  Coercion redex_to_term : redex >-> term.

  Inductive dec' : term -> context -> decomp -> Prop :=
  | t_var : forall (x : var_name) (c : context), dec' (var x) c (d_red (r_var x) c)
  | t_num : forall (n : nat) (c : context) (d : decomp),
              decctx' (v_num n) c d -> dec' (num n) c d
  | t_plus: forall (t0 t1 : term) (c : context) (d : decomp),
              dec' t0 (plus_r t1 :: c) d -> dec' (plus t0 t1) c d
  | t_mul : forall (t0 t1 : term) (c : context) (d : decomp),
              dec' t0 (times_r t1 :: c) d -> dec' (times t0 t1) c d
  with decctx' : value -> context -> decomp -> Prop :=
  | c_empty : forall (v : value), decctx' v empty (d_val v)
  | c_plus_r: forall (v : value) (t : term) (c : context) (d : decomp),
                dec' t (plus_l v :: c) d -> decctx' v (plus_r t :: c) d
  | c_plus_l: forall (v v0 : value) (c : context), decctx' v (plus_l v0 :: c) (d_red (r_plus v0 v) c)
  | c_mul_r : forall (v : value) (t : term) (c : context) (d : decomp),
                dec' t (times_l v :: c) d -> decctx' v (times_r t :: c) d
  | c_mul_l : forall (v v0 : value) (c : context), decctx' v (times_l v0 :: c) (d_red (r_times v0 v) c).

  Definition dec := dec'.
  Definition decctx := decctx'.

  Scheme dec_Ind := Induction for dec' Sort Prop
  with decctx_Ind := Induction for decctx' Sort Prop.

  (** dec is left inverse of plug *)
  Lemma dec_correct : forall t c d, dec t c d -> decomp_to_term d = plug t c.
  Proof.
    induction 1 using dec_Ind with
    (P := fun t c d (H : dec t c d) => decomp_to_term d = plug t c)
    (P0:= fun v c d (H : decctx v c d) => decomp_to_term d = plug v c); simpl; auto.
  Qed.

  (** A redex in context will only ever be reduced to itself *)
  Lemma dec_redex_self : forall (r : redex) (c : context), dec (redex_to_term r) c (d_red r c).
  Proof.
    intro; case r; intros; constructor; destruct v; destruct v0; repeat constructor.
  Qed.

  Lemma dec_plug : forall c c0 t d, dec (plug t c) c0 d -> dec t (compose c c0) d.
  Proof with auto.
    induction c; intros; simpl in *; auto; destruct a;
    assert (hh := IHc _ _ _ H); inversion hh; subst; auto;
    destruct v; inversion H4; subst; inversion H1; subst...
  Qed.

  Lemma dec_plug_rev : forall c c0 t d, dec t (compose c c0) d -> dec (plug t c) c0 d.
  Proof with auto.
    induction c; intros; simpl in *; auto; destruct a;
    try (destruct v); apply IHc; repeat constructor...
  Qed.

  Inductive decempty : term -> decomp -> Prop :=
  | d_intro : forall (t : term) (d : decomp), dec t empty d -> decempty t d.

  Inductive iter : decomp -> value -> Prop :=
  | i_val : forall (v : value), iter (d_val v) v
  | i_red : forall (r : redex) (t : term) (c : context) (d : decomp) (v : value),
              contract r = Some t -> decempty (plug t c) d -> iter d v -> iter (d_red r c) v.

  Inductive eval : term -> value -> Prop :=
  | e_intro : forall (t : term) (d : decomp) (v : value), decempty t d -> iter d v -> eval t v.

  Definition decompose := Arith_Lang.decompose.

End Arith_Sem.

Module Arith_Ref_Lang <: RED_REF_LANG.

  Module R := Arith_Lang.

  Definition dec_term (t : R.term) : R.interm_dec :=
  match t with
  | Arith_Lang.var vname => R.in_red (Arith_Lang.r_var vname)
  | Arith_Lang.num n => R.in_val (Arith_Lang.v_num n)
  | Arith_Lang.plus n m => R.in_term n (Arith_Lang.plus_r m)
  | Arith_Lang.times n m => R.in_term n (Arith_Lang.times_r m)
  end.
  Definition dec_context : R.elem_context -> R.value -> R.interm_dec :=
  fun (ec : R.elem_context) (v : R.value) => match ec with
  | Arith_Lang.plus_r n => R.in_term n (Arith_Lang.plus_l v)
  | Arith_Lang.plus_l v' => R.in_red (Arith_Lang.r_plus v' v)
  | Arith_Lang.times_r n => R.in_term n (Arith_Lang.times_l v)
  | Arith_Lang.times_l v' => R.in_red (Arith_Lang.r_times v' v)
  end.

  Inductive subterm_one_step : R.term -> R.term -> Prop :=
  | st_1 : forall t t0 ec (DECT : t = R.atom_plug t0 ec), subterm_one_step t0 t.
  Lemma wf_st1 : well_founded subterm_one_step.
  Proof.
    prove_st_wf.
  Qed.

  Definition subterm_order := clos_trans_n1 R.term subterm_one_step.
  Notation " a <| b " := (subterm_order a b) (at level 40).
  Definition wf_sto : well_founded subterm_order := wf_clos_trans_r _ _ wf_st1.

(*  Inductive elem_context_one_step : R.elem_context -> R.elem_context -> Prop :=
  | ec_1 : forall ec ec0 v t (DECEC : dec_context ec v = R.in_term t ec0),
             elem_context_one_step ec0 ec.

  Ltac wf_ec_step :=
  constructor; match goal with
    | [ |- forall u (T:?eco u _), Acc ?eco u ] => intros y T; inversion T as [ec ec0 ?t ?v ?Hcc]; subst ec ec0; clear T
  end; match goal with
    | [ Hcc : dec_context _ _ = R.in_term _ ?cc |- Acc ?eco ?cc] => inversion Hcc; subst; clear Hcc
  end.

  Ltac prove_ec_wf := intro a; destruct a; repeat wf_ec_step.

  Lemma wf_ec1 : well_founded elem_context_one_step.
  Proof.
    prove_ec_wf.
  Qed.

  Definition ec_order := clos_trans_1n _ elem_context_one_step.
  Notation " a <: b " := (ec_order a b) (at level 40).
  Definition wf_eco : well_founded ec_order := wf_clos_trans_l _ _ wf_ec1.*)

  Definition ec_order (ec0 ec1 : R.elem_context) : Prop :=
  match ec0, ec1 with
  | R.plus_l _, R.plus_r _ => True
  | R.times_l _, R.times_r _ => True
  | _, _ => False
  end.
  Notation " a <: b " := (ec_order a b) (at level 40).
  Lemma wf_eco : well_founded ec_order.
  Proof.
    prove_ec_wf.
  Qed.

  Lemma dec_term_red_empty  : forall t r, dec_term t = R.in_red r -> R.only_empty t.
  Proof.
    intros t r H; destruct t; inversion H; subst; intros t c; generalize t; induction c; intros;
    simpl in *; auto; clear H; assert (ht := IHc _ H0); subst c; destruct a; inversion H0.
  Qed.
  Lemma dec_term_val_empty : forall t v, dec_term t = R.in_val v -> R.only_empty t.
  Proof.
    intros t v H; destruct t; inversion H; subst; intros t c; generalize t; induction c; intros;
    simpl in *; auto; clear H; assert (ht := IHc _ H0); subst c; destruct a; inversion H0.
  Qed.

  Lemma dec_term_term_top   : forall t t' ec, dec_term t = R.in_term t' ec -> forall ec', ~ ec <: ec'.
  Proof.
    intros t t' ec H ec' H0; destruct t; inversion H; subst; destruct ec'; inversion H0.
  Qed.
  Lemma dec_context_red_bot : forall ec v r, dec_context ec v = R.in_red r -> forall ec', ~ec' <: ec.
  Proof.
    intros ec v r H ec' H0; destruct ec; inversion H; subst; destruct ec'; inversion H0.
  Qed.
  Lemma dec_context_val_bot : forall ec v v0, dec_context ec v = R.in_val v0 -> forall ec', ~ec' <: ec.
  Proof.
    intros ec v r H ec' H0; destruct ec; inversion H; subst; destruct ec'; inversion H0.
  Qed.
  Lemma dec_context_term_next : forall ec v t ec', dec_context ec v = R.in_term t ec' -> ec' <: ec /\ forall ec'', ec'' <: ec -> ~ec' <: ec''.
  Proof.
    intros; destruct ec; inversion H; subst; repeat constructor; intros; destruct ec''; inversion H0; intro; inversion H1.
  Qed.

  Lemma dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t' ec => R.atom_plug t' ec = t
    end.
  Proof.
    destruct t; simpl; auto.
  Qed.
  Lemma dec_context_correct : forall ec v, match dec_context ec v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) ec
    | R.in_val v0 => R.value_to_term v0 = R.atom_plug (R.value_to_term v) ec
    | R.in_term t ec' => R.atom_plug t ec' = R.atom_plug (R.value_to_term v) ec
    end.
  Proof.
    destruct ec; simpl; auto.
  Qed.

  Ltac inj_vr := match goal with
  | [Hv : R.value_to_term _ = R.value_to_term _ |- _] => apply R.value_to_term_injective in Hv
  | [Hr : R.redex_to_term _ = R.redex_to_term _ |- _] => apply R.redex_to_term_injective in Hr
  | [ |- _] => idtac
  end.

  Lemma ec_order_antisym : forall ec ec0, ec <: ec0 -> ~ec0 <: ec.
  Proof.
    destruct ec; destruct ec0; intros H H0; inversion H; inversion H0.
  Qed.
  Lemma dec_ec_ord : forall t0 t1 ec0 ec1, R.atom_plug t0 ec0 = R.atom_plug t1 ec1 -> ec0 <: ec1 \/ ec1 <: ec0 \/ (t0 = t1 /\ ec0 = ec1).
  Proof.
    destruct ec0; destruct ec1; intros; inversion H; inj_vr; subst; simpl in *; auto.
  Qed.
  Lemma elem_context_det : forall t0 t1 ec0 ec1, ec0 <: ec1 -> R.atom_plug t0 ec0 = R.atom_plug t1 ec1 ->
    exists v, t1 = R.value_to_term v.
  Proof.
    destruct ec0; destruct ec1; intros; inversion H; inversion H0; subst; exists v; auto.
  Qed.

End Arith_Ref_Lang.

Module Arith_Ref_Sem_Auto <: RED_REF_SEM Arith_Lang := RedRefSem Arith_Ref_Lang.

Module Arith_Ref_Sem <: RED_REF_SEM Arith_Lang.

  Definition term := Arith_Lang.term.
  Definition value := Arith_Lang.value.
  Definition redex := Arith_Lang.redex.
  Definition context := Arith_Lang.context.
  Definition empty := Arith_Lang.empty.
  Definition decomp := Arith_Lang.decomp.
  Definition elem_context := Arith_Lang.elem_context.
  Definition d_val := Arith_Lang.d_val.
  Definition d_red := Arith_Lang.d_red.
  Definition value_to_term : value -> term := Arith_Lang.value_to_term.
  Definition redex_to_term : redex -> term := Arith_Lang.redex_to_term.
  Definition decomp_to_term : (decomp -> term) := Arith_Lang.decomp_to_term.
  Definition atom_plug := Arith_Lang.atom_plug.
  Definition plug : term -> context -> term := Arith_Lang.plug.
  Definition compose : context -> context -> context := Arith_Lang.compose.
  Definition contract : redex -> option term := Arith_Lang.contract.
  Definition interm_dec := Arith_Lang.interm_dec.
  Definition in_red := Arith_Lang.in_red.
  Definition in_val := Arith_Lang.in_val.
  Definition in_term := Arith_Lang.in_term.

  Coercion value_to_term : value >-> term.
  Coercion redex_to_term : redex >-> term.

  (** Functions specifying atomic steps of induction on terms and contexts -- needed to avoid explicit induction on terms and contexts in construction of the AM *)
  Definition dec_term : term -> interm_dec :=
  fun (t : term) => match t with
  | Arith_Lang.var vname => in_red (Arith_Lang.r_var vname)
  | Arith_Lang.num n => in_val (Arith_Lang.v_num n)
  | Arith_Lang.plus n m => in_term n (Arith_Lang.plus_r m)
  | Arith_Lang.times n m => in_term n (Arith_Lang.times_r m)
  end.
  Definition dec_context : elem_context -> value -> interm_dec :=
  fun (ec : elem_context) (v : value) => match ec with
  | Arith_Lang.plus_r n => in_term n (Arith_Lang.plus_l v)
  | Arith_Lang.plus_l v' => in_red (Arith_Lang.r_plus v' v)
  | Arith_Lang.times_r n => in_term n (Arith_Lang.times_l v)
  | Arith_Lang.times_l v' => in_red (Arith_Lang.r_times v' v)
  end.

  Lemma dec_term_value : forall (v:value), dec_term (v:term) = in_val v.
  Proof.
    destruct v; simpl; auto.
  Qed.
  Hint Resolve dec_term_value.

  Lemma dec_term_correct : forall t, match dec_term t with
    | in_red r => redex_to_term r = t
    | in_val v => value_to_term v = t
    | in_term t0 c0 => atom_plug t0 c0 = t
  end.
  Proof.
    intro t; case t; intros; simpl; auto.
  Qed.
  Lemma dec_context_correct : forall c v, match dec_context c v with
    | in_red r => redex_to_term r = atom_plug (value_to_term v) c
    | in_val v0 => value_to_term v0 = atom_plug (value_to_term v) c
    | in_term t c0 => atom_plug t c0 = atom_plug (value_to_term v) c
  end.
  Proof.
    destruct c; intros; simpl; auto.
  Qed.

  (** A decomposition function specified in terms of the atomic functions above *)
  Inductive dec : term -> context -> decomp -> Prop :=
  | d_dec  : forall (t : term) (c : context) (r : redex),
                 dec_term t = in_red r -> dec t c (d_red r c)
  | d_v    : forall (t : term) (c : context) (v : value) (d : decomp),
                 dec_term t = in_val v -> decctx v c d -> dec t c d
  | d_term : forall (t t0 : term) (c : context) (ec : elem_context) (d : decomp),
                 dec_term t = in_term t0 ec -> dec t0 (ec :: c) d -> dec t c d
  with decctx : value -> context -> decomp -> Prop :=
  | dc_end  : forall (v : value), decctx v empty (d_val v)
  | dc_dec  : forall (v : value) (ec : elem_context) (c : context) (r : redex),
                dec_context ec v = in_red r -> decctx v (ec :: c) (d_red r c)
  | dc_val  : forall (v v0 : value) (ec : elem_context) (c : context) (d : decomp),
                dec_context ec v = in_val v0 -> decctx v0 c d -> decctx v (ec :: c) d
  | dc_term : forall (v : value) (ec ec0 : elem_context) (c : context) (t : term) (d : decomp),
                dec_context ec v = in_term t ec0 -> dec t (ec0 :: c) d -> decctx v (ec :: c) d.

  Scheme dec_Ind := Induction for dec Sort Prop
  with decctx_Ind := Induction for decctx Sort Prop.

  Lemma dec_red_ref : forall t c d, Arith_Sem.dec t c d <-> dec t c d.
  Proof with eauto.
    intros; split; intro.
    induction H using Arith_Sem.dec_Ind with
    (P := fun t c d (H : Arith_Sem.dec t c d) => dec t c d)
    (P0:= fun v c d (H : Arith_Sem.decctx v c d) => decctx v c d);
    [ constructor | econstructor 2 | econstructor 3 | econstructor 3 | constructor
    | econstructor 4 | constructor | econstructor 4 | constructor]; simpl...
    induction H using dec_Ind with
    (P := fun t c d (H : dec t c d) => Arith_Sem.dec t c d)
    (P0:= fun v c d (H : decctx v c d) => Arith_Sem.decctx v c d);
    try (destruct t; inversion e; subst; constructor); auto; try constructor;
    destruct ec; inversion e; subst; constructor...
  Qed.

  Module RS : RED_SEM Arith_Lang with Definition dec := dec.

    Definition dec := dec.

    Inductive decempty : term -> decomp -> Prop :=
    | d_intro : forall (t : term) (d : decomp), dec t empty d -> decempty t d.

    Inductive iter : decomp -> value -> Prop :=
    | i_val : forall (v : value), iter (d_val v) v
    | i_red : forall (r : redex) (t : term) (c : context) (d : decomp) (v : value),
                contract r = Some t -> decempty (plug t c) d -> iter d v -> iter (d_red r c) v.

    Inductive eval : term -> value -> Prop :=
    | e_intro : forall (t : term) (d : decomp) (v : value), decempty t d -> iter d v -> eval t v.

    Lemma dec_redex_self : forall (r : redex) (c : context), dec (redex_to_term r) c (d_red r c).
    Proof.
      intros; rewrite <- dec_red_ref; apply Arith_Sem.dec_redex_self.
    Qed.

    (** dec is left inverse of plug *)
    Lemma dec_correct : forall t c d, dec t c d -> decomp_to_term d = plug t c.
    Proof.
      intros; apply Arith_Sem.dec_correct; rewrite dec_red_ref; auto.
    Qed.

    Lemma dec_plug : forall c c0 t d, dec (plug t c) c0 d -> dec t (compose c c0) d.
    Proof.
      intros; rewrite <- dec_red_ref; apply Arith_Sem.dec_plug; rewrite dec_red_ref; auto.
    Qed.

    Lemma dec_plug_rev : forall c c0 t d, dec t (compose c c0) d -> dec (plug t c) c0 d.
    Proof.
      intros; rewrite <- dec_red_ref; apply Arith_Sem.dec_plug_rev; rewrite dec_red_ref; auto.
    Qed.
    Definition decompose := Arith_Sem.decompose.

  End RS.

  Lemma iter_red_ref : forall d v, Arith_Sem.iter d v <-> RS.iter d v.
  Proof.
    intros; split; intro; induction H; try constructor;
    constructor 2 with t d; auto; constructor;
    [ inversion_clear H0; rewrite <- dec_red_ref | inversion_clear D_EM; rewrite dec_red_ref]; auto.
  Qed.

  Lemma eval_red_ref : forall t v, Arith_Sem.eval t v <-> RS.eval t v.
  Proof.
    intros; split; intro; inversion_clear H; constructor 1 with d.
    constructor; inversion_clear H0; rewrite <- dec_red_ref; auto.
    rewrite <- iter_red_ref; auto.
    constructor; inversion_clear D_EM; rewrite dec_red_ref; auto.
    rewrite iter_red_ref; auto.
  Qed.

  Lemma dec_val_self : forall v c d, dec (Arith_Lang.value_to_term v) c d <-> decctx v c d.
  Proof.
    split; intro.
    destruct v; inversion H; inversion H0; subst; auto.
    assert (hh := dec_term_value v); econstructor; eauto.
  Qed.

End Arith_Ref_Sem.

Module Arith_PE_Sem <: PE_REF_SEM Arith_Lang.

  Module Red_Sem := Arith_Ref_Sem.

  Lemma dec_context_not_val : forall (v v0 : Arith_Lang.value) (ec : Arith_Lang.elem_context), ~Red_Sem.dec_context ec v = Arith_Lang.in_val v0.
  Proof.
    destruct ec; intros; simpl; intro; discriminate.
  Qed.
  Hint Resolve dec_context_not_val.
  Definition dec_term_value := Red_Sem.dec_term_value.

End Arith_PE_Sem.

Module EAM := ProperEAMachine Arith_Lang Arith_Ref_Sem.
Module PEM := ProperPEMachine Arith_Lang Arith_PE_Sem.

Module EAArithMachine <: ABSTRACT_MACHINE.

  Definition term := Arith_Lang.term.
  Definition value := Arith_Lang.value.
  Definition redex := Arith_Lang.redex.
  Definition context := Arith_Lang.context.
  Definition num := Arith_Lang.num.
  Definition plus := Arith_Lang.plus.
  Definition times := Arith_Lang.times.
  Definition var  := Arith_Lang.var.
  Definition v_num := Arith_Lang.v_num.
  Definition r_plus := Arith_Lang.r_plus.
  Definition r_times:= Arith_Lang.r_times.
  Definition r_var  := Arith_Lang.r_var.
  Definition empty := Arith_Lang.empty.
  Definition plus_r := Arith_Lang.plus_r.
  Definition plus_l := Arith_Lang.plus_l.
  Definition times_r := Arith_Lang.times_r.
  Definition times_l := Arith_Lang.times_l.
  Definition value_to_term : value -> term := Arith_Lang.value_to_term.
  Definition redex_to_term : redex -> term := Arith_Lang.redex_to_term.
  Coercion value_to_term : value >-> term.
  Coercion redex_to_term : redex >-> term.

  Definition contract := Arith_Lang.contract.
  Definition plug := Arith_Lang.plug.
  Definition compose := Arith_Lang.compose.

  Definition decomp := Arith_Lang.decomp.
  Definition d_val := Arith_Lang.d_val.
  Definition d_red := Arith_Lang.d_red.

  Definition configuration := EAM.configuration.
  Definition c_init := EAM.c_init.
  Definition c_eval := EAM.c_eval.
  Definition c_apply := EAM.c_apply.
  Definition c_final := EAM.c_final.

  Definition var_name := Arith_Lang.var_name.
  Definition env := Arith_Lang.env.

  Inductive transition' : configuration -> configuration -> Prop :=
  | t_init : forall t : term, transition' (c_init t) (c_eval t empty)
  | t_val  : forall (v : value) (c : context), transition' (c_eval (v:term) c) (c_apply c v)
  | t_plus : forall (t s : term) (c : context), transition' (c_eval (plus t s) c) (c_eval t (plus_r s :: c))
  | t_times: forall (t s : term) (c : context), transition' (c_eval (times t s) c) (c_eval t (times_r s :: c))
  | t_var  : forall (x : var_name) (c : context), transition' (c_eval (var x) c) (c_eval (num (env x)) c)
  | t_empty  : forall v : value, transition' (c_apply empty v) (c_final v)
  | t_plus_r : forall (t : term) (v : value) (c : context), transition' (c_apply (plus_r t :: c) v) (c_eval t (plus_l v :: c))
  | t_plus_l : forall (v v0 : value) (c : context) (t : term),
                 contract (r_plus v0 v) = Some t -> transition' (c_apply (plus_l v0 :: c) v) (c_eval t c)
  | t_times_r: forall (t : term) (v : value) (c : context), transition' (c_apply (times_r t :: c) v) (c_eval t (times_l v :: c))
  | t_times_l: forall (v v0 : value) (c : context) (t : term),
                 contract (r_times v0 v) = Some t -> transition' (c_apply (times_l v0 :: c) v) (c_eval t c).

  Definition transition := transition'.

  Inductive trans_close : configuration -> configuration -> Prop :=
  | one_step   : forall (c0 c1 : configuration), transition c0 c1 -> trans_close c0 c1
  | multi_step : forall (c0 c1 c2 : configuration), transition c0 c1 -> trans_close c1 c2 -> trans_close c0 c2.

  Inductive eval : term -> value -> Prop :=
  | e_intro : forall (t : term) (v : value), trans_close (c_init t) (c_final v) -> eval t v.

  Lemma trEA_M : forall w w' : configuration, EAM.transition w w' -> transition w w'.
  Proof with eauto.
    intros w w' H; inversion H; subst;
    try (destruct ec; inversion DC; subst; constructor; auto);
    try constructor; destruct t; inversion DT; subst; try constructor.
    inversion CONTR; subst; constructor.
    cutrewrite (Arith_Lang.num n = value_to_term (Arith_Lang.v_num n)); [constructor | auto].
  Qed.
  Hint Resolve trEA_M.

  Lemma tcEA_M : forall w w' : configuration, EAM.AM.trans_close w w' -> trans_close w w'.
  Proof with eauto.
    intros w w' H; induction H; subst; [ constructor 1 | econstructor 2]...
  Qed.

  Lemma evalEA_M : forall t v, EAM.AM.eval t v -> eval t v.
  Proof.
    intros t v H; inversion H; constructor; apply tcEA_M; auto.
  Qed.
  Hint Resolve evalEA_M.

  Lemma trM_EA : forall w w' : configuration, transition w w' -> EAM.AM.transition w w'.
  Proof with eauto.
    intros w w' H; inversion H; subst; econstructor; simpl...
  Qed.
  Hint Resolve trM_EA.

  Lemma tcM_EA : forall w w' : configuration, trans_close w w' -> EAM.AM.trans_close w w'.
  Proof with eauto.
    induction 1; [ constructor 1 | econstructor 2]...
  Qed.

  Lemma evalM_EA : forall t v, eval t v -> EAM.AM.eval t v.
  Proof.
    intros t v H; inversion H; constructor; apply tcM_EA; auto.
  Qed.
  Hint Resolve evalM_EA.

  Theorem ArithMachineCorrect : forall (t : term) (v : value), Arith_Sem.eval t v <-> eval t v.
  Proof with auto.
    intros; rewrite Arith_Ref_Sem.eval_red_ref; rewrite EAM.eval_apply_correct; split...
  Qed.

End EAArithMachine.

Module PEArithMachine <: ABSTRACT_MACHINE.

  Definition term := Arith_Lang.term.
  Definition value := Arith_Lang.value.
  Definition redex := Arith_Lang.redex.
  Definition context := Arith_Lang.context.
  Definition num := Arith_Lang.num.
  Definition plus := Arith_Lang.plus.
  Definition times := Arith_Lang.times.
  Definition var  := Arith_Lang.var.
  Definition v_num := Arith_Lang.v_num.
  Definition r_plus := Arith_Lang.r_plus.
  Definition r_times:= Arith_Lang.r_times.
  Definition r_var  := Arith_Lang.r_var.
  Definition empty := Arith_Lang.empty.
  Definition plus_r := Arith_Lang.plus_r.
  Definition plus_l := Arith_Lang.plus_l.
  Definition times_r := Arith_Lang.times_r.
  Definition times_l := Arith_Lang.times_l.
  Definition value_to_term : value -> term := Arith_Lang.value_to_term.
  Definition redex_to_term : redex -> term := Arith_Lang.redex_to_term.
  Coercion value_to_term : value >-> term.
  Coercion redex_to_term : redex >-> term.

  Definition contract := Arith_Lang.contract.
  Definition plug := Arith_Lang.plug.
  Definition compose := Arith_Lang.compose.

  Definition decomp := Arith_Lang.decomp.
  Definition d_val := Arith_Lang.d_val.
  Definition d_red := Arith_Lang.d_red.

  Definition configuration := PEM.configuration.
  Definition c_init := PEM.c_init.
  Definition c_eval := PEM.c_eval.
  Definition c_final := PEM.c_final.

  Definition var_name := Arith_Lang.var_name.
  Definition env := Arith_Lang.env.

  Inductive transition' : configuration -> configuration -> Prop :=
  | t_init : forall t : term, transition' (c_init t) (c_eval t empty)
  | t_plus : forall (t s : term) (c : context), transition' (c_eval (plus t s) c) (c_eval t (plus_r s :: c))
  | t_times: forall (t s : term) (c : context), transition' (c_eval (times t s) c) (c_eval t (times_r s :: c))
  | t_var  : forall (x : var_name) (c : context), transition' (c_eval (var x) c) (c_eval (num (env x)) c)
  | t_empty  : forall v : value, transition' (c_eval (v:term) empty) (c_final v)
  | t_plus_r : forall (t : term) (v : value) (c : context), transition' (c_eval (v:term) (plus_r t :: c)) (c_eval t (plus_l v :: c))
  | t_plus_l : forall (v v0 : value) (c : context) (t : term),
                 contract (r_plus v0 v) = Some t -> transition' (c_eval (v:term) (plus_l v0 :: c)) (c_eval t c)
  | t_times_r: forall (t : term) (v : value) (c : context), transition' (c_eval (v:term) (times_r t :: c)) (c_eval t (times_l v :: c))
  | t_times_l: forall (v v0 : value) (c : context) (t : term),
                 contract (r_times v0 v) = Some t -> transition' (c_eval (v:term) (times_l v0 :: c)) (c_eval t c).

  Definition transition := transition'.
  Inductive trans_close : configuration -> configuration -> Prop :=
  | one_step   : forall (c0 c1 : configuration), transition c0 c1 -> trans_close c0 c1
  | multi_step : forall (c0 c1 c2 : configuration), transition c0 c1 -> trans_close c1 c2 -> trans_close c0 c2.

  Inductive eval : term -> value -> Prop :=
  | e_intro : forall (t : term) (v : value), trans_close (c_init t) (c_final v) -> eval t v.

  Lemma trPE_M : forall w w' : configuration, PEM.transition w w' -> transition w w'.
  Proof with eauto.
    assert (numeq : forall (n : nat), Arith_Lang.num n = value_to_term (Arith_Lang.v_num n))...
    intros w w' H; inversion H; subst;
    try constructor; destruct t; inversion DT; subst; try constructor.
    inversion CONTR; subst; constructor.
    rewrite numeq; constructor.
    destruct ec; inversion DC; subst; destruct v; inversion CONTR; subst; rewrite numeq; constructor...
    destruct ec; inversion DC; subst; rewrite numeq; constructor...
  Qed.
  Hint Resolve trPE_M.

  Lemma tcPE_M : forall w w' : configuration, PEM.AM.trans_close w w' -> trans_close w w'.
  Proof with eauto.
    intros w w' H; induction H; subst; [ constructor 1 | econstructor 2]...
  Qed.

  Lemma evalPE_M : forall t v, PEM.AM.eval t v -> eval t v.
  Proof.
    intros t v H; inversion H; constructor; apply tcPE_M; auto.
  Qed.
  Hint Resolve evalPE_M.

  Lemma trM_PE : forall w w' : configuration, transition w w' -> PEM.AM.transition w w'.
  Proof with eauto.
    intros w w' H; inversion H; subst; econstructor; simpl...
  Qed.
  Hint Resolve trM_PE.

  Lemma tcM_PE : forall w w' : configuration, trans_close w w' -> PEM.AM.trans_close w w'.
  Proof with eauto.
    induction 1; [ constructor 1 | econstructor 2]...
  Qed.

  Lemma evalM_PE : forall t v, eval t v -> PEM.AM.eval t v.
  Proof.
    intros t v H; inversion H; constructor; apply tcM_PE; auto.
  Qed.
  Hint Resolve evalM_PE.

  Theorem ArithMachineCorrect : forall (t : term) (v : value), Arith_Sem.eval t v <-> eval t v.
  Proof with auto.
    intros t v; rewrite Arith_Ref_Sem.eval_red_ref; rewrite PEM.push_enter_correct; split...
  Qed.

End PEArithMachine.


Require Import BinInt ZArith_dec Zorder.
Require Export Id.
Require Export State.
Require Export Expr.

From hahn Require Import HahnBase.

Definition eval_op (op : bop) (z1 z2 : Z) : option Z :=
  match op with
  | Add => Some (z1 + z2)%Z
  | Sub => Some (z1 - z2)%Z
  | Mul => Some (z1 * z2)%Z
  | Div =>
    match z2 with
    | 0%Z => None
    | _   => Some (Z.div z1 z2)
    end
  | Mod =>
    match z2 with
    | 0%Z => None
    | _   => Some (Z.modulo z1 z2)
    end
  | Le =>
    match Ztrichotomy_inf z1 z2 with
    | inleft  _ => Some 1%Z
    | _ => Some 0%Z
    end
  | Lt =>
    match Ztrichotomy_inf z1 z2 with
    | inleft (left _) => Some 1%Z
    | _ => Some 0%Z
    end
  | Ge =>
    match Ztrichotomy_inf z1 z2 with
    | inleft (right _)
    | inright _ => Some 1%Z
    | _ => Some 0%Z
    end
  | Gt =>
    match Ztrichotomy_inf z1 z2 with
    | inright _ => Some 1%Z
    | _ => Some 0%Z
    end
  | Eq =>
    match Ztrichotomy_inf z1 z2 with
    | inleft (right _) => Some 1%Z
    | _ => Some 0%Z
    end
  | Ne =>
    match Ztrichotomy_inf z1 z2 with
    | inleft (right _) => Some 0%Z
    | _ => Some 1%Z
    end
  | And =>
    match z1, z2 with
    | 1%Z, 1%Z => Some 1%Z
    | 0%Z, 0%Z
    | 0%Z, 1%Z
    | 1%Z, 0%Z => Some 0%Z
    | _, _ => None
    end
  | Or =>
    match z1, z2 with
    | 0%Z, 0%Z => Some 0%Z
    | 0%Z, 1%Z
    | 1%Z, 0%Z
    | 1%Z, 1%Z => Some 1%Z
    | _, _ => None
    end
  end.

Fixpoint cfold (e : expr) : expr :=
  match e with
  | Bop op e1 e2 =>
    let (c1, c2) := (cfold e1, cfold e2) in
    match c1, c2 with
    | Nat z1, Nat z2 =>
      match eval_op op z1 z2 with
      | Some v1 => Nat v1
      | _       => Bop op c1 c2
      end
    | _, _ => Bop op c1 c2
    end
  | _ => e
  end.

Lemma cfold_correct (e : expr) : cfold e ~e~ e.
Proof. admit. Admitted.


Require Import XR_Rmin.
Require Import XR_Rle_dec.
Require Import XR_Rle_trans.
Require Import XR_Rnot_le_lt.

Local Open Scope R_scope.

Lemma Rle_min_compat_l : forall x y z, x <= y -> Rmin z x <= Rmin z y.
Proof.
  intros x y z.
  intro h.
  unfold Rmin.
  destruct (Rle_dec z x) as [ hminxl | hminxr ] ;
  destruct (Rle_dec z y) as [ hminyl | hminyr ].
  {
    right.
    reflexivity.
  }
  {
    apply Rle_trans with x.
    { exact hminxl. }
    { exact h. }
  }
  {
    left.
    apply Rnot_le_lt.
    exact hminxr.
  }
  { exact h. }
Qed.


Definition compose {A B C: Prop} (f: A -> B) (g: B -> C) (x: A) := g (f (x)).

Lemma transitive : forall A B C D: Prop, forall f: A -> B, forall g: B -> C, forall h: C -> D, forall x: A, h ((compose f g) x) = (compose g h) (f x).
Proof.
  intros.
  unfold compose.
  reflexivity.
Qed.


From mathcomp Require Import all_ssreflect.
From Equations Require Import Equations.
Set Equations With UIP.

Section list.

Variable (A : Set) (A_eqdec : EqDec A).

Inductive list := nil | cons : A -> list -> list.

Derive NoConfusion EqDec for list.

Fixpoint length (l : list) : nat :=
  match l with
  | nil => 0
  | cons _ l' => (length l').+1
  end.

End list.

Section tuple.

Variable (A : Set) (A_eqdec : EqDec A).

Inductive tuple i := { l : list A; p : (length _ l == i) = true }.

(* Derive NoConfusionHom seems much slower, so we use Derive NoConfusion *)
(* Time Equations Derive NoConfusionHom for t. *)

(* Equations Derive NoConfusion EqDec for bool.
Equations Derive NoConfusion EqDec for nat. *)
Time Equations Derive NoConfusion EqDec for tuple.

End tuple.

Succeed Check tuple_eqdec.


(* (c) Copyright Christian Doczkal, Saarland University                   *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import Relations Recdef.
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From libs Require Import edone bcase fset base.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** * Directed Acyclic Graphs *)

(** ** Termination and Transitive Closure *)

Inductive sn (X : Type) (R : X -> X -> Prop) (x : X) : Prop :=
  SN : (forall y, R x y -> sn R y) -> sn R x.

Inductive star (X : Type) (R : X -> X -> Prop) (x : X) : X -> Prop :=
| Star0 : star R x x
| StarL y z : R x z -> star R z y -> star R x y.

Definition terminates X (e : X -> X -> Prop) := forall x, sn e x.

Lemma sn_preimage T1 T2 (e1 : T1 -> T1 -> Prop) (e2 : T2 -> T2 -> Prop) (h : T1 -> T2) x :
  (forall x y, e1 x y -> e2 (h x) (h y)) -> sn e2 (h x) -> sn e1 x.
Proof.
  move eqn:(h x) => v A B. elim: B h x A eqn => {v} - v _ ih h x A eqn.
  apply: SN => y /A. rewrite eqn => /ih; eauto.
Qed.

Lemma terminates_gtn : terminates (fun n m => m < n).
Proof.
  move => n. elim: n {-2}n (leqnn n) => [|n IHn] m Hm ;constructor.
  - move => k Hk. by move: (leq_trans Hk Hm).
  - move => k Hk. apply: IHn. rewrite -ltnS. exact: leq_trans Hm.
Qed.

Lemma terminates_measure T (f : T -> nat) (e : T -> T -> Prop)  :
      (forall x y, e x y -> f y < f x) -> terminates e.
Proof. move => H x. exact: sn_preimage (terminates_gtn (f x)). Qed.

(** ** Finite Rooted Labeled Graphs *)

Record graph (L : Type) :=
  Graph { vertex :> finType ; edge : rel vertex ; label : vertex -> L  }.

Record rGraph (L : Type) := RGraph {
    graph_of :> graph L ;
    root : graph_of ;
    rootP x : connect (@edge _ graph_of) root x }.

Section GraphTheory.
  Variables (L : choiceType) (p : L -> {fset L} -> bool).
  Implicit Types (G : graph L) (rG : rGraph L).

  Definition erel G := (@edge _ G).

  Definition glocal G := [forall x : G, p (label x) [fset (label y) | y <- fset (edge x)]].
  Definition respects e G := [forall x : G, forall y : G, edge x y ==> e (label x) (label y)].

  Definition leaf G (x:G) := ~~ [exists y, edge x y].
End GraphTheory.

Arguments erel [L] G _ _.
Arguments existT [A] [P] x _.

(** The reachable subgraph of every element is rooted at that element *)

Definition restrict (T : finType) (P : pred T) (Tp : subType P) (e : rel T) :=
  fun x y : Tp => e (val x) (val y).
Arguments restrict [T P] Tp e x y.

Lemma connect_subtype (T : finType) (x0 : T) (e : rel T) (Tp : subFinType (connect e x0)) :
  forall x p, connect (restrict Tp e) (Sub x0 p) x.
Proof.
  move => x. case: (SubP x) => {x} - x Px.
  case/connectP : Px (Px) => pth. elim/last_ind: pth x => [x _ -> Px /= p|pth y IH x /=].
  - by rewrite (bool_irrelevance p Px) connect0.
  - rewrite rcons_path last_rcons.
    case/andP => Pth xy E Px p. subst.
    have conn : connect e x0 (last x0 pth) by apply/connectP; exists pth.
    apply: connect_trans.
    + exact: IH.
    + apply: connect1. by rewrite /restrict !SubK.
Qed.

(** Disjoint Union of finite graphs *)

Section Disjoint.
  Variables (L : Type) (I:finType) (G : I -> graph L).

  Definition lift_edge (x y : {i : I & G i}) :=
    (tag x == tag y) && edge (tagged x) (tagged_as x y).

  Lemma lift_eq (i : I) (x y : G i)  :
    lift_edge (existT i x) (existT i y) = edge x y.
  Proof. by rewrite /lift_edge /= eqxx tagged_asE. Qed.

  Lemma lift_eqn (ix iy : I) (x : G ix) (y : G iy)  :
    ix != iy -> lift_edge (existT ix x) (existT iy y) = false.
  Proof. by rewrite /lift_edge /= => /negbTE ->. Qed.

  Lemma liftE (i j : I) (x : G i) (y : G j) :
    lift_edge (existT i x) (existT j y) -> j = i.
  Proof. by case/andP => /= /eqP. Qed.

  Lemma lift_connect (i : I) (x y : G i) :
    connect (@edge _ (G i)) x y -> connect lift_edge (existT i x) (existT i y).
  Proof. case/connectP => p.
    elim: p x y => /= [x y _  ->|z p IHp x y /andP [? ?] ?]; first exact: connect0.
    apply: (@connect_trans _ _ (existT i z)); last exact: IHp.
    by rewrite connect1 // lift_eq.
  Qed.
End Disjoint.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*                                                            *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

(* A inductive characterization of list bi-inclusion
    as closure under contraction and permutation

    The proof does not require decidable equality
    and uses the somehow generalized PHP that
    states m ⊆ l and |l| <= |m| -> m has dup \/ l ~p m

 *)

Require Import Arith Lia List Permutation.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac php.

From Undecidability.Shared.Libs.DLW.Wf
  Require Import measure_ind.

Set Implicit Arguments.

Local Reserved Notation "x ≡ y" (at level 70, no associativity).
Local Reserved Notation "x ⪼ y" (at level 70, no associativity).

Local Notation lhd := list_has_dup.
Local Infix "~p" := Permutation (at level 70, no associativity).
Local Notation "⌊ l ⌋" := (length l) (at level 1, format "⌊ l ⌋").

Local Infix "∈" := In (at level 70, no associativity).
Local Infix "⊆" := incl (at level 70, no associativity).
Local Infix "≃ₛ" := (fun l p => l ⊆ p /\ p ⊆ l) (at level 70, no associativity).

Section incl_extra.

  Variable (X : Type).

  Implicit Type (l : list X).

  Hint Resolve incl_refl incl_tl incl_cons incl_nil_l : core.

  Fact lequiv_refl l : l ≃ₛ l.
  Proof. split; auto. Qed.

  Fact lequiv_sym l m : l ≃ₛ m -> m ≃ₛ l.
  Proof. simpl; tauto. Qed.

  Fact lequiv_trans l m k : l ≃ₛ m -> m ≃ₛ k -> l ≃ₛ k.
  Proof. intros [] []; split; apply incl_tran with m; auto. Qed.

  Fact incl_cons_simpl x l m : l ⊆ m -> x::l ⊆ x::m.
  Proof. intros; apply incl_cons; simpl; auto. Qed.

  Fact incl_tail_simpl x l : l ⊆ x::l.
  Proof. auto. Qed.

  Hint Resolve incl_cons_simpl incl_tail_simpl : core.

  Fact incl_swap (x y : X) l : x::y::l ⊆ y::x::l.
  Proof. intros ? [ -> | [ -> | ] ]; simpl; auto. Qed.

  Fact incl_cntr (x : X) l : x::x::l ⊆ x::l.
  Proof. intros ? [ -> | [ -> | ] ]; simpl; auto. Qed.

  Fact lequiv_swap x y l : x::y::l ≃ₛ y::x::l.
  Proof. split; apply incl_cons; simpl; auto. Qed.

  Fact lequiv_app_comm l m : l++m ≃ₛ m++l.
  Proof. split; intros ?; rewrite !in_app_iff; tauto. Qed.

  Fact incl_cons_l_inv l m x : x::m ⊆ l -> x ∈ l /\ m ⊆ l.
  Proof.
    intros H; split.
    + apply H; simpl; auto.
    + apply incl_tran with (2 := H); simpl; auto.
  Qed.

  Hint Resolve perm_skip Permutation_cons_app : core.

  Fact incl_app_r_inv l m p : m ⊆ l++p -> exists m1 m2, m ~p m1++m2 /\ m1 ⊆ l /\ m2 ⊆ p.
  Proof.
    induction m as [ | x m IHm ].
    + exists nil, nil; auto.
    + intros H; apply incl_cons_l_inv in H as (H1 & H2).
      destruct (IHm H2) as (m1 & m2 & H3 & H4 & H5).
      apply in_app_or in H1 as [].
      * exists (x::m1), m2; simpl; auto.
      * exists m1, (x::m2); simpl; auto.
  Qed.

  Fact incl_cons_r_inv x l m :
         m ⊆ x::l -> exists m1 m2, m ~p m1 ++ m2 /\ Forall (eq x) m1 /\ m2 ⊆ l.
  Proof.
    intros H.
    apply (@incl_app_r_inv (x::nil) _ l) in H as (m1 & m2 & H1 & H2 & H3).
    exists m1, m2; msplit 2; auto.
    rewrite Forall_forall.
    intros a Ha; apply H2 in Ha; destruct Ha as [ | [] ]; auto.
  Qed.

  Fact incl_right_cons_choose x l m : m ⊆ x::l -> x ∈ m \/ m ⊆ l.
  Proof.
    intros H; apply incl_cons_r_inv in H
      as ([ | y m1] & m2 & H1 & H2 & H3).
    + right.
      intros u H; apply H3; revert H.
      apply Permutation_in; auto.
    + left.
      apply Permutation_in with (1 := Permutation_sym H1).
      rewrite Forall_forall in H2.
      rewrite (H2 y); left; auto.
  Qed.

  Fact incl_left_right_cons x l y m :
          x::l ⊆ y::m  -> y = x /\ y ∈ l
                       \/ y = x /\ l ⊆ m
                       \/ x ∈ m /\ l ⊆ y::m.
  Proof.
    intros H; apply incl_cons_l_inv in H
      as [ [|] H2 ]; auto.
    apply incl_right_cons_choose in H2; tauto.
  Qed.

  Fact perm_incl_left m1 m2 l: m1 ~p m2 -> m2 ⊆ l -> m1 ⊆ l.
  Proof. intros H1 H2 ? H; apply H2; revert H; apply Permutation_in; auto. Qed.

  Fact perm_incl_right m l1 l2: l1 ~p l2 -> m ⊆ l1 -> m ⊆ l2.
  Proof. intros H1 H2 ? ?; apply Permutation_in with (1 := H1), H2; auto. Qed.

End incl_extra.

Section seteq.

  Variable X : Type.

  Implicit Types l : list X.

  Inductive list_contract : list X -> list X -> Prop :=
    | lc_nil      : nil ⪼  nil
    | lc_skip     : forall x l m, l ⪼ m -> x::l ⪼ x::m
    | lc_swap     : forall x y l, x::y::l ⪼ y::x::l
    | lc_cntr     : forall x l, x::x::l ⪼ x::l
    | lc_trans    : forall l m k, l ⪼ m -> m ⪼ k -> l ⪼ k
  where "l ⪼ m" := (list_contract l m).

  Hint Constructors list_contract : core.

  Fact perm_lc l m : l ~p m -> l ⪼ m.
  Proof. induction 1; eauto. Qed.

  Fact lc_length l m : l ⪼ m -> ⌊m⌋ <= ⌊l⌋.
  Proof. induction 1; simpl; lia. Qed.

  Fact lc_nil_inv_l l : nil ⪼ l -> l = nil.
  Proof.
    intros H; apply lc_length in H.
    destruct l; simpl in *; auto; lia.
  Qed.

  Hint Resolve perm_swap perm_trans : core.

  Fact lc_length_perm l m : l ⪼ m -> ⌊m⌋ < ⌊l⌋ \/ l ~p m.
  Proof.
    induction 1 as [ | ? ? ? ? [] | |
      | ? ? ? ? [] ? [] ]; simpl; eauto;
      repeat match goal with
        | H: _ ⪼ _ |- _ => apply lc_length in H
      end; lia.
  Qed.

  Fact lc_refl l : l ⪼ l.
  Proof. apply perm_lc; auto. Qed.

  (* When viewed as sets, the lists are equivalent,
      ie closed under perm + contraction + RST *)

  Inductive list_seteq : list X -> list X -> Prop :=
    | lseq_nil   : nil ≡ nil
    | lseq_skip  : forall x l m, l ≡ m -> x::l ≡ x::m
    | lseq_swap  : forall x y l, x::y::l ≡ y::x::l
    | lseq_dup   : forall x l, x::x::l ≡ x::l
    | lseq_sym   : forall l m, l ≡ m -> m ≡ l
    | lseq_trans : forall l m k, l ≡ m -> m ≡ k -> l ≡ k
  where "l ≡ m" := (list_seteq l m).

  Hint Constructors list_seteq : core.

  Fact lc_lseq l m : l ⪼ m -> l ≡ m.
  Proof. induction 1; eauto. Qed.

  Hint Resolve perm_lc lc_lseq : core.

  Fact perm_lseq l m : l ~p m -> l ≡ m.
  Proof. auto. Qed.

  Hint Resolve incl_refl incl_cons_simpl incl_swap incl_cntr incl_tl incl_tran : core.

  Fact lseq_lequiv l m : l ≡ m -> l ≃ₛ m.
  Proof.
    induction 1 as [ | ? ? ? ? [] | |
                   | ? ? ? []
                   | ? ? ? ? [] ? [] ]; eauto.
  Qed.

  Hint Resolve lseq_lequiv : core.

  Fact lc_lequiv l m : l ⪼ m -> l ≃ₛ m.
  Proof. intro; apply lseq_lequiv; auto. Qed.

  Hint Resolve incl_l_nil : core.

  Fact lc_nil_inv_r l : l ⪼ nil -> l = nil.
  Proof. intros H; apply lc_lequiv in H as []; auto. Qed.

  Hint Resolve list_has_dup_swap in_eq in_cons in_list_hd0 in_list_hd1 : core.

  Notation lhd_cons_iff := list_has_dup_cons_iff.

  Fact lc_lhd l m : l ⪼ m -> lhd m -> lhd l.
  Proof.
    induction 1 as [ | x l m H IH | | | ]; eauto.
    rewrite !lhd_cons_iff; intros []; auto.
    apply lc_lequiv in H as []; auto.
  Qed.

  Fact lseq_incl l m : l ≡ m -> l ⊆ m.
  Proof. intro; apply lseq_lequiv; auto. Qed.

  (* A list with a dup is contractible in a smaller one *)

  Lemma lhd_lc l : lhd l -> exists m, l ⪼ m /\ ⌊m⌋ < ⌊l⌋.
  Proof.
    induction 1 as [ l x H | l x H (m & H1 & H2) ].
    + apply in_split in H as (l1 & l2 & ->).
      exists (l1++x::l2); split; simpl; try lia.
      apply lc_trans with (x::x::l1++l2).
      * apply perm_lc, perm_skip, Permutation_sym,
              Permutation_cons_app; auto.
      * apply lc_trans with (1 := lc_cntr _ _), perm_lc,
              Permutation_cons_app; auto.
    + exists (x::m); split; simpl; auto; lia.
  Qed.

  Hint Resolve lc_lseq : core.

  Lemma lhd_lseq l : lhd l -> exists m, l ≡ m /\ ⌊m⌋ < ⌊l⌋.
  Proof. intro H; apply lhd_lc in H as (? & ? & ?); eauto. Qed.

  Hint Constructors list_contract : core.

  Hint Resolve lc_refl lc_lhd : core.

  Lemma lequiv_php_choose l m : l ≃ₛ m -> l ~p m \/ lhd l \/ lhd m.
  Proof.
    intros [ I1 I2 ].
    destruct (le_lt_dec ⌊m⌋ ⌊l⌋) as [ H1 | H1 ].
    + apply length_le_and_incl_implies_dup_or_perm in H1; tauto.
    + apply finite_php_dup in H1; tauto.
  Qed.

  (* if l and m are equivalent, either
     1) l ~p m in which case l is contractible into m
     2) lhd l hence l is contracted into a smaller one and recursion
     3) lhd m hence m is contracted into a smaller one and recursion
   *)

  Hint Resolve lequiv_trans : core.

  Lemma lequiv_lc l m : l ≃ₛ m -> exists c, l ⪼ c /\ m ⪼ c.
  Proof.
    induction on l m as IH with measure (⌊l⌋+⌊m⌋); intros H1.
    destruct (lequiv_php_choose H1) as [ H2 | [ H2 | H2 ] ]; eauto.
    + apply lhd_lc in H2 as (c & ? & ?).
      destruct (IH c m) as (d & ? & ?); eauto; lia.
    + apply lhd_lc in H2 as (c & ? & ?).
      destruct (IH l c) as (d & ? & ?); eauto; lia.
  Qed.

  Lemma lequiv_lseq l m : l ≃ₛ m -> l ≡ m.
  Proof. intros H; apply lequiv_lc in H as (c & []); eauto. Qed.

  Hint Resolve lequiv_lseq : core.

  (* seteq is equivalent to bi-inclusion *)

  Theorem lseq_lequiv_iff l m : l ≡ m <-> l ≃ₛ m.
  Proof. split; auto. Qed.

  (* A nice induction principle for list bi-inclusion *)

  Section lequiv_ind.

    Variables (P : list X -> list X -> Prop)
              (HP0 : P nil nil)
              (HP1 : forall x l m, l ≃ₛ m -> P l m -> P (x::l) (x::m))
              (HP2 : forall x y l, P (x::y::l) (y::x::l))
              (HP3 : forall x l, P (x::x::l) (x::l))
              (HP4 : forall l m, l ≃ₛ m -> P l m -> P m l)
              (HP5 : forall l m k, l ≃ₛ m -> P l m -> m ≃ₛ k -> P m k -> P l k).

    Theorem lequiv_ind l m : l ≃ₛ m -> P l m.
    Proof. rewrite <- lseq_lequiv_iff; induction 1; eauto. Qed.

  End lequiv_ind.

  Lemma lequiv_lhd_or_contract l m : l ≃ₛ m -> lhd m \/ l ⪼  m.
  Proof.
    simpl; intros H.
    destruct lequiv_lc with (1 := H) as (d & H1 & H2).
    apply lc_length_perm in H2 as [ H2 | H2 ].
    + apply finite_php_dup in H2; auto.
      apply lc_lseq, lseq_lequiv in H1.
      apply incl_tran with l; tauto.
    + right; apply lc_trans with (1 := H1).
      apply perm_lc, Permutation_sym; auto.
  Qed.

End seteq.


(*Technically we haven't learned how to do Definitions yet but I didn't want to type this twice so looked ahead*)
Definition sum5 (a1:nat) (a2:nat) (a3:nat) (a4:nat) (a5:nat) : nat :=
    a1 + a2 + a3 + a4 + a5.

Check sum5.

Compute sum5 1 1 1 1 1. (*5*)
Compute sum5 1 2 3 4 5. (*15*)


From mathcomp Require Import all_ssreflect.

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

Lemma ltn_perm_iota n l (p : perm_eq l (iota 0 n.+1)) m : nth 0 l m < n.+1.
Proof.
have [ltms|] := boolP (m < size l); last by rewrite -leqNgt => lesm; rewrite nth_default.
move: (perm_mem p) (@mem_nth _ 0 _ _ ltms) => ->.
by rewrite mem_iota add0n => /andP [].
Qed.

Section RankImpl.

Variables (n : nat) (T : eqType) (r : rel T) (s : n.+1.-tuple T).

Variable (tr : transitive r) (rr : reflexive r) (totr : total r) (ar : antisymmetric r).

Let A := 'I_n.+1.

Let ranking := n.+1.-tuple 'I_n.+1.

Notation i0 := ord0.
Notation t0 := (tnth s ord0).

Let si := zip_tuple s (ord_tuple n.+1).

Let ri :=
      [rel si1 si2 : T * 'I_n.+1 | r si1.1 si2.1 && ((si1.1 == si2.1) ==> (si1.2 <= si2.2))].

Lemma transitive_ri: transitive ri.
Proof.
move=> x y z /=; rewrite /ri /= => /andP [ryx /implyP leyx] /andP [rxy /implyP lexz].
apply/andP; split; first by rewrite (@tr x.1).
apply/implyP => /eqP eqyz.
rewrite -eqyz in lexz.
have [eqxy1|] := boolP (y.1 == x.1).
- by rewrite (@leq_trans x.2) // ?leyx // ?leyz lexz // eq_sym.
- rewrite -eqyz in rxy.
  have -> // : y.1 = x.1.
    apply: ar; rewrite ryx rxy => //.
    by rewrite eq_refl.
Qed.

Lemma reflexive_ri: reflexive ri.
Proof. move=> j. rewrite /ri /=. by rewrite rr leqnn //= implybT. Qed.

Lemma total_ri: total ri.
Proof.
move=> x y; rewrite /ri /=.
have [|//] := boolP (x.1 == y.1).
- rewrite eq_sym => /eqP ->.
  rewrite eq_refl !implyTb.
  move: (leq_total x.2 y.2) => /orP [le2|le2']; first by rewrite le2 rr.
  by rewrite le2' rr orbT.
- rewrite -(negbK (y.1 == x.1)) eq_sym => -> /=.
  by rewrite !andbT totr.
Qed.

Lemma anti_ri : antisymmetric ri.
Proof.
move=> x y; rewrite /ri /= => /andP [/andP [rxy lexy2]] /andP [ryx leyx2].
have eq11: x.1 = y.1 by apply: ar; rewrite rxy ryx.
rewrite eq11 eq_refl ?implyTb in lexy2 leyx2.
have/eqP eq22: x.2 == y.2.
  by rewrite -(inj_eq val_inj) /= eqn_leq lexy2 leyx2.
by rewrite (surjective_pairing x) (surjective_pairing y) eq22 eq11.
Qed.

Let si' := sort ri si.

Let is_rank (rank : A -> 'I_n.+1) (rval : 'I_n.+1 -> T) :=
  (forall (i j : A), i <= j -> r (rval i) (rval j))
  /\ (forall i : 'I_n.+1, rval (rank i) = tnth s i).

Local Lemma ltn_pred2k k l (p : perm_eq l (iota 0 n.+1)) :
  find [pred t | t.2 == k] [seq nth (t0, i0) si i | i <- l] < size l.
Proof.
have kinl: val k \in l by rewrite (perm_mem p) mem_iota add0n ltn_ord.
have nth_si : nth (t0, i0) si k = (tnth s k, k).
  by rewrite [in RHS](tnth_nth t0) nth_zip ?nth_ord_enum
           1?(tnth_nth t0) ?size_enum_ord ?size_tuple.
set l' := (X in find _ X); set t2k := [pred t | t.2 == k].
have // : find t2k l' < size l.
  have -> : size l = size l' by rewrite size_map.
  rewrite -has_find /=.
  apply/(has_nthP (t0, i0)).
  exists (index (tnth s k, k) l') => /=; first by rewrite index_mem -nth_si map_f.
  by rewrite nth_index //= -nth_si map_f.
Qed.

Definition zip_rank : A -> 'I_n.+1.
have zip_rank_bnd (i : A) : find [pred t | t.2 == i] si' < n.+1.
  rewrite /si' /=; have [l p ->] := perm_iota_sort ri (t0, i0) si.
  rewrite size_tuple in p.
  by rewrite (@leq_trans (size l)) ?ltn_pred2k // (perm_size p) size_iota.
exact: (fun (i : A) => Ordinal (zip_rank_bnd i)).
Defined.

Definition zip_rval := (fun (r : 'I_n.+1) => (nth (t0, i0) si' r).1).

Lemma is_rank_zip : is_rank zip_rank zip_rval.
Proof.
rewrite /zip_rank /zip_rval /=.
have szsn1 : size s = size (enum 'I_n.+1) by rewrite size_tuple ?cardE size_enum_ord.
have find_zip t (alln1 : forall j, j \in t -> j < n.+1) k :
  find [pred x | x.2 == k] [seq nth (t0, i0) si i | i <- t] =
    find [pred x | x == val k] t.
  elim: t alln1 => [//=|x t IH alln1 /=].
  rewrite nth_zip /= -?(inj_eq val_inj) /= ?nth_enum_ord ?alln1 ?mem_head // ?IH //
          ?size_tuple ?cardE ?size_enum_ord // => q qint.
  by rewrite alln1 // inE qint orbT.
split=> [i j leij|k].
- have ssi' : sorted ri si' by rewrite sort_sorted //; exact: total_ri.
  move: (sorted_leq_nth transitive_ri reflexive_ri (t0, i0) ssi' i j).
  by rewrite ?inE ?size_tuple ?ltn_ord // => /(_ erefl erefl leij) /= /andP [].
- rewrite /si' /=; have [l p ->] := perm_iota_sort ri (t0, i0) si.
  have kinl: val k \in l.
    by rewrite (perm_mem p) mem_iota add0n size_zip size_tuple /= size_enum_ord minnn.
  rewrite size_tuple in p.
  set l' := (X in find _ X); set t2k := [pred t | t.2 == k].
  have ltfinds : find t2k l' < size l by rewrite ltn_pred2k.
  rewrite (nth_map 0) /=; last by exact: ltfinds.
  rewrite nth_zip ?[RHS](tnth_nth t0) //=.
  have nthfindl' : nth 0 l (find t2k l') = (nth (t0, i0) l' (find t2k l')).2.
    by rewrite (nth_map 0) ?nth_zip /= ?nth_enum_ord //  ltn_perm_iota.
  rewrite nthfindl'.
  set ikl' := (find t2k l'); pose ikl := index (val k) l.
  have eqnths : nth 0 l ikl' = nth 0 l ikl.
    rewrite nth_index //=.
    move: (ltfinds); have -> : size l = size l' by rewrite size_map.
    rewrite -has_find => /(has_nthP (t0, i0)) [j ltjs].
    rewrite size_map in ltjs.
    rewrite nthfindl' (nth_map 0) // nth_zip /= -?(inj_eq val_inj) //=.
    rewrite (nth_map 0) // nth_zip /= ?nth_enum_ord ?ltn_perm_iota //.
    rewrite find_zip // => [nthljk|q /(nthP 0) [? _ <-]]; last by rewrite ltn_perm_iota.
    have -> : (find [pred x | x == val k] l) = j; last by exact/eqP.
       case: findP => [/hasPn /(_ (nth 0 l j)) /=|q ltql pre post];
         first by rewrite nthljk mem_nth // => /(_ erefl).
       have/(uniqP 0)/(_ q j): uniq l by rewrite (perm_uniq p) iota_uniq.
       apply; rewrite ?inE //.
       move: (pre 0) => /= /eqP ->.
       by rewrite (eqP nthljk).
   by rewrite -nthfindl' eqnths nth_index.
Qed.

End RankImpl.

Variable (n' : nat).
Let n := n'.+2.

Definition A := 'I_n.

Definition bids := A -> nat.
Definition vals := A -> nat.

Section RankDef.

Definition is_rank (b : bids) (rank : A -> 'I_n) (rval : 'I_n -> nat) :=
  (forall (i j : 'I_n), i <= j -> rval j <= rval i)
  /\ (forall i : 'I_n, rval (rank i) = b i).

Record ranking (b : bids):= Ranking {
    rank : A -> 'I_n;
    rval : 'I_n -> nat;
    _ : is_rank b rank rval }.

Lemma rval_def (b : bids) (r : ranking b) i : rval r (rank r i) = b i.
Proof. by case: r => ? ? [h1 h2] /=. Qed.

Lemma rval_geq (b : bids) (r : ranking b) (i j : 'I_n) : i <= j -> rval r j <= rval r i.

Proof. by case: r => ? ? [h1 h2] /h1. Qed.

Definition differ_on (b b' : bids) (i : A):= forall j, i != j -> b j = b' j.

Lemma differ_on_sym (b b' : bids) i : differ_on b b' i -> differ_on b' b i.
Proof. by move=> d j neij; move: d => /(_ j neij) ->. Qed.

Definition buildr (b : bids) : ranking b.
have tr: transitive geq by move=> i j k /= ? ?; exact: (@leq_trans i).
have rr: reflexive geq. by move=> /= ?.
have totr : total geq by move=> i j /=; exact: leq_total.
have ar : antisymmetric geq by move=> i j /=;rewrite -eqn_leq => /eqP ->.
pose tb := mktuple b.
have/Ranking //: is_rank b (zip_rank geq tb) (zip_rval geq tb).
  move: (is_rank_zip tb tr rr totr ar) => /= [rk rv].
  by split=> // => i; rewrite -(tnth_mktuple b).
Defined.

Lemma rank_stable (b b' : bids) i (h_diff : differ_on b b' i) :
  let r := buildr b in
  let r' := buildr b' in
  forall (h_notmoved : rank r i = rank r' i) j (h_idx : rank r i != j),
     rval r j = rval r' j.
Proof.
set r := buildr b; set r' := buildr b'.
move=> /= eqrr'i rj.
Admitted.

Lemma rank_shift (b b' : bids)
  (r : ranking b)
  (r' : ranking b')
  i
  (h_diff : differ_on b b' i)
  (h_rank : rank r i <= rank r' i)
  :
  forall j, rval r' j = if rank r i <= j < rank r' i then rval r (inord j.+1) else rval r j.
(*¨  (forall (j : 'I_n), (j < rank r i) || (rank r' i <= j) -> rval r j = rval r' j)
  /\ (forall (j : 'I_n),
      (rank r i <= j < rank r i) -> rval r (inord j.+1) = rval r' j). *)
Proof.
Admitted.

Definition U_SP (v : vals) (b : bids) (i : A) :=
  let r := buildr b in
  if rank r i == inord 0 then
    v i - rval r (inord 1)
  else
    0
.

Lemma SP_truthful
   (v : vals) (b b': bids) (i : A)
   (h_diff : differ_on b b' i) (h_truth : b i = v i) :
   U_SP v b i >= U_SP v b' i.
Proof.
rewrite /U_SP.
set r := buildr b.
set r' := buildr b'.
case: ifP => h_r2 => //; case: ifP => h_r1.
- have h_idx: rank r i != inord 1.
    by rewrite (eqP h_r1) -(inj_eq val_inj) /= !inordK.
  have snd_eq : rval r (inord 1) = rval r' (inord 1).
    apply: (rank_stable h_diff _ h_idx) => //.
    by rewrite (eqP h_r1) (eqP h_r2).
  by rewrite snd_eq.
- (* overbidding case *)
  have -> : rval r' (inord 1) = rval r (inord 0).
    have ltr'r: rank r' i <= rank r i by rewrite (eqP h_r2) inordK.
    rewrite (rank_shift (differ_on_sym h_diff) ltr'r) ifT ?inordK // (eqP h_r2) inordK //=.
    rewrite (contraFltn _ h_r1) // leq_eqVlt ltn0 h_r1.
    rewrite -(inj_eq val_inj) /= inordK // in h_r1.
    by rewrite h_r1.
  by rewrite -h_truth -(rval_def r) leq_subCl subn0 (@rval_geq _ _ (inord 0)) // inordK.
Qed.

End RankDef.


Require Import Relations.
Section Sequences.
 Variable A : Set.

 Variable R : A -> A -> Prop.

 Lemma not_acc : forall a b:A, R a b -> ~ Acc R a -> ~ Acc R b.
 Proof.
  intros a b H H0 H1.
  absurd (Acc R a); auto.
  generalize a H.
  elim H1; auto.
 Qed.

 Lemma acc_imp : forall a b:A, R a b -> Acc R b -> Acc R a.
 Proof.
  intros a b H H0.
  generalize a H.
  elim H0; auto.
 Qed.

 Hypothesis W : well_founded R.
 Hint Resolve W.

 Section seq_intro.
  Variable seq : nat -> A.

  Let is_in_seq (x:A) :=  exists i : nat, x = seq i.

  Lemma not_decreasing_aux : ~ (forall n:nat, R (seq (S n)) (seq n)).
  Proof.
   unfold not in |- *; intro dec.
   cut (forall a:A, is_in_seq a -> ~ Acc R a).
   intro H.
   absurd (Acc R (seq 0)).
   apply H.
   exists 0; trivial.
   apply W.
   intro a; pattern a in |- *.
   apply well_founded_ind with A R.
   assumption.
   intros x Hx H.
   elim H.
   intros i egi.
   cut (R (seq (S i)) (seq i)).
   intro H1.
   rewrite egi.
   apply not_acc with (seq (S i)); auto.
   apply Hx.
   rewrite egi; auto.
   exists (S i); auto.
   auto.
 Qed.
 End seq_intro.

 Theorem not_decreasing :
  ~ (exists seq : nat -> A, (forall i:nat, R (seq (S i)) (seq i))).
 Proof.
  unfold not in |- *; intro H.
  case H; intros s Hs.
  absurd (forall i:nat, R (s (S i)) (s i)); auto.
  apply not_decreasing_aux.
 Qed.

End Sequences.

Require Import Relation_Operators.

Inductive R0  : nat->nat-> Prop :=
r0_intro : R0 2 1.

Lemma R0_wf : well_founded  R0.
split.
intros.
inversion H.
split.
inversion 1.
Qed.

Require Import Wf_nat.

Search well_founded.
Check (lt_wf: well_founded lt).

Hypothesis Uwf : well_founded (union _ lt R0).

Fixpoint s (n:nat) : nat :=
 match n with 0 => 1
            | 1 => 2
            | S (S p) => s p
 end.

Goal False.
destruct (not_decreasing _ (union _ lt R0)).
apply Uwf.
exists s.
assert (forall i, union nat lt R0 (s (S i)) (s i) /\
                  union nat lt R0 (s (S (S i))) (s (S i))).
induction i;simpl.
split.
right;constructor.
left;auto with arith.
destruct IHi;split;auto.
firstorder.
Qed.


Require Import ZArith.
Open Scope Z_scope.
(* Types *)
Notation Int P := {v:Z|P v}.
(* Notation RefZ P  := (sig P Z). *)

Notation Nat := ({v:Z| v >= 0}).
Definition Bool {b:bool} := {v:bool | v = b}.

Notation "` x" := (proj1_sig x) (at level 10).


Require Import Relations.
Section leibniz.
 Variable A : Type.

 Definition leibniz (a b:A) : Prop := forall P:A -> Prop, P a -> P b.

 Theorem leibniz_sym : symmetric A leibniz.
 Proof.
  intros a b H Q; apply H; trivial.
 Qed.

 Theorem leibniz_refl : reflexive A leibniz.
 Proof.
  intros a P; trivial.
 Qed.

 Theorem leibniz_trans : transitive A leibniz.
 Proof.
  intros x y z Hxy Hyz; unfold leibniz; intros P H.
  apply Hyz;  apply Hxy; assumption.
 Qed.

 #[local] Hint Resolve leibniz_trans leibniz_sym leibniz_refl : core.

 Theorem leibniz_equiv : equiv A leibniz.
 Proof.
  now repeat split.
 Qed.

 Theorem leibniz_least :
  forall R:relation A, reflexive A R -> inclusion A leibniz R.
 Proof.
  intros R H x y H0; apply H0; apply H.
 Qed.

 Theorem leibniz_eq : forall a b:A, leibniz a b -> a = b.
 Proof.
  intros a b H;   now apply H.
 Qed.

 Theorem eq_leibniz : forall a b:A, a = b -> leibniz a b.
 Proof.
  intros a b e; rewrite e; unfold leibniz; auto.
 Qed.

 Theorem leibniz_ind :
  forall (x:A) (P:A -> Prop), P x -> forall y:A, leibniz x y -> P y.
 Proof.
  intros x P H y Hy; now apply Hy.
 Qed.

End leibniz.


Require Import Coq.Logic.ChoiceFacts.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.ClassicalChoice.
Require Import Coq.micromega.Psatz.
Require Import Coq.Arith.Arith.
Require Import Logic.lib.Coqlib.
Require Import Logic.lib.RelationPairs_ext.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.UpwardsClosure.
Require Import Logic.SeparationLogic.Model.DownwardsClosure.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Model.OSAGenerators.

(***********************************)
(* ALGEBRAS ON NATURALS            *)
(***********************************)

Section nat_algs.

  Definition nat_leR: Relation nat := le.
  Definition nat_geR: Relation nat := ge.

  Instance po_nat_leR: PreOrder (@Krelation _ nat_leR) := Nat.le_preorder.

  Instance po_nat_geR: PreOrder (@Krelation _ nat_geR).
  Proof.
    constructor.
    + hnf; intros; hnf; lia.
    + hnf; intros; hnf in *; lia.
  Qed.

  Definition indexAlg: @SeparationAlgebra nat equiv_Join.
  Proof. constructor; intros.
         - inversion H; congruence.
         - inversion H; inversion H0; subst.
           exists mxyz; split; constructor; auto.
  Defined.

  (* upwards-closed*)
  Instance IndexAlg_uSA:
    @UpwardsClosedSeparationAlgebra _  nat_geR equiv_Join.
  Proof.
    hnf; intros.
    inversion H; subst.
    exists n, n. repeat split; auto.
  Qed.

  (* Increasing*)
  Instance IndexAlg_increasing:
    @IncreasingSeparationAlgebra _ nat_geR equiv_Join.
  Proof.
    constructor; intro.
    hnf; intros. inversion H; subst.
    hnf; reflexivity.
  Qed.

  (* Residual*)
  Instance IndexAlg_residual:
    @ResidualSeparationAlgebra _ nat_geR equiv_Join.
  Proof.
    constructor; intro.
    exists n, n; split;
    constructor;
    reflexivity.
  Qed.

  (* Unital *)
  Instance IndexAlg_unital:
    @UnitalSeparationAlgebra _ nat_geR equiv_Join.
  Proof.
    apply <- (@incr_unital_iff_residual _ nat_geR _ equiv_Join).
    + apply IndexAlg_residual.
    + apply IndexAlg_increasing.
  Qed.

  (* Minimum Algebra *)
  Inductive min_Join: nat -> nat -> nat -> Prop:=
  | min_j x y z: z <= x -> z <= y -> min_Join x y z.

  Definition minAlg: @SeparationAlgebra nat min_Join.
  Proof.
     constructor; intros.
     - inversion H; subst; constructor; auto.
     - inversion H; inversion H0; subst.
       exists (Min.min my mz); split; constructor.
       + apply Min.le_min_l.
       + apply Min.le_min_r.
       + transitivity mxy; auto.
       + apply Min.min_glb.
         * transitivity mxy; auto.
         * auto.
  Qed.

  (* downwards closure of Index algebra *)
  Lemma min_Join_is_downwards_closure: min_Join = @DownwardsClosure_J _ nat_geR equiv_Join.
  Proof.
    extensionality a.
    extensionality b.
    extensionality c.
    unfold DownwardsClosure_J.
    apply prop_ext.
    split; intros.
    + simpl.
      inversion H; subst.
      exists c, c.
      split; [| split]; hnf; auto.
    + destruct H as [a' [b' [? [? ?]]]].
      inversion H1; subst.
      constructor; auto.
  Qed.

  (* upwards-closed *)
  Instance minAlg_uSA:
    @UpwardsClosedSeparationAlgebra _ nat_geR min_Join.
  Proof.
    hnf; intros.
    inversion H;  subst.
    exists m1, m2; split; constructor;
    first[ solve[transitivity m; auto] | reflexivity].
  Qed.

  (* downwards-closed *)
  Instance minAlg_dSA:
    @DownwardsClosedSeparationAlgebra _ nat_geR min_Join.
  Proof.
    hnf; intros.
    inversion H; subst.
    exists m; split ; constructor.
    - transitivity m1; auto.
    - transitivity m2; auto.
  Qed.

  (* Increasing *)
  Instance minAlg_increasing:
    @IncreasingSeparationAlgebra _ nat_geR min_Join.
  Proof.
    constructor; intro.
    hnf; intros. inversion H; subst; auto.
  Qed.

  (*Residual*)
  Instance minAlg_residual:
    @ResidualSeparationAlgebra _ nat_geR min_Join.
  Proof.
    constructor; intro.
    exists n, n; split.
    constructor; reflexivity.
    reflexivity.
  Qed.

  (* Unital *)
  Instance minAlg_unital:
    @UnitalSeparationAlgebra _ nat_geR min_Join.
  Proof.
    apply incr_unital_iff_residual.
    apply minAlg_increasing.
    apply minAlg_residual.
  Qed.

(** *Sum Algebra on NAT*)

  Inductive sum_Join: nat -> nat -> nat -> Prop:=
  |sum_j x y z: x + y = z -> sum_Join x y z.

  Definition sumAlg: @SeparationAlgebra _ sum_Join.
  Proof.
    constructor; intros.
    - inversion H; subst.
      rewrite Nat.add_comm;
      constructor; auto.
    - inversion H; inversion H0; subst.
      exists (my+mz); split; try constructor; simpl;
      lia.
  Qed.

  (* upwards-closed*)
  Instance sumAlg_uSA:
    @UpwardsClosedSeparationAlgebra _ nat_geR sum_Join.
  Proof.
    hnf; intros.
    simpl in H0.
    inversion H;  subst.
    destruct (le_lt_dec n m1).
    - exists n, 0; split; constructor; simpl; hnf; try lia.
    - exists m1, (n - m1); split; constructor; simpl; hnf in *; try lia.
  Qed.

  (* downwards-closed*)
  Instance sumAlg_dSA:
    @DownwardsClosedSeparationAlgebra _ nat_geR sum_Join.
  Proof.
    hnf; intros.
    simpl in H0, H1.
    inversion H; subst.
    exists (n1 + n2); split; simpl; try constructor; hnf in *; try lia.
  Qed.

  (* The only increasing is 0*)
  Lemma sumAlg_zero_decreasing:
  @increasing nat nat_geR sum_Join 0.
  Proof. hnf; intros.
       hnf.
       inversion H; subst; lia.
  Qed.

  Lemma sumAlg_zero_decreasing_only:
    forall x,
      @increasing nat nat_geR sum_Join x -> x = 0.
  Proof.
    intros.
    specialize (H 1 (x+1) ltac:(constructor; lia)).
    simpl in H. hnf in H; lia.
  Qed.

  (* Unital *)
  Instance sumAlg_unital:
    @UnitalSeparationAlgebra _ nat_geR sum_Join.
  Proof.
    constructor; intros.
    - exists 0; split.
      + exists n; split; simpl; try constructor; lia.
      + hnf; intros.
        inversion H; subst; simpl;
        hnf; lia.
  Qed.

  (*Residual*)
  Instance sumAlg_residual:
    @ResidualSeparationAlgebra _ nat_geR sum_Join.
  Proof.
    constructor; intro.
    exists 0, n; split.
    constructor; lia.
    hnf; lia.
  Qed.

(** *Minimum Algebra on Positive integers*)

  Record natPlus: Type:=
   natp { nat_p:> nat;
      is_pos: 0 < nat_p}.

  Inductive sump_Join: natPlus -> natPlus -> natPlus -> Prop:=
  |sump_j (x y z:natPlus): x + y = z -> sump_Join x y z.

  Definition lep (n m:natPlus):= n <= m.

  Lemma lep_preorder: RelationClasses.PreOrder lep.
  Proof.
    constructor;
    hnf; intros;
    try apply Nat.le_preorder.
    destruct x, y, z;
    unfold lep in *; simpl in *;
    lia.
  Qed.

  Definition natPlus_R: Relation natPlus:= lep.

  Definition po_natPlus_R: PreOrder (@Krelation _ natPlus_R) :=
    lep_preorder.

Definition sumpAlg: @SeparationAlgebra _ sump_Join.
Proof. constructor; intros.
       - inversion H; subst.
         rewrite Nat.add_comm in H0;
           constructor; auto.
       - inversion H; inversion H0; subst.
         exists (natp (my+mz)
                          ltac:(destruct my, mz; simpl in *; lia))
         ; split; try constructor; simpl;
         lia.
Qed.

(* it is NOT upwards-closed*)
Instance sumpAlg_uSA:
  @UpwardsClosedSeparationAlgebra _ natPlus_R sump_Join.
Proof.
  hnf; intros.
  simpl in H0.
  inversion H;  subst.
Abort.

(* downwards-closed*)
Instance sumpAlg_dSA:
  @DownwardsClosedSeparationAlgebra _ natPlus_R sump_Join.
Proof.
  hnf; intros.
  simpl in H0, H1.
  inversion H; subst.
  unfold lep in *.
  destruct m1, m2, m, n1, n2; simpl in *.
  exists (natp (nat_p3 + nat_p4) ltac:(simpl in *; lia));
    split; simpl; try constructor; try lia.
  reflexivity.
  unfold natPlus_R, lep in *; simpl.
  revert is_pos2 H.
  rewrite <- H2. unfold Krelation in *. simpl in *. lia.
Qed.

  (*it is NOT Residual*)
  Instance sumpAlg_residual:
    @ResidualSeparationAlgebra _ natPlus_R sump_Join.
  Proof.
    constructor; intro.
    unfold residue.
  Abort.

(** *sum Algebra inverted*)

Definition suminvAlg: @SeparationAlgebra _ sum_Join.
Proof. constructor; intros.
       - inversion H; subst.
         rewrite Nat.add_comm;
         constructor; auto.
       - inversion H; inversion H0; subst.
         exists (my+mz)
         ; split; try constructor; simpl;
         lia.
Qed.

(* upwards-closed*)
Instance suminvAlg_uSA:
  @UpwardsClosedSeparationAlgebra _ nat_leR sum_Join.
Proof.
  hnf; intros.
  simpl in H0.
  inversion H;  subst.
  destruct (le_ge_dec m1 m2).
  - exists m1, (n- m1). split; constructor; simpl; hnf in *; try lia.
  - exists (n-m2), m2. split; constructor; simpl; hnf in *; try lia.
Qed.

(* downwards-closed*)
Instance suminvAlg_dSA:
  @DownwardsClosedSeparationAlgebra _ nat_leR sum_Join.
Proof.
  hnf; intros.
  simpl in H0, H1.
  inversion H; subst.
  exists (n1 + n2); split; simpl; try constructor; hnf in *; try lia.
Qed.

  (*Residual*)
  Instance suminvAlg_increasing:
    @IncreasingSeparationAlgebra _ nat_leR sum_Join.
  Proof.
    constructor; intro.
    hnf; intros.
    inversion H; subst.
    hnf. lia.
  Qed.

  (*Residual*)
  Instance suminvAlg_residual:
    @ResidualSeparationAlgebra _ nat_leR sum_Join.
  Proof.
    constructor; intro.
    exists 0, n; split.
    constructor; lia.
    reflexivity.
  Qed.

  (* Unital *)
  Instance suminvAlg_unital:
    @UnitalSeparationAlgebra _ nat_leR sum_Join.
  Proof.
    apply incr_unital_iff_residual.
    apply suminvAlg_increasing.
    apply suminvAlg_residual.
  Qed.
End nat_algs.

(***********************************)
(* ALGEBRAS ON RATIONALS           *)
(***********************************)

Require Import Coq.QArith.QArith.
(*Require Import Coq.Reals.Rdefinitions.*)
(*Q overloads <= !*)
Require Import Ring.

(** *Minimum Algebra on Positive rationals*)
  (*
  Record QPlus: Type:=
   qp { q_p:> Q;
      qis_pos: (0 < q_p)}.

  Inductive sumqp_Join: QPlus -> QPlus -> QPlus -> Prop:=
  |sumqp_j (x y z:QPlus): (x + y) = z -> sumqp_Join x y z.

Definition leqp (n m:QPlus):= (n <= m).
Lemma leqp_preorder: RelationClasses.PreOrder leqp.
Proof.
  constructor;
  hnf; intros.
  unfold leqp.
  - apply Qle_refl.
  - eapply Qle_trans; eauto.
Qed.

Definition QPlus_kiM: KripkeIntuitionisticModel QPlus:=
    Build_KripkeIntuitionisticModel _ _ leqp_preorder.

Definition qpAlg: @SeparationAlgebra _ sumqp_Join.
Proof. constructor; intros.
       - inversion H; subst.
         destruct m1, m2, m.
         simpl in *.
         rewrite Qplus_comm in H0. ;
           constructor; auto.
       - inversion H; inversion H0; subst.
         assert (HH: 0 < (my+mz)).
         { destruct my, mz; simpl.
           replace 0 with (0+0) by reflexivity.
           apply Qplus_lt_le_compat; auto.
           apply Qlt_le_weak; auto. }

         exists (qp (my+mz) HH); split; simpl;
         constructor; simpl.
         reflexivity.
         rewrite <- H5, <-H1.
         apply Qplus_assoc.
Qed.

(* it is NOT upwards-closed*)
Instance sumqpAlg_dSA:
  @UpwardsClosedSeparationAlgebra _ sumqp_Join QPlus_kiM.
Proof.
  hnf; intros.
  simpl in H0.
  unfold leqp in H0.
  inversion H;  subst.
  rewrite <- H1 in H0.
  destruct (Qlt_le_dec (n/(1+1)) m1).
  assert (HH: 0 < n / (1 + 1)).
  { apply Qlt_shift_div_l.
    - rewrite <- (Qplus_0_l 0).
      apply Qplus_lt_le_compat.
      unfold Qlt; simpl; lia.
      unfold Qle; simpl; lia.
    - rewrite Qmult_0_l.
      destruct n; auto. }
  exists (qp (n / (1 + 1)) HH), (qp (n / (1 + 1)) HH); split.
  - constructor; simpl.

  simpl.
  - exists bindings_list
Abort.

(* downwards-closed*)
Instance sumpAlg_uSA:
  @DownwardsClosedSeparationAlgebra _ sump_Join natPlus_kiM.
Proof.
  hnf; intros.
  simpl in H0, H1.
  inversion H; subst.
  unfold lep in *.
  destruct m1, m2, m, n1, n2; simpl in *.
  exists (natp (nat_p3 + nat_p4) ltac:(simpl in *; lia));
    split; simpl; try constructor; try lia.
  reflexivity.
  unfold lep; simpl.
  rewrite <- H2; lia.
Qed.

  (*it is NOT Residual*)
  Instance sumpAlg_residual:
    @ResidualSeparationAlgebra _ natPlus_kiM sump_Join.
  Proof.
    constructor; intro.
    unfold residue.
  Abort.
*)

(***********************************)
(* Regular HEAPS                   *)
(***********************************)

Section heaps.
  Context (addr val: Type).

Definition Heap: Type := addr -> option val.

Instance Heap_Join: Join Heap :=
  @fun_Join _ _ (@option_Join _ (trivial_Join)).

Instance Heap_SA: SeparationAlgebra Heap :=
  @fun_SA _ _ _ (@option_SA _ _ (trivial_SA)).

(** * Discrete heap *)
Instance discHeap_R: Relation Heap := eq.
Instance po_discHeap_R: PreOrder Krelation := eq_preorder _.

Program Instance discHeap_ikiM: IdentityKripkeIntuitionisticModel Heap.

(*Upwards-closed*)
Instance discHeap_uSA:
  @UpwardsClosedSeparationAlgebra Heap discHeap_R Heap_Join.
Proof.
  eapply ikiM_uSA.
Qed.

(*Downwards-closed*)
Instance discHeap_dSA:
  @DownwardsClosedSeparationAlgebra Heap discHeap_R Heap_Join.
Proof.
  eapply ikiM_dSA.
Qed.

(*Empty heap is increasing element*)
Lemma discHeap_empty_increasing:
  @increasing Heap discHeap_R Heap_Join (fun _ => None).
Proof. hnf; intros.
       hnf.
       extensionality x; specialize (H  x).
       inversion H; reflexivity.
Qed.

(*Unital*)
Instance discHeap_unital:
  @UnitalSeparationAlgebra Heap discHeap_R Heap_Join.
Proof.
  constructor; intros.
  - exists (fun _ => None); split.
    + exists n; split.
      * hnf; intros.
        unfold join.
        destruct (n x); constructor.
      * hnf; intros.
        reflexivity.
    + hnf; intros.
      hnf; extensionality x.
      specialize (H x).
      inversion H; reflexivity.
Qed.

(*Residual*)
Instance discHeap_residual:
  @ResidualSeparationAlgebra Heap discHeap_R Heap_Join.
Proof. apply unital_is_residual; apply discHeap_unital. Qed.

(** * Monotonic heap*)

Instance monHeap_R: Relation Heap :=
  @pointwise_relation _ _ (@option01_relation _ eq).

Instance po_monHeap_R: PreOrder Krelation :=
  @pointwise_preorder _ _ _ (@option01_preorder _ _ (eq_preorder _)).

(* Upwards-closed*)
Instance monHeap_uSA:
  @UpwardsClosedSeparationAlgebra Heap monHeap_R Heap_Join.
Proof.
  apply fun_uSA.
  apply option_ord_uSA.
  apply (@ikiM_uSA val eq (eq_preorder _) (eq_ikiM)).
Qed.

(*Downwards-closed*)
Definition monHeap_dSA:
  @DownwardsClosedSeparationAlgebra Heap monHeap_R Heap_Join.
Proof.
  eapply fun_dSA.
  eapply option_ord_dSA.
  - apply eq_preorder.
  - apply trivial_SA.
  - apply (@ikiM_dSA val eq (eq_preorder _) (eq_ikiM)).
  - apply trivial_incrSA.
Qed.

(* Increasing *)
Instance monHeap_increasing:
  @IncreasingSeparationAlgebra Heap monHeap_R Heap_Join.
Proof.
  constructor; intros.
  hnf; intros.
  hnf; intros.
  specialize (H a).
  inversion H; constructor.
  - reflexivity.
  - inversion H3. (*subst; reflexivity.*)
Qed.

(* Residual *)
Instance monHeap_residual:
  @ResidualSeparationAlgebra Heap monHeap_R Heap_Join.
Proof.
  constructor; intros.
  exists (fun _ => None).
  hnf; intros.
  exists n; split.
  - hnf; intros x; destruct (n x); constructor.
  - reflexivity.
Qed.

(* Unital *)
Instance monHeap_unital:
  @UnitalSeparationAlgebra Heap monHeap_R Heap_Join.
Proof.
  apply incr_unital_iff_residual.
  apply monHeap_increasing.
  apply monHeap_residual.
Qed.

End heaps.

(***********************************)
(* The other nondisjoint HEAPS     *)
(***********************************)

Section heaps'.
  Context (addr val: Type).

Definition Heap': Type := addr -> option val.

Instance Heap_Join': Join Heap' :=
  @fun_Join _ _ (@option_Join _ (equiv_Join)).

Instance Heap_SA': SeparationAlgebra Heap' :=
  @fun_SA _ _ _ (@option_SA _ _ (equiv_SA)).

(** * Discrete heap *)
Instance discHeap_R': Relation Heap' :=
  eq.

Instance po_discHeap_R': PreOrder Krelation :=
  eq_preorder _.

Program Instance discHeap_ikiM': IdentityKripkeIntuitionisticModel Heap'.

(*Upwards-closed*)
Instance discHeap_uSA':
  @UpwardsClosedSeparationAlgebra Heap' discHeap_R' Heap_Join'.
Proof.
  eapply ikiM_uSA.
Qed.

(*Downwards-closed*)
Instance discHeap_dSA':
  @DownwardsClosedSeparationAlgebra Heap' discHeap_R' Heap_Join'.
Proof.
  eapply ikiM_dSA.
Qed.

(*Empty heap is increasing element*)
Lemma discHeap_empty_increasing':
  @increasing Heap' discHeap_R' Heap_Join' (fun _ => None).
Proof. hnf; intros.
       hnf.
       extensionality x; specialize (H  x).
       inversion H; reflexivity.
Qed.

(*Unital*)
Instance discHeap_unital':
  @UnitalSeparationAlgebra Heap' discHeap_R' Heap_Join'.
Proof.
  constructor; intros.
  - exists (fun _ => None); split.
    + exists n; split.
      * hnf; intros.
        unfold join.
        destruct (n x); constructor.
      * hnf; intros.
        reflexivity.
    + hnf; intros.
      hnf; extensionality x.
      specialize (H x).
      inversion H; reflexivity.
Qed.

(*Residual*)
Instance discHeap_residual':
  @ResidualSeparationAlgebra Heap' discHeap_R' Heap_Join'.
Proof. apply unital_is_residual; apply discHeap_unital'. Qed.

(** * Monotonic heap*)
Instance monHeap_R': Relation Heap' :=
  @pointwise_relation _ _ (@option01_relation _ eq).

Instance po_monHeap_R': PreOrder Krelation :=
  @pointwise_preorder _ _ _ (@option01_preorder _ _ (eq_preorder _)).

(* Upwards-closed*)
Instance monHeap_uSA':
  @UpwardsClosedSeparationAlgebra Heap' monHeap_R' Heap_Join'.
Proof.
  eapply fun_uSA.
  eapply option_ord_uSA.
  apply (@ikiM_uSA val eq (eq_preorder _) (eq_ikiM)).
Qed.

(*Downwards-closed*)
Definition monHeap_dSA':
  @DownwardsClosedSeparationAlgebra Heap' monHeap_R' Heap_Join'.
Proof.
  eapply fun_dSA.
  eapply option_ord_dSA.
  - apply eq_preorder.
  - apply equiv_SA.
  - apply (@ikiM_dSA val eq (eq_preorder _) (eq_ikiM)).
  - apply equiv_incrSA.
Qed.

(* Increasing *)
Instance monHeap_increasing':
  @IncreasingSeparationAlgebra Heap' monHeap_R' Heap_Join'.
Proof.
  constructor; intros.
  hnf; intros.
  hnf; intros.
  specialize (H a).
  inversion H; constructor.
  - reflexivity.
  - inversion H3. subst; reflexivity.
Qed.

(* Residual *)
Instance monHeap_residual':
  @ResidualSeparationAlgebra Heap' monHeap_R' Heap_Join'.
Proof.
  constructor; intros.
  exists (fun _ => None).
  hnf; intros.
  exists n; split.
  - hnf; intros x; destruct (n x); constructor.
  - reflexivity.
Qed.

(* Unital *)
Instance monHeap_unital':
  @UnitalSeparationAlgebra Heap' monHeap_R' Heap_Join'.
Proof.
  apply incr_unital_iff_residual.
  apply monHeap_increasing'.
  apply monHeap_residual'.
Qed.

End heaps'.

(***********************************)
(* TYPED HEAPS                     *)
(***********************************)

Section typed_heaps.

  Inductive htype:=
  |char
  |short1
  |short2.

  Inductive ht_ord: htype -> htype -> Prop :=
    |htype_refl x: ht_ord x x
    |htype_sht1 : ht_ord char short1
    |htype_sht2 : ht_ord char short2.

  Instance ht_preorder: PreOrder ht_ord.
  Proof.
    constructor;
    hnf; intros.
    - constructor.
    - inversion H; inversion H0; subst; subst; try solve [constructor].
  Qed.

  Notation THeap':= (nat -> option htype).
  Definition THvalid (TH:THeap'):=
     forall n, TH n = Some short1 <->
                   TH (S n) = Some short2.
  Record THeap: Type :=
    { theap:> nat -> option htype;
      th_wf1: THvalid theap}.

  Instance THeap_Join': Join THeap' :=
    @fun_Join _ _ (@option_Join _ (trivial_Join)).

  Inductive THeap_Join: Join THeap :=
  | th_join (h1 h2 h3: THeap): THeap_Join' h1 h2 h3 ->
                               THeap_Join h1 h2 h3.

Instance THeap_SA': @SeparationAlgebra _ THeap_Join':=
  @fun_SA _ _ _ (@option_SA _ _ (trivial_SA)).

Lemma THeap_Join_valid:
  forall {h1 h2 h3}, THeap_Join' h1 h2 h3 ->
              THvalid h1 ->
              THvalid h2 ->
              THvalid h3.
Proof.
  intros; intros n; assert (H' :=  H).
  specialize (H n); specialize (H' (S n));
  specialize (H0 n); specialize (H1 n);
  destruct H0 as [H0 H0']; destruct H1 as [H1 H1'].
  split; intros HH.
  - rewrite HH in H.
    inversion H; subst.
    + symmetry in H4;
      rewrite (H1 H4) in H'.
      inversion H'; try reflexivity; subst.
      inversion H7; subst; reflexivity.
    + symmetry in H3;
      rewrite (H0 H3) in H'.
      inversion H'; try reflexivity; subst.
      inversion H7; subst; reflexivity.
    + inversion H5; subst.
  - rewrite HH in H'.
    inversion H'; subst.
    + symmetry in H4;
      rewrite (H1' H4) in H.
      inversion H; try reflexivity; subst.
      inversion H7; subst; reflexivity.
    + symmetry in H3;
      rewrite (H0' H3) in H.
      inversion H; try reflexivity; subst.
      inversion H7; subst; reflexivity.
    + inversion H5; subst.
Qed.

Instance THeap_SA: @SeparationAlgebra THeap THeap_Join.
Proof.
  constructor; intros.
  - inversion H; subst.
    constructor. apply join_comm; auto.
  - inversion H; inversion H0; subst.
    pose ( join_assoc _ _  _ _ _ H1 H5) as HH.
    destruct HH as [myz' [HH1 HH2]].
    assert (forall n, myz' n = Some short1 <->
                 myz' (S n) = Some short2).
    { eapply (THeap_Join_valid HH1).
      apply my.
      apply mz. }
    exists (Build_THeap myz' H2); split; constructor; auto.
Qed.

Inductive THeap_order': THeap' -> THeap' -> Prop:=
| THeap_ord (h1 h2:THeap'):
    (forall (n:nat) (c:htype), h2 n = Some c ->
           exists (c':htype), h1 n = Some c' /\
                         ht_ord c' c) ->
THeap_order' h2 h1.

Definition THeap_order (h1 h2: THeap): Prop:=
  THeap_order' h1 h2.

Instance THeap_preorder': PreOrder THeap_order'.
constructor.
- hnf; intros.
  constructor; intros.
  exists c; split; auto; constructor.
- hnf; intros.
  inversion H;
    inversion H0; subst.
  constructor; intros.
  apply H1 in H2; destruct H2 as [c0 [HH1 HH2]].
  apply H4 in HH1; destruct HH1 as [c' [HH3 HH4]].
  exists c'; split; auto.
  transitivity c0; auto.
Qed.

Lemma THeap_preorder: PreOrder THeap_order.
constructor.
- hnf; intros.
  hnf; reflexivity.
- hnf; intros.
  hnf in H, H0.
  hnf; transitivity y; auto.
Qed.

Instance THeap_R': Relation THeap' := THeap_order'.

Instance po_THeap_R': PreOrder (@Krelation _ THeap_R').
Proof.
  eapply THeap_preorder'.
Defined.

Instance THeap_R: Relation THeap := THeap_order.

Instance po_THeap_R: PreOrder (@Krelation _ THeap_R).
Proof.
  eapply THeap_preorder.
Defined.

(*It is NOT up-closed*)
Instance THeap_uSA:
  @UpwardsClosedSeparationAlgebra THeap THeap_R THeap_Join.
Proof.
  hnf; intros.
  hnf in H0.
  exists m1.
  pose (m2':= (fun n => match m1 n with
                       Some _ => None
                     | _ => m n
                     end)).
  assert (THvalid m2').
Abort.

(* downwards-closed*)
Instance THeap_dSA':
  @DownwardsClosedSeparationAlgebra _ THeap_R' THeap_Join'.
Proof.
  hnf; intros.
  inversion H0; inversion H1; subst.
  exists (fun n => match n1 n with
           |Some x => Some x
           |_ => n2 n
           end); split.
  - hnf; intros.
    destruct (n1 x) eqn:AA.
    + destruct (n2 x) eqn:BB.
      * specialize (H2 x); specialize (H5 x).
        apply H2 in AA; destruct AA as [x' [AA1 AA2]].
        apply H5 in BB; destruct BB as [x'' [BB1 BB2]].
        specialize (H x).
        rewrite AA1, BB1 in H.
        inversion H; subst. inversion H7.
      * constructor.
    + destruct (n2 x); constructor.
  - constructor; intros.
    destruct (n1 n) eqn:n1n.
    + apply H2 in n1n; destruct n1n as [c' [HH1 HH2]].
      exists c';split.
      * specialize (H n).
        rewrite HH1 in H.
        inversion H; subst; try reflexivity.
        inversion H8.
      * inversion H3; subst; auto.
    + apply H5 in H3; destruct H3 as [c' [HH1 HH2]].
      exists c';split.
      * specialize (H n).
        rewrite HH1 in H.
        inversion H; subst; try reflexivity.
        inversion H7.
      * auto.
Qed.

Instance THeap_dSA:
  @DownwardsClosedSeparationAlgebra THeap THeap_R THeap_Join.
Proof.
  hnf; intros.
  hnf in H0, H1.
  inversion H; subst.
  destruct (THeap_dSA' _ _ _ _ _ H2 H0 H1) as [n [HH1 HH2]].
  assert (HH: THvalid n).
  { apply (THeap_Join_valid HH1);
    first [apply n1 | apply n2]. }
  exists (Build_THeap n HH); split; auto;
  constructor; auto.
Qed.

(* Increasing *)
Instance THeap_increasingSA':
  @IncreasingSeparationAlgebra _ THeap_R' THeap_Join'.
Proof.
  constructor; intros.
  hnf; intros.
  constructor; intros.
  specialize (H n0).
  rewrite H0 in H; inversion H; subst.
  - exists c; split; auto; reflexivity.
  - inversion H4.
Qed.

Instance THeap_increasingSA:
  @IncreasingSeparationAlgebra _ THeap_R THeap_Join.
Proof.
  constructor; intros.
  hnf; intros.
  simpl in *.
  eapply THeap_increasingSA'; auto.
  hnf in H; hnf ; intros.
  inversion H; subst; auto.
Qed.

(*Residual*)
Instance THeap_residualSA':
  @ResidualSeparationAlgebra _ THeap_R' THeap_Join'.
Proof.
  constructor; intros.
  exists (fun _ => None).
  hnf; intros.
  exists n; split; try reflexivity.
  hnf; intros.
  destruct (n x); constructor.
Qed.

Instance THeap_residualSA:
  @ResidualSeparationAlgebra _ THeap_R THeap_Join.
Proof.
  constructor; intros.
  assert (THvalid (fun _ => None)).
  { constructor; intros HH; inversion HH. }
  exists (Build_THeap _ H).
  exists n; split; try reflexivity.
  constructor.
  hnf; intros. destruct (n x); constructor.
Qed.

(*Unital*)
Instance THeap_UnitalSA':
  @UnitalSeparationAlgebra _ THeap_R' THeap_Join'.
Proof.
  apply incr_unital_iff_residual.
  apply THeap_increasingSA'.
  apply THeap_residualSA'.
Qed.

Instance THeap_UnitalSA:
  @UnitalSeparationAlgebra _ THeap_R THeap_Join.
Proof.
  apply incr_unital_iff_residual.
  apply THeap_increasingSA.
  apply THeap_residualSA.
Qed.

End typed_heaps.

(***********************************)
(* Step-Index                      *)
(***********************************)

Section step_index.

  Definition StepIndex_R (worlds: Type) {R: Relation worlds}:
    Relation (nat * worlds) :=
    @RelProd _ _ nat_geR R.

  Definition po_StepIndex_R (worlds: Type) {R: Relation worlds} {po_R: PreOrder (@Krelation _ R)}:
    PreOrder (@Krelation _ (StepIndex_R worlds)):=
    @RelProd_Preorder _ _ _ _ po_nat_geR po_R.

  Definition StepIndex_Join (worlds: Type) {J: Join worlds}: Join (nat * worlds) :=
    @prod_Join _ _ equiv_Join J.

  Definition StepIndex_SA
             (worlds: Type)
             {J: Join worlds}
             {SA: SeparationAlgebra worlds}:
    @SeparationAlgebra (nat * worlds)
                       (StepIndex_Join worlds) := @prod_SA _ _ _ _ equiv_SA SA.

  Definition StepIndex_uSA (worlds: Type) {R: Relation worlds}
             {J: Join worlds} {uSA: UpwardsClosedSeparationAlgebra worlds}:
    @UpwardsClosedSeparationAlgebra (nat * worlds) (StepIndex_R worlds) (StepIndex_Join worlds) :=
    @prod_uSA _ _ _ _  _ _ (@identity_uSA _ nat_geR) uSA.

  Definition StepIndex_Increasing
             (worlds: Type) {R: Relation worlds}
             {J: Join worlds} {incrSA: IncreasingSeparationAlgebra worlds}:
    @IncreasingSeparationAlgebra (nat * worlds)
                                  (StepIndex_R worlds)
                                  (StepIndex_Join worlds) :=
    @prod_incrSA _ _ _ _ _ _ IndexAlg_increasing incrSA.

  Definition StepIndex_Unital
             (worlds: Type) {R: Relation worlds}
             {J: Join worlds} {USA: UnitalSeparationAlgebra worlds}:
    @UnitalSeparationAlgebra (nat * worlds)
                                  (StepIndex_R worlds)
                                  (StepIndex_Join worlds) :=
    @prod_unitalSA _ _ _  _ _ _ IndexAlg_unital USA.

  Definition StepIndex_Residual
             (worlds: Type) {R: Relation worlds}
             {J: Join worlds} {rSA: ResidualSeparationAlgebra worlds}:
    @ResidualSeparationAlgebra (nat * worlds)
                                  (StepIndex_R worlds)
                                  (StepIndex_Join worlds) :=
    @prod_residualSA _ _ _  _ _ _ IndexAlg_residual rSA.

  (** *step-indexed HEAPS*)
  Context (addr val: Type).
  Notation heap:= (Heap addr val).

  Instance heap_jn: Join heap:= (Heap_Join addr val).

  Instance SIheap_Join: Join (nat * heap) := StepIndex_Join heap.

  (** *Monotonic, step-indexed heap *)
  Definition monSIheap_R := @StepIndex_R heap (monHeap_R addr val).

  Definition po_monSIheap_R := @po_StepIndex_R heap _ (po_monHeap_R addr val).

  (*Upwards-closed *)
  Instance monSIheap_uSA:
    @UpwardsClosedSeparationAlgebra _ monSIheap_R SIheap_Join.
  Proof.
    eapply StepIndex_uSA.
    apply monHeap_uSA.
  Qed.

  (* NOT Downwards-closed *)

  (* Increasing *)
  Instance monSIheap_increasing:
    @IncreasingSeparationAlgebra _ monSIheap_R SIheap_Join.
  Proof.
    eapply StepIndex_Increasing.
    apply monHeap_increasing.
  Qed.

  (*Unital *)
  Instance monSIheap_unital:
    @UnitalSeparationAlgebra _ monSIheap_R SIheap_Join.
  Proof.
    eapply StepIndex_Unital.
    apply monHeap_unital.
  Qed.

  (*Residual *)
  Instance monSIheap_residual:
    @ResidualSeparationAlgebra _ monSIheap_R SIheap_Join.
  Proof.
    eapply StepIndex_Residual.
    apply monHeap_residual.
  Qed.

  (** *Discrete, step-indexed heap *)
  Definition discSIheap_R:= @StepIndex_R heap (discHeap_R addr val).
  Definition po_discSIheap_R:= @po_StepIndex_R heap _ (po_discHeap_R addr val).

  (*Upwards-closed *)
  Instance discSIheap_uSA:
    @UpwardsClosedSeparationAlgebra _ discSIheap_R SIheap_Join.
  Proof.
    eapply StepIndex_uSA.
    apply discHeap_uSA.
  Qed.

  (* NOT Downwards-closed *)

  (* NOT Decreasing *)

  (*Unital *)
  Instance discSIheap_unital:
    @UnitalSeparationAlgebra _ discSIheap_R SIheap_Join.
  Proof.
    eapply StepIndex_Unital.
    apply discHeap_unital.
  Qed.

  (*Residual *)
  Instance discSIheap_residual:
    @ResidualSeparationAlgebra _ discSIheap_R SIheap_Join.
  Proof.
    eapply StepIndex_Residual.
    apply discHeap_residual.
  Qed.

End step_index.

(***********************************)
(* ALGEBRAS ON NATURALS            *)
(***********************************)

Section Prop_alg.

Instance Prop_Join: Join Prop := fun P Q R => (P \/ Q <-> R) /\ (P -> Q -> False).

Instance discProp_R: Relation Prop := fun P Q => P <-> Q.

Instance Prop_SA: SeparationAlgebra Prop.
Proof.
  constructor.
  + intros.
    hnf in *; tauto.
  + intros.
    exists (my \/ mz).
    split; hnf in *; tauto.
Qed.

Instance po_discProp_R: PreOrder Krelation.
Proof.
  constructor; constructor;
  hnf in *; tauto.
Qed.

Instance discProp_ikiM: IdentityKripkeIntuitionisticModel Prop.
Proof.
  constructor.
  intros.
  apply prop_ext; auto.
Qed.

Instance discProp_uSA:
  @UpwardsClosedSeparationAlgebra Prop discProp_R Prop_Join.
Proof.
  eapply ikiM_uSA.
Qed.

Instance discProp_dSA:
  @DownwardsClosedSeparationAlgebra Prop discProp_R Prop_Join.
Proof.
  eapply ikiM_dSA.
Qed.

Instance discProp_unitSA:
  @UnitalSeparationAlgebra Prop discProp_R Prop_Join.
Proof.
  constructor.
  intros.
  exists False.
  split.
  + hnf.
    exists n; split; hnf; tauto.
  + hnf.
    intros.
    hnf in *; tauto.
Qed.

End Prop_alg.

Section pred_alg.

Context (A : Type).

Definition Pred: Type := A -> Prop.

Instance Pred_Join: Join Pred :=
  @fun_Join _ _ Prop_Join.

Instance Pred_SA: SeparationAlgebra Pred :=
  @fun_SA _ _ _ Prop_SA.

Instance discPred_R: Relation Pred := pointwise_relation _ discProp_R.
Instance po_discPred_R: PreOrder Krelation := pointwise_preorder _ _ po_discProp_R.

Instance discPred_uSA: @UpwardsClosedSeparationAlgebra Pred discPred_R Pred_Join :=
  fun_uSA _ _ discProp_uSA.

Instance discPred_dSA: @DownwardsClosedSeparationAlgebra Pred discPred_R Pred_Join :=
  fun_dSA _ _ discProp_dSA.

Instance discPred_unital: @UnitalSeparationAlgebra Pred discPred_R Pred_Join :=
  fun_unitSA _ _ discProp_unitSA.

End pred_alg.

(***********************************)
(* Resource Bounds                 *)
(***********************************)

(*
(** * Discrete heap *)
Instance discHeap_kiM: KripkeIntuitionisticModel Heap :=
  identity_kiM.

Program Instance discHeap_ikiM: IdentityKripkeIntuitionisticModel Heap.

(*Upwards-closed*)
Instance discHeap_dSA:
  @UpwardsClosedSeparationAlgebra Heap Heap_Join discHeap_kiM.
Proof.
  eapply ikiM_dSA.
Qed.

(*Downwards-closed*)
Instance discHeap_uSA:
  @DownwardsClosedSeparationAlgebra Heap Heap_Join discHeap_kiM.
Proof.
  eapply ikiM_uSA.
Qed.

(*Empty heap is decreasing element*)
Lemma discHeap_empty_decreasing:
  @nonpositive Heap discHeap_kiM Heap_Join (fun _ => None).
Proof. hnf; intros.
       hnf.
       extensionality x; specialize (H  x).
       inversion H; reflexivity.
Qed.

(*Unital*)
Instance discHeap_unital:
  @UnitalSeparationAlgebra Heap discHeap_kiM Heap_Join.
Proof.
  constructor; intros.
  - exists (fun _ => None); split.
    + exists n; split.
      * hnf; intros.
        unfold join.
        destruct (n x); constructor.
      * hnf; intros.
        reflexivity.
    + hnf; intros.
      hnf; extensionality x.
      specialize (H x).
      inversion H; reflexivity.
  - hnf; intros.
    inversion H; subst.
    apply H0 in H1.
    inversion H1.
    reflexivity.
Qed.

Class SeparationAlgebra_unit (worlds: Type) {J: Join worlds} := {
  unit: worlds;
  unit_join: forall n, join n unit n;
  unit_spec: forall n m, join n unit m -> n = m
}.

(***********************************)
(* More examples                   *)
(***********************************)
(*
Program Definition nat_le_kiM: KripkeIntuitionisticModel nat :=
  Build_KripkeIntuitionisticModel nat (fun a b => a <= b) _.
Next Obligation.
  constructor; hnf; intros.
  + apply le_n.
  + eapply NPeano.Nat.le_trans; eauto.
Qed.

(* TODO: Probably don't need this one. *)
Program Definition SAu_kiM (worlds: Type) {J: Join worlds} {SA: SeparationAlgebra worlds} {SAu: SeparationAlgebra_unit worlds} : KripkeIntuitionisticModel worlds :=
  Build_KripkeIntuitionisticModel worlds (fun a b => exists b', join b b' a) _.
Next Obligation.
  constructor; hnf; intros.
  + exists unit; apply unit_join.
  + destruct H as [? ?], H0 as [? ?].
    destruct (join_assoc _ _ _ _ _ H0 H) as [? [? ?]].
    exists x2; auto.
Qed.

Definition Stack (LV val: Type): Type := LV -> val.

Definition StepIndex_kiM (worlds: Type) {kiM: KripkeIntuitionisticModel worlds}: KripkeIntuitionisticModel (nat * worlds) := @prod_kiM _ _ nat_le_kiM kiM.

Definition StepIndex_Join (worlds: Type) {J: Join worlds}: Join (nat * worlds) :=
  @prod_Join _ _ (equiv_Join _) J.

Definition StepIndex_SA (worlds: Type) {J: Join worlds} {SA: SeparationAlgebra worlds}:
  @SeparationAlgebra (nat * worlds) (StepIndex_Join worlds) := @prod_SA _ _ _ _ (equiv_SA _) SA.

Definition StepIndex_dSA (worlds: Type) {kiM: KripkeIntuitionisticModel worlds}
           {J: Join worlds} {dSA: UpwardsClosedSeparationAlgebra worlds}:
  @UpwardsClosedSeparationAlgebra (nat * worlds) (StepIndex_Join worlds) (StepIndex_kiM worlds):= @prod_dSA _ _ _ _ _ _ (@identity_dSA _ nat_le_kiM) dSA.

*)*)


Require Import Classical.

Parameter S: Set.
Parameter c d: S.

(*Praedikate*)
Parameter D P Q: S -> Prop.
Parameter L: S -> S -> Prop.

Axiom A1: forall x, D x -> exists y, P y /\ L y x.
Axiom A2: forall x, P x -> forall y, Q y -> ~L x y.

Theorem T: forall x, D x -> ~Q x.
Proof.
  intro c.
  intro.
  intro.

  pose proof A1 as A1.
  pose proof A2 as A2.

  assert (exists y, P y /\ L y c).
  apply A1.
  assumption.

  destruct H1 as [d H1].
  destruct H1 as [H1 H2].

  assert (~L d c).
  apply A2.
  assumption.
  assumption.

  contradiction.
Qed.


Require Import XR_Rsqr.
Require Import XR_Rsqr_neg.
Require Import XR_Rsqr_plus.
Require Import XR_R2.
Require Import XR_Rminus.
Require Import XR_Ropp_mult_distr_r.

Local Open Scope R_scope.

Lemma Rsqr_minus : forall x y:R, Rsqr (x - y) = Rsqr x + Rsqr y - R2 * x * y.
Proof.
  intros x y.
  unfold Rminus.
  rewrite Rsqr_plus.
  rewrite <- Rsqr_neg.
  rewrite <- Ropp_mult_distr_r.
  reflexivity.
Qed.