(*

  Copyright 2014 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

*)

Add LoadPath "close".

Require Export nuprl_type_sys.
Require Export univ_tacs.
Require Import rel_nterm.
(** printing #  $\times$ #×# *)
(** printing <=>  $\Leftrightarrow$ #⇔# *)
(** printing ~<~  $\preceq$ *)
(** printing ~=~  $\sim$ *)
(* printing ===>  $\longmapsto$ *)
(** printing ===>  $\Downarrow$ *)
(** printing [[  $[$ *)
(** printing ]]  $]$ *)
(** printing \\  $\backslash$ *)
(** printing mkc_axiom   $\mathtt{Ax}$ *)
(** printing mkc_base    $\mathtt{Base}$ *)
(** printing mkc_int     $\intg$ *)
(** printing mkc_integer $\mathtt{int}$ *)

Lemma nuprli_refl {p} :
  forall lib i t1 t2 eq,
    @nuprli p lib i t1 t2 eq -> nuprli lib i t1 t1 eq.
Proof.
  intros.
  generalize (@nuprli_type_system p lib i); intro nts.
  dest_ts nts.
  apply ts_tyt with (T2 := t2); sp.
Qed.

(*
(* COMMENTED OUT BECAUSE MIGHT CAUSE A UNIVERSE INCONSISTENCY *)
Lemma tequalityi_eq :
  forall i T1 T2,
    tequalityi i T1 T2 <=> {eq : per , nuprli i T1 T2 eq}.
Proof.
  unfold tequalityi, equality; split; introv e; exrepnd.

  - inversion e1; try not_univ.
    duniv j h.
    allrw univi_exists_iff; exrepd.
    computes_to_value_isvalue; GC.
    discover; exrepnd.
    allfold (nuprli j0).
    exists eqa; sp.

  - exists (fun A A' => {eq : per , close (univi i) A A' eq}).
    allfold (nuprli i); dands.
    apply CL_init; unfold univ.
    exists (S i); simpl; left; sp; try (spcast; apply computes_to_valc_refl; sp).
    exists eq; sp.
Qed.

Lemma univi_exists_iff2 :
  forall i T T' eq,
    univi i T T' eq
    <=> {j : nat
          , j < i
          # ccomputes_to_valc T  (mkc_uni j)
          # ccomputes_to_valc T' (mkc_uni j)
          # eq_term_equals eq (tequalityi j)}.
Proof.
  introv.
  rw univi_exists_iff; split; sp.

  exists j; sp.
  unfold eq_term_equals; sp.
  allrw.
  rw tequalityi_eq; sp.

  exists j; sp.
  allrw.
  rw tequalityi_eq; sp.
Qed.
*)

Lemma equality_eq_refl {p} :
  forall lib A B a b eq,
    @nuprl p lib A B eq
    -> eq a b
    -> eq a a.
Proof.
  sp; nts.
  eapply type_system_term_mem; eauto.
Qed.

Lemma equality_eq_sym {p} :
  forall lib A B a b eq,
    @nuprl p lib A B eq
    -> eq a b
    -> eq b a.
Proof.
  sp; nts.
  apply nts_tes with (T := A) (T' := B); sp.
Qed.

Lemma equality_eq_trans {p} :
  forall lib A B a b c eq,
    @nuprl p lib A B eq
    -> eq a b
    -> eq b c
    -> eq a c.
Proof.
  sp; nts.
  apply nts_tet with (T := A) (T' := B) (t2 := b); sp.
Qed.

Lemma equality_sym {p} :
  forall lib t1 t2 T,
    @equality p lib t1 t2 T -> equality lib t2 t1 T.
Proof.
  unfold equality; sp.
  exists eq; sp.
  eapply equality_eq_sym; eauto.
Qed.
Hint Resolve equality_sym : nequality.

Lemma equality_trans {p} :
  forall lib t1 t2 t3 T,
    @equality p lib t1 t2 T -> equality lib t2 t3 T -> equality lib t1 t3 T.
Proof.
  unfold equality; introv e1 e2; exrepnd.
  apply nuprl_uniquely_valued with (eq1 := eq0) in e2; auto.
  exists eq0; auto.
  rw <- e2 in e0; sp.
  eapply equality_eq_trans; eauto.
Qed.
Hint Resolve equality_trans : nequality.

Lemma tequality_sym {p} :
  forall lib t1 t2,
    @tequality p lib t1 t2 -> tequality lib t2 t1.
Proof.
  unfold tequality; sp.
  exists eq.
  apply nuprl_sym; sp.
Qed.
Hint Resolve tequality_sym : nequality.

Lemma tequality_refl {p} :
  forall lib t1 t2,
    @tequality p lib t1 t2 -> tequality lib t1 t1.
Proof.
  unfold tequality; introv t; exrepnd.
  exists eq.
  apply nuprl_refl in t0; sp.
Qed.
Hint Resolve tequality_refl : nequality.

Lemma tequality_trans {p} :
  forall lib t1 t2 t3,
    @tequality p lib t1 t2 -> tequality lib t2 t3 -> tequality lib t1 t3.
Proof.
  unfold tequality; sp.
  exists eq0.
  eapply nuprl_trans; eauto.
Qed.
Hint Resolve tequality_trans : nequality.

Lemma member_eq {p} :
  forall lib t T,
    @equality p lib t t T = member lib t T.
Proof.
  unfold member; auto.
Qed.

Lemma fold_type {p} :
  forall lib T,
    @tequality p lib T T = type lib T.
Proof.
  unfold type; auto.
Qed.

Lemma fold_equorsq {p} :
  forall lib t1 t2 T,
    (@equality p lib t1 t2 T {+} ccequivc lib t1 t2) = equorsq lib t1 t2 T.
Proof. sp. Qed.

Lemma fold_equorsq2 {p} :
  forall lib t1 t2 t3 t4 T,
    (@equorsq p lib t1 t2 T # equorsq lib t3 t4 T) = equorsq2 lib t1 t2 t3 t4 T.
Proof. sp. Qed.

Lemma equality_refl {p} :
  forall lib t1 t2 T,
    @equality p lib t1 t2 T -> member lib t1 T.
Proof.
  unfold member, equality; sp.
  exists eq; sp.
  eapply equality_eq_refl; eauto.
Qed.
Hint Resolve equality_refl : nequality.

Lemma tequality_iff_nuprl {p} :
  forall lib a b,
    {eq : per(p) , nuprl lib a b eq} <=> tequality lib a b.
Proof.
  sp.
Qed.

Lemma tequality_if_nuprl {p} :
  forall lib a b eq,
    @nuprl p lib a b eq -> tequality lib a b.
Proof.
  sp.
  apply tequality_iff_nuprl; exists eq; sp.
Qed.

Lemma equality_eq {p} :
  forall lib A a b eq,
    @nuprl p lib A A eq
    -> (eq a b <=> equality lib a b A).
Proof.
  sp; split; intro k.
  unfold equality; exists eq; sp.
  unfold equality in k; sp.
  assert (eq_term_equals eq eq0) as eqt.
  eapply nuprl_uniquely_valued with (t := A); eauto.
  unfold eq_term_equals in eqt.
  apply eqt; sp.
Qed.

Lemma equality_eq1 {p} :
  forall lib A B a b eq,
    @nuprl p lib A B eq
    -> (eq a b <=> equality lib a b A).
Proof.
  introv n; split; intro k.
  unfold equality; exists eq; sp.
  apply nuprl_refl in n; sp.
  unfold equality in k; sp.
  assert (eq_term_equals eq eq0) as eqt.
  eapply nuprl_uniquely_valued with (t := A); eauto.
  apply nuprl_refl in n; sp.
  unfold eq_term_equals in eqt.
  apply eqt; sp.
Qed.

Lemma eqorceq_commutes_equality {p} :
  forall lib a b c d eq A B,
    @nuprl p lib A B eq
    -> eqorceq lib eq a b
    -> eqorceq lib eq c d
    -> (equality lib a c A <=> equality lib b d B).
Proof.
  introv n eos1 eos2.
  applydup @nuprl_sym  in n  as n0.
  applydup @nuprl_refl in n0 as n1.
  applydup @nuprl_refl in n  as n2.
  rw <- (equality_eq1 lib A B a c eq n).
  rw <- (equality_eq1 lib B A b d eq n0).
  nts.
  split; sp.
  apply (eqorceq_commutes lib) with (a := a) (c := c); auto.
  apply nts_tev with (T := A); auto.
  apply nts_tes with (T := A) (T' := A); auto.
  apply nts_tet with (T := A) (T' := A); auto.
  apply (eqorceq_commutes lib) with (a := b) (c := d); auto.
  apply nts_tev with (T := A); auto.
  apply nts_tes with (T := A) (T' := A); auto.
  apply nts_tet with (T := A) (T' := A); auto.
  apply eqorceq_sym; auto.
  apply nts_tes with (T := A) (T' := A); auto.
  apply eqorceq_sym; auto.
  apply nts_tes with (T := A) (T' := A); auto.
Qed.

Lemma eq_equality1 {p} :
  forall lib a b A (eq : per(p)),
    eq a b
    -> nuprl lib A A eq
    -> equality lib a b A.
Proof.
  introv e n.
  unfold equality.
  exists eq; sp.
Defined.

Lemma eq_equality2 {p} :
  forall lib a b A B (eq : per(p)),
    eq a b
    -> nuprl lib A B eq
    -> equality lib a b A.
Proof.
  introv e n.
  unfold equality.
  exists eq; sp.
  apply nuprl_refl in n; sp.
Defined.

Lemma eq_equality3 {p} :
  forall lib a b A B (eq : per(p)) i,
    eq a b
    -> nuprli lib i A B eq
    -> equality lib a b A.
Proof.
  introv e n.
  exists eq; sp.
  apply nuprli_implies_nuprl in n; sp.
  apply nuprl_refl in n; sp.
Qed.

Lemma equality_respects_cequivc {p} :
  forall lib t1 t2 T,
    @cequivc p lib t1 t2
    -> member lib t1 T
    -> equality lib t1 t2 T.
Proof.
  unfold member, equality; sp.
  exists eq; sp.
  nts.
  apply nts_tev with (T := T); sp; spcast; sp.
Qed.
Hint Resolve equality_respects_cequivc : nequality.

Lemma equality_respects_alphaeqc {p} :
  forall lib t1 t2 T,
    @alphaeqc p t1 t2
    -> member lib t1 T
    -> equality lib t1 t2 T.
Proof.
  unfold member, equality; introv a m; exrepnd.
  exists eq; sp.
  nts.
  apply nts_tev with (T := T); sp; spcast.
  apply alphaeqc_implies_cequivc; sp.
Qed.
Hint Resolve equality_respects_alphaeqc : nequality.

Lemma equality_respects_cequivc_left {p} :
  forall lib t1 t2 t T,
    @cequivc p lib t1 t
    -> equality lib t1 t2 T
    -> equality lib t t2 T.
Proof.
  sp.
  apply @equality_trans with (t2 := t1); sp.
  apply equality_sym.
  apply equality_respects_cequivc; sp.
  allapply @equality_refl; sp.
Qed.
Hint Resolve equality_respects_cequivc_left : nequality.

Lemma equality_respects_cequivc_right {p} :
  forall lib t1 t2 t T,
    @cequivc p lib t2 t
    -> equality lib t1 t2 T
    -> equality lib t1 t T.
Proof.
  introv c e.
  apply @equality_trans with (t2 := t2); sp.
  apply equality_respects_cequivc; sp.
  apply equality_sym in e.
  allapply @equality_refl; sp.
Qed.
Hint Resolve equality_respects_cequivc_right : nequality.

Lemma equality_respects_alphaeqc_left {p} :
  forall lib t1 t2 t T,
    @alphaeqc p t1 t
    -> equality lib t1 t2 T
    -> equality lib t t2 T.
Proof.
  sp.
  apply @equality_trans with (t2 := t1); sp.
  apply equality_sym.
  apply equality_respects_cequivc; sp.
  apply alphaeqc_implies_cequivc; sp.
  allapply @equality_refl; sp.
Qed.
Hint Resolve equality_respects_alphaeqc_left : nequality.

Lemma equality_respects_alphaeqc_right {p} :
  forall lib t1 t2 t T,
    @alphaeqc p t2 t
    -> equality lib t1 t2 T
    -> equality lib t1 t T.
Proof.
  introv a e.
  apply @equality_trans with (t2 := t2); sp.
  apply equality_respects_cequivc; sp.
  apply alphaeqc_implies_cequivc; sp.
  apply equality_sym in e.
  allapply @equality_refl; sp.
Qed.
Hint Resolve equality_respects_alphaeqc_right : nequality.

Lemma tequality_respects_cequivc_left {p} :
  forall lib T1 T2 T3,
    @cequivc p lib T1 T3
    -> tequality lib T1 T2
    -> tequality lib T3 T2.
Proof.
  unfold tequality; sp.
  exists eq.
  apply nuprl_value_respecting_left with (t1 := T1); auto.
Qed.
Hint Resolve tequality_respects_cequivc_left : nequality.

Lemma tequality_respects_cequivc_right {p} :
  forall lib T1 T2 T3,
    @cequivc p lib T2 T3
    -> tequality lib T1 T2
    -> tequality lib T1 T3.
Proof.
  unfold tequality; sp.
  exists eq.
  apply nuprl_value_respecting_right with (t2 := T2); auto.
Qed.
Hint Resolve tequality_respects_cequivc_right : nequality.

Lemma tequality_respects_alphaeqc_left {p} :
  forall lib T1 T2 T3,
    @alphaeqc p T1 T3
    -> tequality lib T1 T2
    -> tequality lib T3 T2.
Proof.
  unfold tequality; sp.
  exists eq.
  apply nuprl_value_respecting_left with (t1 := T1); auto.
  apply alphaeqc_implies_cequivc; sp.
Qed.
Hint Resolve tequality_respects_alphaeqc_left : nequality.

Lemma tequality_respects_alphaeqc_right {p} :
  forall lib T1 T2 T3,
    @alphaeqc p T2 T3
    -> tequality lib T1 T2
    -> tequality lib T1 T3.
Proof.
  unfold tequality; sp.
  exists eq.
  apply nuprl_value_respecting_right with (t2 := T2); auto.
  apply alphaeqc_implies_cequivc; sp.
Qed.
Hint Resolve tequality_respects_alphaeqc_right : nequality.

Lemma type_respects_cequivc_left {p} :
  forall lib T T',
    @cequivc p lib T T'
    -> type lib T
    -> tequality lib T' T.
Proof.
  unfold type; sp.
  apply tequality_respects_cequivc_left with (T1 := T); auto.
Qed.
Hint Resolve type_respects_cequivc_left : nequality.

Lemma type_respects_cequivc_right {p} :
  forall lib T T',
    @cequivc p lib T T'
    -> type lib T
    -> tequality lib T T'.
Proof.
  unfold type; sp.
  apply tequality_respects_cequivc_right with (T2 := T); auto.
Qed.
Hint Resolve type_respects_cequivc_right : nequality.

Lemma type_respects_alphaeqc_left {p} :
  forall lib T T',
    @alphaeqc p T T'
    -> type lib T
    -> tequality lib T' T.
Proof.
  unfold type; sp.
  apply tequality_respects_alphaeqc_left with (T1 := T); auto.
Qed.

Lemma type_respects_alphaeqc_right {p} :
  forall lib T T',
    @alphaeqc p T T'
    -> type lib T
    -> tequality lib T T'.
Proof.
  unfold type; sp.
  apply tequality_respects_alphaeqc_right with (T2 := T); auto.
Qed.

Lemma cequivc_preserving_equality {p} :
  forall lib a b A B,
    @equality p lib a b A
    -> cequivc lib A B
    -> equality lib a b B.
Proof.
  unfold equality; introv e c; exrepnd.
  nts.
  unfold type_value_respecting in nts_tyv.
  apply nts_tyv with (eq := eq) in c; sp.
  exists eq; sp.
  generalize (type_system_type_mem2 (nuprl lib) A B eq); sp.
Qed.

Lemma alphaeqc_preserving_equality {p} :
  forall lib a b A B,
    @equality p lib a b A
    -> alphaeqc A B
    -> equality lib a b B.
Proof.
  unfold equality; introv e al; exrepnd.
  nts.
  unfold type_value_respecting in nts_tyv.
  apply (alphaeqc_implies_cequivc lib) in al.
  apply nts_tyv with (eq := eq) in al; sp.
  exists eq; sp.
  generalize (type_system_type_mem2 (nuprl lib) A B eq); sp.
Qed.

Lemma tequality_preserving_equality {p} :
  forall lib a b A B,
    @equality p lib a b A
    -> tequality lib A B
    -> equality lib a b B.
Proof.
  unfold tequality, equality; introv e t; exrepnd.
  nts.
  assert (nuprl lib A A eq # nuprl lib B B eq) as n; repd.
  apply type_system_type_mem2; sp.
  exists eq; sp.
  assert (eq_term_equals eq0 eq) as eqt.
  apply uniquely_valued_eq with (ts := nuprl lib) (T := A) (T1 := A) (T2 := A); sp.
  apply eqt; sp.
Qed.
Hint Resolve tequality_preserving_equality : nequality.

Lemma tequalityi_refl {p} :
  forall lib l T1 T2, @tequalityi p lib l T1 T2 -> tequalityi lib l T1 T1.
Proof.
  unfold tequalityi; sp.
  allapply @equality_refl; sp.
Qed.

Lemma eqtypes_refl {p} :
  forall lib l T1 T2, @eqtypes p lib l T1 T2 -> eqtypes lib l T1 T1.
Proof.
  destruct l; simpl; sp.
  allapply @tequality_refl; sp.
  allapply @tequalityi_refl; sp.
Qed.

Lemma tequalityi_preserving_equality {p} :
  forall lib i a b A B,
    @equality p lib a b A
    -> tequalityi lib i A B
    -> equality lib a b B.
Proof.
  unfold tequalityi, equality; introv e teq; exrepnd.
  inversion teq1; try not_univ.
  duniv j h.
  allrw @univi_exists_iff; exrepd.
  discover; exrepnd.
  allfold (@nuprli p lib j0).
  allapply @nuprli_implies_nuprl.
  nts.
  assert (nuprl lib A A eqa # nuprl lib B B eqa); repd.
  apply type_system_type_mem2; sp.
  exists eqa; sp.
  assert (eq_term_equals eq0 eqa) as k.
  apply uniquely_valued_eq with (ts := nuprl lib) (T := A) (T1 := A) (T2 := A); sp.
  allunfold @eq_term_equals.
  apply k; auto.
Qed.

Lemma eqtypes_preserving_equality {p} :
  forall lib l a b A B,
    @equality p lib a b A
    -> eqtypes lib l A B
    -> equality lib a b B.
Proof.
  destruct l; introv eq eqt.
  apply @tequality_preserving_equality with (A := A); sp.
  apply @tequalityi_preserving_equality with (A := A) (i := n); sp.
Qed.

Lemma tequalityi_sym {p} :
  forall lib i T1 T2, @tequalityi p lib i T1 T2 -> tequalityi lib i T2 T1.
Proof.
  unfold tequalityi; introv teq.
  apply equality_sym; sp.
Qed.

Lemma eqtypes_sym {p} :
  forall lib l T1 T2, @eqtypes p lib l T1 T2 -> eqtypes lib l T2 T1.
Proof.
  destruct l; introv eqt.
  apply tequality_sym; sp.
  apply tequalityi_sym; sp.
Qed.

Lemma tequalityi_trans {p} :
  forall lib i t1 t2 t3,
    @tequalityi p lib i t1 t2
    -> tequalityi lib i t2 t3
    -> tequalityi lib i t1 t3.
Proof.
  unfold tequalityi; introv teq1 teq2.
  apply @equality_trans with (t2 := t2); sp.
Qed.

Lemma eqtypes_trans {p} :
  forall lib l t1 t2 t3,
    @eqtypes p lib l t1 t2
    -> eqtypes lib l t2 t3
    -> eqtypes lib l t1 t3.
Proof.
  destruct l; introv teq1 teq2.
  apply @tequality_trans with (t2 := t2); sp.
  apply @tequalityi_trans with (t2 := t2); sp.
Qed.

Lemma equality3_implies_cequorsq2 {p} :
  forall lib a b c d T,
    @equality p lib a c T
    -> equality lib b d T
    -> equality lib a b T
    -> equorsq2 lib a b c d T.
Proof.
  sp.
  unfold equorsq2, equorsq; sp.
  left.
  apply equality_trans with (t2 := b); auto.
  apply equality_trans with (t2 := a); auto.
  apply equality_sym; auto.
Qed.

Lemma inhabited_implies_tequality {p} :
  forall lib t1 t2 T,
    @equality p lib t1 t2 T -> type lib T.
Proof.
  unfold equality, type, tequality; introv eq; exrepnd.
  exists eq0; sp.
Qed.

Hint Resolve tequality_preserving_equality cequivc_preserving_equality : nequality.

Lemma cequivc_equality {p} : forall lib, respects3 (cequivc lib) (@equality p lib).
Proof.
  introv; unfolds_base; dands; introv Hr Heq;
  eauto 3 with nequality.
Qed.
Hint Resolve cequivc_equality : respects.

Lemma sym_cequivc_eauto {p} : forall lib, symm_rel (@cequivc p lib).
Proof.
  introv Hab.
  apply cequivc_sym; auto.
Qed.
Hint Resolve sym_cequivc_eauto : nequality.
Hint Resolve sym_cequivc_eauto : respects.

Lemma cequorsq2_prop {p} :
  forall lib A a1 a2 b1 b2,
    @equorsq2 p lib a1 b1 a2 b2 A
    -> equality lib a1 a2 A
    -> equality lib a1 b2 A.
Proof.
  introv ceq e1.
  unfold equorsq2, equorsq in ceq; repnd; repdors; spcast.

  apply equality_trans with (t2 := a2); sp.

  apply equality_trans with (t2 := a2); sp.

  apply equality_trans with (t2 := a2); sp.
  apply cequivc_sym in ceq.
  rwg ceq.
  apply equality_sym in e1; apply equality_refl in e1; auto.

  apply equality_trans with (t2 := a2); sp.
  apply cequivc_sym in ceq.
  rwg ceq.
  apply equality_sym in e1; apply equality_refl in e1; auto.
Qed.

Lemma cequorsq_equality_trans1 {p} :
  forall lib t1 t2 t3 T,
    @equorsq p lib t1 t2 T
    -> equality lib t2 t3 T
    -> equality lib t1 t3 T.
Proof.
  introv c e.
  unfold equorsq in c; sp.
  apply @equality_trans with (t2 := t2); sp.
  spcast; apply @equality_respects_cequivc_left with (t1 := t2); sp.
  apply cequivc_sym; sp.
Qed.

Lemma cequorsq_equality_trans2 {p} :
  forall lib t1 t2 t3 T,
    @equality p lib t1 t2 T
    -> equorsq lib t2 t3 T
    -> equality lib t1 t3 T.
Proof.
  introv e c.
  unfold equorsq in c; sp.
  apply @equality_trans with (t2 := t2); sp.
  spcast; apply @equality_respects_cequivc_right with (t2 := t2); sp.
Qed.

Lemma cequorsq_sym {p} :
  forall lib a b T, @equorsq p lib a b T -> equorsq lib b a T.
Proof.
  unfold equorsq; introv ceq; sp.
  left; apply equality_sym; sp.
  right; spcast; sp; apply cequivc_sym; sp.
Qed.

Hint Resolve alphaeqc_preserving_equality : nequality.

Lemma respects_alphaeqc_equality {p} : forall lib, respects3 alphaeqc (@equality p lib).
Proof.
  introv; unfolds_base; dands; introv Hr Heq;
  eauto 3 with nequality.
Qed.

Lemma sym_alphaeqc_eauto {p} : symm_rel (@alphaeqc p).
Proof.
  introv Hab.
  apply alphaeqc_sym; auto.
Qed.

Hint Resolve respects_alphaeqc_equality sym_alphaeqc_eauto : respects.

Lemma respects_alphaeqc_tequality {p} : forall lib, respects2 alphaeqc (@tequality p lib).
Proof.
  introv; unfolds_base; dands; introv Hr Heq;
  eauto 3 with nequality.
Qed.

Hint Resolve respects_alphaeqc_tequality : respects.

Lemma respects_cequivc_tequality {p} :
  forall lib, respects2 (cequivc lib) (@tequality p lib).
Proof.
  introv; unfolds_base; dands; introv Hr Heq;
  eauto 3 with nequality.
Qed.

Hint Resolve respects_cequivc_tequality : respects.

Lemma respects_cequivc_equality {p} : forall lib, respects3 (cequivc lib) (@equality p lib).
Proof.
  introv; unfolds_base; dands; introv Hr Heq;
  eauto 3 with nequality.
Qed.

Hint Resolve respects_cequivc_equality : respects.

Lemma nuprli_sym {p} :
  forall lib i t1 t2 eq,
    @nuprli p lib i t1 t2 eq -> nuprli lib i t2 t1 eq.
Proof.
  intros.
  generalize (@nuprli_type_system p lib i); intro nts.
  dest_ts nts.
  apply ts_tys; sp.
Qed.

Lemma nuprl_ext {p} :
  forall lib t1 t2 eq1 eq2,
    @nuprl p lib t1 t2 eq1
    -> eq_term_equals eq1 eq2
    -> nuprl lib t1 t2 eq2.
Proof.
  introv n1 eqs; nts.
  apply nts_ext with (eq := eq1); sp.
Qed.

Lemma nuprli_ext {p} :
  forall lib i t1 t2 eq1 eq2,
    @nuprli p lib i t1 t2 eq1
    -> eq1 <=2=> eq2
    -> nuprli lib i t1 t2 eq2.
Proof.
  introv n1 eqs.
  generalize (@nuprli_type_system p lib i); intro nts.
  dest_ts nts.
  apply ts_ext with (eq := eq1); sp.
Qed.

Lemma eqorceq_iff_equorsq {o} :
  forall lib (A B a b : @CTerm o) eq,
    nuprl lib A B eq
    -> (eqorceq lib eq a b <=> equorsq lib a b A).
Proof.
  introv n.
  unfold eqorceq, equorsq.
  split; intro k; dorn k; auto; left; apply nuprl_refl in n; auto.
  - exists eq; dands; auto.
  - pose proof (equality_eq lib A a b eq n) as h; apply h; auto.
Qed.

Lemma equorsq_tequality {o} :
  forall lib (A B a b : @CTerm o),
    equorsq lib a b A
    -> tequality lib A B
    -> equorsq lib a b B.
Proof.
  introv e t.
  allunfold @equorsq.
  dorn e; auto.
  left.
  eapply tequality_preserving_equality; eauto.
Qed.

Lemma respects_cequivc_equorsq {p} : forall lib, respects3 (cequivc lib) (@equorsq p lib).
Proof.
  unfold equorsq; introv; unfolds_base; dands; introv Hr Heq; allsimpl; dorn Heq;
  try (complete (left; eauto 3 with nequality));
  right; spcast; eauto 3 with nequality.
  apply (cequivc_trans lib a' a b); auto; apply cequivc_sym; auto.
  apply (cequivc_trans lib a b b'); auto; apply cequivc_sym; auto.
Qed.
Hint Resolve respects_cequivc_equorsq : respects.

Lemma respects_alphaeqc_equorsq {p} : forall lib, respects3 alphaeqc (@equorsq p lib).
Proof.
  unfold equorsq; introv; unfolds_base; dands; introv Hr Heq; allsimpl; dorn Heq;
  try (complete (left; eauto 3 with nequality));
  right; spcast; eauto 3 with nequality.
  apply (cequivc_trans lib a' a b); auto; apply cequivc_sym; apply alphaeqc_implies_cequivc; auto.
  apply (cequivc_trans lib a b b'); auto; apply alphaeqc_implies_cequivc; auto.
Qed.
Hint Resolve respects_alphaeqc_equorsq : respects.

Lemma equorsq_sym {o} :
  forall lib (A a b : @CTerm o),
    equorsq lib a b A -> equorsq lib b a A.
Proof.
  introv e.
  allunfold @equorsq; sp.
  left; apply equality_sym; auto.
  right; spcast; sp; apply cequivc_sym; sp.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


From Coq Require Import Arith Psatz Bool String List Nat Program.Equality.
From Coq Require Import ZArith.
Local Open Scope string_scope.
Local Open Scope nat_scope.
Local Open Scope list_scope.

Require Import DanTrick.StackLanguage DanTrick.StackLangEval DanTrick.LogicProp DanTrick.StackPure DanTrick.StackLangTheorems DanTrick.StackSemanticsMutInd.
Require Export DanTrick.StackFrameBase.

Lemma geq_one_implies_successor :
  forall n,
    n >= 1 ->
    exists n',
      n = S n'.
Proof.
  destruct n; intros; [inversion H | ].
  exists n. reflexivity.
Qed.

Lemma geq_two_implies_succ2 :
  forall n,
    n >= 2 ->
    exists n',
      n = S (S n').
Proof.
  destruct n; intros; [inversion H | ].
  assert (n >= 1) by intuition.
  apply geq_one_implies_successor in H0.
  destruct H0. exists x.
  rewrite H0. reflexivity.
Qed.

Lemma successor_minus_one_same :
  forall n,
    S n - 1 = n.
Proof.
  induction n; intros.
  - reflexivity.
  - rewrite <- IHn. simpl. reflexivity.
Qed.

Definition frame_rule_mut_ind_theorem (P: aexp_stack -> fun_env_stk -> nat -> Prop) (P0: list aexp_stack -> fun_env_stk -> nat -> Prop) (P1: bexp_stack -> fun_env_stk -> nat -> Prop) (P2: imp_stack -> fun_env_stk -> nat -> nat -> Prop): Prop :=
  (forall (a : aexp_stack) (fenv : fun_env_stk) (frame : nat),
      aexp_frame_rule a fenv frame ->
      P a fenv frame) /\
    (forall (args: list aexp_stack) (fenv: fun_env_stk) (frame: nat),
        args_frame_rule args fenv frame ->
        P0 args fenv frame) /\
    (forall (b: bexp_stack) (fenv: fun_env_stk) (frame: nat),
        bexp_frame_rule b fenv frame ->
        P1 b fenv frame) /\
    (forall (i: imp_stack) (fenv: fun_env_stk) (frame frame': nat),
        imp_frame_rule i fenv frame frame' ->
        P2 i fenv frame frame').

Definition frame_rule_mut_ind_theorem_P (P: aexp_stack -> fun_env_stk -> nat -> Prop): forall (a: aexp_stack) (f20: fun_env_stk) (n: nat), aexp_frame_rule a f20 n -> Prop :=
    fun (a: aexp_stack) (fenv: fun_env_stk) (frame: nat) =>
    fun (_: aexp_frame_rule a fenv frame) =>
      P a fenv frame.

Definition frame_rule_mut_ind_theorem_P0 (P0: list aexp_stack -> fun_env_stk -> nat -> Prop): forall (l: list aexp_stack) (f20: fun_env_stk) (n: nat), args_frame_rule l f20 n -> Prop :=
  fun (args: list aexp_stack) (fenv: fun_env_stk) (frame: nat) =>
  fun (_: args_frame_rule args fenv frame) =>
    P0 args fenv frame.
Definition frame_rule_mut_ind_theorem_P1 (P1: bexp_stack -> fun_env_stk -> nat -> Prop): forall (b: bexp_stack) (f20: fun_env_stk) (n: nat), bexp_frame_rule b f20 n -> Prop :=
  fun (b: bexp_stack) (fenv: fun_env_stk) (frame: nat) =>
  fun (_: bexp_frame_rule b fenv frame) =>
    P1 b fenv frame.

Definition frame_rule_mut_ind_theorem_P2 (P2: imp_stack -> fun_env_stk -> nat -> nat -> Prop): forall (i: imp_stack) (f20: fun_env_stk) (n n0: nat), imp_frame_rule i f20 n n0 -> Prop :=
  fun (i: imp_stack) (fenv: fun_env_stk) (frame frame': nat) =>
  fun (_: imp_frame_rule i fenv frame frame') =>
    P2 i fenv frame frame'.

Ltac frame_rule_mutual_induction P P0 P1 P2 P_def P0_def P1_def P2_def :=
  pose (frame_rule_mut_ind_theorem_P P_def) as P;
  pose (frame_rule_mut_ind_theorem_P0 P0_def) as P0;
  pose (frame_rule_mut_ind_theorem_P1 P1_def) as P1;
  pose (frame_rule_mut_ind_theorem_P2 P2_def) as P2;
  apply (stack_frame_rule_mut_ind P P0 P1 P2);
  unfold P, P0, P1, P2;
  unfold frame_rule_mut_ind_theorem_P, frame_rule_mut_ind_theorem_P0, frame_rule_mut_ind_theorem_P1, frame_rule_mut_ind_theorem_P2;
  unfold P_def, P0_def, P1_def, P2_def.

Theorem frame_implies_pure_rel_old :
  (forall (a : aexp_stack) (fenv : fun_env_stk) (frame : nat),
      aexp_frame_rule a fenv frame ->
      aexp_stack_pure_rel a fenv) /\
    (forall (args: list aexp_stack) (fenv: fun_env_stk) (frame: nat),
        args_frame_rule args fenv frame ->
        args_stack_pure_rel args fenv) /\
    (forall (b: bexp_stack) (fenv: fun_env_stk) (frame: nat),
        bexp_frame_rule b fenv frame ->
        bexp_stack_pure_rel b fenv) /\
    (forall (i: imp_stack) (fenv: fun_env_stk) (frame frame': nat),
        imp_frame_rule i fenv frame frame' ->
        never_assigns_out_of_max_stack i frame frame' fenv).
Proof.
  pose (fun (a: aexp_stack) (fenv: fun_env_stk) (frame: nat) =>
        fun (_: aexp_frame_rule a fenv frame) =>
          aexp_stack_pure_rel a fenv) as P.
  pose (fun (args: list aexp_stack) (fenv: fun_env_stk) (frame: nat) =>
        fun (_: args_frame_rule args fenv frame) =>
          args_stack_pure_rel args fenv) as P0.
  pose (fun (b: bexp_stack) (fenv: fun_env_stk) (frame: nat) =>
        fun (_: bexp_frame_rule b fenv frame) =>
          bexp_stack_pure_rel b fenv) as P1.
  pose (fun (i: imp_stack) (fenv: fun_env_stk) (frame frame': nat) =>
        fun (_: imp_frame_rule i fenv frame frame') =>
          never_assigns_out_of_max_stack i frame frame' fenv) as P2.
  apply (stack_frame_rule_mut_ind P P0 P1 P2); unfold P, P0, P1, P2; intros.
  - econstructor.
  - econstructor.
  - econstructor; eassumption.
  - econstructor; eassumption.
  - econstructor.
    + eassumption.
    + assumption.
    + rewrite Nat.add_comm. assumption.
    + assumption.
  - econstructor.
  - econstructor; assumption.
  - constructor.
  - constructor.
  - econstructor. assumption.
  - econstructor; assumption.
  - constructor; assumption.
  - constructor; assumption.
  - constructor; assumption.
  - constructor.
  - constructor; assumption.
  - assert (frame + 1 = S frame) by intuition.
    rewrite H.
    constructor.
  - assert (exists n, frame = S n) by (apply geq_one_implies_successor in g; assumption).
    destruct H.
    rewrite H. rewrite successor_minus_one_same. constructor.
  - econstructor; eassumption.
  - constructor; eassumption.
  - econstructor; assumption.
Qed.

Lemma aexp_frame_implies_pure' :
  forall (a: aexp_stack) (fenv: fun_env_stk) (frame: nat),
    aexp_frame_rule a fenv frame ->
    aexp_stack_pure a fenv.
Proof.
  pose proof (frame_implies_pure_rel_old) as H.
  destruct H as (AEXP & _ ).
  intros.
  eapply AEXP in H.
  eapply aexp_stack_pure_backwards in H. assumption.
Qed.

Lemma aexp_frame_implies_pure :
  forall (a: aexp_stack) (fenv: fun_env_stk) (frame: nat) (stk stk': stack) (v: nat),
    aexp_frame_rule a fenv frame ->
    aexp_stack_sem a fenv stk (stk', v) ->
    stk = stk'.
Proof.
  pose proof (aexp_frame_implies_pure') as H.
  unfold aexp_stack_pure in H.
  intros.
  eapply H; eassumption.
Qed.

Lemma bexp_frame_implies_pure' :
  forall (b: bexp_stack) (fenv: fun_env_stk) (frame: nat),
    bexp_frame_rule b fenv frame ->
    bexp_stack_pure b fenv.
Proof.
  pose proof (frame_implies_pure_rel_old) as H.
  destruct H as (_ & _ & BEXP & _).
  intros. eapply BEXP in H. pose proof (stack_pure) as H'.
  destruct H' as (_ & _ & BEXP' & _).
  eapply BEXP' in H. assumption.
Qed.

Lemma bexp_frame_implies_pure :
  forall (b: bexp_stack) (fenv: fun_env_stk) (frame: nat) (stk stk': stack) (v: bool),
    bexp_frame_rule b fenv frame ->
    bexp_stack_sem b fenv stk (stk', v) ->
    stk = stk'.
Proof.
  pose proof (bexp_frame_implies_pure') as H.
  unfold bexp_stack_pure in H.
  intros. eapply H; eassumption.
Qed.

Lemma args_frame_implies_pure :
  forall (args: list aexp_stack) (fenv: fun_env_stk) (frame: nat) (stk stk': stack) (vals: list nat),
    args_frame_rule args fenv frame ->
    args_stack_sem args fenv stk (stk', vals) ->
    stk = stk'.
Proof.
  pose proof (stack_pure) as H.
  destruct H as (_ & _ & _ & ARGS).
  intros.
  pose proof (frame_implies_pure_rel_old) as PURE.
  destruct PURE as (_ & ARGS' & _).
  eapply ARGS' in H. eapply ARGS in H; [ | eassumption ].
  eassumption.
Qed.

Lemma imp_frame_implies_never_assigns_out_of_max_stack :
  (forall (i: imp_stack) (fenv: fun_env_stk) (frame frame': nat),
        imp_frame_rule i fenv frame frame' ->
        never_assigns_out_of_max_stack i frame frame' fenv).
Proof.
  pose proof (PURE := frame_implies_pure_rel_old).
  destruct PURE as (_ & _ & _ & IMP).
  apply IMP.
Qed.

Lemma imp_frame_implies_untouched_stack :
  forall i fenv max_stack_begin max_stack_end,
    imp_frame_rule i fenv max_stack_begin max_stack_end ->
    forall stk stk',
      imp_stack_sem i fenv stk stk' ->
      skipn max_stack_begin stk = skipn max_stack_end stk'.
Proof.
  intros.
  eapply imp_frame_implies_never_assigns_out_of_max_stack in H.
  eapply frame_stk.
  eassumption.
  assumption.
Qed.

Lemma le_ge_sym :
  forall (m n: nat),
    m <= n <-> n >= m.
Proof.
  lia.
Qed.

Lemma skipn_nil_implies_n_geq_length :
  forall A (l: list A) (n: nat),
    skipn n l = nil ->
    n >= Datatypes.length l.
Proof.
  induction l; intros.
  -  simpl. lia.
  - simpl. induction n.
    + inversion H.
    + apply le_ge_sym.
      apply Peano.le_n_S.
      apply le_ge_sym.
      apply IHl.
      simpl in H. assumption.
Qed.

Lemma imp_frame_implies_stack_decomposition :
  forall i fenv frame frame' stk stk',
    imp_frame_rule i fenv frame frame' ->
    imp_stack_sem i fenv stk stk' ->
    Datatypes.length stk >= frame ->
    Datatypes.length stk' >= frame' ->
    exists x x' y,
      (stk = x ++ y) /\ (stk' = x' ++ y) /\ Datatypes.length x = frame /\ Datatypes.length x' = frame'.
Proof.
  intros.
  apply imp_frame_implies_untouched_stack with (stk := stk) (stk' := stk') in H; [ | assumption ].
  exists (firstn frame stk).
  exists (firstn frame' stk').
  exists (skipn frame stk).
  split; [ | split; [ | split ]].
  - symmetry. apply firstn_skipn.
  - symmetry. rewrite H. apply firstn_skipn.
  - apply firstn_length_le.
    apply le_ge_sym. assumption.
  - apply firstn_length_le. apply le_ge_sym. assumption.
Qed.

Lemma frame_implies_rest_stk_untouched_le :
  forall i frame frame' fenv stk stk1 stk2,
    imp_frame_rule i fenv frame (frame + frame') ->
    frame = Datatypes.length stk1 ->
    frame' + frame <= Datatypes.length stk ->
    imp_stack_sem i fenv (stk1 ++ stk2) stk ->
    exists stk1',
      Datatypes.length stk1' = frame + frame' /\  stk = stk1' ++ stk2.
Proof.
  intros. rewrite Nat.add_comm.
  pose proof (imp_frame_implies_never_assigns_out_of_max_stack _ _ _ _ H).
  eapply imp_stack_pure_stack_decomposition; eauto.
  + rewrite Nat.add_comm. apply H3.
  + eapply imp_frame_implies_untouched_stack; eauto.
    rewrite Nat.add_comm. auto.
Qed.

Lemma same_after_popping_calculate_length :
  forall (stk stk': stack) (n: nat),
    same_after_popping stk' stk n ->
    Datatypes.length stk' = Datatypes.length stk - n.
Proof.
  intros stk stk' n. revert stk stk'.
  dependent induction n; intros; invs H.
  - auto with arith.
  - simpl. apply IHn. auto.
Qed.

Lemma stack_mutated_at_index_preserves_length :
  forall stk stk' k c,
    stack_mutated_at_index stk' k c stk ->
    Datatypes.length stk' = Datatypes.length stk.
Proof.
  intros.
  invs H.
  - reflexivity.
  - simpl. f_equal. assumption.
Qed.

Local Definition P_stack_length_same (i: imp_stack) (fenv: fun_env_stk) (stk stk': stack) : Prop :=
  forall frame frame',
    imp_frame_rule i fenv frame frame' ->
    Datatypes.length stk - frame = Datatypes.length stk' - frame'.

Local Definition P0_stack_length_same (a: aexp_stack) (fenv: fun_env_stk) (stk: stack) (stk'n: stack * nat) : Prop :=
  forall stk' n frame,
    stk'n = (stk', n) ->
    aexp_frame_rule a fenv frame ->
    Datatypes.length stk = Datatypes.length stk'.

Local Definition P1_stack_length_same (b: bexp_stack) (fenv: fun_env_stk) (stk: stack) (stk'v: stack * bool) : Prop :=
  forall stk' v frame,
    stk'v = (stk', v) ->
    bexp_frame_rule b fenv frame ->
    Datatypes.length stk = Datatypes.length stk'.

Local Definition P2_stack_length_same (args: list aexp_stack) (fenv: fun_env_stk) (stk: stack) (stk'vals: stack * (list nat)) : Prop :=
  forall stk' vals frame,
    stk'vals = (stk', vals) ->
    args_frame_rule args fenv frame ->
    Datatypes.length stk = Datatypes.length stk'.

Lemma n_plus_one_eq_n_false:
  forall (P: Prop) (n: nat),
    n + 1 = n -> P.
Proof.
  induction n; intros.
  - invs H.
  - invs H. eapply IHn in H1. assumption.
Qed.

Lemma stack_length_same :
  stack_sem_mut_ind_theorem P_stack_length_same P0_stack_length_same P1_stack_length_same P2_stack_length_same.
Proof.
  stack_sem_mutual_induction P P0 P1 P2 P_stack_length_same P0_stack_length_same P1_stack_length_same P2_stack_length_same; intros.
  - invs H. reflexivity.
  - invs H0. eapply stack_mutated_at_index_preserves_length in s. rewrite s.
    assert (stk = stk') by (eapply aexp_frame_implies_pure; [ eapply H8 | eassumption ]). subst. reflexivity.
  - invs H. rewrite Nat.add_1_r. simpl. reflexivity.
  - invs H. simpl. destruct frame; [ invs H0 | ].
    simpl. rewrite Nat.sub_0_r.  reflexivity.
  - invs H1.
    eapply H in H4. eapply H0 in H8. rewrite H8 in H4. assumption.
  - invs H1. specialize (H stk' true).
    eapply H in H5; [ | reflexivity ]. rewrite H5. clear H5. eapply H0 in H9. eassumption.
  - invs H1. specialize (H stk' false). eapply H in H5; [ | reflexivity ]. rewrite H5. clear H5. eapply H0 in H10. eassumption.
  - invs H0. specialize (H stk' false). eapply H in H3; [ | reflexivity ].
    rewrite H3. reflexivity.
  - invs H2. specialize (H stk1 true). eapply H in H5; [ | reflexivity ]. rewrite H5 in *. clear H5.
    eapply H0 in H9. rewrite H9 in *. clear H9. eapply H1 in H2. assumption.
  - invs H. reflexivity.
  - invs H. reflexivity.
  - invs H1. invs H2. eapply H in H5; [ | reflexivity]. eapply H0 in H8; [ | reflexivity ]. rewrite H5. rewrite H8. reflexivity.
  - invs H1. invs H2. eapply H in H5; [ | reflexivity ]. eapply H0 in H8; [ | reflexivity ]. rewrite H5. rewrite H8. reflexivity.
  - invc H2. invs H3. eapply H in H5; [ | eauto ]. eapply H0 in H7. eapply H1 in H10; [ | eauto ]. rewrite H5 in *. clear H5. rewrite H10 in *. clear H10. eapply args_stack_sem_preserves_length in a. rewrite app_length in H7. rewrite e3 in H7. rewrite <- a in H7. rewrite minus_plus in H7.
    eapply same_after_popping_calculate_length in s.
    rewrite e3 in s.
    rewrite <- s in H7. assumption.
  - invs H. reflexivity.
  - invs H. reflexivity.
  - invs H0. invs H1. eapply H in H3; [ | eauto ]. assumption.
  - invs H1. invs H2. eapply H in H5; [ | eauto ]. eapply H0 in H8; [ | eauto ]. rewrite H5. rewrite H8. reflexivity.
  - invc H1. invs H2. eapply H in H4; [ | eauto ]. eapply H0 in H7; [ | eauto ]. rewrite H4. rewrite H7. reflexivity.
  - invc H1. invs H2. eapply H in H4; [ | eauto ]. eapply H0 in H7; [ | eauto ]. rewrite H4. rewrite H7. reflexivity.
  - invc H1. invs H2. eapply H in H4; [ | eauto ]. eapply H0 in H7; [ | eauto ]. rewrite H4. rewrite H7. reflexivity.
  - invs H. reflexivity.
  - invc H1. invs H2. eapply H in H4; [ | eauto ]. eapply H0 in H7; [ | eauto]. rewrite H4. rewrite H7. reflexivity.
Qed.

Lemma imp_stack_len_same :
   (forall (i : imp_stack) (fenv : fun_env_stk) (stk stk' : stack),
   imp_stack_sem i fenv stk stk' ->
   forall frame frame' : nat,
   imp_frame_rule i fenv frame frame' ->
   Datatypes.length stk - frame = Datatypes.length stk' - frame').
Proof.
  pose proof (stack_length_same).
  destruct H. eapply H.
Qed.

Lemma aexp_stack_len_same :
  (forall (a : aexp_stack) (fenv : fun_env_stk) (stk : stack)
     (stk'n : stack * nat),
   aexp_stack_sem a fenv stk stk'n ->
   forall (stk' : stack) (n frame : nat),
   stk'n = (stk', n) ->
   aexp_frame_rule a fenv frame ->
   Datatypes.length stk = Datatypes.length stk').
Proof.
  pose proof (stack_length_same).
  destruct H. destruct H0. eapply H0.
Qed.

Lemma bexp_stack_len_same :
  (forall (b : bexp_stack) (fenv : fun_env_stk) (stk : stack)
     (stk'v : stack * bool),
   bexp_stack_sem b fenv stk stk'v ->
   forall (stk' : stack) (v : bool) (frame : nat),
   stk'v = (stk', v) ->
   bexp_frame_rule b fenv frame ->
   Datatypes.length stk = Datatypes.length stk').
Proof.
  pose proof (stack_length_same).
  destruct H. destruct H0. destruct H1. eapply H1.
Qed.

Lemma args_stack_len_same :
  (forall (args : list aexp_stack) (fenv : fun_env_stk)
     (stk : stack) (stk'vals : stack * list nat),
   args_stack_sem args fenv stk stk'vals ->
   forall (stk' : stack) (vals : list nat) (frame : nat),
   stk'vals = (stk', vals) ->
   args_frame_rule args fenv frame ->
   Datatypes.length stk = Datatypes.length stk').
Proof.
  pose proof (stack_length_same).
  destruct H. destruct H0. destruct H1. unfold P_stack_length_same in H2. eapply H2.
Qed.

Section frame_relative_section.

  Definition int_diff_nats (n1 n2: nat): Z :=
    ((Z.of_nat n1) - (Z.of_nat n2))%Z.

  Lemma neq_pred :
    forall frame,
      frame >= 1 ->
      frame <> frame - 1.
  Proof.
    destruct frame; intros.
    - invs H.
    - rewrite Nat.sub_succ. rewrite Nat.sub_0_r. unfold not. intros.
      symmetry in H0. eapply Nat.neq_succ_diag_r in H0. assumption.
  Qed.

  Lemma frame_relative :
    forall (i: imp_stack) (fenv: fun_env_stk) (frame frame': nat),
      imp_frame_rule i fenv frame frame' ->
      forall (f f': nat),
        imp_frame_rule i fenv f f' ->
        int_diff_nats f' f = int_diff_nats frame' frame.
  Proof.
    unfold int_diff_nats. induction i; intros.
    - invs H0. invs H. lia.
    - invs H. invs H0. lia.
    - invs H. invs H0. lia.
    - invs H. invs H0. lia.
    - invs H. invs H0. eapply IHi1 in H3; [ | eapply H4 ].
      eapply IHi2 in H7; [ | eapply H9 ]. eapply Z.sub_move_r in H7. eapply Z.sub_move_r in H3.
      rewrite <- H3 in H7. rewrite Z.opp_sub_distr in H7. rewrite Z.opp_sub_distr in H7. rewrite Z.add_opp_r in H7.
      rewrite Z.add_opp_l in H7.
      repeat rewrite Z.sub_sub_distr in H7.
      rewrite <- Z.sub_add_distr in H7.
      rewrite (Z.add_comm (Z.of_nat frame'0) (Z.of_nat frame)) in H7.
      rewrite Z.sub_add_distr in H7.
      rewrite Z.sub_add in H7.
      symmetry in H7.
      eapply Z.sub_move_r in H7. assumption.
    - invs H. invs H0. eapply IHi1 in H8; [ | eapply H11 ].
      symmetry in H8. assumption.
    - invs H. invs H0. repeat rewrite Z.sub_diag. reflexivity.
  Qed.

  Lemma exists_nat_pos :
    forall (p: positive),
    exists (n: nat),
      Z.pos p = Z.of_nat n.
  Proof.
    destruct p.
    - exists (Z.to_nat (Z.pos (p~1))).
      erewrite Z2Nat.id.
      reflexivity.
      lia.
    - exists (Z.to_nat (Z.pos (p~0))).
      erewrite Z2Nat.id.
      reflexivity.
      lia.
    - exists 1. simpl. reflexivity.
  Qed.

  Lemma frame_relative'' :
    forall (i: imp_stack) (fenv: fun_env_stk) (frame frame': nat),
      imp_frame_rule i fenv frame frame' ->
      forall (f f': nat),
        imp_frame_rule i fenv f f' ->
        frame <= frame' -> f <= f'.
  Proof.
    intros. pose proof (frame_relative).
    specialize (H2 i fenv frame frame' H f f' H0).
    destruct (int_diff_nats f' f) eqn:?; unfold int_diff_nats in *.
    -
      symmetry in H2.
      eapply Zminus_eq in H2.
      eapply Zminus_eq in Heqz.
      pose proof (f_equal Z.to_nat Heqz).
      repeat rewrite Nat2Z.id in H3.
      lia.
    - eapply Z.sub_move_r in Heqz.
      pose proof (exists_nat_pos p).
      destruct H3. rewrite H3 in Heqz.
      rewrite <- Nat2Z.inj_add in Heqz.
      pose proof (f_equal Z.to_nat Heqz). repeat rewrite Nat2Z.id in H4.
      rewrite H4. rewrite Nat.add_comm. lia.
    - destruct f', f.
      simpl in Heqz. invs Heqz. simpl in Heqz.
      assert (Z.of_nat frame <= Z.of_nat frame')%Z.
      lia.
      assert (0 <= Z.of_nat frame' - Z.of_nat frame)%Z by lia.
      eapply Z_of_nat_complete in H4. destruct H4.
      rewrite H4 in H2. unfold Z.of_nat in H2. destruct x.
      invs H2. invs H2.
      lia. pose proof (Zlt_neg_0 p).
      rewrite <- Heqz in H3. pose proof Z.lt_sub_0.
      specialize (H4 (Z.of_nat (S f')) (Z.of_nat (S f))).
      apply H4 in H3. lia.
  Qed.

  Lemma frame_relative_leq :
    forall (i: imp_stack) (fenv: fun_env_stk) (frame frame': nat),
      imp_frame_rule i fenv frame frame' ->
      forall (f f': nat),
        imp_frame_rule i fenv f f' ->
        frame >= frame' -> f >= f'.
  Proof.
    intros. pose proof (frame_relative).
    specialize (H2 i fenv frame frame' H f f' H0).
    destruct (int_diff_nats f' f) eqn:?; unfold int_diff_nats in *.
    - symmetry in H2.
      eapply Zminus_eq in H2.
      eapply Zminus_eq in Heqz.
      pose proof (f_equal Z.to_nat Heqz).
      repeat rewrite Nat2Z.id in H3.
      lia.
    - assert (Z.of_nat frame >= Z.of_nat frame')%Z by lia.
      assert (0 >= Z.of_nat frame' - Z.of_nat frame)%Z by lia.
      pose proof (Z_of_nat_complete).
      specialize (H5 (Z.pos p)).
      assert (0 <= Z.pos p)%Z by lia.
      pose proof (H7 := H6).
      apply H5 in H6.
      destruct H6. rewrite H2 in H6.
      pose proof Z.le_sub_0.
      specialize (H8 (Z.of_nat frame') (Z.of_nat frame)).
      assert (Z.of_nat frame' - Z.of_nat frame <= 0)%Z by lia.
      apply H8 in H9.
      assert (Z.of_nat frame >= Z.of_nat frame')%Z by lia.
      assert (Z.of_nat frame' = Z.of_nat frame)%Z by lia.
      rewrite H11 in H2. rewrite Z.sub_diag in H2. invs H2.
    - pose proof (Zlt_neg_0).
      specialize (H3 p).
      rewrite <- Heqz in H3.
      assert (Z.of_nat f' < Z.of_nat f)%Z by lia.
      lia.
  Qed.

End frame_relative_section.

Local Definition P_frame_expansion (a: aexp_stack) (fenv: fun_env_stk) (frame: nat): Prop :=
  forall frame',
    frame <= frame' ->
    aexp_frame_rule a fenv frame'.

Local Definition P0_frame_expansion (args: list aexp_stack) (fenv: fun_env_stk) (frame: nat): Prop :=
  forall frame',
    frame <= frame' ->
    args_frame_rule args fenv frame'.

Local Definition P1_frame_expansion (b: bexp_stack) (fenv: fun_env_stk) (frame: nat) : Prop :=
  forall frame',
    frame <= frame' ->
    bexp_frame_rule b fenv frame'.

Local Definition P2_frame_expansion (i: imp_stack) (fenv: fun_env_stk) (frame frame': nat): Prop :=
  forall frame'',
    frame <= frame'' ->
    imp_frame_rule i fenv frame'' (frame'' + frame' - frame).

Lemma frame_expansion :
  frame_rule_mut_ind_theorem P_frame_expansion P0_frame_expansion P1_frame_expansion P2_frame_expansion.
Proof.
  frame_rule_mutual_induction P P0 P1 P2 P_frame_expansion P0_frame_expansion P1_frame_expansion P2_frame_expansion; intros.
  - constructor.
  - constructor; lia.
  - constructor.
    + eapply H. eassumption.
    + eapply H0. eassumption.
  - constructor.
    + apply H. assumption.
    + apply H0. assumption.
  - econstructor.
    + apply H. assumption.
    + eassumption.
    + eassumption.
    + eassumption.
  - constructor.
  - constructor; [ eapply H | eapply H0 ]; eassumption.
  - econstructor.
  - constructor.
  - constructor. eapply H. assumption.
  - constructor; [ eapply H | eapply H0 ]; eassumption.
  - constructor; [ eapply H | eapply H0 ]; eassumption.
  - constructor; [ eapply H | eapply H0 ]; eassumption.
  - constructor; [ eapply H | eapply H0 ]; eassumption.
  - rewrite Nat.add_sub. constructor.
  - rewrite Nat.add_sub. constructor. lia. lia. eapply H. assumption.
  - rewrite <- Nat.add_sub_assoc.
    rewrite minus_plus. constructor. lia.
  - rewrite Nat.add_sub_assoc.
    rewrite Nat.add_sub_swap.
    rewrite <- Nat.add_sub_assoc.
    rewrite Nat.sub_diag. rewrite Nat.add_0_r. econstructor.
    lia. lia. lia. lia.
  - econstructor.
    + eapply H. eassumption.
    + assert (frame''0 + frame' - frame + frame'' - frame' = frame''0 + frame'' - frame).
      rewrite Nat.add_sub_swap.
      rewrite Nat.add_sub_swap.
      pose proof plus_minus.
      pose proof minus_plus.
      remember (frame''0 - frame) as sth.
      rewrite (Nat.add_comm sth frame').
      rewrite minus_plus. rewrite Heqsth. rewrite Nat.add_sub_swap. reflexivity.
      auto. auto.
      assert (frame''0 - frame >= 0) by lia.
      rewrite Nat.add_sub_swap.
      rewrite Nat.add_comm. lia. auto.  rewrite <- H2. eapply H0.
      rewrite Nat.add_sub_swap.
      rewrite Nat.add_comm. lia. auto.
  - constructor.
    + eapply H. assumption.
    + eapply H0. assumption.
    + eapply H1. assumption.
  - rewrite Nat.add_comm. rewrite minus_plus. econstructor.
    + eapply H. assumption.
    + specialize (H0 frame''). eapply H0 in H1. rewrite Nat.add_comm in H1. rewrite minus_plus in H1. assumption.
Qed.

Lemma aexp_frame_expansion :
  (forall (a : aexp_stack) (fenv : fun_env_stk) (frame : nat),
   aexp_frame_rule a fenv frame ->
   forall frame' : nat, frame <= frame' -> aexp_frame_rule a fenv frame').
Proof.
  pose proof frame_expansion. destruct H. apply H.
Qed.

Lemma args_frame_expansion :
  (forall (args : list aexp_stack) (fenv : fun_env_stk) (frame : nat),
   args_frame_rule args fenv frame ->
   forall frame' : nat,
     frame <= frame' -> args_frame_rule args fenv frame').
Proof.
  pose proof frame_expansion. destruct H. destruct H0. apply H0.
Qed.

Lemma bexp_frame_expansion :
  (forall (b : bexp_stack) (fenv : fun_env_stk) (frame : nat),
   bexp_frame_rule b fenv frame ->
   forall frame' : nat, frame <= frame' -> bexp_frame_rule b fenv frame').
Proof.
  pose proof frame_expansion. destruct H. destruct H0. destruct H1. apply H1.
Qed.

Lemma imp_frame_expansion :
  (forall (i : imp_stack) (fenv : fun_env_stk) (frame frame' : nat),
   imp_frame_rule i fenv frame frame' ->
   forall frame'' : nat,
   frame <= frame'' ->
   imp_frame_rule i fenv frame'' (frame'' + frame' - frame)).
Proof.
  pose proof frame_expansion. destruct H. destruct H0. destruct H1. apply H2.
Qed.

Lemma frame_diff_equal :
  forall (i : imp_stack) (fenv : fun_env_stk) (frame frame' : nat),
    imp_frame_rule i fenv frame frame' ->
    forall f f' : nat,
      imp_frame_rule i fenv f f' ->
      (frame' >= frame /\ frame' - frame = f' - f) \/ (frame' <= frame /\ frame - frame' = f - f').
Proof.
  intros.
  pose proof (frame_relative).
  pose proof le_ge_dec.
  specialize (H2 frame' frame).
  specialize (H1 i fenv frame frame' H f f' H0).
  destruct H2.
  - right. split; [ assumption | ].
    unfold int_diff_nats in H1.
    symmetry in H1.
    lia.
  - left. split; [ assumption | ].
    unfold int_diff_nats in H1. lia.
Qed.

Lemma frame_diff_equal' :
  forall (i : imp_stack) (fenv : fun_env_stk) (frame frame' : nat),
    imp_frame_rule i fenv frame frame' ->
    forall f f' : nat,
      imp_frame_rule i fenv f f' ->
      (frame' >= frame /\
         exists diff,
           frame' = frame + diff /\ f' = f + diff) \/
        (frame' <= frame /\
           exists diff,
             frame' + diff = frame /\ f' + diff = f).
Proof.
  intros.
  pose proof (frame_diff_equal i fenv frame frame' H f f' H0).
  destruct H1.
  - left. destruct H1. split.
    + assumption.
    + exists (frame' - frame).
      split.
      * rewrite Nat.add_sub_assoc; [ | assumption].
        rewrite minus_plus. reflexivity.
      * assert (frame' = f' - f + frame).
        lia.
        rewrite H3.
        rewrite Nat.add_sub. rewrite Nat.add_sub_assoc.
        rewrite minus_plus. reflexivity.
        eapply frame_relative''.
        eapply H. eassumption. assumption.
  - right. destruct H1. split. assumption.
    exists (frame - frame'). split.
    + rewrite Nat.add_sub_assoc; [ | assumption ].
      rewrite minus_plus. reflexivity.
    + rewrite Nat.add_sub_assoc; [ | assumption ].
      assert (frame = f - f' + frame') by lia.
      rewrite H3. rewrite <- Nat.add_sub_assoc.
      * rewrite Nat.add_sub. rewrite Nat.add_sub_assoc.
        rewrite minus_plus. reflexivity.
        eapply frame_relative_leq.
        eapply H. eapply H0. eassumption.
      * rewrite <- H3. auto.
Qed.

Lemma frame_is_enough :
  forall (i: imp_stack) (fenv: fun_env_stk) (frame frame': nat),
    imp_frame_rule i fenv frame frame' ->
    frame' <= frame ->
    forall f f': nat,
      imp_frame_rule i fenv f f' ->
      f >= frame - frame'.
Proof.
  intros.
  pose proof (frame_diff_equal).
  specialize (H2 i fenv frame frame' H f f' H1).
  destruct H2.
  - destruct H2.
    assert (frame' = frame) by lia.
    rewrite H4. rewrite Nat.sub_diag. lia.
  - destruct H2.
    rewrite H3. lia.
Qed.

Lemma frames_equal :
  forall (i : imp_stack) (fenv : fun_env_stk) (frame frame' : nat),
    imp_frame_rule i fenv frame frame' ->
    forall f f' : nat,
      imp_frame_rule i fenv f f' ->
      frame = frame' ->
      f = f'.
Proof.
  intros.
  pose proof frame_relative''.
  pose proof frame_relative_leq.
  specialize (H2 i fenv frame frame' H f f' H0).
  specialize (H3 i fenv frame frame' H f f' H0).
  assert (frame <= frame') by lia.
  assert (frame >= frame') by lia.
  specialize (H2 H4).
  specialize (H3 H5).
  lia.
Qed.

Lemma frame_deterministic :
  forall (i: imp_stack) (fenv: fun_env_stk) (frame frame' frame'': nat),
    imp_frame_rule i fenv frame frame' ->
    imp_frame_rule i fenv frame frame'' ->
    frame' = frame''.
Proof.
  induction i; intros.
  - invs H. invs H0. reflexivity.
  - invs H. invs H0. reflexivity.
  - invs H. invs H0. reflexivity.
  - invs H. invs H0. reflexivity.
  - invs H. invs H0. specialize (IHi1 fenv frame frame'0 frame'1 H3 H4).
    subst frame'0. clear H4.
    specialize (IHi2 fenv frame'1 frame' frame'' H7 H9). subst frame'. reflexivity.
  - invs H. invs H0. specialize (IHi1 fenv frame frame' frame'' H8 H11).
    assumption.
  - invs H. invs H0. reflexivity.
Qed.

Lemma frame_deterministic' :
  forall (i: imp_stack) (fenv: fun_env_stk) (frame frame' frame'': nat),
    imp_frame_rule i fenv frame frame'' ->
    imp_frame_rule i fenv frame' frame'' ->
    frame = frame'.
Proof.
  induction i; intros; invs H; invs H0.
  - reflexivity.
  - reflexivity.
  - repeat rewrite Nat.add_1_r in H1. invs H1. reflexivity.
  - destruct frame', frame; invs H1; invs H3.
    reflexivity.
    simpl in H2. rewrite Nat.sub_0_r in H2. subst. reflexivity.
    rewrite Nat.sub_succ in H2. rewrite Nat.sub_succ in H2. simpl in H2. rewrite Nat.sub_0_r in H2. symmetry in H2. subst. reflexivity.
    repeat rewrite Nat.sub_succ in H2. repeat rewrite Nat.sub_0_r in H2. subst. reflexivity.
  - specialize (IHi2 fenv frame'0 frame'1 frame'' H7 H9). subst.
    specialize (IHi1 fenv frame frame' frame'1 H3 H4). subst. reflexivity.
  - specialize (IHi1 fenv frame frame' frame'' H8 H11). subst. reflexivity.
  - reflexivity.
Qed.

Lemma frame_relative''' :
  forall (i: imp_stack) (fenv: fun_env_stk) (frame frame': nat),
    imp_frame_rule i fenv frame frame' ->
    forall (f f': nat),
      imp_frame_rule i fenv f f' ->
      (frame' >= frame /\ f' = f + frame' - frame) \/
        (frame' <= frame /\ f' + frame - frame' = f).
Proof.
  intros. pose proof (frame_diff_equal).
  specialize (H1 _ _ _ _ H _ _ H0).
  destruct H1.
  - left. destruct H1. assert (frame' = f' - f + frame) by lia.
    rewrite H3.
    split.
    + rewrite <- H3. auto.
    + rewrite <- Nat.add_sub_assoc.
      * rewrite Nat.add_sub. rewrite Nat.add_sub_assoc.
        rewrite minus_plus.
        auto.
        pose proof (frame_relative'').
        eapply H4. eapply H. eapply H0. auto.
      * rewrite <- H3. auto.
  - right. destruct H1. assert (frame = f - f' + frame') by lia.
    split.
    + auto.
    + rewrite H3. rewrite <- Nat.add_sub_assoc.
      * rewrite Nat.add_sub. rewrite Nat.add_sub_assoc. rewrite minus_plus. reflexivity.
        pose proof (frame_relative_leq).
        eapply H4. eapply H. auto. auto.
      * rewrite <- H3. auto.
Qed.

Lemma frame_diff_cant_be_bigger_than_start :
  forall (i: imp_stack) (fenv: fun_env_stk) (frame frame': nat),
    imp_frame_rule i fenv frame frame' ->
    forall (f f': nat),
      imp_frame_rule i fenv f f' ->
      (frame' >= frame /\ f' >= f) \/
        (frame' < frame /\ frame - frame' <= f).
Proof.
  intros.
  pose proof (frame_relative''').
  pose proof (le_gt_dec frame frame').
  specialize (H1 _ _ _ _ H _ _ H0).
  destruct H2.
  - left. split. auto.
    assert (f <= f').
    eapply frame_relative''. eapply H. assumption. assumption. assumption.
  - right. split. auto.
    destruct H1.
    + destruct H1. assert (frame <= frame') by lia.
      eapply le_not_gt in H3. congruence.
    + destruct H1. lia.
Qed.

Lemma frame_relative' :
  forall (i: imp_stack) (fenv: fun_env_stk) (frame frame': nat),
    imp_frame_rule i fenv frame frame' ->
    forall (f f': nat),
      imp_frame_rule i fenv f f' ->
      imp_frame_rule i fenv f (f + frame' - frame).
Proof.
  induction i; intros.
  - invs H. invs H0. rewrite Nat.add_comm. rewrite minus_plus. constructor.
  - invs H. invs H0. rewrite Nat.add_comm. rewrite minus_plus. constructor; assumption.
  - invs H0. invs H. rewrite Nat.add_assoc.
    assert (f + frame + 1 - frame = f + 1) by lia.
    rewrite H1.
    assumption.
  - invs H0. invs H. rewrite Nat.add_sub_assoc. assert (f + frame - 1 - frame = f - 1) by lia.
    rewrite H3.
    assumption. assumption.
  - pose proof (frame_relative''').
    specialize (H1 (Seq_Stk i1 i2) fenv frame frame' H f f' H0).
    destruct H1.
    + destruct H1.  rewrite H2 in H0. assumption.
    + destruct H1. rewrite <- H2.
      rewrite Nat.sub_add.
      rewrite Nat.add_sub.
      rewrite <- H2 in H0. assumption.
      assert (f' + frame = f + frame') by lia.
      lia.
  - invs H. invs H0. specialize (IHi1 fenv frame frame' H8 f f' H11).
    specialize (IHi2 fenv frame frame' H9 f f' H12). econstructor; assumption.
  - invs H. rewrite Nat.add_sub. invs H0. assumption.
Qed.


(**
  This file defines an inductive type [choice_type] corresponding to codes for
  choice types.
  We give a total order on this type, which is then used to show that
  [choice_type] forms a [choiceType].
 *)

From Coq Require Import Utf8 Lia.
From Relational Require Import OrderEnrichedCategory
  OrderEnrichedRelativeMonadExamples GenericRulesSimple.
Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format".
From mathcomp Require Import ssrnat ssreflect ssrfun ssrbool ssrnum eqtype
  choice reals distr realsum seq all_algebra fintype.
Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format".
From Crypt Require Import Prelude Axioms.
From extructures Require Import ord fset fmap.
From Mon Require Import SPropBase.
Require Equations.Prop.DepElim.
From Equations Require Import Equations.

Set Equations With UIP.

Import SPropNotations.

Set Bullet Behavior "Strict Subproofs".
Set Default Goal Selector "!".
Set Primitive Projections.

Open Scope fset.
Open Scope fset_scope.
Open Scope type_scope.

(* Basic structure *)

Inductive choice_type :=
| chUnit
| chNat
| chBool
| chProd (A B : choice_type)
| chMap (A B : choice_type)
| chOption (A : choice_type)
| chFin (n : positive).

Derive NoConfusion NoConfusionHom for choice_type.

(* Definition void_leq (x y : void) := true. *)

(* Lemma void_leqP : Ord.axioms void_leq. *)
(* Proof. split; by do ![case]. Qed. *)

(* Definition void_ordMixin := OrdMixin void_leqP. *)
(* Canonical void_ordType := Eval hnf in OrdType void void_ordMixin. *)

Fixpoint chElement_ordType (U : choice_type) : ordType :=
  match U with
  | chUnit => unit_ordType
  | chNat => nat_ordType
  | chBool => bool_ordType
  | chProd U1 U2 => prod_ordType (chElement_ordType U1) (chElement_ordType U2)
  | chMap U1 U2 => fmap_ordType (chElement_ordType U1) (chElement_ordType U2)
  | chOption U => option_ordType (chElement_ordType U)
  | chFin n => [ordType of ordinal n.(pos) ]
  end.

Fixpoint chElement (U : choice_type) : choiceType :=
  match U with
  | chUnit => unit_choiceType
  | chNat => nat_choiceType
  | chBool => bool_choiceType
  | chProd U1 U2 => prod_choiceType (chElement U1) (chElement U2)
  | chMap U1 U2 => fmap_choiceType (chElement_ordType U1) (chElement U2)
  | chOption U => option_choiceType (chElement U)
  | chFin n => [choiceType of ordinal n.(pos) ]
  end.

Coercion chElement : choice_type >-> choiceType.

(* Canonical element in a type of the choice_type *)
#[program] Fixpoint chCanonical (T : choice_type) : T :=
  match T with
  | chUnit => Datatypes.tt
  | chNat => 0
  | chBool => false
  | chProd A B => (chCanonical A, chCanonical B)
  | chMap A B => _
  | chOption A => None
  | chFin n => _
  end.
Next Obligation.
  eapply fmap_of_fmap. apply emptym.
Defined.
Next Obligation.
  exists 0. destruct n as [p h]. simpl.
  unfold Positive in h. auto.
Defined.

Section choice_typeTypes.

  Fixpoint choice_type_test (u v : choice_type) : bool :=
    match u, v with
    | chNat , chNat => true
    | chUnit , chUnit => true
    | chBool , chBool => true
    | chProd a b , chProd a' b' => choice_type_test a a' && choice_type_test b b'
    | chMap a b , chMap a' b' => choice_type_test a a' && choice_type_test b b'
    | chOption a, chOption a' => choice_type_test a a'
    | chFin n, chFin n' => n == n'
    | _ , _ => false
    end.

  Definition choice_type_eq : rel choice_type :=
    fun u v => choice_type_test u v.

  Lemma choice_type_eqP : Equality.axiom choice_type_eq.
  Proof.
    move=> x y.
    induction x as [ | | | x1 ih1 x2 ih2 | x1 ih1 x2 ih2 | x1 ih1 | x1]
    in y |- *.
    all: destruct y as [ | | | y1 y2 | y1 y2 | y1 | y1].
    all: simpl.
    all: try solve [ right ; discriminate ].
    all: try solve [ left ; reflexivity ].
    - destruct (ih1 y1), (ih2 y2).
      all: simpl.
      all: subst.
      all: try solve [ right ; congruence ].
      left. reflexivity.
    - destruct (ih1 y1), (ih2 y2).
      all: simpl.
      all: subst.
      all: try solve [ right ; congruence ].
      left. reflexivity.
    - destruct (ih1 y1).
      all: subst.
      + left. reflexivity.
      + right. congruence.
    - destruct (x1 == y1) eqn:e.
      + move: e => /eqP e. subst. left. reflexivity.
      + move: e => /eqP e. right. intro h.
        apply e. inversion h. reflexivity.
  Qed.

  Lemma choice_type_refl :
    ∀ u, choice_type_eq u u.
  Proof.
    intros u. destruct choice_type_eq eqn:e.
    - constructor.
    - move: e => /choice_type_eqP []. reflexivity.
  Qed.

  Canonical choice_type_eqMixin := EqMixin choice_type_eqP.
  Canonical choice_type_eqType :=
    Eval hnf in EqType choice_type choice_type_eqMixin.

  Fixpoint choice_type_lt (t1 t2 : choice_type) :=
  match t1, t2 with
  | chUnit, chUnit => false
  | chUnit, _ => true
  | chBool, chUnit => false
  | chBool, chBool => false
  | chBool, _ => true
  | chNat, chUnit => false
  | chNat, chBool => false
  | chNat, chNat => false
  | chNat, _ => true
  | chProd _ _, chUnit => false
  | chProd _ _, chBool => false
  | chProd _ _, chNat => false
  | chProd u1 u2, chProd w1 w2 =>
    (choice_type_lt u1 w1) ||
    (choice_type_eq u1 w1 && choice_type_lt u2 w2)
  | chProd _ _, _ => true
  | chMap _ _, chUnit => false
  | chMap _ _, chBool => false
  | chMap _ _, chNat => false
  | chMap _ _, chProd _ _ => false
  | chMap u1 u2, chMap w1 w2 =>
    (choice_type_lt u1 w1) ||
    (choice_type_eq u1 w1 && choice_type_lt u2 w2)
  | chMap _ _, _ => true
  | chOption _, chUnit => false
  | chOption _, chBool => false
  | chOption _, chNat => false
  | chOption _, chProd _ _ => false
  | chOption _, chMap _ _ => false
  | chOption u, chOption w => choice_type_lt u w
  | chOption _, _ => true
  | chFin n, chUnit => false
  | chFin n, chBool => false
  | chFin n, chNat => false
  | chFin n, chProd _ _ => false
  | chFin n, chMap _ _ => false
  | chFin n, chOption _ => false
  | chFin n, chFin n' => n < n'
  end.

  Definition choice_type_leq (t1 t2 : choice_type) :=
    choice_type_eq t1 t2 || choice_type_lt t1 t2.

  Lemma choice_type_lt_transitive : transitive (T:=choice_type) choice_type_lt.
  Proof.
    intros v u w h1 h2.
    induction u as [ | | | u1 ih1 u2 ih2 | u1 ih1 u2 ih2 | u ih | u]
    in v, w, h1, h2 |- *.
    - destruct w. all: try auto.
      destruct v. all: discriminate.
    - destruct w. all: try auto.
      all: destruct v. all: discriminate.
    - destruct w. all: try auto.
      all: destruct v. all: discriminate.
    - destruct v. all: try discriminate.
      all: destruct w. all: try discriminate. all: try reflexivity.
      cbn in *.
      move: h1 => /orP h1.
      move: h2 => /orP h2.
      apply/orP.
      destruct h1 as [h1|h1], h2 as [h2|h2].
      + left. eapply ih1. all: eauto.
      + left. move: h2 => /andP [/eqP e h2]. subst. auto.
      + left. move: h1 => /andP [/eqP e h1]. subst. auto.
      + right. move: h1 => /andP [/eqP e1 h1].
        move: h2 => /andP [/eqP e2 h2].
        apply/andP. subst. split.
        * apply/eqP. reflexivity.
        * eapply ih2. all: eauto.
    - destruct v. all: try discriminate.
      all: destruct w. all: try discriminate. all: try reflexivity.
      simpl in *.
      move: h1 => /orP h1.
      move: h2 => /orP h2.
      apply/orP.
      destruct h1 as [h1|h1], h2 as [h2|h2].
      + left. eapply ih1. all: eauto.
      + left. move: h2 => /andP [/eqP e h2]. subst. auto.
      + left. move: h1 => /andP [/eqP e h1]. subst. auto.
      + right. move: h1 => /andP [/eqP e1 h1].
        move: h2 => /andP [/eqP e2 h2].
        apply/andP. subst. split.
        * apply/eqP. reflexivity.
        * eapply ih2. all: eauto.
    - destruct v. all: try discriminate.
      all: destruct w. all: try reflexivity. all: try discriminate.
      simpl in *.
      eapply ih. all: eauto.
    - destruct v. all: try discriminate.
      destruct w. all: try discriminate.
      simpl in *.
      eapply ltn_trans. all: eauto.
  Qed.

  Lemma choice_type_lt_areflexive :
    ∀ x, ~~ choice_type_lt x x.
  Proof.
    intros x.
    induction x as [ | | | x1 ih1 x2 ih2 | x1 ih1 x2 ih2 | x ih | x] in |- *.
    all: intuition; simpl.
    - simpl.
      apply/norP. split.
      + apply ih1.
      + apply/nandP.
        right. apply ih2.
    - simpl.
      apply/norP. split.
      + apply ih1.
      + apply/nandP.
        right. apply ih2.
    - rewrite ltnn. auto.
  Qed.

  Lemma choice_type_lt_total_holds :
    ∀ x y,
      ~~ (choice_type_test x y) ==> (choice_type_lt x y || choice_type_lt y x).
  Proof.
    intros x y.
    induction x as [ | | | x1 ih1 x2 ih2| x1 ih1 x2 ih2| x ih| x]
    in y |- *.
    all: try solve [ destruct y ; intuition ; reflexivity ].
    - destruct y. all: try (intuition; reflexivity).
      cbn.
      specialize (ih1 y1). specialize (ih2 y2).
      apply/implyP.
      move /nandP => H.
      apply/orP.
      destruct (choice_type_test x1 y1) eqn:Heq.
      + destruct H. 1: discriminate.
        move: ih2. move /implyP => ih2.
        specialize (ih2 H).
        move: ih2. move /orP => ih2.
        destruct ih2.
        * left. apply/orP. right. apply/andP. split.
          all: intuition auto.
        * right. apply/orP. right. apply/andP. intuition.
          move: Heq. move /eqP => Heq. rewrite Heq. apply/eqP. reflexivity.
      + destruct H.
        * move: ih1. move /implyP => ih1.
          specialize (ih1 H).
          move: ih1. move /orP => ih1.
          destruct ih1.
          -- left. apply/orP. left. assumption.
          -- right. apply/orP. left. assumption.
        * move: ih2. move /implyP => ih2.
          specialize (ih2 H).
          move: ih2. move /orP => ih2.
          destruct ih2.
          --- simpl in ih1.  move: ih1. move /orP => ih1.
              destruct ih1.
              +++ left. apply/orP. left. assumption.
              +++ right. apply/orP. left. assumption.
          --- simpl in ih1.  move: ih1. move /orP => ih1.
              destruct ih1.
              +++ left. apply/orP. left. assumption.
              +++ right. apply/orP. left. assumption.
    - destruct y. all: try (intuition; reflexivity).
      cbn.
      specialize (ih1 y1). specialize (ih2 y2).
      apply/implyP.
      move /nandP => H.
      apply/orP.
      destruct (choice_type_test x1 y1) eqn:Heq.
      + destruct H. 1: discriminate.
        move: ih2. move /implyP => ih2.
        specialize (ih2 H).
        move: ih2. move /orP => ih2.
        destruct ih2.
        * left. apply/orP. right. apply/andP. split.
          all: intuition auto.
        * right. apply/orP. right. apply/andP. intuition.
          move: Heq. move /eqP => Heq. rewrite Heq. apply/eqP. reflexivity.
      + destruct H.
        * move: ih1. move /implyP => ih1.
          specialize (ih1 H).
          move: ih1. move /orP => ih1.
          destruct ih1.
          -- left. apply/orP. left. assumption.
          -- right. apply/orP. left. assumption.
        * move: ih2. move /implyP => ih2.
          specialize (ih2 H).
          move: ih2. move /orP => ih2.
          destruct ih2.
          --- simpl in ih1. move: ih1. move /orP => ih1.
              destruct ih1.
              +++ left. apply/orP. left. assumption.
              +++ right. apply/orP. left. assumption.
          --- simpl in ih1. move: ih1. move /orP => ih1.
              destruct ih1.
              +++ left. apply/orP. left. assumption.
              +++ right. apply/orP. left. assumption.
    - destruct y. all: try (intuition; reflexivity).
      unfold choice_type_lt.
      unfold choice_type_test.
      rewrite -neq_ltn.
      apply /implyP. auto.
  Qed.

  Lemma choice_type_lt_asymmetric :
    ∀ x y,
      (choice_type_lt x y ==> ~~ choice_type_lt y x).
  Proof.
    intros x y.
    apply /implyP. move => H.
    destruct (~~ choice_type_lt y x) eqn:Heq.
    - intuition.
    - move: Heq. move /negP /negP => Heq.
      pose  (choice_type_lt_areflexive x) as Harefl.
      move: Harefl. apply /implyP. rewrite implyNb.
      apply /orP. left.
      apply (choice_type_lt_transitive _ _ _ H Heq).
  Qed.

  Lemma choice_type_lt_total_not_holds :
    ∀ x y,
      ~~ (choice_type_test x y) ==> (~~ (choice_type_lt x y && choice_type_lt y x)).
  Proof.
    intros x y. apply /implyP. intros Hneq.
    pose (choice_type_lt_total_holds x y) as Htot.
    move: Htot. move /implyP => Htot. specialize (Htot Hneq).
    move: Htot. move /orP => Htot. apply /nandP. destruct Htot.
    - right. pose (choice_type_lt_asymmetric x y) as Hasym.
      move: Hasym. move /implyP => Hasym. specialize (Hasym H). assumption.
    - left. pose (choice_type_lt_asymmetric y x) as Hasym.
      move: Hasym. move /implyP => Hasym. specialize (Hasym H). assumption.
  Qed.

  Lemma choice_type_lt_tot :
    ∀ x y,
      (choice_type_lt x y || choice_type_lt y x || choice_type_eq x y).
  Proof.
    intros x y.
    destruct (choice_type_eq x y) eqn:H.
    - intuition.
    - apply/orP.
      left.
      unfold choice_type_eq in H.
      pose (choice_type_lt_total_holds x y).
      move: i. move /implyP => i.
      apply i. apply/negP.
      intuition. move: H0. rewrite H. intuition.
  Qed.

  Lemma choice_type_leqP : Ord.axioms choice_type_leq.
  Proof.
    split => //.
    - intro x. unfold choice_type_leq.
      apply/orP. left. apply /eqP. reflexivity.
    - intros v u w h1 h2.
      move: h1 h2. unfold choice_type_leq.
      move /orP => h1. move /orP => h2.
      destruct h1.
      + move: H. move /eqP => H. destruct H.
        apply/orP. assumption.
      + destruct h2.
        * move: H0. move /eqP => H0. destruct H0.
          apply/orP. right. assumption.
        * apply/orP. right. exact (choice_type_lt_transitive _ _ _ H H0).
    - unfold antisymmetric.
      move => x y. unfold choice_type_leq. move/andP => [h1 h2].
      move: h1 h2. unfold choice_type_leq.
      move /orP => h1. move /orP => h2.
      destruct h1.
      1:{ move: H. move /eqP. intuition auto. }
      destruct h2.
      1:{ move: H0. move /eqP. intuition auto. }
      destruct (~~ (choice_type_test x y)) eqn:Heq.
      + move: Heq. move /idP => Heq.
        pose (choice_type_lt_total_not_holds x y) as Hp.
        move: Hp. move /implyP => Hp. specialize (Hp Heq).
        move: Hp. move /nandP => Hp.
        destruct Hp.
        * move: H. move /eqP /eqP => H. rewrite H in H1. simpl in H1.
          discriminate.
        * move: H0. move /eqP /eqP => H0. rewrite H0 in H1. simpl in H1.
          discriminate.
      + move: Heq. move /eqP. auto.
    - unfold total.
      intros x y. unfold choice_type_leq.
      pose (choice_type_lt_tot x y).
      move: i. move /orP => H.
      destruct H.
      + move: H. move /orP => H.
        destruct H.
        * apply/orP. left. apply/orP. right. assumption.
        * apply/orP. right. apply/orP. right. assumption.
      + apply/orP. left. apply/orP. left. assumption.
  Qed.

  Fixpoint encode (t : choice_type) : GenTree.tree nat :=
  match t with
  | chUnit => GenTree.Leaf 1
  | chBool => GenTree.Leaf 2
  | chNat => GenTree.Leaf 3
  | chProd l r => GenTree.Node 1 [:: encode l ; encode r]
  | chMap l r => GenTree.Node 2 [:: encode l ; encode r]
  | chOption u => GenTree.Node 3 [:: encode u]
  | chFin n => GenTree.Leaf ((4 + n) - 1)%N
  end.

  Fixpoint decode (t : GenTree.tree nat) : option choice_type :=
    match t with
    | GenTree.Leaf 1 => Some chUnit
    | GenTree.Leaf 2 => Some chBool
    | GenTree.Leaf 3 => Some chNat
    | GenTree.Leaf n =>
      Some ( chFin (mkpos ((n - 4).+1)%N) )
    | GenTree.Node 1 [:: l ; r] =>
      match decode l, decode r with
      | Some l, Some r => Some (chProd l r)
      | _, _ => None
      end
    | GenTree.Node 2 [:: l ; r] =>
      match decode l, decode r with
      | Some l, Some r => Some (chMap l r)
      | _, _ => None
      end
    | GenTree.Node 3 [:: l] =>
      match decode l with
      | Some l => Some (chOption l)
      | _ => None
      end
    | _ => None
    end.

  Lemma codeK : pcancel encode decode.
  Proof.
    intro t. induction t.
    all: intuition.
    all: simpl.
    - rewrite IHt1. rewrite IHt2. reflexivity.
    - rewrite IHt1. rewrite IHt2. reflexivity.
    - rewrite IHt. reflexivity.
    - destruct n as [n npos]. cbn.
      destruct n.
      + discriminate.
      + cbn.
        rewrite -subnE subn0. repeat f_equal. apply eq_irrelevance.
  Defined.

  Definition choice_type_choiceMixin := PcanChoiceMixin codeK.
  Canonical choice_type_choiceType :=
    ChoiceType choice_type choice_type_choiceMixin.

  Definition choice_type_ordMixin := OrdMixin choice_type_leqP.
  Canonical choice_type_ordType :=
    Eval hnf in OrdType choice_type choice_type_ordMixin.

End choice_typeTypes.


From vcfloat Require Export klist FPLang FPLangOpt RAux Rounding Reify Float_notations Automate Prune.
Require Derive.
Set Bullet Behavior "Strict Subproofs".

(* The following RtoFloat tactics are a very crude way to convert a n
  expression of type R that uses only IZR, Rplus, Rmult, Rdiv, Rinv,
  to a primitive floating-point constant.  It's crude in part because
  it always uses rounding-UP, which is not really appropriate, and it'
 does not use interval arithmetic.   It could perhaps be improved to actually
 compute in interval arithmetic, etc.

  Usage:
  RtoFloat' x    returns a float-valued expression corresponding
                                  to the real-valued expression
  RtoFloat x    returns a float-valued constant from the real-valued expr
  ShowBound  prints it out with its name.
*)

Ltac RtoFloat' x :=
lazymatch x with
| IZR ?z => constr:(Tactic_float.Float.fromZ_UP 53%Z z)
| Rplus ?a ?b => let a' := RtoFloat' a in let b' := RtoFloat' b in constr:(PrimFloat.add a' b')
| Rmult ?a ?b => let a' := RtoFloat' a in let b' := RtoFloat' b in constr:(PrimFloat.mul a' b')
| Rdiv ?a ?b => let a' := RtoFloat' a in let b' := RtoFloat' b in constr:(PrimFloat.div a' b')
| Rinv ?a => let a' := RtoFloat' a in constr:(PrimFloat.div PrimFloat.one a')
| _ => let y := eval unfold x in x in RtoFloat' y
end.

Ltac RtoFloat x :=
   let y := eval simpl in x in
   let y := RtoFloat' y in
   let y := eval compute in y in
   exact y.

Import Binary.

Definition some_nan64:  {x : binary_float 53 1024 | is_nan _ _ x = true}.
exists (B754_nan 53 1024 false 1 (eq_refl _)). reflexivity.
Defined.

Require Import vcfloat.Float_notations.

Ltac ShowBound bound :=
  match type of bound with
  | ?t => first [unify t R | fail 1 "ShowBound expects an argument of type R but" bound "has type" t]
  end;
  let y := eval simpl in bound in
  let y := RtoFloat' y in
  let y := constr:(BSN2B _ _ some_nan64 (@BinarySingleNaN.SF2B 53 1024 (FloatOps.Prim2SF y) (eq_refl _))) in
  let y := eval compute in y in
  match y with  B754_finite 53 1024 ?s ?m ?e ?H =>
     let z := constr:(b64_B754_finite s m e H) in
     idtac "ShowBound" bound z; exact z
  end.

Ltac CheckBound x hi :=
     idtac "Checking that" x "is indeed less than" hi;
       exact (Binary.Bcompare _ _ ltac:(ShowBound x) hi = Some Lt).


Require Import List.
Require Import Psatz.
Require Import Classical.
Require Import ZArith.
Require Import VCF.Sem.
Require Import VCF.ZFuncDomain.
Require Import VCF.SetsDomain.
Require Import VCF.BinRelDomain.
Require VCF.WhileLang.
Require VCF.WhileLang_RelSem.
Require VCF.ThreeValueWhileLang.

Import ListNotations.

Module S.
Include VCF.WhileLang.
Include VCF.WhileLang_RelSem.
End S.

Module T := VCF.ThreeValueWhileLang.

Fixpoint max_var_aexp (a: S.aexp): S.var :=
  match a with
  | S.APlus a1 a2 => Nat.max (max_var_aexp a1) (max_var_aexp a2)
  | S.AMinus a1 a2 => Nat.max (max_var_aexp a1) (max_var_aexp a2)
  | S.AMult a1 a2 => Nat.max (max_var_aexp a1) (max_var_aexp a2)
  | S.AId X => X
  | S.ANum _ => 0%nat
  end.

Fixpoint max_var_bexp (b: S.bexp): S.var :=
  match b with
  | S.BEq a1 a2 => Nat.max (max_var_aexp a1) (max_var_aexp a2)
  | S.BLe a1 a2 => Nat.max (max_var_aexp a1) (max_var_aexp a2)
  | S.BAnd b1 b2 => Nat.max (max_var_bexp b1) (max_var_bexp b2)
  | S.BNot b1 => max_var_bexp b1
  | S.BTrue => 0%nat
  | S.BFalse => 0%nat
  end.

Fixpoint max_var_com (c: S.com): S.var :=
  match c with
  | S.CAss X a => Nat.max X (max_var_aexp a)
  | S.CSkip => 0%nat
  | S.CSeq c1 c2 => Nat.max (max_var_com c1) (max_var_com c2)
  | S.CIf b c1 c2 => Nat.max (max_var_bexp b) (Nat.max (max_var_com c1) (max_var_com c2))
  | S.CWhile b c1 => Nat.max (max_var_bexp b) (max_var_com c1)
  end.

Fixpoint op_count_aexp (a: S.aexp): nat :=
  match a with
  | S.APlus a1 a2 => 1 + op_count_aexp a1 + op_count_aexp a2
  | S.AMinus a1 a2 => 1 + op_count_aexp a1 + op_count_aexp a2
  | S.AMult a1 a2 => 1 + op_count_aexp a1 + op_count_aexp a2
  | S.AId X => 0%nat
  | S.ANum _ => 1%nat
  end.

Fixpoint op_count_bexp (b: S.bexp): nat :=
  match b with
  | S.BEq a1 a2 => 1 + op_count_aexp a1 + op_count_aexp a2
  | S.BLe a1 a2 => 1 + op_count_aexp a1 + op_count_aexp a2
  | S.BAnd b1 b2 => 1 + op_count_bexp b1 + op_count_bexp b2
  | S.BNot b1 => 1 + op_count_bexp b1
  | S.BTrue => 1%nat
  | S.BFalse => 1%nat
  end.

Fixpoint op_count_com (c: S.com): S.var :=
  match c with
  | S.CAss X a => op_count_aexp a
  | S.CSkip => 0%nat
  | S.CSeq c1 c2 => op_count_com c1 + op_count_com c2
  | S.CIf b c1 c2 => op_count_bexp b + op_count_com c1 + op_count_com c2
  | S.CWhile b c1 => op_count_bexp b + op_count_com c1
  end.

Fixpoint translate_aexp (a: S.aexp) (bg: nat): list T.com * T.var :=
  match a with
  | S.APlus a1 a2 =>
      match translate_aexp a1 bg, translate_aexp a2 (bg + op_count_aexp a1) with
      | (c1, X1), (c2, X2) =>
           (c1 ++ c2 ++ [T.CAssBinop (bg + op_count_aexp a1 + op_count_aexp a2 + 1) T.APlus X1 X2],
            bg + op_count_aexp a1 + op_count_aexp a2 + 1)
      end
  | S.AMinus a1 a2 =>
      match translate_aexp a1 bg, translate_aexp a2 (bg + op_count_aexp a1) with
      | (c1, X1), (c2, X2) =>
           (c1 ++ c2 ++ [T.CAssBinop (bg + op_count_aexp a1 + op_count_aexp a2 + 1) T.AMinus X1 X2],
            bg + op_count_aexp a1 + op_count_aexp a2 + 1)
      end
  | S.AMult a1 a2 =>
      match translate_aexp a1 bg, translate_aexp a2 (bg + op_count_aexp a1) with
      | (c1, X1), (c2, X2) =>
           (c1 ++ c2 ++ [T.CAssBinop (bg + op_count_aexp a1 + op_count_aexp a2 + 1) T.AMult X1 X2],
            bg + op_count_aexp a1 + op_count_aexp a2 + 1)
      end
  | S.AId X => ([], X)
  | S.ANum n => ([T.CAssConst (bg + 1) n], bg + 1)
  end.

Fixpoint translate_bexp (b: S.bexp) (bg: nat): list T.com * T.var :=
  match b with
  | S.BEq a1 a2 =>
      match translate_aexp a1 bg, translate_aexp a2 (bg + op_count_aexp a1) with
      | (c1, X1), (c2, X2) =>
           (c1 ++ c2 ++ [T.CAssBinop (bg + op_count_aexp a1 + op_count_aexp a2 + 1) T.BEq X1 X2],
            bg + op_count_aexp a1 + op_count_aexp a2 + 1)
      end
  | S.BLe a1 a2 =>
      match translate_aexp a1 bg, translate_aexp a2 (bg + op_count_aexp a1) with
      | (c1, X1), (c2, X2) =>
           (c1 ++ c2 ++ [T.CAssBinop (bg + op_count_aexp a1 + op_count_aexp a2 + 1) T.BLe X1 X2],
            bg + op_count_aexp a1 + op_count_aexp a2 + 1)
      end
  | S.BAnd b1 b2 =>
      match translate_bexp b1 bg, translate_bexp b2 (bg + op_count_bexp b1) with
      | (c1, X1), (c2, X2) =>
           (c1 ++ c2 ++ [T.CAssBinop (bg + op_count_bexp b1 + op_count_bexp b2 + 1) T.BAnd X1 X2],
            bg + op_count_bexp b1 + op_count_bexp b2 + 1)
      end
  | S.BNot b1 =>
      match translate_bexp b1 bg with
      | (c1, X1) =>
           (c1 ++ [T.CAssUnop (bg + op_count_bexp b1 + 1) T.BNot X1],
            bg + op_count_bexp b1 + 1)
      end
  | S.BTrue => ([T.CAssConst (bg + 1) 1], bg + 1)
  | S.BFalse => ([T.CAssConst (bg + 1) 0], bg + 1)
  end.

Fixpoint translate_com (c: S.com) (bg: nat): T.com :=
  match c with
  | S.CSkip => T.CSkip
  | S.CAss X a =>
      match translate_aexp a bg with
      | (cs, Y) => fold_right T.CSeq (T.CAssVar X Y) cs
      end
  | S.CSeq c1 c2 =>
      T.CSeq (translate_com c1 bg) (translate_com c2 (bg + op_count_com c))
  | S.CIf b c1 c2 =>
      match translate_bexp b bg with
      | (cs, Y) => fold_right T.CSeq (T.CIf Y (translate_com c1 (bg + op_count_bexp b)) (translate_com c2 (bg + op_count_bexp b + op_count_com c1))) cs
      end
  | S.CWhile b c1 =>
      match translate_bexp b bg with
      | (cs, Y) => fold_right T.CSeq (T.CWhile Y (fold_left T.CSeq cs (translate_com c1 (bg + op_count_bexp b)))) cs
      end
  end.

Definition compile (c: S.com): T.com := translate_com c 0%nat.

Lemma translate_aexp_new_var_correct: forall a bg cs Y,
  translate_aexp a bg = (cs, Y) ->
  max_var_aexp a <= bg ->
  Y <= bg + op_count_aexp a.
Proof.
  induction a; intros; simpl in *.
  + injection H as ? ?; omega.
  + injection H as ? ?; omega.
  + destruct (translate_aexp a1 bg) as [cs1 Y1] eqn:?TR.
    destruct (translate_aexp a2 (bg + op_count_aexp a1)) as [cs2 Y2] eqn:?TR.
    injection H as ? ?; omega.
  + destruct (translate_aexp a1 bg) as [cs1 Y1] eqn:?TR.
    destruct (translate_aexp a2 (bg + op_count_aexp a1)) as [cs2 Y2] eqn:?TR.
    injection H as ? ?; omega.
  + destruct (translate_aexp a1 bg) as [cs1 Y1] eqn:?TR.
    destruct (translate_aexp a2 (bg + op_count_aexp a1)) as [cs2 Y2] eqn:?TR.
    injection H as ? ?; omega.
Qed.

Lemma translate_bexp_new_var_correct: forall b bg cs Y,
  translate_bexp b bg = (cs, Y) ->
  max_var_bexp b <= bg ->
  Y <= bg + op_count_bexp b.
Proof.
  induction b; intros; simpl in *.
  + injection H as ? ?; omega.
  + injection H as ? ?; omega.
  + destruct (translate_aexp a1 bg) as [cs1 Y1] eqn:?TR.
    destruct (translate_aexp a2 (bg + op_count_aexp a1)) as [cs2 Y2] eqn:?TR.
    injection H as ? ?; omega.
  + destruct (translate_aexp a1 bg) as [cs1 Y1] eqn:?TR.
    destruct (translate_aexp a2 (bg + op_count_aexp a1)) as [cs2 Y2] eqn:?TR.
    injection H as ? ?; omega.
  + destruct (translate_bexp b bg) as [cs1 Y1] eqn:?TR.
    injection H as ? ?; omega.
  + destruct (translate_bexp b1 bg) as [cs1 Y1] eqn:?TR.
    destruct (translate_bexp b2 (bg + op_count_bexp b1)) as [cs2 Y2] eqn:?TR.
    injection H as ? ?; omega.
Qed.

Lemma translate_aexp_correct: forall a bg st1 st2 st3 cs Y,
  (forall X, X <= max_var_aexp a -> st1 X = st2 X) ->
  max_var_aexp a <= bg ->
  translate_aexp a bg = (cs, Y) ->
  T.ceval (fold_right T.CSeq T.CSkip cs) st2 st3 ->
  (forall X, X <= bg -> st2 X = st3 X) /\ S.aeval a st1 = st3 Y.
Proof.
  induction a; simpl max_var_aexp; intros.
  + simpl in H1.
    injection H1 as ? ?; subst.
    simpl in H2.
    rewrite (Rel_concat_id _ _ _ _ _) in H2.
    destruct H2.
    split.
    - intros.
      apply H2; omega.
    - unfold S.aeval, S.constant_func.
      congruence.
  + simpl in H1.
    injection H1 as ? ?; subst.
    simpl in H2.
    unfold Rel.id in H2; subst.
    split; auto.
    simpl.
    unfold S.query_var.
    apply H.
    lia.
  + pose proof Nat.max_lub_l _ _ _ H0.
    pose proof Nat.max_lub_r _ _ _ H0.
    simpl in H1.
    destruct (translate_aexp a1 bg) as [cs1 Y1] eqn:?TR.
    destruct (translate_aexp a2 (bg + op_count_aexp a1)) as [cs2 Y2] eqn:?TR.
    injection H1 as ? ?; subst.
    simpl in H2.
    rewrite T.ceval_fold_right_CSeq in H2.
    rewrite !map_app, !fold_right_app in H2.
    apply fold_right_concat_iff in H2.
    destruct H2 as [st2' [? ?]].
    apply fold_right_concat_iff in H2.
    destruct H2 as [st2'' [? ?]].
    simpl in H5.
    rewrite (Rel_concat_id _ _ _ _ _) in H5.
    destruct H5.
    assert (forall X, X <= max_var_aexp a1 -> st1 X = st2 X)
           by (intros; apply H; lia).
    specialize (IHa1 _ _ _ _ _ _ H7 H3 TR
                     ltac:(rewrite T.ceval_fold_right_CSeq; apply H1)).
    assert (forall X, X <= max_var_aexp a2 -> st1 X = st2' X).
    {
      intros.
      rewrite H by lia.
      apply (proj1 IHa1).
      lia.
    }
    specialize (IHa2 (bg + op_count_aexp a1) _ _ _ _ _ H8
                     ltac:(lia) TR0
                     ltac:(rewrite T.ceval_fold_right_CSeq; apply H2)).
    split.
    - intros.
      rewrite (proj1 IHa1) by lia.
      rewrite (proj1 IHa2) by lia.
      apply H6.
      omega.
    - simpl.
      unfold ZFunc.add.
      rewrite H5.
      rewrite (proj2 IHa1), (proj2 IHa2).
      rewrite (proj1 IHa2) by (eapply translate_aexp_new_var_correct; eauto).
      auto.
  + pose proof Nat.max_lub_l _ _ _ H0.
    pose proof Nat.max_lub_r _ _ _ H0.
    simpl in H1.
    destruct (translate_aexp a1 bg) as [cs1 Y1] eqn:?TR.
    destruct (translate_aexp a2 (bg + op_count_aexp a1)) as [cs2 Y2] eqn:?TR.
    injection H1 as ? ?; subst.
    simpl in H2.
    rewrite T.ceval_fold_right_CSeq in H2.
    rewrite !map_app, !fold_right_app in H2.
    apply fold_right_concat_iff in H2.
    destruct H2 as [st2' [? ?]].
    apply fold_right_concat_iff in H2.
    destruct H2 as [st2'' [? ?]].
    simpl in H5.
    rewrite (Rel_concat_id _ _ _ _ _) in H5.
    destruct H5.
    assert (forall X, X <= max_var_aexp a1 -> st1 X = st2 X)
           by (intros; apply H; lia).
    specialize (IHa1 _ _ _ _ _ _ H7 H3 TR
                     ltac:(rewrite T.ceval_fold_right_CSeq; apply H1)).
    assert (forall X, X <= max_var_aexp a2 -> st1 X = st2' X).
    {
      intros.
      rewrite H by lia.
      apply (proj1 IHa1).
      lia.
    }
    specialize (IHa2 (bg + op_count_aexp a1) _ _ _ _ _ H8
                     ltac:(lia) TR0
                     ltac:(rewrite T.ceval_fold_right_CSeq; apply H2)).
    split.
    - intros.
      rewrite (proj1 IHa1) by lia.
      rewrite (proj1 IHa2) by lia.
      apply H6.
      omega.
    - simpl.
      unfold ZFunc.sub.
      rewrite H5.
      rewrite (proj2 IHa1), (proj2 IHa2).
      rewrite (proj1 IHa2) by (eapply translate_aexp_new_var_correct; eauto).
      auto.
  + pose proof Nat.max_lub_l _ _ _ H0.
    pose proof Nat.max_lub_r _ _ _ H0.
    simpl in H1.
    destruct (translate_aexp a1 bg) as [cs1 Y1] eqn:?TR.
    destruct (translate_aexp a2 (bg + op_count_aexp a1)) as [cs2 Y2] eqn:?TR.
    injection H1 as ? ?; subst.
    simpl in H2.
    rewrite T.ceval_fold_right_CSeq in H2.
    rewrite !map_app, !fold_right_app in H2.
    apply fold_right_concat_iff in H2.
    destruct H2 as [st2' [? ?]].
    apply fold_right_concat_iff in H2.
    destruct H2 as [st2'' [? ?]].
    simpl in H5.
    rewrite (Rel_concat_id _ _ _ _ _) in H5.
    destruct H5.
    assert (forall X, X <= max_var_aexp a1 -> st1 X = st2 X)
           by (intros; apply H; lia).
    specialize (IHa1 _ _ _ _ _ _ H7 H3 TR
                     ltac:(rewrite T.ceval_fold_right_CSeq; apply H1)).
    assert (forall X, X <= max_var_aexp a2 -> st1 X = st2' X).
    {
      intros.
      rewrite H by lia.
      apply (proj1 IHa1).
      lia.
    }
    specialize (IHa2 (bg + op_count_aexp a1) _ _ _ _ _ H8
                     ltac:(lia) TR0
                     ltac:(rewrite T.ceval_fold_right_CSeq; apply H2)).
    split.
    - intros.
      rewrite (proj1 IHa1) by lia.
      rewrite (proj1 IHa2) by lia.
      apply H6.
      omega.
    - simpl.
      unfold ZFunc.mul.
      rewrite H5.
      rewrite (proj2 IHa1), (proj2 IHa2).
      rewrite (proj1 IHa2) by (eapply translate_aexp_new_var_correct; eauto).
      auto.
Qed.

Lemma translate_bexp_correct: forall b bg st1 st2 st3 cs Y,
  (forall X, X <= max_var_bexp b -> st1 X = st2 X) ->
  max_var_bexp b <= bg ->
  translate_bexp b bg = (cs, Y) ->
  T.ceval (fold_right T.CSeq T.CSkip cs) st2 st3 ->
  (forall X, X <= bg -> st2 X = st3 X) /\ (S.beval b st1 <-> st3 Y = 1%Z) /\ (~ S.beval b st1 <-> st3 Y = 0%Z).
Proof.
  induction b; simpl max_var_bexp; intros.
  + simpl in H1.
    injection H1 as ? ?; subst.
    simpl in H2.
    rewrite (Rel_concat_id _ _ _ _ _) in H2.
    destruct H2.
    split; [| split].
    - intros.
      apply H2; omega.
    - simpl.
      unfold S.beval.
      tauto.
    - simpl.
      unfold S.beval.
      split; [tauto | intros; omega].
  + simpl in H1.
    injection H1 as ? ?; subst.
    simpl in H2.
    rewrite (Rel_concat_id _ _ _ _ _) in H2.
    destruct H2.
    split; [| split].
    - intros.
      apply H2; omega.
    - simpl.
      unfold S.beval.
      split; [tauto | intros; omega].
    - simpl.
      unfold S.beval.
      tauto.
  + pose proof Nat.max_lub_l _ _ _ H0.
    pose proof Nat.max_lub_r _ _ _ H0.
    simpl in H1.
    destruct (translate_aexp a1 bg) as [cs1 Y1] eqn:?TR.
    destruct (translate_aexp a2 (bg + op_count_aexp a1)) as [cs2 Y2] eqn:?TR.
    injection H1 as ? ?; subst.
    simpl in H2.
    rewrite T.ceval_fold_right_CSeq in H2.
    rewrite !map_app, !fold_right_app in H2.
    apply fold_right_concat_iff in H2.
    destruct H2 as [st2' [? ?]].
    apply fold_right_concat_iff in H2.
    destruct H2 as [st2'' [? ?]].
    simpl in H5.
    rewrite (Rel_concat_id _ _ _ _ _) in H5.
    destruct H5.
    assert (forall X, X <= max_var_aexp a1 -> st1 X = st2 X)
           by (intros; apply H; lia).
    specialize (translate_aexp_correct _ _ _ _ _ _ _ H7 H3 TR
                     ltac:(rewrite T.ceval_fold_right_CSeq; apply H1)) as IHa1.
    assert (forall X, X <= max_var_aexp a2 -> st1 X = st2' X).
    {
      intros.
      rewrite H by lia.
      apply (proj1 IHa1).
      lia.
    }
    specialize (translate_aexp_correct _ (bg + op_count_aexp a1) _ _ _ _ _ H8
                     ltac:(lia) TR0
                     ltac:(rewrite T.ceval_fold_right_CSeq; apply H2)) as IHa2.
    split.
    - intros.
      rewrite (proj1 IHa1) by lia.
      rewrite (proj1 IHa2) by lia.
      apply H6.
      omega.
    - simpl.
      unfold ZFunc.test_eq.
      rewrite H5.
      rewrite (proj2 IHa1), (proj2 IHa2).
      rewrite (proj1 IHa2) by (eapply translate_aexp_new_var_correct; eauto).
      destruct (st2'' Y1 =? st2'' Y2)%Z eqn:?H.
      * apply Z.eqb_eq in H9.
        split; [tauto | split; intros; [tauto | congruence]].
      * apply Z.eqb_neq in H9.
        split; [split; intros; [tauto | congruence] | tauto].
  + pose proof Nat.max_lub_l _ _ _ H0.
    pose proof Nat.max_lub_r _ _ _ H0.
    simpl in H1.
    destruct (translate_aexp a1 bg) as [cs1 Y1] eqn:?TR.
    destruct (translate_aexp a2 (bg + op_count_aexp a1)) as [cs2 Y2] eqn:?TR.
    injection H1 as ? ?; subst.
    simpl in H2.
    rewrite T.ceval_fold_right_CSeq in H2.
    rewrite !map_app, !fold_right_app in H2.
    apply fold_right_concat_iff in H2.
    destruct H2 as [st2' [? ?]].
    apply fold_right_concat_iff in H2.
    destruct H2 as [st2'' [? ?]].
    simpl in H5.
    rewrite (Rel_concat_id _ _ _ _ _) in H5.
    destruct H5.
    assert (forall X, X <= max_var_aexp a1 -> st1 X = st2 X)
           by (intros; apply H; lia).
    specialize (translate_aexp_correct _ _ _ _ _ _ _ H7 H3 TR
                     ltac:(rewrite T.ceval_fold_right_CSeq; apply H1)) as IHa1.
    assert (forall X, X <= max_var_aexp a2 -> st1 X = st2' X).
    {
      intros.
      rewrite H by lia.
      apply (proj1 IHa1).
      lia.
    }
    specialize (translate_aexp_correct _ (bg + op_count_aexp a1) _ _ _ _ _ H8
                     ltac:(lia) TR0
                     ltac:(rewrite T.ceval_fold_right_CSeq; apply H2)) as IHa2.
    split.
    - intros.
      rewrite (proj1 IHa1) by lia.
      rewrite (proj1 IHa2) by lia.
      apply H6.
      omega.
    - simpl.
      unfold ZFunc.test_le.
      rewrite H5.
      rewrite (proj2 IHa1), (proj2 IHa2).
      rewrite (proj1 IHa2) by (eapply translate_aexp_new_var_correct; eauto).
      destruct (st2'' Y1 <=? st2'' Y2)%Z eqn:?H.
      * apply Z.leb_le in H9.
        split; [tauto | split; intros; [tauto | congruence]].
      * apply Z.leb_gt in H9.
        split; [split; intros; [omega | congruence] | omega].
  + simpl in H1.
    destruct (translate_bexp b bg) as [cs1 Y1] eqn:?TR.
    injection H1 as ? ?; subst.
    rewrite T.ceval_fold_right_CSeq in H2.
    rewrite !map_app, !fold_right_app in H2.
    apply fold_right_concat_iff in H2.
    destruct H2 as [st2' [? ?]].
    simpl in H2.
    rewrite (Rel_concat_id _ _ _ _ _) in H2.
    destruct H2.
    assert (forall X, X <= max_var_bexp b -> st1 X = st2 X)
           by (intros; apply H; lia).
    specialize (IHb _ _ _ _ _ _ H4 H0 TR
                     ltac:(rewrite T.ceval_fold_right_CSeq; apply H1)).
    split.
    - intros.
      rewrite (proj1 IHb) by lia.
      apply H3.
      omega.
    - simpl.
      unfold Sets.complement.
      rewrite H2.
      destruct (st2' Y1 =? 0)%Z eqn:?H.
      * apply Z.eqb_eq in H5.
        split; [tauto | split; intros; [tauto | congruence]].
      * apply Z.eqb_neq in H5.
        split; [split; intros; [tauto | congruence] | tauto].
  + pose proof Nat.max_lub_l _ _ _ H0.
    pose proof Nat.max_lub_r _ _ _ H0.
    simpl in H1.
    destruct (translate_bexp b1 bg) as [cs1 Y1] eqn:?TR.
    destruct (translate_bexp b2 (bg + op_count_bexp b1)) as [cs2 Y2] eqn:?TR.
    injection H1 as ? ?; subst.
    simpl in H2.
    rewrite T.ceval_fold_right_CSeq in H2.
    rewrite !map_app, !fold_right_app in H2.
    apply fold_right_concat_iff in H2.
    destruct H2 as [st2' [? ?]].
    apply fold_right_concat_iff in H2.
    destruct H2 as [st2'' [? ?]].
    simpl in H5.
    rewrite (Rel_concat_id _ _ _ _ _) in H5.
    destruct H5.
    assert (forall X, X <= max_var_bexp b1 -> st1 X = st2 X)
           by (intros; apply H; lia).
    specialize (IHb1 _ _ _ _ _ _ H7 H3 TR
                     ltac:(rewrite T.ceval_fold_right_CSeq; apply H1)).
    assert (forall X, X <= max_var_bexp b2 -> st1 X = st2' X).
    {
      intros.
      rewrite H by lia.
      apply (proj1 IHb1).
      lia.
    }
    specialize (IHb2 (bg + op_count_bexp b1) _ _ _ _ _ H8
                     ltac:(lia) TR0
                     ltac:(rewrite T.ceval_fold_right_CSeq; apply H2)).
    split.
    - intros.
      rewrite (proj1 IHb1) by lia.
      rewrite (proj1 IHb2) by lia.
      apply H6.
      omega.
    - simpl.
      rewrite H5.
      rewrite (proj1 IHb2) in IHb1 by (eapply translate_bexp_new_var_correct; eauto).
      destruct (classic (S.beval b1 st1)) as [HH1 | HH1];
        [ pose proof proj1 (proj1 (proj2 IHb1)) HH1
        | pose proof proj1 (proj2 (proj2 IHb1)) HH1];
      (destruct (classic (S.beval b2 st1)) as [HH2 | HH2];
        [ pose proof proj1 (proj1 (proj2 IHb2)) HH2
        | pose proof proj1 (proj2 (proj2 IHb2)) HH2]);
      rewrite H9, H10; simpl;
      first [ split; [tauto | split; intros; [tauto | congruence]]
            | split; [split; intros; [tauto | congruence] | tauto]].
Qed.

Lemma translate_com_correct: forall c bg st1 st2 st3 st4 c',
  (forall X, X <= max_var_com c -> st1 X = st2 X) ->
  max_var_com c <= bg ->
  translate_com c bg = c' ->
  S.ceval c st1 st3 ->
  T.ceval c' st2 st4 ->
  (forall X, X <= bg -> st3 X = st4 X).
Proof.
  induction c.
  + intros.
    simpl in H1.
    subst.
    simpl in H2, H3.
    unfold Rel.id.
Abort.


Require Import Coq.derive.Derive.

Derive f SuchThat (f = 1 + 1) As feq.
Proof.
  transitivity 2; [refine (eq_refl 2)|].
  transitivity 2.
  2:abstract exact (eq_refl 2).


From QuickChick Require Import Show Checker State Classes.
From QuickChick Require Import Producer Generators.
Require Import List.
Import ListNotations.

(*
=====================
  Utility functions
=====================
*)

(* Make a frequency-weighted list of generators where the weight is equal to *)
(* some constant mutliple of the rank (worst = 1, 2nd worst = 2, etc.)*)
Fixpoint rankify {A : Type} {_ : Mutate A} (scale : nat) (l : list (A * nat)) : (list (nat * G A) * nat) :=
    match l with
    | nil => (nil, 0)
    | (a, _) :: l' =>
      let (rest, rank) := rankify scale l' in
      let rank' := (scale * rank+1) in
      ((rank', mutate a) :: rest, rank + 1)
    end.

(* Large(?) constant for focusedStrat.*)
Axiom focusedStratScaleRatio    : nat.
Extract Constant focusedStratScaleRatio    => "100".

Definition gte n m := Nat.leb m n.

(*
=====================
  Strategies
=====================
*)
(* Just use arbitrary every time. Only here for completeness *)
Definition blindStrat {A : Type} {_ : Gen A}
           (_ : State) (_ : list (A * nat)) (_ : list (A * nat)) : G A := arbitrary.

(* Mutate the highest scoring result every time. *)
Definition bestFirstStrat {A : Type} {_ : Gen A} {_ : Mutate A}
           (_ : State) (passed : list (A * nat)) (discarded : list (A * nat)) : G A :=
    match passed with
    | nil => arbitrary
    | (a, score) :: t => mutate a
    end.

(* Mutates a randomly chosen past result weighted directly by score *)
Definition geneticStrat {A : Type} {_ : Gen A} {_ : Mutate A}
           (_ : State) (passed : list (A * nat)) (_ : list (A * nat)) : G A :=
    match passed with
    | nil => arbitrary
    | l => freq_ arbitrary (map (fun x => match x with (c,s) => (s, mutate c) end) l)
    end.

(* Mutates a randomly chosen past result weighted by _rank_ *)
(* Worst case so far has weight 1, 2nd worst has 2, etc. *)
(* Useful when your score curve is a bit jagged and weird. *)
Definition rankStrat {A : Type} {_ : Gen A} {_ : Mutate A}
                     (_ : State) (passed : list (A * nat)) (_ : list (A * nat)) : G A :=
    match passed with
    | nil => arbitrary
    | l => freq_ arbitrary (fst (rankify 1 l))
    end.

(* An approximation to simulated annealing *)
(* Real simulated annealing is probably very annoying since I have no idea how *)
(* Coq deals with floats but I assume the answer is "not very well" *)
(* This is similar to rankStrat, but the scale factor increases over time *)
(* (here, by 1 per 100 tests run.) This has the effect of starting out with *)
(* 100 arbitrarily generated test cases, and then eventually becoming more like *)
(* best first as time goes on. *)
Definition focusingStrat {A : Type} {_ : Gen A} {_ : Mutate A}
                         (st : State) (passed : list (A * nat)) (_ : list (A * nat)) : G A :=
    match passed with
    | nil => arbitrary
    | l => let totalTests := (numSuccessTests st) + (numDiscardedTests st) in
      if gte focusedStratScaleRatio totalTests then
        arbitrary (* If totalTests / focusedStratScaleRatio would be 0, just be random! *)
      else
        let scale := Nat.div totalTests focusedStratScaleRatio in
        freq_ arbitrary (fst (rankify scale l))
    end.


From isla Require Import opsem.

Definition a48 : isla_trace :=
  Smt (DeclareConst 0%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "PC" [] (RegVal_Base (Val_Symbolic 0%Z)) Mk_annot :t:
  Smt (DefineConst 1%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 0%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DeclareConst 10%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "x10" [] (RegVal_Base (Val_Symbolic 10%Z)) Mk_annot :t:
  Smt (DefineConst 11%Z (Binop ((Bvarith Bvlshr)) (Val (Val_Symbolic 10%Z) Mk_annot) (Val (Val_Bits (BV 64%N 0x1%Z)) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "x10" [] (RegVal_Base (Val_Symbolic 11%Z)) Mk_annot :t:
  WriteReg "PC" [] (RegVal_Base (Val_Symbolic 1%Z)) Mk_annot :t:
  tnil
.


Require Import Coq.ZArith.BinInt Coq.Strings.String Coq.Lists.List. Import ListNotations.
Require Import coqutil.Macros.subst coqutil.Macros.unique bedrock2.Syntax.
Require Import bedrock2.NotationsCustomEntry.
Require Import coqutil.sanity.

Local Open Scope Z_scope. Local Open Scope list_scope. Local Open Scope string_scope.

Definition bsearch := func! (left, right, target) ~> left {
  while (right - left) {
    mid = left + (((right-left) >> $4) << $3);
    if (load(mid) < target) {
      left = mid + $8
    } else {
      right = mid
    };
    coq:(cmd.unset "mid")
  }
}.

(* input_base is an address fixed at compile time *)
Definition listsum (input_base: Z) := func! () ~> sumreg {
  sumreg = $0;
  n = load4(input_base);
  i = $0;
  while (i < n) {
    a = load4(coq:(input_base + 4) + (i << $2));
    sumreg = sumreg + a;
    i = i + $1
  }
}.

(* input_base is an address fixed at compile time *)
Definition fibonacci(n: Z) := func! () ~> b {
  a = $0;
  b = $1;
  i = $0;
  while (i < n) {
    c = a + b;
    a = b;
    b = c;
    i = i + $1
  }
}.

Definition fibonacciServer (n_load_addr n_store_addr: Z) := func! () ~> b {
  n = load4(n_load_addr);
  a = $0;
  b = $1;
  i = $0;
  if (n < $47) {
    while (i < n) {
      c = a + b;
      a = b;
      b = c;
      i = i + $1
    }
  } else {
    b = $-1
  };
  store4(n_store_addr, b)
}.

Definition dummy := func! { /*skip*/ }.

Definition allProgs: list (string*func) :=
  Eval unfold bsearch, listsum, fibonacci in
    [("bsearch",bsearch); ("listsum1024",listsum 1024); ("fibonacci6",fibonacci 6)].

(*
Print allProgs.
*)

Require Import bedrock2.ToCString.
Definition allProgsAsCString : string :=
  Eval cbv in c_module allProgs.

(*
Print allProgsAsCString.
*)