(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli & Mark Bickford

*)

Require Export cequiv.
Require Export terms3.

Lemma canonical_dec_pair {p} :
  forall x : @CanonicalOp p, {x = NPair} + {x <> NPair}.
Proof.
  introv.
  destruct x;
  try (left; auto; fail);
  try (right; sp; inversion H; fail).
Qed.

Lemma nt_wf_NPair_iff {o} :
  forall (bs : list (@BTerm o)),
    nt_wf (oterm (Can NPair) bs)
    <=> {a : NTerm & {b : NTerm & bs = [nobnd a, nobnd b] # nt_wf a # nt_wf b }}.
Proof.
  introv; split; intro h; exrepnd; subst.
  - inversion h as [|?|? ? imp e]; clear h; subst; allsimpl.
    repeat (destruct bs; allsimpl; tcsp).
    destruct b as [l1 t1].
    destruct b0 as [l2 t2].
    allunfold @num_bvars; allsimpl.
    destruct l1; allsimpl; ginv.
    destruct l2; allsimpl; ginv.
    pose proof (imp (bterm [] t1)) as h1; autodimp h1 hyp.
    pose proof (imp (bterm [] t2)) as h2; autodimp h2 hyp.
    allrw @bt_wf_iff.
    unfold nobnd.
    eexists; eexists; dands; eauto.
  - constructor; unfold num_bvars; simpl; auto.
    introv i; repndors; subst; tcsp; allrw @bt_wf_iff; auto.
Qed.

Lemma ispair_cases {p} :
  forall lib (t : @NTerm p),
    hasvalue lib t
    -> {a, b : NTerm $ computes_to_value lib t (mk_pair a b)}
       [+] (forall a b, reduces_to lib (mk_ispair t a b) b).
Proof.
  introv hv.
  destruct hv as [ t' c ].
  destruct c as [ red iv ].
  inversion iv as [? isp isc]; subst.
  apply iscan_implies in isc; repndors; exrepnd; subst.

  { destruct (canonical_dec_pair c); subst.

    - left.
      inversion isp as [cl wf]; allsimpl; clear isp.
      allrw @nt_wf_NPair_iff; exrepnd; subst.
      exists a b; constructor; auto.

    - right; introv.
      eapply reduces_to_trans;[apply reduces_to_prinarg;eauto|].
      apply reduces_to_if_step.
      destruct c; try (complete (simpl; sp)).
  }

  { right; introv.
    eapply reduces_to_trans;[apply reduces_to_prinarg;eauto|].
    apply reduces_to_if_step.
    csunf; simpl; auto. }
Qed.

Lemma ispair_cases_c {p} :
  forall lib (t : @CTerm p),
    hasvaluec lib t
    -> {a, b : CTerm $ computes_to_valc lib t (mkc_pair a b)}
       [+] (forall a b, reduces_toc lib (mkc_ispair t a b) b).
Proof.
  introv hv.
  destruct_cterms.
  unfold hasvaluec in hv.
  unfold computes_to_valc, reduces_toc.
  allsimpl.
  apply ispair_cases in hv; repdors; exrepnd.

  left.
  applydup @preserve_program in hv0; try (complete (allrw @isprogram_eq; sp)).
  rw <- @isprogram_pair_iff in hv1; repnd; allrw @isprogram_eq.
  exists (mk_ct a hv2) (mk_ct b hv1); simpl; sp.

  right.
  introv; destruct_cterms; simpl.
  apply hv.
Qed.

Lemma canonical_dec_inl {p} :
  forall x : @CanonicalOp p, {x = NInj NInl} + {x <> NInj NInl}.
Proof.
  introv.
  destruct x;
  try (left; auto; fail);
  try (right; sp; inversion H; fail).
  destruct c;
  try (left; auto; fail);
  try (right; sp; inversion H; fail).
Qed.

Lemma isinl_cases {p} :
  forall lib (t : @NTerm p),
    hasvalue lib t
    -> {a : NTerm $ computes_to_value lib t (mk_inl a)}
       [+] (forall a b, reduces_to lib (mk_isinl t a b) b).
Proof.
  introv hv.
  destruct hv as [ t' c ].
  destruct c as [ red iv ].
  dup iv as iv'.
  rw @isvalue_iff in iv'; repnd.
  apply iscan_implies in iv'0; repndors; exrepnd; subst.

  - destruct (canonical_dec_inl c).

    + left.
      subst.
      destruct iv' as [ cl wf ].
      inverts wf as bw eq.
      simpl in eq.
      repeat (destruct bterms; allsimpl; sp).
      apply cons_inj in eq; destruct eq as [ l1 eq ].
      clear eq.
      allunfold @num_bvars.
      destruct b; allsimpl.
      exists n.
      allrw length0; subst.
      constructor; sp.

    + right; introv.
      eapply reduces_to_trans;
        [apply reduces_to_prinarg;eauto|].
      apply reduces_to_if_step; csunf; simpl; auto.
      repeat (destruct c; try (complete (simpl; sp))).

  - right; introv.
    eapply reduces_to_trans;
      [apply reduces_to_prinarg;eauto|].
    apply reduces_to_if_step; csunf; simpl; auto.
Qed.

Lemma isinl_cases_c {p} :
  forall lib (t : @CTerm p),
    hasvaluec lib t
    -> {a : CTerm $ computes_to_valc lib t (mkc_inl a)}
       [+] (forall a b, reduces_toc lib (mkc_isinl t a b) b).
Proof.
  introv hv.
  destruct_cterms.
  unfold hasvaluec in hv.
  unfold computes_to_valc, reduces_toc.
  allsimpl.
  apply isinl_cases in hv; repdors; exrepnd.

  left.
  applydup @preserve_program in hv1; try (complete (allrw @isprogram_eq; sp)).
  rw <- @isprogram_inl_iff in hv0; repnd; allrw @isprogram_eq.
  exists (mk_ct a hv0). simpl; sp.
  right.
  introv; destruct_cterms; simpl.
  apply hv.
Qed.

Lemma canonical_dec_inr {p} :
  forall x : @CanonicalOp p, {x = NInj NInr} + {x <> NInj NInr}.
Proof.
  introv.
  destruct x;
  try (left; auto; fail);
  try (right; sp; inversion H; fail).
  destruct c;
  try (left; auto; fail);
  try (right; sp; inversion H; fail).
Qed.

Lemma isinr_cases {p} :
  forall lib (t : @NTerm p),
    hasvalue lib t
    -> {a : NTerm $ computes_to_value lib t (mk_inr a)}
       [+] (forall a b, reduces_to lib (mk_isinr t a b) b).
Proof.
  introv hv.
  destruct hv as [ t' c ].
  destruct c as [ red iv ].
  dup iv as iv'.
  rw @isvalue_iff in iv'; repnd.
  apply iscan_implies in iv'0; repndors; exrepnd; subst.

  - destruct (canonical_dec_inr c).

    + left.
      subst.
      destruct iv' as [ cl wf ].
      inverts wf as bw eq.
      simpl in eq.
      repeat (destruct bterms; allsimpl; sp).
      apply cons_inj in eq; destruct eq as [ l1 eq ].
      clear eq.
      allunfold @num_bvars.
      destruct b; allsimpl.
      exists n.
      allrw length0; subst.
      constructor; sp.

    + right; introv.
      eapply reduces_to_trans;
        [apply reduces_to_prinarg;eauto|].
      apply reduces_to_if_step; csunf; simpl; auto.
      repeat (destruct c; try (complete (simpl; sp))).

  - right; introv.
    eapply reduces_to_trans;
      [apply reduces_to_prinarg;eauto|].
    apply reduces_to_if_step; csunf; simpl; auto.
Qed.

Lemma isinr_cases_c {p} :
  forall lib (t : @CTerm p),
    hasvaluec lib t
    -> {a : CTerm $ computes_to_valc lib t (mkc_inr a)}
       [+] (forall a b, reduces_toc lib (mkc_isinr t a b) b).
Proof.
  introv hv.
  destruct_cterms.
  unfold hasvaluec in hv.
  unfold computes_to_valc, reduces_toc.
  allsimpl.
  apply isinr_cases in hv; repdors; exrepnd.

  left.
  applydup @preserve_program in hv1; try (complete (allrw @isprogram_eq; sp)).
  rw <- @isprogram_inr_iff in hv0; repnd; allrw @isprogram_eq.
  exists (mk_ct a hv0). simpl; sp.
  right.
  introv; destruct_cterms; simpl.
  apply hv.
Qed.

Lemma canonical_dec_lambda {p} :
  forall x : @CanonicalOp p, {x = NLambda} + {x <> NLambda}.
Proof.
  introv.
  destruct x;
  try (left; auto; fail);
  try (right; sp; inversion H; fail).
Qed.

Lemma islambda_cases {p} :
  forall lib (t : @NTerm p),
    hasvalue lib t
    -> {v : NVar $ {a : NTerm $ computes_to_value lib t (mk_lam v a)}}
       [+] (forall a b, reduces_to lib (mk_islambda t a b) b).
Proof.
  introv hv.
  destruct hv as [ t' c ].
  destruct c as [ red iv ].
  dup iv as iv'.
  rw @isvalue_iff in iv'; repnd.
  apply iscan_implies in iv'0; repndors; exrepnd; subst.

  - destruct (canonical_dec_lambda c).

    + left.
      subst.
      destruct iv' as [ cl wf ].
      inverts wf as bw eq.
      simpl in eq.
      repeat (destruct bterms; allsimpl; sp).
      destruct b as [l b]; allsimpl.
      allunfold @num_bvars; allsimpl.
      repeat (destruct l; allsimpl; ginv).
      exists n b.
      constructor; sp.

    + right; introv.
      eapply reduces_to_trans;
        [apply reduces_to_prinarg;eauto|].
      apply reduces_to_if_step; csunf; simpl; auto.
      destruct c; try (complete (simpl; sp)).

  - right; introv.
    eapply reduces_to_trans;
      [apply reduces_to_prinarg;eauto|].
    apply reduces_to_if_step; csunf; simpl; auto.
Qed.

(* Need islambda_cases_c ?? But first need  (mkc_lambda v a)  and what is it?
   a  covered by [v] ?
*)

Lemma canonical_dec_axiom {p} :
  forall x : @CanonicalOp p, {x = NAxiom} + {x <> NAxiom}.
Proof.
  introv.
  destruct x;
  try (left; auto; fail);
  try (right; sp; inversion H; fail).
Qed.

Lemma isaxiom_cases {p} :
  forall lib (t : @NTerm p),
    hasvalue lib t
    -> computes_to_value lib t mk_axiom
       [+] (forall a b, reduces_to lib (mk_isaxiom t a b) b).
Proof.
  introv hv.
  destruct hv as [ t' c ].
  destruct c as [ red iv ].
  dup iv as iv'.
  rw @isvalue_iff in iv'; repnd.
  apply iscan_implies in iv'0; repndors; exrepnd; subst.

  - destruct (canonical_dec_axiom c).

    + left.
      subst.
      destruct iv' as [ cl wf ].
      inverts wf as bw eq.
      simpl in eq.
      repeat (destruct bterms; allsimpl; sp); GC; fold_terms.
      constructor; sp.

    + right; introv.
      eapply reduces_to_trans;
        [apply reduces_to_prinarg;eauto|].
      apply reduces_to_if_step; csunf; simpl; auto.
      destruct c; try (complete (simpl; sp)).

  - right; introv.
    eapply reduces_to_trans;
      [apply reduces_to_prinarg;eauto|].
    apply reduces_to_if_step; csunf; simpl; auto.
Qed.

Lemma isaxiom_cases_c {p} :
  forall lib (t : @CTerm p),
    hasvaluec lib t
    -> computes_to_valc lib t mkc_axiom
       [+] (forall a b, reduces_toc lib (mkc_isaxiom t a b) b).
Proof.
  introv hv.
  destruct_cterms.
  unfold hasvaluec in hv.
  unfold computes_to_valc, reduces_toc.
  allsimpl.
  apply isaxiom_cases in hv; repdors; exrepnd; auto.
  right.
  introv; destruct_cterms; simpl.
  apply hv.
Qed.

Lemma reduces_to_pi1_pair {p} :
  forall lib (a b : @NTerm p), reduces_to lib (mk_pi1 (mk_pair a b)) a.
Proof.
  introv.
  apply reduces_to_if_step.
  simpl.
  unfold apply_bterm; simpl.
  change_to_lsubst_aux4; simpl; auto.
Qed.
Hint Immediate reduces_to_pi1_pair.

Lemma reduces_to_pi2_pair {p} :
  forall lib (a b : @NTerm p), reduces_to lib (mk_pi2 (mk_pair a b)) b.
Proof.
  introv.
  apply reduces_to_if_step.
  simpl.
  unfold apply_bterm; simpl.
  change_to_lsubst_aux4; simpl; auto.
Qed.
Hint Immediate reduces_to_pi2_pair.

Lemma cequiv_pi1_pair {p} :
  forall lib (a b : @NTerm p),
    isprogram a
    -> isprogram b
    -> cequiv lib (mk_pi1 (mk_pair a b)) a.
Proof.
  introv ipa ipb.
  apply reduces_to_implies_cequiv; sp.
  rw @isprogram_pi1.
  apply isprogram_pair; sp.
Qed.

Lemma cequiv_pi2_pair {p} :
  forall lib (a b : @NTerm p),
    isprogram a
    -> isprogram b
    -> cequiv lib (mk_pi2 (mk_pair a b)) b.
Proof.
  introv ipa ipb.
  apply reduces_to_implies_cequiv.
  - rw @isprogram_pi2;
  apply isprogram_pair; sp.
  - auto.
Qed.

Lemma reduces_to_outl_inl {p} :
  forall lib (a : @NTerm p), reduces_to lib (mk_outl (mk_inl a)) a.
Proof.
  introv.
  apply reduces_to_if_step.
  simpl.
  unfold apply_bterm; simpl.
  change_to_lsubst_aux4; simpl; auto.
Qed.
Hint Immediate reduces_to_outl_inl.

Lemma reduces_to_outr_inr {p} :
  forall lib (a : @NTerm p), reduces_to lib (mk_outr (mk_inr a)) a.
Proof.
  introv.
  apply reduces_to_if_step.
  simpl.
  unfold apply_bterm; simpl.
  change_to_lsubst_aux4; simpl; auto.
Qed.
Hint Immediate reduces_to_outr_inr.

Lemma cequiv_outl_inl {p} :
  forall lib (a : @NTerm p),
    isprogram a
    -> cequiv lib (mk_outl (mk_inl a)) a.
Proof.
  introv ipa.
  apply reduces_to_implies_cequiv; sp.
  rw @isprogram_outl.
  apply isprogram_inl; sp.
Qed.

Lemma cequiv_outr_inr {p} :
  forall lib (a : @NTerm p),
    isprogram a
    -> cequiv lib (mk_outr (mk_inr a)) a.
Proof.
  introv ipa .
  apply reduces_to_implies_cequiv; sp.
  rw @isprogram_outr.
  apply isprogram_inr; sp.
Qed.

(* !! MOVE *)
Lemma resp_cequiv {p} : forall lib, respects2 (cequiv lib) (@cequiv p lib).
Proof.
   split; introv; intros; eauto with slow.
Qed.
Hint Resolve resp_cequiv : respects.

Lemma cequiv_pair {p} :
  forall lib (a b c d : @NTerm p),
    cequiv lib a c
    -> cequiv lib b d
    -> cequiv lib (mk_pair a b) (mk_pair c d).
Proof.
  introv c1 c2.
  applydup @cequiv_isprogram in c1.
  applydup @cequiv_isprogram in c2.
  repnd.
  unfold mk_pair, nobnd.
  repeat prove_cequiv; auto.
Qed.

Hint Resolve alpha_implies_cequiv_open : slow.

Lemma computes_to_pair_eta {p} :
  forall lib (t a b : @NTerm p),
    isprogram t
    -> computes_to_value lib t (mk_pair a b)
    -> cequiv lib t (mk_eta_pair t).
Proof.
  introv isp c.
  apply computes_to_value_implies_cequiv in c; auto.
  applydup @cequiv_isprogram in c; repnd.
  allrw <- @isprogram_pair_iff; repnd; GC.
  apply @cequiv_trans with (b := mk_pair a b); auto.
  unfold mk_eta_pair.
  apply cequiv_pair.
  - assert (cequiv lib (mk_pi1 t) (mk_pi1 (mk_pair a b))) as ceq1.
    unfold mk_pi1, mk_spread, nobnd.
    repeat prove_cequiv; auto;
    try (complete (constructor; sp));
    try (complete (rw <- isprogram_pair_iff; sp)).
    apply alphabt_blift; simpl; dands; (introns XX); allsimpl; exrepnd;
    eauto 2 with slow.

    apply @cequiv_trans with (b := mk_pi1 (mk_pair a b)); auto with slow.
    apply cequiv_sym.
    apply cequiv_pi1_pair; auto.

  - assert (cequiv lib (mk_pi2 t) (mk_pi2 (mk_pair a b))) as ceq1.
    unfold mk_pi2, mk_spread, nobnd.
    repeat prove_cequiv; auto;
    try (complete (constructor; sp));
    try (complete (rw <- isprogram_pair_iff; sp)).
    apply alphabt_blift; simpl; dands; (introns XX); allsimpl; exrepnd;
    eauto 2 with slow.
    apply @cequiv_trans with (b := mk_pi2 (mk_pair a b)); auto with slow.
    apply cequiv_sym.
    apply cequiv_pi2_pair; auto.
Qed.

Lemma computes_to_pair_eta_c {p} :
  forall lib (t a b : @CTerm p),
    computes_to_valc lib t (mkc_pair a b)
    -> cequivc lib t (mkc_eta_pair t).
Proof.
  introv c.
  destruct_cterms.
  unfold computes_to_valc in c.
  unfold cequivc.
  allsimpl.
  apply computes_to_pair_eta with (a := x0) (b := x); auto.
  rw @isprogram_eq; auto.
Qed.

Lemma cequiv_eta_pair {p} :
  forall lib (a b : @NTerm p),
    cequiv lib a b
    -> cequiv lib (mk_eta_pair a) (mk_eta_pair b).
Proof.
  introv c.
  applydup @cequiv_isprogram in c; repnd.
  unfold mk_eta_pair, mk_pair, mk_pi1, mk_pi2, mk_spread, nobnd.
  repeat prove_cequiv; auto;
  try (complete (constructor; sp));
    apply alphabt_blift; simpl; dands; (introns XX); allsimpl; exrepnd;
    eauto 2 with slow.
Qed.

Lemma cequivc_eta_pair {p} :
  forall lib (a b : @CTerm p),
    cequivc lib a b
    -> cequivc lib (mkc_eta_pair a) (mkc_eta_pair b).
Proof.
  introv c.
  destruct_cterms.
  allunfold @cequivc; allsimpl.
  apply cequiv_eta_pair; sp.
Qed.

Lemma cequivc_eta_pair_replace {p} :
  forall lib (t u : @CTerm p),
    cequivc lib t u
    -> cequivc lib t (mkc_eta_pair t)
    -> cequivc lib u (mkc_eta_pair u).
Proof.
  introv c1 c2.
  apply cequivc_trans with (b := t); auto.
  apply cequivc_sym; auto.
  apply cequivc_trans with (b := mkc_eta_pair t); auto.
  apply cequivc_eta_pair; sp.
Qed.

Lemma cequiv_inl {p} :
  forall lib (a b : @NTerm p),
    cequiv lib a b
    -> cequiv lib (mk_inl a) (mk_inl b).
Proof.
  introv c1.
  applydup @cequiv_isprogram in c1.
  repnd.
  unfold mk_inl, nobnd.
  repeat prove_cequiv; auto.
Qed.

Lemma cequiv_inr {p} :
  forall lib (a b : @NTerm p),
    cequiv lib a b
    -> cequiv lib (mk_inr a) (mk_inr b).
Proof.
  introv c1.
  applydup @cequiv_isprogram in c1.
  repnd.
  unfold mk_inr, nobnd.
  repeat prove_cequiv; auto.
Qed.

Lemma computes_to_inl_eta {p} :
  forall lib (t a : @NTerm p),
    isprogram t
    -> computes_to_value lib t (mk_inl a)
    -> cequiv lib t (mk_eta_inl t).
Proof.
  introv isp c.
  apply computes_to_value_implies_cequiv in c; auto.
  applydup @cequiv_isprogram in c; repnd.
  allrw <- @isprogram_inl_iff; repnd; GC.
  apply @cequiv_trans with (b := mk_inl a); auto.
  unfold mk_eta_inl.
  apply cequiv_inl.
  assert (isprogram (@mk_bot p)) as ispbot.
      eauto 3 with slow.
  assert (isprogram_bt (bterm [nvary] (@mk_bot p))).
     destruct ispbot. constructor. constructor. constructor. auto.
  assert (blift (cequiv_open lib) (bterm [nvary] mk_bot) (bterm [nvary] mk_bot)).
   exists [nvary] (@mk_bot p) (@mk_bot p); sp; apply cequiv_open_refl. destruct ispbot. auto.

  - assert (cequiv lib (mk_outl t) (mk_outl (mk_inl a))) as ceq1.
    { unfold mk_outl, mk_decide, nobnd.
    repeat prove_cequiv; auto;
    try (complete (constructor; sp));
    try (complete (rw <- isprogram_inl_iff; sp)).
    apply alphabt_blift; simpl; dands; (introns XX); allsimpl; exrepnd;
    eauto 3 with slow. }
    {apply @cequiv_trans with (b := mk_outl (mk_inl a)); auto with slow.
    apply cequiv_sym.
    apply cequiv_outl_inl; auto. }
Qed.

Lemma computes_to_inl_eta_c {p} :
  forall lib (t a : @CTerm p),
    computes_to_valc lib t (mkc_inl a)
    -> cequivc lib t (mkc_eta_inl t).
Proof.
  introv c.
  destruct_cterms.
  unfold computes_to_valc in c.
  unfold cequivc.
  allsimpl.
  apply computes_to_inl_eta with (a := x) ; auto.
  rw @isprogram_eq; auto.
Qed.

Hint Resolve cequiv_open_refl : slow.

Lemma cequiv_eta_inl {p} :
  forall lib (a b : @NTerm p),
    cequiv lib a b
    -> cequiv lib (mk_eta_inl a) (mk_eta_inl b).
Proof.
  introv c.
  applydup @cequiv_isprogram in c; repnd.

  assert (isprogram (@mk_bot p)) as ispbot.
  { eauto 3 with slow. }
  assert (isprogram_bt (bterm [nvary] (@mk_bot p))).
  { destruct ispbot. constructor. constructor. constructor. auto. }

  assert (isprogram (mk_decide a nvarx (vterm nvarx) nvary mk_bot)).
   { apply isprogram_decide; auto. destruct ispbot. auto. }
  assert (isprogram (mk_decide b nvarx (vterm nvarx) nvary mk_bot)).
   { apply isprogram_decide; auto. destruct ispbot. auto. }

  unfold mk_eta_inl, mk_decide, mk_outl, nobnd.
  repeat prove_cequiv; auto.
  unfold mk_decide.
  repeat prove_cequiv; auto.

  - exists [nvarx] (@vterm p nvarx ) (@vterm p nvarx).
    sp; eauto 3 with slow.

  - exists [nvary] (@mk_bot p) (@mk_bot p).
    sp; eauto 3 with slow.
Qed.

Lemma cequivc_eta_inl {p} :
  forall lib (a b : @CTerm p),
    cequivc lib a b
    -> cequivc lib (mkc_eta_inl a) (mkc_eta_inl b).
Proof.
  introv c.
  destruct_cterms.
  allunfold @cequivc; allsimpl.
  apply cequiv_eta_inl; sp.
Qed.

Lemma cequivc_eta_inl_replace {p} :
  forall lib (t u : @CTerm p),
    cequivc lib t u
    -> cequivc lib t (mkc_eta_inl t)
    -> cequivc lib u (mkc_eta_inl u).
Proof.
  introv c1 c2.
  apply cequivc_trans with (b := t); auto.
  apply cequivc_sym; auto.
  apply cequivc_trans with (b := mkc_eta_inl t); auto.
  apply cequivc_eta_inl; sp.
Qed.

Lemma computes_to_inr_eta {p} :
  forall lib (t a : @NTerm p),
    isprogram t
    -> computes_to_value lib t (mk_inr a)
    -> cequiv lib t (mk_eta_inr t).
Proof.
  introv isp c.
  apply computes_to_value_implies_cequiv in c; auto.
  applydup @cequiv_isprogram in c; repnd.
  allrw <- @isprogram_inr_iff; repnd; GC.
  apply @cequiv_trans with (b := mk_inr a); auto.
  unfold mk_eta_inr.
  apply cequiv_inr.
  assert (isprogram (@mk_bot p)) as ispbot.
      eauto 3 with slow.
  assert (isprogram_bt (bterm [nvarx] (@mk_bot p))).
     destruct ispbot. constructor. constructor. constructor. auto.
  assert (blift (cequiv_open lib) (bterm [nvarx] mk_bot) (bterm [nvarx] mk_bot)).
   exists [nvarx] (@mk_bot p) (@mk_bot p); sp; apply cequiv_open_refl. destruct ispbot. auto.

   - assert (cequiv lib (mk_outr t) (mk_outr (mk_inr a))) as ceq1.
    { unfold mk_outr, mk_decide, nobnd.
      repeat prove_cequiv; auto;
      try (complete (constructor; sp));
        try (complete (rw <- isprogram_inr_iff; sp));
        apply alphabt_blift; simpl; dands; (introns XX); allsimpl; exrepnd;
        eauto 3 with slow. }
    { apply @cequiv_trans with (b := mk_outr (mk_inr a)); auto with slow.
      apply cequiv_sym.
      apply cequiv_outr_inr; auto. }
Qed.

Lemma computes_to_inr_eta_c {p} :
  forall lib (t a : @CTerm p),
    computes_to_valc lib t (mkc_inr a)
    -> cequivc lib t (mkc_eta_inr t).
Proof.
  introv c.
  destruct_cterms.
  unfold computes_to_valc in c.
  unfold cequivc.
  allsimpl.
  apply computes_to_inr_eta with (a := x) ; auto.
  rw @isprogram_eq; auto.
Qed.

Hint Resolve isprog_bottom : slow.
Hint Resolve isprog_vars_if_isprog : slow.

Lemma cequiv_eta_inr {p} :
  forall lib (a b : @NTerm p),
    cequiv lib a b
    -> cequiv lib (mk_eta_inr a) (mk_eta_inr b).
Proof.
  introv c.
  applydup @cequiv_isprogram in c; repnd.

  assert (isprogram (@mk_bot p)) as ispbot.
  { eauto 3 with slow. }
  assert (isprogram_bt (bterm [nvary] (@mk_bot p))).
  { apply isprog_vars_isprogrambt; eauto 3 with slow. }

  assert (isprogram (mk_decide a nvarx mk_bot  nvary (vterm nvary) )).
  { apply isprogram_decide; auto. destruct ispbot. auto. }
  assert (isprogram (mk_decide b nvarx mk_bot nvary (vterm nvary)  )).
  { apply isprogram_decide; auto. destruct ispbot. auto. }

  unfold mk_eta_inr, mk_decide, mk_outl, nobnd.
  repeat prove_cequiv; auto.
  unfold mk_decide.
  repeat prove_cequiv; auto.

  - exists [nvarx] (@mk_bot p) (@mk_bot p).
    sp; eauto 3 with slow.

  - exists [nvary] (@vterm p nvary ) (@vterm p nvary).
    sp; eauto 3 with slow.
Qed.

Lemma cequivc_eta_inr {p} :
  forall lib (a b : @CTerm p),
    cequivc lib a b
    -> cequivc lib (mkc_eta_inr a) (mkc_eta_inr b).
Proof.
  introv c.
  destruct_cterms.
  allunfold @cequivc; allsimpl.
  apply cequiv_eta_inr; sp.
Qed.

Lemma cequivc_eta_inr_replace {p} :
  forall lib (t u : @CTerm p),
    cequivc lib t u
    -> cequivc lib t (mkc_eta_inr t)
    -> cequivc lib u (mkc_eta_inr u).
Proof.
  introv c1 c2.
  apply cequivc_trans with (b := t); auto.
  apply cequivc_sym; auto.
  apply cequivc_trans with (b := mkc_eta_inr t); auto.
  apply cequivc_eta_inr; sp.
Qed.

Lemma cequiv_ispair {p} :
  forall lib (t1 a1 b1 t2 a2 b2 : @NTerm p),
    cequiv lib t1 t2
    -> cequiv lib a1 a2
    -> cequiv lib b1 b2
    -> cequiv lib (mk_ispair t1 a1 b1) (mk_ispair t2 a2 b2).
Proof.
  introv c1 c2 c3.
  applydup @cequiv_isprogram in c1.
  applydup @cequiv_isprogram in c2.
  applydup @cequiv_isprogram in c3.
  repnd.
  unfold mk_ispair, mk_can_test, nobnd.
  repeat prove_cequiv; auto.
Qed.

Lemma cequivc_mkc_ispair_of_pair {p} :
  forall lib (t a b : @CTerm p),
    cequivc lib t (mkc_eta_pair t)
    -> cequivc lib (mkc_ispair t a b) a.
Proof.
  introv c.
  destruct_cterms.
  allunfold @cequivc; allsimpl.
  allrw @isprog_eq.
  assert (cequiv lib (mk_ispair x1 x0 x) (mk_ispair (mk_eta_pair x1) x0 x))
         as c' by (apply cequiv_ispair; sp; try (complete (apply cequiv_refl; sp))).
  apply cequiv_trans with (b := mk_ispair (mk_eta_pair x1) x0 x); auto.
  apply reduces_to_implies_cequiv; sp.
  apply isprogram_ispair; sp.
  apply isprogram_eta_pair; sp.
  apply reduces_to_if_step.
  simpl; sp.
Qed.

Lemma cequivc_eq_weak {p} :
  forall lib (a b : @CTerm p), a = b -> cequivc lib a b.
Proof.
  intros; subst; sp.
Qed.

Lemma cequiv_beta2 {p} :
  forall lib v (b a1 a2 : @NTerm p),
    isprog a1
    -> isprog a2
    -> isprog_vars [v] b
    -> cequiv lib (mk_apply2 (mk_lam v b) a1 a2) (mk_apply (subst b v a1) a2).
Proof.
  introv ispa1 ispa2 ispb.
  unfold mk_apply2.
  apply sp_implies_cequiv_apply.
  rw @isprogram_eq; auto.
  apply cequiv_beta; auto.
  rw @isprogram_eq; auto.
Qed.

Lemma cequivc_beta2 {p} :
  forall lib v b (a1 a2 : @CTerm p),
    cequivc lib (mkc_apply2 (mkc_lam v b) a1 a2) (mkc_apply (substc a1 v b) a2).
Proof.
  introv.
  rw @mkc_apply2_eq.
  apply sp_implies_cequivc_apply.
  apply cequivc_beta.
Qed.

Lemma cequiv_beta_isp {p} :
  forall lib v b (a : @NTerm p),
    isprog_vars [v] b
    -> isprog a
    -> cequiv lib (mk_apply (mk_lam v b) a) (subst b v a).
Proof.
  introv ipb ipa.
  apply cequiv_beta; sp.
  apply isprogram_eq; sp.
Qed.

Lemma approx_decomp_equality {p} :
  forall lib (a b c d A B : @NTerm p),
    approx lib (mk_equality a b A) (mk_equality c d B)
    <=> approx lib a c # approx lib b d # approx lib A B.
Proof.
  split; unfold mk_equality; introv Hyp.
  - applydup @approx_relates_only_progs in Hyp. repnd.
    apply approx_canonical_form2 in Hyp.
    unfold lblift in Hyp. repnd. allsimpl.
    alpharelbtd; GC.
    allapply @isprogram_equality_implies; allunfold @nobnd; exrepnd; allsimpl; cpx.
    eapply blift_approx_open_nobnd in Hyp2bt; eauto 3 with slow.
    eapply blift_approx_open_nobnd in Hyp1bt; eauto 3 with slow.
    eapply blift_approx_open_nobnd in Hyp0bt; eauto 3 with slow.
  - repnd.
    applydup @approx_relates_only_progs in Hyp. repnd.
    applydup @approx_relates_only_progs in Hyp0. repnd.
    applydup @approx_relates_only_progs in Hyp1. repnd.
    apply approx_canonical_form3.
    + apply isprogram_ot_iff. allsimpl. dands; auto. introv Hin.
      sp; subst; sp; apply implies_isprogram_bt0; eauto with slow.
    + apply isprogram_ot_iff. allsimpl. dands; auto. introv Hin.
      sp; subst; sp; apply implies_isprogram_bt0; eauto with slow.
    + unfold lblift. allsimpl. split; auto.
      introv Hin. unfold selectbt.
      repeat(destruct n; try (omega;fail); allsimpl);
      apply blift_approx_open_nobnd2; sp.
Qed.

Lemma cequiv_decomp_equality {p} :
  forall lib (a b c d A B : @NTerm p),
    cequiv lib (mk_equality a b A) (mk_equality c d B)
    <=> cequiv lib a c # cequiv lib b d # cequiv lib A B.
Proof.
  intros.
  unfold cequiv.
  rw (approx_decomp_equality lib a b c d A B).
  rw (approx_decomp_equality lib c d a b B A).
  split; sp.
Qed.

Lemma cequivc_decomp_equality {p} :
  forall lib (a b c d A B : @CTerm p),
    cequivc lib (mkc_equality a b A) (mkc_equality c d B)
    <=> cequivc lib a c # cequivc lib b d # cequivc lib A B.
Proof.
  introv; destruct_cterms.
  unfold cequivc, mkc_equality; simpl.
  apply cequiv_decomp_equality.
Qed.

Lemma cequiv_mk_inl_if {p} :
  forall lib (a b : @NTerm p),
    cequiv lib a b
    -> cequiv lib (mk_inl a) (mk_inl b).
Proof.
  allunfold @mk_fix. introv Hc.
  applydup @cequiv_isprogram in Hc. repnd.
  repeat(prove_cequiv); auto.
Qed.

Lemma cequivc_mkc_inl_if {p} :
  forall lib (a b : @CTerm p),
    cequivc lib a b
    -> cequivc lib (mkc_inl a) (mkc_inl b).
Proof.
  allunfold @mk_inl.
  unfold cequivc.
  introv Hc.
  dest_cterms Hc.
  allsimpl.
  allrw @isprog_eq.
  apply cequiv_mk_inl_if; auto.
Qed.

Lemma cequiv_mk_inr_if {p} :
  forall lib (a b : @NTerm p),
    cequiv lib a b
    -> cequiv lib (mk_inr a) (mk_inr b).
Proof.
  allunfold @mk_fix. introv Hc.
  applydup @cequiv_isprogram in Hc. repnd.
  repeat(prove_cequiv); auto.
Qed.

Lemma cequivc_mkc_inr_if {p} :
  forall lib (a b : @CTerm p),
    cequivc lib a b
    -> cequivc lib (mkc_inr a) (mkc_inr b).
Proof.
  allunfold @mk_inl.
  unfold cequivc.
  introv Hc.
  dest_cterms Hc.
  allsimpl.
  allrw @isprog_eq.
  apply cequiv_mk_inr_if; auto.
Qed.

Lemma cequivc_mkc_inl_implies {o} :
  forall lib (t a : @CTerm o),
    cequivc lib (mkc_inl a) t
    -> {b : CTerm $ computes_to_valc lib t (mkc_inl b) # cequivc lib a b}.
Proof.
  introv ceq.
  eapply cequivc_mkc_inl; eauto.
  apply computes_to_valc_refl; sp.
  apply iscvalue_mkc_inl.
Qed.

Lemma cequivc_mkc_inr_implies {o} :
  forall lib (t a : @CTerm o),
    cequivc lib (mkc_inr a) t
    -> {b : CTerm $ computes_to_valc lib t (mkc_inr b) # cequivc lib a b}.
Proof.
  introv ceq.
  eapply cequivc_mkc_inr; eauto.
  apply computes_to_valc_refl; sp.
  apply iscvalue_mkc_inr.
Qed.

Lemma cequivc_axiom_implies {o} :
  forall lib (t : @CTerm o),
    cequivc lib mkc_axiom t -> computes_to_valc lib t mkc_axiom.
Proof.
  introv ceq.
  eapply cequivc_axiom; eauto.
  apply computes_to_valc_refl; sp.
Qed.


Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Strings.String.
Open Scope string_scope.
Require Import Ascii.
Require Import StringSplit.
Require Import CCG.
(*Set Typeclasses Unique Instances.*)
Polymorphic Definition wordSpec (l : list word){parse : Synth l S} : Prop := @denote l S parse.

Polymorphic Class StringParse (s : string){ws}{parse : Synth ws S} := { strdenote : Prop }.
Polymorphic Instance doStringParse (s:string)(ws:list word){split : Split s ws}{parse : Synth ws S} : StringParse s :=
  { strdenote := @denote ws S parse }.
Polymorphic Class Parsed (s:string) := { splitstring : list word }.
Polymorphic Instance doParse (s:string){ws:list word}{split : Split s ws} : Parsed s := { splitstring := ws }.

Polymorphic Class Semantics (s : string) (cat : GType) := { sdenote : interp cat }.
Polymorphic Instance bridgeStringWords {s ws cat}(sw:Split s ws)(parse:Synth ws cat) : Semantics s cat :=
  { sdenote := @denote _ _ parse }.

Polymorphic Definition spec (s : string)`{sem : Semantics s S} := @sdenote _ _ sem .


(* Yul's builtins are different from L10-L40 builtins because of the different type system. *)

From Coq Require Import List String Arith.

From Vyper Require Import Config Map NaryFun.
From Vyper.L10 Require Import Base.
From Vyper.L50 Require Import Types.

Record yul_builtin {C: VyperConfig} := {
  b_input_types: list yul_type;
  b_output_types: list yul_type;
  b_fun: world_state -> nary_fun uint256 (List.length b_input_types)
                                         (world_state * expr_result (list uint256))
}.

Inductive mass_typecheck_result
:= MassTypecheckOk
 | MassTypecheckWrongType
 | MassTypecheckWrongArity.

Fixpoint mass_typecheck {C: VyperConfig} (values: list dynamic_value) (types: list yul_type)
: mass_typecheck_result
:= match values, types with
   | nil, nil => MassTypecheckOk
   | (existT _ t _) :: vtail, thead :: ttail =>
      if yul_type_eq_dec t thead
        then mass_typecheck vtail ttail
        else MassTypecheckWrongType
   | _, _ => MassTypecheckWrongArity
   end.

Lemma mass_typecheck_ok_rewrite {C: VyperConfig} (values: list dynamic_value) (types: list yul_type)
                                {Result: Type}
                                (when_ok: mass_typecheck values types = MassTypecheckOk -> Result)
                                (when_wt: mass_typecheck values types = MassTypecheckWrongType -> Result)
                                (when_wa: mass_typecheck values types = MassTypecheckWrongArity -> Result)
                                (Ok: mass_typecheck values types = MassTypecheckOk):
  match mass_typecheck values types as z return _ = z -> Result with
  | MassTypecheckOk => when_ok
  | MassTypecheckWrongType => when_wt
  | MassTypecheckWrongArity => when_wa
  end eq_refl = when_ok Ok.
Proof.
destruct (mass_typecheck values types); try discriminate.
f_equal. apply Eqdep_dec.eq_proofs_unicity. decide equality.
Qed.

(* mass typecheck fails if the numbers of values and types mismatch *)
Lemma mass_typecheck_length {C: VyperConfig} (values: list dynamic_value) (types: list yul_type)
                            (H: mass_typecheck values types = MassTypecheckOk):
  List.length values = List.length types.
Proof.
revert types H.
induction values as [|vhead]; intros; cbn in H; destruct types as [|thead]; try discriminate.
{ trivial. }
{ now destruct vhead. }
cbn. f_equal.
apply IHvalues.
destruct vhead as (t, _).
now destruct (yul_type_eq_dec t thead).
Qed.

(** Test if the list only has u256. *)
Definition all_are_u256 (l: list yul_type)
: bool
:= List.forallb (fun x => if yul_type_eq_dec x U256 then true else false) l.

Lemma all_are_u256_head (head: yul_type) (tail: list yul_type)
                        (Ok: all_are_u256 (head :: tail) = true):
  head = U256.
Proof.
unfold all_are_u256 in Ok.
rewrite forallb_forall in Ok.
rewrite<- Forall_forall in Ok.
apply Forall_inv in Ok.
now destruct (yul_type_eq_dec head U256) as [Y|N].
Qed.

Lemma all_are_u256_tail (head: yul_type) (tail: list yul_type)
                        (Ok: all_are_u256 (head :: tail) = true):
  all_are_u256 tail = true.
Proof.
unfold all_are_u256 in *.
rewrite forallb_forall in *.
rewrite<- Forall_forall in *.
apply Forall_inv_tail in Ok.
exact Ok.
Qed.

Lemma mass_typecheck_u256 {C: VyperConfig}
                          (v: list uint256)
                          (types: list yul_type)
                          (Ok: all_are_u256 types = true):
  mass_typecheck
        (List.map (fun x: uint256 => existT _ U256 (yul_uint256 x)) v)
        types
   =
  if List.length v =? List.length types then MassTypecheckOk else MassTypecheckWrongArity.
Proof.
revert types Ok. induction v as [|h]; intros; destruct types as [|htype]; try easy.
assert (OkHead := all_are_u256_head _ _ Ok). subst htype.
cbn. exact (IHv _ (all_are_u256_tail _ _ Ok)).
Qed.

Fixpoint mass_cast {C: VyperConfig} (values: list uint256) (types: list yul_type)
: string + list dynamic_value
:= match values, types with
   | nil, nil => inr nil
   | vhead :: vtail, thead :: ttail =>
      match yul_value_of_uint256 vhead thead with
      | Some v =>
          match mass_cast vtail ttail with
          | inl err => inl err
          | inr tail => inr (existT _ thead v :: tail)
          end
      | None => inl ("cannot cast to " ++ string_of_type thead)%string
      end
   | _, _ => inl "cannot cast: different number of types"%string
   end.

Local Lemma call_builtin_helper {C: VyperConfig}
                                (b: yul_builtin)
                                (args: list dynamic_value)
                                (E: mass_typecheck args (b_input_types b) = MassTypecheckOk):
  List.length (b_input_types b) <= List.length (List.map uint256_of_dynamic_value args).
Proof.
rewrite List.map_length.
apply Nat.eq_le_incl.
symmetry.
apply mass_typecheck_length.
assumption.
Qed.

Definition call_builtin {C: VyperConfig} (b: yul_builtin) (world: world_state) (args: list dynamic_value)
: world_state * expr_result (list dynamic_value)
:= match mass_typecheck args (b_input_types b) as a return _ = a -> _ with
   | MassTypecheckOk => fun E =>
          let args_u256 := List.map uint256_of_dynamic_value args in
          match nary_call (b_fun b world) args_u256 (call_builtin_helper b args E) with
          | ((world', ExprSuccess outputs_256), _) =>
              (world', match mass_cast outputs_256 (b_output_types b) with
                       | inl err => expr_error err
                       | inr outputs => ExprSuccess outputs
                       end)
          | ((world', ExprAbort ab), _) => (world', ExprAbort ab)
          end
  | MassTypecheckWrongType => fun _ => (world, expr_error "builtin argument type mismatch"%string)
  | MassTypecheckWrongArity => fun _ => (world, expr_error "builtin with wrong arity"%string)
  end eq_refl.


(**
   Version très simplifiée des idée de: "Java bytecode verification: algorithms
   and formalizations", Xavier Leroy (Journal of Automated Reasoning,
   30(3-4):235-269, 2003).

   Dont voici l'abstract:

   "Bytecode verification is a crucial security component for Java applets, on
   the Web and on embedded devices such as smart cards. This paper reviews the
   various bytecode verification algorithms that have been proposed, recasts
   them in a common framework of dataflow analysis, and surveys the use of proof
   assistants to specify bytecode verification and prove its correctness."

 *)

Require Import OrderedType OrderedTypeEx OrderedTypeAlt DecidableType
        DecidableTypeEx RelationClasses  Omega.
From bcv Require Import LibHypsNaming heritage vmtype vmdefinition.

(** * Valeurs de la machine offensive

   La définition des types, classes et instruction est fixée dans [vmtype]. *)

Module OffVal <: VMVal.
  Definition Val := nat.

  (** Calcul du type d'une valeur offensive. *)
  Definition v2t (v:Val): VMType := Top.

  Lemma val_eq_dec : forall v1 v2:Val, {v1=v2}+{v1<>v2}.
  Proof.
    intros v1 v2.
    decide equality.
  Qed.

End OffVal.

Module O (Import H:Herit).

  (** États offensifs. *)
  Module Off := VMDefinition(OffVal)(H).
  Include Off.
  Ltac rename_ovm h th := fail.

  (* Hypothesis renaming stuff from other files + current file.
     DO NOT REDEFINE IN THIS FILE. Redefine rename_ovm instead. *)
  Ltac rename_hyp h th ::=
    match th with
    | _ => (rename_ovm h th)
    | _ => (Off.rename_vmdef h th)
    | _ => (LibHypsNaming.rename_hyp_neg h th)
    end.

  (** test *)
  (*
    Definition obj1:Obj := {| objclass:=1; objfields:=Dico.empty _|}.
    Definition heap1:Heap := Dico.empty _ .
    Definition heap2:Heap := Dico.add 1 obj1 heap1.
    Definition heap3:Heap := Dico.add 2 obj1 heap2.
    Eval vm_compute in (maxkey heap3).
    Eval vm_compute in (maxkey heap2).
   *)
  (* fin test *)

  (** * Construction d'objet frais pour le bytecode [New]. *)

  (** Construit un Dico de valeur par défaut à partir d'un Dico de
      types. + preuve que [build_flds] est un morphisme pour [Dico.Equal]. *)
  Definition build_flds: ClasseDef -> (Dico.t Val) :=
    Dico.map
      (fun t:VMType =>
         match t with
         | Tint => 0
         | Tref id => 0 (** null = 0 *)
         | Object => 0 (** null = 0 *)
         | Top => 0 (** Should never happen *)
         | Trefnull => 0 (** Should never happen *)
         end).

  Add Parametric Morphism: O.build_flds with signature (Dico.Equal ==> Dico.Equal) as build_flds_morphism.
    intros x y H.
    unfold O.build_flds.
    setoid_rewrite H.
    apply  Dicomore.F.Equal_refl.
  Qed.
  (*
  Lemma build_flds_no_vref:forall t i x, FIND i (build_flds t) <> Some x.
  Proof.
    intros t.
    pattern t.
    apply  Dicomore.map_induction_bis;simpl;intros.
    setoid_rewrite <- H.
    apply H0.
    vm_compute.
    intro abs; discriminate abs.
    unfold O.build_flds.
    rewrite Dicomore.add_map.
    destruct (Dico.E.eq_dec i x);simpl in *; subst.
    rewrite Dicofacts.add_eq_o;auto.
    destruct e;simpl;intro;discriminate.

    rewrite Dicofacts.add_neq_o;auto.
  Qed.
   *)

  (** [new cldefs clid heap] vérifie que clid existe bien, puis retourne une
    reference [r] un nouveau [Heap] [h] et telle que [heap(r) = None] et [h(r) =
    Some(o)] où [o] est un objet "frais" et toutes les adresses de [heap] sont
    identiques dans [h]. *)
  Function new (clid:class_id) (heap:Heap) : option (heap_idx * Heap) :=
    match Dico.find clid allcl with
    | None => None (** Classe inconnue *)
    | Some cldef =>
      let flds:Obj := {| objclass := clid; objfields := build_flds cldef |} in
      let newhpidx: nat := maxkey heap in
      Some((S newhpidx), Dico.add (S newhpidx) flds heap)
    end.

  Lemma new_one_change : forall clid hp hpidx newhp,
      new clid hp = Some (hpidx, newhp) ->
      forall idx,
        FIND idx newhp = FIND idx hp \/ idx=hpidx.
  Proof.
    intros clid hp.
    !functional induction new clid hp;intros;simpl;try solve [discriminate].
    inversion heq_Some;clear heq_Some;subst.
    destruct (Dico.E.eq_dec idx (S (maxkey hp)));simpl.
    - right;auto.
    - rewrite Dicomore.add_neq_o;auto.
  Qed.

  Lemma build_flds_empty :  Dico.Equal (build_flds Dico.empty) Dico.empty.
  Proof.
    unfold build_flds.
    apply Dicomore.empty_map.
  Qed.

  (** * Fonction d'exécution offensive d'*un* bytecode *)

  (** Pas de vérif de overflow. pas de nb négatifs. *)
  Definition exec_step (s:State): option State :=
    let frm:Frame := s.(frame) in
    let pc: pc_idx := frm.(pc) in
    let instr_opt := Dico.find pc (frm.(mdef).(instrs)) in
    match instr_opt with
    | None => None
    | Some instr =>
      match instr with
      | ret => Some s
      | Iconst i =>
        Some {| framestack := s.(framestack); heap := s.(heap);
                frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                            pc:= pc + 1;
                            stack:= i :: s.(frame).(stack)
                         |}
             |}
      | Iadd =>
        match s.(frame).(stack) with
        | i1 :: i2 :: stack' =>
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef); regs:= s.(frame).(regs);
                              pc:= pc + 1;
                              stack:= (i1+i2) :: stack'
                           |}
               |}
        | nil | _ :: nil => None (** Stack underflow *)
        end

      | Iload ridx =>
        match Dico.find ridx (s.(frame).(regs)) with
        | Some i =>
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef); regs:= s.(frame).(regs);
                              pc:= pc + 1;
                              stack:= i :: s.(frame).(stack)
                           |}
               |}
        | None => None (** Bad register number *)
        end

      | Rload clid ridx =>
        match Dico.find ridx (s.(frame).(regs)) with
        | Some r =>
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                              pc:= pc + 1;
                              stack:= r :: s.(frame).(stack)
                           |}
               |}
        | None => None (** Bad register number *)
        end

      | Istore ridx =>
        match s.(frame).(stack) with
        | i :: stack' =>
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef) ;
                              regs:= Dico.add ridx i (s.(frame).(regs));
                              pc:= pc + 1;
                              stack:= stack'
                           |}
               |}
        | nil => None (** Stack underflow *)
        end

      | Rstore clid ridx =>
        match s.(frame).(stack) with
        | i :: stack' =>
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef) ;
                              regs:= Dico.add ridx i (s.(frame).(regs));
                              pc:= pc + 1;
                              stack:= stack'
                           |}
               |}
        | nil => None (** Stack underflow *)
        end

      | Iifle jmp => (** ifeqe *)
        match s.(frame).(stack) with
        | 0 :: stack' => (** = 0  --> jump *)
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                              pc:= jmp;
                              stack:= stack'
                           |}
               |}
        | _ :: stack' => (** <> 0  --> pc+1 *)
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                              pc:= pc+1;
                              stack:= stack'
                           |}
               |}
        | nil => None (** Stack underflow *)
        end

      | Goto jmp =>
        Some {| framestack := s.(framestack); heap := s.(heap);
                frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                            stack:= s.(frame).(stack);
                            pc:= jmp
                         |}
             |}

      | Getfield cl namefld typ =>
        match s.(frame).(stack) with
        | hpidx :: stack' =>
          match Dico.find hpidx s.(heap) with
          | None => None (** adresse inconnue *)
          | Some {|objclass:= objcl; objfields:= flds |} => (* TODO: vérifier le type retourné? *)
            match Dico.find namefld flds with
            | None => None (** Champ de classe inconnu ou pas initialisé *)
            | Some v =>
              Some {| framestack := s.(framestack); heap := s.(heap);
                      frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                                  pc:= pc+1;
                                  stack:= v :: stack'
                               |}
                   |}
            end
          end
        | nil => None (** Stack underflow *)
        end

      | Putfield cl namefld typ =>
        match s.(frame).(stack) with
        | hpidx :: v :: stack' =>
          match Dico.find hpidx s.(heap) with
          | None => None (** adresse inconnue, objet non alloué *)
          | Some {| objclass:= objcl; objfields:= flds |}=>
            let newflds := {| objclass:= objcl;
                              objfields:=Dico.add namefld v flds |} in
            let newheap := Dico.add hpidx newflds s.(heap) in
            Some {| framestack := s.(framestack);
                    heap := newheap;
                    frame := {| mdef:=s.(frame).(mdef) ;
                                regs:= s.(frame).(regs);
                                pc:= pc+1;
                                stack:= stack'
                             |}
                 |}
          end
        | nil | _ :: nil => None (** Stack underflow *)
        end

      | New clid =>
        match new clid s.(heap) with
        | None => None (** Classe inconnue *)
        | Some (newobj,newhp) =>
          Some {| framestack := s.(framestack); heap := newhp;
                  frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                              stack:= newobj :: s.(frame).(stack);
                              pc:= pc+1
                           |}
               |}

        end
      end
    end.

  Functional Scheme exec_step_ind := Induction for exec_step Sort Prop.

  (** * Tests *)

  Notation "k --> i , d" := (Dico.add k i d) (at level 55, right associativity).

  Definition prog:MethodDef :=
    {| instrs := (0 --> Iload 1 ,
                  1 --> Istore 2 ,
                  2 --> ret ,
                  Dico.empty) ;
       argstype :=(Tint :: Tint:: nil);
       restype := Tint |}.

  Definition startstate:State :=
    {|
      framestack := nil;
      heap := Dico.empty ;
      frame := {|
                mdef:= prog ;
                regs:= (0 --> 32 , 1--> 11, Dico.empty);
                pc:= 0;
                stack:= nil
              |}
    |}.

  Fixpoint exec_n (s : State) (n:nat) {struct n}: option State :=
    match n with
    | 0 => Some s
    | S n' =>
      match exec_step s with
      | None => None
      | Some s' => exec_n s' n'
      end
    end.
  (*
    Eval simpl in exec_n startstate 1.
    Eval simpl in exec_n startstate 2.
    Eval simpl in exec_n startstate 5.
   *)
  (* Eval simpl in exec_n (fun x y => false) (Dico.empty _) startstate 2. *)

  (** Exemple de preuve très simple sur la fonction d'exécution *)

  Lemma essai : forall s x,
      exec_step s = Some x ->
      x.(framestack) = s.(framestack).
  Proof.
    intros s.
    functional induction exec_step s;intros ;simpl;
      try solve [discriminate | inversion H; subst;simpl;reflexivity] .
  Qed.

End O.


(** * btrees.v : Formal Model of BTrees  *)

Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import VST.msl.wand_frame.
Require Import VST.msl.iter_sepcon.
Require Import VST.floyd.reassoc_seq.
Require Import VST.floyd.field_at_wand.
Require Import FunInd.

Instance Inhabitant_option {X: Type} : Inhabitant (option X) := @None X.

Definition Znth_option {X : Type} (i : Z) (l : list X) : option X :=
     Znth i (map Some l).

Lemma Znth_option_e {X: Type} (i: Z) (l: list X):
   Znth_option i l =
  if zle 0 i then
    if zlt i (Zlength (map Some l)) then
      (@Znth _ None i (map Some l))
    else
      None
  else
    None.
Proof.
unfold Znth_option, Znth.
if_tac.
rewrite zle_false by lia.
auto.
rewrite zle_true by lia.
if_tac.
auto.
autorewrite with sublist in H0.
rewrite Zlength_correct in H0.
apply nth_overflow.
rewrite map_length.
zify.
rewrite ?Z2Nat.id by lia.  (* This line not needed in Coq 8.11 or after *)
lia.
Qed.

Lemma Znth_option_e' {X: Type} {d: Inhabitant X} (i: Z) (l: list X) (x: X):
   Znth_option i l = Some x -> Znth i l = x.
Proof.
intros.
rewrite Znth_option_e in H.
repeat if_tac in H; inv H.
autorewrite with sublist in *.
rewrite Znth_map in H3 by list_solve.
inv H3; auto.
Qed.

(**
    BTREES FORMAL MODEL
 **)

Ltac evaluate x :=
  let x := eval compute in x in exact x.

(* Maximum number of entries in a node *)
Definition Fanout := 15%Z.
Lemma Fanout_eq : Fanout = ltac:(evaluate Fanout).
Proof. reflexivity. Qed.
Hint Rewrite Fanout_eq : rep_lia.
(* Middle = Fanout +1  /2, for splitting nodes *)
Definition Middle := ltac:(evaluate ((Fanout+1)/2)).
Lemma Middle_eq: Middle = ltac:(evaluate Middle).
Proof. reflexivity. Qed.
Global Opaque Fanout.
Global Opaque Middle.
Hint Rewrite Middle_eq : rep_lia.

(* Maximum tree depth *)
Definition MaxTreeDepth := 20%Z.
Lemma MTD_eq : MaxTreeDepth = ltac:(evaluate MaxTreeDepth).
Proof. reflexivity. Qed.
Global Opaque MaxTreeDepth.
Hint Rewrite MTD_eq : rep_lia.

Definition key := Ptrofs.int.
Definition V := Ptrofs.int.

(* Variable X:Type.                (* val or unit *) *)

(* Btree Types *)
Inductive entry (X:Type): Type :=
     | keyval: key -> V -> X -> entry X
     | keychild: key -> node X -> entry X
with node (X:Type): Type :=
     | btnode: forall (entryzero: option (node X)) (le: list (entry X))  (isLeaf: bool) (First: bool) (Last: bool) (x: X), node X.

Definition node_entryzero {X} (n: node X) :=
  match n with btnode entryzero le isLeaf First Last x => entryzero end.

Definition node_le {X} (n: node X) :=
  match n with btnode entryzero le isLeaf First Last x => le end.

Definition node_isLeaf {X} (n: node X) :=
  match n with btnode entryzero le isLeaf First Last x => isLeaf end.

Definition node_First {X} (n: node X) :=
  match n with btnode entryzero le isLeaf First Last x => First end.

Definition node_Last {X} (n: node X) :=
  match n with btnode entryzero le isLeaf First Last x => Last end.

Definition node_x {X} (n: node X) :=
  match n with btnode entryzero le isLeaf First Last x => x end.

Definition cursor (X:Type): Type := list (node X * Z). (* ancestors and index *)
Definition relation (X:Type): Type := node X * X.  (* root and address *)

(* Abstracting a Btree to an ordered list of (key,value) pairs *)
Fixpoint abs_node {X:Type} (n:node X) : list (key * V) :=
  match n with
    btnode o le isLeaf First Last x =>
    match o with
    | Some n' => abs_node n' ++ concat (map abs_entry le)
    | None => concat (map abs_entry le)
    end
  end
with abs_entry {X:Type} (e:entry X) : list (key * V) :=
       match e with
       | keyval k v x => [(k,v)]
       | keychild k n => abs_node n
       end.

(* Btrees depth *)
Fixpoint node_depth {X:Type} (n:node X) : Z :=
  match n with
    btnode ptr0 le _ _ _ _ =>
      Z.max (fold_right Z.max 0 (map entry_depth le))
        (match ptr0 with
         | None => 0
         | Some n' => Z.succ (node_depth n')
         end)
  end
with entry_depth {X:Type} (e:entry X) : Z :=
       match e with
       | keyval _ _ _ => 0
       | keychild _ n => Z.succ (node_depth n)
       end.

Definition listentry_depth {X} (le: list (entry X)) : Z :=
  fold_right Z.max 0 (map entry_depth le).

Lemma node_depth_nonneg: forall {X} (n: node X), 0 <= node_depth n
   with entry_depth_nonneg: forall {X} (e: entry X), 0 <= entry_depth e.
Proof.
-
destruct n.
simpl.
apply Zmax_bound_l.
induction (map entry_depth le).
simpl. lia.
simpl.
apply Zmax_bound_r. auto.
-
destruct e; simpl.
lia.
pose proof (node_depth_nonneg _ n); lia.
Qed.

Lemma listentry_depth_nonneg: forall {X} (le: list (entry X)), 0 <= listentry_depth le.
Proof.
unfold listentry_depth.
induction le; simpl.
lia.
apply Zmax_bound_r; auto.
Qed.

(* root of the relation *)
Definition get_root {X:Type} (rel:relation X) : node X := fst rel.

(* cursor depth used for putentry. the entry_depth should be equal the cursor depth *)
Definition cursor_depth {X:Type} (c:cursor X) (r:relation X) : Z :=
  match c with
  | [] => Z.succ (node_depth (get_root r))
  | (n,i)::c' => node_depth n
  end.

(* Number of Records *)
Fixpoint node_numrec {X:Type} (n:node X) : Z :=
  match n with
    btnode ptr0 le _ _ _ _ =>
      fold_left Z.add (map entry_numrec le)
        (match ptr0 with
         | None => 0
         | Some n' => node_numrec n'
         end)
  end
with entry_numrec {X:Type} (e:entry X) : Z :=
       match e with
       | keyval _ _ _ => 1
       | keychild _ n => node_numrec n
       end.

(* numRecords of the relation *)
Definition get_numrec {X:Type} (rel:relation X) : Z := node_numrec (get_root rel).

(* depth of the relation *)
Definition get_depth {X:Type} (rel:relation X) : Z := node_depth (get_root rel).

(* Index at the current level *)
Definition entryIndex {X:Type} (c:cursor X) : Z :=
  match c with
  | [] => 0
  | (n,i)::c' => i
  end.

(* Ancestor at the current level *)
Definition currNode {X:Type} (c:cursor X) (r:relation X) : node X :=
  match c with
  | [] => get_root r
  | (n,i)::c' => n
  end.

Definition currNode' {X:Type} (c:cursor X) (root:node X) : node X :=
  match c with
  | [] => root
  | (n,i)::c' => n
  end.
Lemma currNode_currNode' {X:Type} (c:cursor X) r: currNode c r = currNode' c (get_root r).
Proof. destruct c; simpl; trivial. Qed.

Instance Inhabitant_node {X: Type} (x: Inhabitant X): Inhabitant (node X) :=
  btnode X None nil true true true x.

Instance Inhabitant_entry {X: Type} (x: Inhabitant X): Inhabitant (entry X) := keychild _ Ptrofs.zero (Inhabitant_node _).

Instance Inhabitant_entry_val : Inhabitant (entry val) := Inhabitant_entry _.

(* is a cursor valid? invalid if the cursor is past the very last key *)
Definition isValid {X:Type} (c:cursor X) (r:relation X): bool :=
  match currNode c r
  with btnode ptr0 le b First Last x =>
       match Last with
       | false => true
       | true =>
         match (Z.eqb (entryIndex c) (Zlength le)) with
               | false => true
               | true => false
                end
       end
  end.

Definition isValid' {X:Type} (c:cursor X) root: bool :=
  match currNode' c root
  with btnode ptr0 le b First Last x =>
       negb (andb Last (Z.eqb (entryIndex c) (Zlength le))) end.
Lemma is_valid_isValid' {X} (c:cursor X) r: isValid c r = isValid' c (get_root r).
Proof. unfold isValid, isValid'. rewrite currNode_currNode'.
  destruct (currNode' c (get_root r)). destruct Last; simpl; trivial.
Qed.

(* does the cursor point to the very first key? *)
Definition isFirst {X:Type} (c:cursor X) : bool :=
  match c with
  | [] => false
  | (n,i)::c' =>
    match n with btnode ptr0 le isLeaf First Last x =>
                 First && (Z.eqb i 0)
    end
  end.

(* Leaf entries have values *)
Definition LeafEntry {X:Type} (e:entry X) : Prop :=
  match e with
  | keyval _ _ _ => True
  | keychild _ _ => False
  end.

Hint Rewrite @Znth_pos_cons using rep_lia : sublist.

Section nth_option.
Context {X : Type} .

Lemma Znth_option_in_range: forall i (le:list (entry X)),
    0 <= i < Zlength le ->
    exists e, Znth_option i le = Some e.
Proof.
  intros.
  rewrite Znth_option_e.
  autorewrite with sublist. rewrite if_true by lia.
  rewrite zle_true by lia.
 generalize dependent i.
  induction le; intros; autorewrite with sublist in *.
  - lia.
  - destruct (zeq i 0); subst; simpl; autorewrite with sublist. eauto.
     apply IHle; auto; lia.
Qed.

(* nth child of a listentry *)
Definition nth_node_le (i:Z) (le:list (entry X)): option (node X) :=
  match Znth_option i le with
  | Some (keychild k child) => Some child
  | _ => None
  end.

Lemma Znth_option_some : forall X (le:list X) i e,
    Znth_option i le = Some e -> (0 <= i < Zlength le).
Proof.
  intros.
  rewrite Znth_option_e in H.
  repeat if_tac in H; inv H.
  autorewrite with sublist in *. lia.
Qed.

Lemma nth_node_le_some : forall  (le:list (entry X)) i n,
    nth_node_le i le = Some n -> (0 <= i < Zlength le).
Proof.
  intros.
  unfold nth_node_le in H.
  destruct (Znth_option i le) eqn:?H; try discriminate.
  eapply Znth_option_some; eauto.
Qed.

Definition nth_node (i:Z) (n:node X): option (node X) :=
  match n with
  | btnode (Some ptr0) le false _ _ _ =>
               if zeq i (-1) then Some ptr0 else nth_node_le i le
  | _ => None
  end.

Lemma nth_node_some: forall (n:node X) i n',
    nth_node i n = Some n' -> -1 <= i < Zlength (node_le n).
Proof.
  intros.
  unfold nth_node in H. destruct n. simpl. destruct entryzero, isLeaf; inv H.
  if_tac in H1. inv H1.
  simpl. rep_lia.
  simpl. apply nth_node_le_some in H1; auto. lia.
Qed.

Lemma nth_node_le_decrease: forall (le:list (entry X)) (n:node X) i,
    nth_node_le i le = Some n ->
    (node_depth n < listentry_depth le).
Proof.
  intros.
  unfold nth_node_le in H.
  destruct (Znth_option i le) as [[|]|] eqn:?H; inv H.
  rename H0 into H.
  rewrite Znth_option_e in H.
  revert i k n H;
  induction le; intros.
  - repeat if_tac in H; inv H. autorewrite with sublist in H1; lia.
  -
    repeat if_tac in H; inv H. autorewrite with sublist in H1.
    unfold listentry_depth.
    simpl.
    destruct (zeq i 0).
   + subst. autorewrite with sublist in H3. inv H3. simpl.
      apply Z.max_lt_iff. left. lia.
   + apply Z.max_lt_iff. right. apply (IHle (i-1) k).
      autorewrite with sublist in H3|-*.
      rewrite zle_true by lia. rewrite zlt_true by lia. auto.
Qed.

Lemma nth_node_decrease: forall (n:node X) (n':node X) i,
    nth_node i n = Some n' ->
    (node_depth n' < node_depth n).
Proof.
  intros. unfold nth_node, Znth_option in H.
  destruct n.
 destruct isLeaf, entryzero; try easy.
  if_tac in H.
  - subst. inv H. simpl. apply Z.max_lt_iff; right. lia.
  - apply nth_node_le_decrease in H. simpl.
     apply Z.max_lt_iff; left. auto.
Qed.

Definition next_node (c:cursor X) (root:node X) : option (node X) :=
  match c with
  | [] => Some root
  | (n,i)::c' => nth_node i n
  end.

(* entry pointed to by a cursor. Leaf entry for a complete cursor. Keychild entry for a partial cursor *)
Definition getCEntry (c:cursor X) : option (entry X) :=
  match c with
  | [] => None
  | (n,i)::c' => Znth_option i (node_le n)
  end.

(* get Key pointed to by cursor *)
Definition getCKey (c:cursor X) : option key :=
  match (getCEntry c) with
  | None => None
  | Some e => match e with
              | keychild _ _ => None
              | keyval k v x => Some k
              end
  end.

(* get record pointed to by cursor *)
Definition getCRecord (c:cursor X) : option V  :=
  match (getCEntry c) with
  | None => None
  | Some e => match e with
              | keychild _ _ => None
              | keyval k v x => Some v
              end
  end.

(* get address pointed to by cursor *)
Definition getCVal (c:cursor X) : option X :=
  match (getCEntry c) with
  | None => None
  | Some e => match e with
              | keychild _ _ => None
              | keyval k v x => Some x
              end
  end.

End nth_option.

Lemma nth_entry_child: forall i le k child,
    Znth_option i le = Some (keychild val k child) ->
    nth_node_le i le = Some child.
Proof.
  intros.
  unfold nth_node_le. rewrite H; auto.
Qed.

(* findChildIndex for an intern node *)
Fixpoint findChildIndex' {X:Type} (le:list (entry X)) (key:key) (i:Z): Z :=
  match le with
  | nil => i
  | cons e le' =>
    match e with
    | keyval k v x =>
      match (Ptrofs.ltu key k) with
      | true => i
      | false => findChildIndex' le' key (Z.succ i)
      end
    | keychild k c =>
      match (Ptrofs.ltu key k) with
      | true => i
      | false => findChildIndex' le' key (Z.succ i)
      end
    end
  end.

Definition findChildIndex {X:Type} (n:node X) (key:key): Z :=
  match n with btnode ptr0 le b F L x =>
               findChildIndex' le key (-1) end.

(* The key of an entry *)
Definition entry_key {X:Type} (e:entry X) : key :=
  match e with
  | keychild k c => k
  | keyval k v x => k
  end.

(* findRecordIndex for a leaf node *)
Fixpoint findRecordIndex' {X:Type} (le:list (entry X)) (key:key) (i:Z): Z :=
  match le with
  | nil => i
  | cons e le' =>
      if (Ptrofs.cmpu Cle key (entry_key e))
      then i
      else findRecordIndex' le' key (Z.succ i)
  end.

Definition findRecordIndex {X:Type} (n:node X) (key:key) : Z :=
    match n with btnode ptr0 le b F L x =>
                 findRecordIndex' le key 0 end.

(* takes a PARTIAL cursor, n next node (pointed to by the cursor) and goes down to first key *)
Fixpoint moveToFirst {X:Type} (n:node X) (c:cursor X) (level:nat): cursor X :=
  match n with
    btnode ptr0 le isLeaf First Last x =>
    if isLeaf
    then (n, 0)::c
    else match ptr0 with
           | None => c      (* not possible, isLeaf is false *)
           | Some n' => moveToFirst n' ((n, -1)::c) (level+1)
           end
  end.

(* takes a PARTIAL cursor, n next node (pointed to by the cursor) and goes down to last key *)
Function moveToLast {X:Type} (n:node X) (c:cursor X) (level:Z) {measure (Z.to_nat oo node_depth) n}: cursor X :=
  match n with
    btnode ptr0 le isLeaf First Last x =>
    if isLeaf
    then (n, Zlength (node_le n))::c
    else match (nth_node (Zlength (node_le n) -1) n)  with
           | None => c      (* not possible, isLeaf is false *)
           | Some n' => moveToLast n' ((n, Zlength (node_le n) -1)::c) (level+1)
           end
  end.
Proof.
  intros. apply nth_node_decrease in teq1.
  unfold Basics.compose.
  pose proof (node_depth_nonneg n').
  zify.
  rewrite ?Z2Nat.id by lia.  (* this line not needed in Coq 8.11 or after *)
 rewrite ?Z2Nat.id in * by lia.  (* this line not needed in Coq 8.11 or after *)
 lia.
Qed.

(* takes a PARTIAL cursor, n next node (pointed to by the cursor) and goes down to the key, or where it should be inserted *)
Function moveToKey {X:Type} (n:node X) (key:key) (c:cursor X) {measure (Z.to_nat oo node_depth) n} : cursor X :=
  match n with
    btnode ptr0 le isLeaf First Last x =>
    if isLeaf
    then (n,findRecordIndex n key)::c
    else match (nth_node (findChildIndex n key) n) with (* next child *)
            | None => c                                    (* not possible *)
            | Some n' => moveToKey n' key ((n,findChildIndex n key)::c)
            end
  end.
Proof.
  intros. apply nth_node_decrease in teq1.
  unfold Basics.compose.
  pose proof (node_depth_nonneg n').
  zify.
  rewrite ?Z2Nat.id by lia.   (* this line not needed in Coq 8.11 or after *)
 rewrite ?Z2Nat.id in * by lia.   (* this line not needed in Coq 8.11 or after *)
 lia.
Qed.

(* Returns node->isLeaf *)
Definition isnodeleaf {X:Type} (n:node X) : bool :=
  match n with btnode _ _ isLeaf _ _ _ => isLeaf end.

(* Child of an entry *)
Definition entry_child {X:Type} (e:entry X) : option (node X) :=
  match e with
  | keychild k c => Some c
  | keyval k v x => None
  end.

Section Foo.
Context {X: Type}.

(* Returns true if we know for sure that the node is a parent of the key *)
Definition isNodeParent (n:node X) (key:key): bool :=
  match n with btnode ptr0 le isLeaf First Last x =>
  if isLeaf then
    let numkeys := Zlength le in
    if zle numkeys 0 then true
    else
      match Znth_option 0 le with
      | None => false                 (* impossible *)
      | Some e0 =>
        let lowest := entry_key e0 in
        match Znth_option (Z.pred numkeys) le with
        | None => false         (* impossible *)
        | Some el =>
          let highest := entry_key el in
          andb ( orb (Ptrofs.cmpu Cge key lowest) (First))
               ( orb (Ptrofs.cmpu Cle key highest) (Last))
        end
    end
  else let i := findChildIndex n key
           in if zeq i (-1) then false
            else negb (Z.eqb (Z.succ i) (Zlength (node_le n)))
  end.

(* Ascend to parent in a cursor *)
Fixpoint AscendToParent (c:cursor X) (key:key): cursor X :=
  match c with
  | [] => []
  | [(n,i)] => [(n,i)]          (* root is parent *)
  | (n,i)::c' => match isNodeParent n key with
                 | true => c
                 | false => AscendToParent c' key
                 end
  end.

(* go to a Key from any position in the cursor: ascendtoparent then movetokey *)
Definition goToKey (c:cursor X) (r:relation X) (key:key) : cursor X :=
  let partialc := AscendToParent c key in
  match partialc with
  | [] => moveToKey X (get_root r) key []
  | (n,i)::c' => moveToKey X n key c'
  end.

(* Returns the index of the last pointer of a node *)
Definition lastpointer (n:node X): Z :=
  match n with btnode ptr0 le isLeaf First Last pn =>
               if isLeaf
               then Zlength le
               else Z.pred (Zlength le)
   end.

(* Returns the index of the first pointer of a node *)
Definition firstpointer (n:node X): Z :=
  match n with btnode ptr0 le isLeaf First Last pn =>
               if isLeaf then 0 else -1
  end.

(* Goes up in the cursor as long as the index is the last possible one for the current node *)
Fixpoint up_at_last (c:cursor X): cursor X :=
  match c with
  | [] => []
  | [(n,i)] => [(n,i)]
  | (n,i)::c' => if Z.eqb i (lastpointer n) then up_at_last c' else c
  end.

(* Increments current index of the cursor. The current index should not be the last possible one *)
Definition next_cursor (c:cursor X): cursor X :=
  match c with
  | [] => []
  | (n,i)::c' => (n,Z.succ i)::c'
  end.

(* moves the cursor to the next position (possibly an equivalent one)
   takes a FULL cursor as input *)
Definition moveToNext (c:cursor X) (r:relation X) : cursor X :=
  if isValid c r
  then let cincr := next_cursor (up_at_last c) in
    match cincr with
    | [] => moveToFirst (get_root r) [] O
    | (n,i)::c' =>
      if isnodeleaf n
      then cincr         (* if we did not go up *)
      else match (nth_node i n) with
             | None => cincr       (* impossible *)
             | Some n' =>
               moveToFirst n' cincr (length cincr) (* going down on the left if we had to go up *)
        end
    end
  else c.  (* invalid cursor: no change to the cursor *)

(* Goes up in the cursor as long as the index is the first possible one for the current node *)
Fixpoint up_at_first (c:cursor X): cursor X :=
  match c with
  | [] => []
  | (n,i)::c' => if Z.eqb i (firstpointer n) then up_at_first c' else c
  end.

(* Decrements current index of the cursor. The current index should not be the first possible one *)
Definition prev_cursor (c:cursor X): cursor X :=
  match c with
  | [] => []
  | (n,i)::c' => (n,Z.pred i)::c'
  end.

(* moves the cursor to the previous position (possibly an equivalent one)
 takes a FULL cursor as input *)
Definition moveToPrev (c:cursor X) (r:relation X) : cursor X :=
  if isFirst c
  then c              (* first cursor: no change to the cursor *)
  else
    let cdecr := prev_cursor (up_at_first c) in
    match cdecr with
    | [] => moveToFirst (get_root r) [] O
    | (n,i)::c' =>
      if isnodeleaf n
      then cdecr         (* if we did not go up *)
      else match (nth_node i n) with
             | None => cdecr       (* impossible *)
             | Some n' =>
          moveToLast X n' cdecr (Zlength cdecr) (* going down on the left if we had to go up *)
        end
    end.

Definition normalize (c:cursor X) (r:relation X) : cursor X :=
  match c with
  | [] => c
  | (n,i)::c' => if Z.eqb i (Zlength (node_le n)) then moveToNext c r else c
  end.

(* moves the cursor to the next non-equivalent position
 takes a FULL cursor as input *)
Definition RL_MoveToNext (c:cursor X) (r:relation X) : cursor X :=
  match c with
  | [] => c                     (* not possible *)
  | (n,i)::c' => if Z.eqb i (Zlength (node_le n))
                 then moveToNext (moveToNext c r) r (* at last position, move twice *)
                 else moveToNext c r
  end.

(* move the cursor to the previous non-equivalent position
 takes a FULL cursor as input *)
Definition RL_MoveToPrevious (c:cursor X) (r:relation X) : cursor X :=
  match c with
  | [] => c                     (* not possible *)
  | (n,i)::c => if Z.eqb i 0
                then moveToPrev (moveToPrev c r) r (* at first position, move twice *)
                else moveToPrev c r
  end.

End Foo.

Lemma Znth_option_nil: forall {X: Type } i,
  @Znth_option X i nil = None.
Proof.
intros.
apply Znth_nil.
Qed.

Lemma Znth_option_0: forall {X} (a: X) l i, i=0 -> Znth_option i (a::l) = Some a.
Proof.
intros. subst.
unfold Znth_option; simpl.
autorewrite with sublist.
auto.
Qed.

Lemma Znth_option_cons: forall {X} (a: X) l i, 0 <> i -> Znth_option i (a::l) = Znth_option (i-1) l.
Proof.
intros.
rewrite !Znth_option_e; simpl.
autorewrite with sublist.
repeat if_tac; try lia; auto.
autorewrite with sublist; auto.
Qed.

Hint Rewrite @Znth_option_nil : sublist.
Hint Rewrite @Znth_option_0 using rep_lia : sublist.
Hint Rewrite @Znth_option_cons using rep_lia : sublist.

Lemma Zlength_sublist_hack:
  forall {X: Type} i j (al: list X),
    i <= j ->
    Zlength (sublist i j al) <= j-i.
Proof.
intros.
unfold sublist.
rewrite Zlength_correct.
assert (j = (j-i) + i) by lia.
assert (0 <= (j-i)) by lia.
forget (j-i) as k.
subst j.
rewrite <- (Z2Nat.id k) in * by lia.
forget (Z.to_nat k) as k'; clear k; rename k' into k.
apply inj_le.
destruct (zlt i 0).
rewrite Z2Nat_neg by auto.
simpl.
rewrite firstn_le_length. zify; lia.
rewrite skipn_length.
rewrite Z2Nat.inj_add by lia.
rewrite Nat2Z.id.
pose proof (firstn_le_length (k + Z.to_nat i) al).
lia.
Qed.

(* nth_entry when skipping entries *)
Lemma nth_entry_skipn: forall X i le (e:entry X),
    Znth_option i le = Some e ->
    Znth_option 0 (sublist i (Zlength le) le) = Some e.
Proof.
  intros.
  rewrite !Znth_option_e in H|-*.
  repeat if_tac in H; inv  H.
  autorewrite with sublist in H1.
  rewrite zle_true by lia.
  rewrite zlt_true by list_solve.
  replace (map Some le) with (map Some (sublist 0 (Zlength le) le)).
  rewrite (sublist_split 0 i) by list_solve.
  rewrite map_app.
  rewrite app_Znth2 by list_solve.
  autorewrite with sublist. auto.
  rewrite sublist_same; auto.
Qed.

(* Inserts an entry in a list of entries (that doesnt already has the key) *)
Fixpoint insert_le {X:Type} (le:list (entry X)) (e:entry X) : list (entry X) :=
  match le with
  | nil => e :: nil
  | cons e' le' => if Ptrofs.cmpu Cle (entry_key e) (entry_key e')
                          then e :: le
                          else e' :: insert_le le' e
  end.

(* inserting adds one entry *)
Lemma Zlength_insert_le: forall X (l:list (entry X)) e,
    Zlength (insert_le l e) = Z.succ (Zlength l).
Proof.
  intros. induction l.
  - simpl. auto.
  - simpl. destruct (Ptrofs.ltu (entry_key a) (entry_key e)); simpl.
    + Zlength_solve.
    + Zlength_solve.
Qed.

Hint Rewrite @Zlength_insert_le : sublist.

(* Inserts an entry e in a full node n. This function returns the right node containing the first
   values after the split. e should have a key not already contained by the node *)
Definition splitnode_left {X:Type} (n:node X) (e:entry X) : (node X) :=
  match n with btnode ptr0 le isLeaf First Last x =>
               btnode X ptr0
                      (sublist 0 Middle (insert_le le e))
                      isLeaf
                      First
                      false    (* the right node can't be the last one *)
                      x end.

Definition splitnode_leafnode {X:Type} (le:list (entry X)) (e:entry X) (newx:X) Last :=
  (btnode X None (* Leaf node has no ptr0 *)
          (sublist Middle (Zlength (insert_le le e)) (insert_le le e))
          true   (* newnode is at same level as old one *)
          false  (* newnode can't be first node *)
          Last   (* newnode is last leaf if the split node was *)
          newx).

Definition splitnode_internnode {X:Type} (le:list (entry X)) (e:entry X) newx Last child :=
  (btnode X (Some child) (* ptr0 of the new node is the previous child of the pushed up entry *)
          (sublist (Z.succ Middle) (Zlength (insert_le le e)) (insert_le le e)) (* the middle entry isn't copied *)
          false  (* newnode is at the same level as old one *)
          false  (* newnode can't be first node *)
          Last   (* newnode is last leaf if the split node was *)
          newx).

(* This function contains the new entry to be pushed up after splitting the node
   Its child is the new node from splinode, containing the last entries
   newx is the the address of the new node *)
Definition splitnode_right {X:Type} (n:node X) (e:entry X) (newx:X) : (entry X) :=
  match n with
    btnode ptr0 le isLeaf First Last x =>
    if isLeaf
    then                  (* in a leaf the middle key is copied up *)
      match Znth_option Middle (insert_le le e) with
      | None => e     (* not possible: the split node should be full *)
      | Some e' =>
        keychild X (entry_key e') (splitnode_leafnode le e newx Last)
      end
    else
      match Znth_option Middle (insert_le le e) with
      | None => e                (* not possible: the split node should be full *)
      | Some e' =>
        match (entry_child e') with
        | None => e              (* not possible: at intern leaf, each entry has a child *)
        | Some child =>
          keychild X (entry_key e') (splitnode_internnode le e newx Last child)
        end
      end
  end.

(* The key that is copied up when splitting a node *)
Definition splitnode_key {X:Type}(n:node X) (e:entry X) : key :=
  match n with
    btnode ptr0 le isLeaf First Last x =>
    match Znth_option Middle (insert_le le e) with
    | None => Ptrofs.repr 0     (* splitnode should be full *)
    | Some e' => entry_key e'
    end
  end.

(* returns true if the node is full and should be split on insertion *)
Definition fullnode {X:Type} (n:node X) : bool :=
  (Fanout <=? Zlength (node_le n)).

(* Is a key already in a listentry? *)
Fixpoint key_in_le {X:Type} (key:key) (le:list (entry X)) : bool :=
  match le with
  | nil => false
  | cons e le' => if Ptrofs.eq (entry_key e) key then true else key_in_le key le'
  end.

(* listentry should contain an entry with the same key as e
   the child or record of this entry will be updated to the one of the entry
   this is useful when inserting a (key,record) in a tree where the key has already been inserted *)
Fixpoint update_le {X:Type} (e:entry X) (le:list (entry X)) : list (entry X) :=
  match le with
  | nil => nil                (* not possible *)
  | cons e' le' => if Ptrofs.eq (entry_key e) (entry_key e')
                  then cons e le'
                  else cons e' (update_le e le')
  end.

(* updates a child in a listentry *)
Fixpoint update_le_nth_child {X:Type} (i:Z) (le:list (entry X)) (n:node X) : list (entry X) :=
  match le with
  | nil => nil
  | cons e le' => if zle i 0
                          then  cons (keychild X (entry_key e) n) le'
                                 (* e is not expected to be a keyval *)
                         else update_le_nth_child (Z.pred i) le' n
  end.

(* updates value in a listentry *)
Fixpoint update_le_nth_val {X:Type} (i:Z) (le:list (entry X)) (newv:V) (newx:X) : list (entry X) :=
  match le with
  | nil => nil
  | cons e le' =>  if zle i 0
                          then cons (keyval X (entry_key e) newv newx) le'
                                  (* e is not expected to be a keychild *)
                         else update_le_nth_val (Z.pred i) le' newv newx
  end.

(* updates nth child of a node *)
Definition update_node_nth_child {X:Type} (i:Z) (oldn:node X) (n:node X) : node X :=
  match oldn with btnode ptr0 le isLeaf First Last x =>
  if zeq i (-1)
  then btnode X (Some n) le isLeaf First Last x
  else btnode X ptr0 (update_le_nth_child i le n) isLeaf First Last x
  end.

(* recursively updates a partial cursor and the corresponding relation wih a new node (to be put where the cursor points to)
   the new cursor will point to n *)
Fixpoint update_partial_cursor_rel {X:Type} (c:cursor X) (r:relation X) (n:node X) : (cursor X * relation X) :=
  match r with (root,prel) =>
  match c with
  | [] => ([], (n,prel))
  | (oldn,i)::c' =>
    let newn := update_node_nth_child i oldn n in
    let (newc',newrel) := update_partial_cursor_rel c' r newn in
    ((newn, i)::newc', newrel)
  end
  end.

Lemma update_partial_same_length: forall X (c:cursor X) r n,
    length c = length (fst (update_partial_cursor_rel c r n)).
Proof.
  intros. destruct r as [root prel].
  generalize dependent n.
  induction c as [|[n' i] c'].
  - simpl. auto.
  - intros. simpl.
    pose (u:= update_partial_cursor_rel c' (root, prel) (update_node_nth_child i n' n)).
    fold u.
    destruct u as [newc' newrel] eqn:HU. simpl.
    assert (length c' = length (fst u)). unfold u. apply IHc'. rewrite H. rewrite HU. simpl.
    auto.
Qed.

Lemma update_partial_snd_r X r: forall (c:cursor X) n,
      snd r = snd(snd (update_partial_cursor_rel c r n)).
Proof.
  destruct r. induction c; simpl; intros; trivial.
  destruct a; simpl in *.  remember (update_partial_cursor_rel c (n, x) (update_node_nth_child z n1 n0) ) .
  destruct p. simpl. specialize (IHc (update_node_nth_child z n1 n0)). rewrite <- Heqp in IHc. apply IHc.
Qed.

Lemma update_partial_cursor_result root i n prel: forall c' c nd ndd,
(c, (n, prel)) = update_partial_cursor_rel c' (root, prel) nd ->
map (fun x0 : node val * Z => Vint (Int.repr (snd x0)))
  ((nd, i) :: c') =
map (fun x0 : node val * Z => Vint (Int.repr (snd x0)))
  ((ndd,i) :: c).
Proof. induction c'; simpl; intros.
+ inv H; trivial.
+ destruct a. f_equal. remember (update_partial_cursor_rel c' (root, prel)(update_node_nth_child z n0 nd)).
  destruct p; inv H; simpl. f_equal. eapply (IHc' c0 (update_node_nth_child z n0 nd) nd) in Heqp; clear IHc'.
  simpl in Heqp. inv Heqp. trivial.
Qed.

Lemma update_partial_cursor_result' root i n prel: forall c' c nd ndd,
(c, (n, prel)) = update_partial_cursor_rel c' (root, prel) nd ->
map (fun x0 : node val * Z => Vint (Int.repr (snd x0)))
  ((ndd, i) :: c') =
map (fun x0 : node val * Z => Vint (Int.repr (snd x0)))
  ((nd,i) :: c).
Proof. induction c'; simpl; intros.
+ inv H; trivial.
+ destruct a. f_equal. remember (update_partial_cursor_rel c' (root, prel)(update_node_nth_child z n0 nd)).
  destruct p; inv H; simpl. f_equal. eapply (IHc' c0 (update_node_nth_child z n0 nd) nd) in Heqp; clear IHc'.
  simpl in Heqp. inv Heqp. trivial.
Qed.

(* recursively updates a cursor and the relation with a new node (that should replace the currNode)
   this need a non-empty cursor
   the index is unchanged. Should it be updated somehow?*)
Definition update_currnode_cursor_rel {X:Type} (c:cursor X) (r:relation X) (n:node X) : (cursor X * relation X) :=
  match c with
  | [] => (c,r)                  (* impossible, we ask for a non-empty cursor *)
  | (oldn, i)::c' =>
    let (newc',newrel) := update_partial_cursor_rel c' r n in
    ((n,i)::newc', newrel)
  end.

Lemma update_currnode_same_length: forall X (c:cursor X) r n,
    length c = length (fst (update_currnode_cursor_rel c r n)).
Proof.
  intros. destruct c as [|[n' i] c'].
  - simpl. auto.
  - simpl.
    pose (u:= update_partial_cursor_rel c' r n). fold u.
    destruct u as [newc' newrel] eqn:HU. simpl.
    assert(length c' = length (fst u)). unfold u. apply update_partial_same_length. rewrite H.
    rewrite HU. simpl. auto.
Qed.

(* inserts a new entry in a relation
   the cursor should point to where the entry has to be inserted
   newx is the addresses of the new nodes for splitnode. d is default value (shouldn't be used)
   we remember with oldk the key that was inserted in the tree: the cursor should point to it *)
Function putEntry {X:Type} (c:cursor X) (r:relation X) (e:entry X) (oldk:key) (newx:list X) (d:X) {measure length c}: (cursor X * relation X) :=
  match r with
    (root, prel) =>
    match c with
    | [] => let relation := ((btnode X (Some root) (* root has been split *)
                                    (cons e (nil))
                                    false       (* new root can't be leaf *)
                                    true
                                    true
                                    (hd d newx)), prel) in
           let cursor := moveToKey X (get_root relation) oldk [] in
           (cursor, relation)
    | (n,i)::c' =>
      match n with
        btnode ptr0 le isLeaf First Last x =>
        if isLeaf
        then
          if key_in_le (entry_key e) le
          then              (* the key is already in the tree, we only update the listentry *)
            let newle := update_le e le in
            let newn := btnode X ptr0 newle isLeaf First Last x in
            update_currnode_cursor_rel c r newn
          else
            if fullnode n
            then
              let newn := splitnode_left n e in
              let newe := splitnode_right n e (hd d newx) in
              let (newc,newr) := update_currnode_cursor_rel c r newn in
              putEntry (tl newc) newr newe oldk (tl newx) d (* recursive call on previous level *)
            else          (* we insert e in le, because the node isn't full *)
              let newle := insert_le le e in
              let newn := btnode X ptr0 newle isLeaf First Last x in
              update_currnode_cursor_rel c r newn
        else
          if fullnode n
          then
            let newn := splitnode_left n e in
            let newe := splitnode_right n e (hd d newx) in
            let (newc,newr) := update_currnode_cursor_rel c r newn in
            putEntry (tl newc) newr newe oldk (tl newx) d (* recusive call on previous level *)
          else
            let newle := insert_le le e in
            let newn := btnode X ptr0 newle isLeaf First Last x in
            let (newc,newr) := update_currnode_cursor_rel c r newn in
            let movec := moveToKey X newn oldk (tl newc) in
            (movec,newr)
      end
    end
  end.
Proof.
  intros.
  - pose (c'':=((btnode X ptr0 le true First Last x, i) :: c')). fold c''. fold c'' in teq6.
    assert (length c'' = length(fst(newc,newr))).
    rewrite <- teq6. apply update_currnode_same_length. rewrite H. simpl.
    destruct newc eqn:HC.
    + simpl in H. inv H.
    + simpl. lia.
  - intros.
    pose (c'':=((btnode X ptr0 le false First Last x, i) :: c')). fold c''. fold c'' in teq5.
    assert (length c'' = length(fst(newc,newr))).
    rewrite <- teq5. apply update_currnode_same_length. rewrite H. simpl.
    destruct newc eqn:HC.
    + simpl in H. inv H.
    + simpl. lia.
Qed.

(* Add a new (key,record) in a btree, updating cursor and relation
   x is the address of the new entry to insert
   newx is the list of addresses for the new nodes of splitnode *)
Definition RL_PutRecord {X:Type} (c:cursor X) (r:relation X) (key:key) (record:V) (x:X) (newx:list X) (d:X) : (cursor X * relation X) :=
  let c' := goToKey c r key in
  let e := keyval X key record x in
  let (putc, putr) := putEntry X c' r e key newx d in
  (RL_MoveToNext putc putr, putr).

(* Gets the record pointed to by the cursor *)
Definition RL_GetRecord (c:cursor val) r : val :=
  let normc := normalize c r in
  match getCVal normc with
  | None => nullval
  | Some x => x
  end.

Lemma FCI_increase: forall X (le:list (entry X)) key i,
    i <= findChildIndex' le key i.
Proof.
  intros. generalize dependent i.
  induction le; intros.
  - simpl. lia.
  - destruct a; simpl.
    * destruct (Ptrofs.ltu key0 k). lia.
      eapply Z.le_trans with (m:= Z.succ i). lia.
      apply IHle.
    * destruct (Ptrofs.ltu key0 k). lia.
      eapply Z.le_trans with (m:=Z.succ i). lia.
      apply IHle.
Qed.

Lemma FCI'_next_index {X: Type} (le: list (entry X)) key i:
  findChildIndex' le key (Z.succ i) = Z.succ (findChildIndex' le key i).
Proof.
  revert i.
  induction le as [|[k v x|k n] le]; simpl; try easy;
    destruct (Ptrofs.ltu key k); easy.
Qed.

Lemma FRI'_next_index {X: Type} (le: list (entry X)) key i:
  findRecordIndex' le key (Z.succ i) = Z.succ (findRecordIndex' le key i).
Proof.
  revert i.
  induction le as [|[k v x|k n] le]; simpl; try easy;
    destruct (Ptrofs.ltu k key); simpl; easy.
Qed.

Lemma FCI_inrange: forall X (n:node X) key,
    -1 <= findChildIndex n key < Zlength (node_le n).
Proof.
  intros X n key.
  destruct n as [ptr0 le isLeaf F L x]; simpl.
  induction le. easy. simpl.
  autorewrite with sublist.
  destruct a as [k v x'|k n]; destruct (Ptrofs.ltu key k);
  replace (findChildIndex' le key 0) with (Z.succ (findChildIndex' le key (-1))) by now rewrite <- FCI'_next_index.
  all: destruct (findChildIndex' le key (-1)); unfold  findChildIndex' in IHle |- *; lia.
Qed.

Lemma FCI_inrange'': forall X (le:list (entry X)) key j i,
    findChildIndex' le key j = i ->
    j <= i.
Proof.
  intros.
  revert j H; induction le; simpl; intros. lia.
  destruct a as [k v x'|k n]; destruct (Ptrofs.ltu key0 k); simpl in *; try lia.
  1,2: apply IHle in H; lia.
Qed.

Lemma FRI_increase: forall X (le:list (entry X)) key i,
    i <= findRecordIndex' le key i.
Proof.
  intros. generalize dependent i.
  induction le; intros.
  - simpl. lia.
  - destruct a; simpl.
    * destruct (Ptrofs.ltu k key0); simpl; try lia.
      eapply Z.le_trans with (m:= Z.succ i). lia.
      apply IHle.
    * destruct (Ptrofs.ltu k key0); simpl; try lia.
      eapply Z.le_trans with (m:= Z.succ i). lia.
      apply IHle.
Qed.

Lemma FRI_inrange: forall X (n:node X) key,
    0 <= findRecordIndex n key <= Zlength (node_le n).
Proof.
  intros X n key.
   destruct n as [ptr0 le isLeaf F L x]; simpl.
  rewrite <- (Z.add_0_r (Zlength le)).
  forget 0 as i.
  revert i; induction le; intros. easy.
  simpl. autorewrite with sublist.
  pose proof (Zlength_nonneg le).
  destruct (Ptrofs.ltu (entry_key a) key); simpl; try easy; try lia.
  specialize (IHle (Z.succ i));   lia.
Qed.


Require Import LibTactics.
Require Import Metalib.Metatheory.

Require Import
        syntax_ott
        rules_inf
        Infrastructure
        KeyProperties
        SubtypingInversion
        Disjointness
        Deterministic
        Progress.

Require Import Arith Lia.

#[export]
Hint Extern 0 => match goal with
                   | [ H1: ~topLike ?A, H2: topLike (t_rcd _ ?A) |- _ ] => (exfalso; apply H1; inverts H2)
                 end : falseHd.

Theorem consistent_sound: forall v1 v2 A B,
    value v1 -> value v2 ->
    Typing nil v1 Inf A -> Typing nil v2 Inf B ->
    consistent v1 v2 -> consistencySpec v1 v2.
Proof.
  intros v1 v2 A B Val1 Val2 Typ1 Typ2 Cons.
  unfolds. intros C v1' v2' Ord R1 R2.
  forwards*: TypedReduce_unique Cons.
Qed.

Lemma consistent_mergel: forall v1 v2 v,
    consistent (e_merge v1 v2) v -> consistent v1 v /\ consistent v2 v.
Proof.
  intros v1 v2 v H.
  inductions H.
  -
    inverts H.
    lets* (?&?): disjoint_splitl H1.
  - split; eauto.
  - forwards (?&?): IHconsistent1; try reflexivity; auto.
    forwards (?&?): IHconsistent2; try reflexivity; auto.
Qed.

Lemma consistent_merger: forall v1 v2 v,
    consistent v (e_merge v1 v2) -> consistent v v1 /\ consistent v v2.
Proof.
  intros v1 v2 v H.
  inductions H.
  -
    inverts H0.
    lets* (?&?): disjoint_splitr H1.
  - forwards (?&?): IHconsistent1; try reflexivity; auto.
    forwards (?&?): IHconsistent2; try reflexivity; auto.
  - split; eauto.
Qed.

Lemma consistencySpec_mergel: forall v1 v2 v,
    lc_exp v1 -> lc_exp v2 -> consistencySpec (e_merge v1 v2) v -> consistencySpec v1 v /\ consistencySpec v2 v.
Proof.
  intros v1 v2 v Lc1 Lc2 H.
  split; unfolds; intros.
  - forwards*: H A.
  - forwards*: H A.
Qed.

Lemma consistencySpec_merger: forall v1 v2 v,
    lc_exp v1 -> lc_exp v2 -> consistencySpec v (e_merge v1 v2) -> consistencySpec v v1 /\ consistencySpec v v2.
Proof.
  intros v1 v2 v Lc1 Lc2 H.
  split; unfolds; intros.
  - forwards*: H A.
  - forwards*: H A.
Qed.

Lemma consistencySpec_lams_inv : forall T1 T2 e1 e2 A1 A2 B1 B2,
    Typing nil (e_abs A1 e1 B1) Inf T1 -> Typing nil (e_abs A2 e2 B2) Inf T2 ->
    consistencySpec (e_abs A1 e1 B1) (e_abs A2 e2 B2) -> disjoint B1 B2 \/ (e1=e2) /\ (A1=A2).
Proof.
  introv Typ1 Typ2 Cons.
  inverts keep Typ1. inverts keep Typ2.
  lets~ [?|(?&?&?&?&?)]: disjoint_or_exists B1 B2.
  right.
  assert (S1: algo_sub (t_arrow A1 B1) (t_arrow (t_and A1 A2) x)) by auto_sub.
  assert (S2: algo_sub (t_arrow A2 B2) (t_arrow (t_and A1 A2) x)) by auto_sub.
  forwards~ T1: Typ_sub Typ1 S1.
  forwards~ T2: Typ_sub Typ2 S2.
  forwards* (?&R1) : TypedReduce_progress T1.
  forwards* (?&R2) : TypedReduce_progress T2.
  forwards~ : Cons R1 R2.
  inverts keep R1; inverts keep R2; solve_false.
  (* TEMP0 : e_abs A0 e0 x = e_abs A e x *)
  inverts~ TEMP0.
Qed.

Lemma consistencySpec_rcd_inv : forall T1 T2 l v1 v2,
    value v1 -> value v2 -> nil ⊢ v1 ⇒ T1 -> nil ⊢ v2 ⇒ T2 ->
    consistencySpec (e_rcd l v1) (e_rcd l v2) -> consistencySpec v1 v2.
Proof.
  intros T1 T2 l v1 v2 Val1 Val2 Typ1 Typ2 Cons.
  unfolds. introv Ord R1 R2.
  destruct (toplike_decidable A).
  - forwards~: TypedReduce_toplike R1 R2.
  - forwards*: Cons (t_rcd l A).
    inversion~ H0.
Qed.

Ltac indExpSize s :=
  assert (SizeInd: exists i, s < i) by eauto;
  destruct SizeInd as [i SizeInd];
  repeat match goal with | [ h : exp |- _ ] => (gen h) end;
  induction i as [|i IH]; [
      intros; match goal with | [ H : _ < 0 |- _ ] => inverts H end
    | intros ].

Theorem consistent_complete: forall v1 v2 A B,
    value v1 -> value v2 ->
    Typing nil v1 Inf A -> Typing nil v2 Inf B ->
    consistencySpec v1 v2 -> consistent v1 v2.
Proof with (simpl; try lia; auto).
  intros v1 v2 A B Val1 Val2 Typ1 Typ2 Cons. gen Val1 Val2 Cons A B.
  indExpSize (size_exp v1 + size_exp v2);
  inverts Val1 as V1_1 V1_2; inverts Val2 as V2_1 V2_2; simpl in SizeInd;
    try solve [
          inverts Typ1 as T1_1 T1_2; inverts Typ2 as T2_1 T2_2;
            match goal with
            | |- consistent (e_merge _ _) _ =>
              ( lets~ (C1&C2): consistencySpec_mergel Cons;
                forwards*: IH C1; simpl; try lia; auto;
                try forwards*: IH C2; simpl; try lia; auto
              )
            | |- consistent _ (e_merge _ _) =>
              ( lets~ (C1&C2): consistencySpec_merger Cons;
                forwards*: IH C1; simpl; try lia; auto;
                try forwards*: IH C2; simpl; try lia; auto
              )
            | _ =>
              ( applys C_disjoint; constructor* )
            end].
  - (* lit *)
    inverts keep Typ1; inverts keep Typ2.
    enough (i5=i0).
    subst~.
    forwards* (?&R1) : TypedReduce_progress (e_lit i0).
    forwards* (?&R2) : TypedReduce_progress (e_lit i5).
    forwards*: Cons. subst*.
    forwards R1': TReduce_refl i0. forwards R2': TReduce_refl i5.
    forwards*: TypedReduce_unique R1 R1'.
    forwards*: TypedReduce_unique R2 R2'.
    congruence.
  - (* abs *)
    forwards* [?|(?&?)]: consistencySpec_lams_inv Cons.
    + applys* C_disjoint.
    + subst*.
  - (* rcd *)
    inverts keep Typ1; inverts keep Typ2.
    destruct (l0==l1).
    + subst*.
      forwards~ Con': consistencySpec_rcd_inv H1 H2 Cons.
      forwards*: IH Con'...
    + applys C_disjoint; constructor*.
Qed.

Lemma consistent_lams_inv : forall T1 T2 e1 e2 A1 A2 B1 B2,
    Typing nil (e_abs A1 e1 B1) Inf T1 -> Typing nil (e_abs A2 e2 B2) Inf T2 ->
    consistent (e_abs A1 e1 B1) (e_abs A2 e2 B2) -> disjoint B1 B2 \/ (e1=e2) /\ (A1=A2).
Proof.
  introv Typ1 Typ2 Cons.
  eapply consistent_sound in Cons; eauto.
  forwards* : consistencySpec_lams_inv Cons.
Qed.

Lemma consistent_rcd_inv : forall l v1 v2,
    consistent (e_rcd l v1) (e_rcd l v2) -> consistent v1 v2.
Proof.
  intros l v1 v2 H.
  inverts~ H.
  - inverts H0. inverts H1.
    enough (Dis: disjoint A0 A).
    applys* C_disjoint Dis. eauto.
Qed.

#[export]
Hint Immediate consistent_rcd_inv : core.

Lemma consistent_top_l : forall u v,
    consistent u v -> consistent e_top v.
Proof.
  introv Hc.
  forwards Hp: consistent_prevalue2 Hc.
  forwards (?&?): prevalue_exists_ptype Hp.
  applys* C_disjoint.
Qed.

Lemma consistent_top_r : forall u v,
    consistent u v -> consistent u e_top.
Proof.
  introv Hc.
  forwards Hp: consistent_prevalue1 Hc.
  forwards (?&?): prevalue_exists_ptype Hp.
  applys* C_disjoint.
Qed.

Lemma consistent_meg_l : forall v u1 u2,
    consistent (e_merge u1 u2) v <-> consistent (meg_exp u1 u2) v.
Proof.
  split; introv Hc.
  - forwards* (?&?): consistent_mergel Hc.
    destruct u1; destruct u2; simpl; eauto.
  - destruct u1; destruct u2; simpl in Hc; eauto; constructor*.
    all: applys* consistent_top_l.
Qed.

Lemma consistent_meg_r : forall v u1 u2,
    consistent v (e_merge u1 u2) <-> consistent v (meg_exp u1 u2).
Proof.
  split; introv Hc.
  - forwards* (?&?): consistent_merger Hc.
    destruct u1; destruct u2; simpl; eauto.
  - destruct u1; destruct u2; simpl in Hc; eauto; constructor*.
    all: applys* consistent_top_r.
Qed.


(*
Pretty print for terms with bruijn indices
(it might be easier to go the other way
and print coq terms with indices)

For a complete pretty print with names
unquote and use Coqs Print Command

It is useful as debugging if a term does not type
 *)

Require Import MetaCoq.Template.All.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction
     PCUICLiftSubst PCUICEquality
     PCUICUnivSubst PCUICTyping PCUICGeneration.

From MetaCoq.PCUIC Require Import TemplateToPCUIC.

Require Import List String.
Require Import Ascii.
Require Import Program Arith Lia PeanoNat.
Import ListNotations MCMonadNotation Nat.

Definition ascii_to_string (a:ascii) : string := String a (EmptyString).
Definition natToChar (n:nat) : ascii := ascii_of_nat(48+n).

Program Fixpoint natToString (n:nat) {measure n} : string :=
  match leb n 9 with
    true =>
    ascii_to_string (natToChar n)
  | false =>
    append (natToString (Nat.div n 10)) (ascii_to_string(natToChar(Nat.modulo n 10)))
  end.
Next Obligation.
  symmetry in Heq_anonymous.
  apply leb_complete_conv in Heq_anonymous.
  pose proof (divmod_spec n 9 0 9).
  destruct divmod.
  destruct H;trivial.
  cbn. lia.
Qed.

Infix ":s" := String (at level 73).
Infix "+s" := append (at level 72).
Definition linebreak := ascii_to_string(ascii_of_nat 10).

Definition join (xs:list string) : string :=
  fold_left append xs EmptyString.

Require Import String.
Open Scope string_scope.

(* needed for mutual inductive types *)
Definition getInductiveName (ind:kername) (indIndex:nat) :TemplateMonad string :=
  ind <- tmQuoteInductive ind;;
  tmEval lazy match nth_error (trans_minductive_body ind).(ind_bodies) indIndex with
           | None => ""
           | Some b => b.(ind_name)
              end.

Definition getConstructName (ind:kername) (indIndex:nat) (consIndex:nat) :TemplateMonad string :=
  ind <- tmQuoteInductive ind;;
  tmEval lazy match nth_error (trans_minductive_body ind).(ind_bodies) indIndex with
           | None => ""
           | Some b => match nth_error b.(ind_ctors) consIndex with
                        None => ""
                      | Some (s,_,_) => s
                      end
           end.

Definition nameToString (s:name) : string :=
  match s with
    nAnon => "_"
  | nNamed s => s
  end.

Definition concatString (xs:list string) : string :=
  fold_left (fun a b => a +s b) xs "".

(* Print kername.
Print ident.
Print tmQuoteInductive. *)

Fixpoint bruijn_print_aux (t:term) : TemplateMonad string :=
  match t with
  | tRel n => tmReturn("R" :s (natToString n))
  | tVar ident => tmReturn(ident)
  | tEvar n xs => tmReturn "TODO:EVAR"
  | tSort univ =>
    tmReturn "tSort ?"
  | tProd n t t2 => match n.(binder_name) with
                   | nAnon => s1 <- bruijn_print_aux t;;
                             s2 <- bruijn_print_aux t2;;
                             tmReturn("(":s append s1 (append ") -> " s2))
                   | nNamed s => s1 <- bruijn_print_aux t;;
                                s2 <- bruijn_print_aux t2;;
                                tmReturn("∀ (" +s s +s (" : "+s s1) +s "), " +s s2)
                   end
  | tLambda s t t2 => s1 <- bruijn_print_aux t;;
                    s2 <- bruijn_print_aux t2;;
                    tmReturn("λ ("+s match s.(binder_name) with
                        nAnon => "_"
                      | nNamed s => s
                      end
                     +s " : "+s s1+s"). "+s s2)
  | tLetIn name t1 t2 t3 =>
    s1 <- bruijn_print_aux t1;;
    s2 <- bruijn_print_aux t2;;
    s3 <- bruijn_print_aux t3;;
    tmReturn("let "+s (nameToString name.(binder_name)) +s " := "+s s1 +s " : " +s s2 +s " in "+s linebreak +s s3)
  | tApp t1 t2 =>
    s1 <- bruijn_print_aux t1;;
    s2 <- bruijn_print_aux t2;;
    tmReturn("(" +s s1 +s " " +s s2 +s ")")
  | tConst kn ui => let (_,name) := kn in tmReturn name
  | tInd ind ui => getInductiveName ind.(inductive_mind) ind.(inductive_ind)
  | tConstruct ind n ui => getConstructName ind.(inductive_mind) ind.(inductive_ind) n
  | tCase (ind,n) p c brs =>
    sc <- bruijn_print_aux c;;
    sp <- bruijn_print_aux p;;
    sb <- fold_left (fun sa x => match x with (n,t) => st <- bruijn_print_aux t;;sb <- sa;;tmReturn (sb +s " | ("+s(natToString n)+s") " +s st +s linebreak) end) brs (tmReturn "");;
    tmReturn(linebreak +s "match (P:" +s (natToString n) +s ") "+s sc +s " return " +s sp +s " with" +s linebreak +s
            sb +s
             "end")
  | tProj p t => tmReturn "TODO:Proj"
  | tFix mf n =>
    (fix f xs := match xs with
                  nil => tmReturn ""
                | mfb::xs =>
                  sr <- f xs;;
          stype <- bruijn_print_aux (mfb.(dtype));;
          sbody <- bruijn_print_aux (mfb.(dbody));;
          tmReturn (linebreak +s "(fix "+s (nameToString mfb.(dname).(binder_name)) +s " : " +s stype +s " := " +s linebreak +s sbody +s ") "+s sr)
                end
    ) mf
  | _ => tmReturn "TODO"
  end.

Definition bruijn_print (t:term) : TemplateMonad unit :=
  s <- bruijn_print_aux t;;
  val <- tmEval lazy s;;
  tmMsg val.

MetaCoq Quote Definition printTest :=
  (forall (P:nat->Prop) (H0:P 0) (HS: forall n, P n -> P (S n)) (n:nat), P n).

(* MetaCoq Run (bruijn_print (trans printTest)). *)