(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 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/>.

  Websites : http://nuprl.org/html/verification/
             http://nuprl.org/html/Nuprl2Coq
             https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export alphaeq5.
Require Export cvterm.
Require Export nat_defs.
Require Export cequiv_props4.
Require Export per_props_set.
Require Export per_props_union.
Require Export per_props_false.
Require Export per_props_not.
Require Export per_props_product.
Require Export types_converge.
(*Require Export list.  (* ??? *)*)

Lemma nuprl_int {p} :
  forall lib, @nuprl p lib mkc_int mkc_int (equality_of_int lib).
Proof.
  sp.
  apply CL_int.
  unfold per_int; sp; spcast; try computes_to_value_refl.
Qed.

Lemma equality_of_int_xxx {p} :
  forall lib, @close p lib (univ lib) mkc_int mkc_int (equality_of_int lib).
Proof.
  apply nuprl_int.
Qed.

Lemma nat_in_int {p} : forall lib (n : nat), @member p lib (mkc_nat n) mkc_int.
Proof.
  unfold member, equality; sp.
  exists (@equality_of_int p lib).
  sp;[apply equality_of_int_xxx|].
  exists (Z_of_nat n); sp;
  unfold mkc_nat, mkc_integer, isprog_mk_nat, isprog_mk_integer, mk_nat;
    spcast; computes_to_value_refl.
Qed.

Lemma equality_in_int {p} :
  forall lib (t1 t2 : @CTerm p),
    equality lib t1 t2 mkc_int <=> equality_of_int lib t1 t2.
Proof.
  intros; split; intro e.

  - unfold equality, nuprl in e; exrepnd.
    inversion e1; subst; try not_univ.
    allunfold @per_int; sp.
    discover; sp.

  - unfold equality, nuprl.
    exists (fun a b : @CTerm p => equality_of_int lib a b); dands; tcsp.
    apply CL_int; unfold per_int; sp;
    spcast; apply computes_to_value_isvalue_refl; repeat constructor; simpl; sp.
Qed.

Lemma hasvaluec_mkc_less {o} :
  forall lib (a b c d : @CTerm o),
    hasvaluec lib (mkc_less a b c d)
    -> {k1 : Z
        & {k2 : Z
        & reduces_toc lib a (mkc_integer k1)
        # reduces_toc lib b (mkc_integer k2)
        # (((k1 < k2)%Z # hasvaluec lib c)
           [+]
           ((k2 <= k1)%Z # hasvaluec lib d)
          )}}.
Proof.
  introv hv.
  destruct_cterms; allsimpl.
  allunfold @hasvaluec; allsimpl.
  allunfold @reduces_toc; allsimpl.
  apply hasvalue_mk_less in hv; eauto 3 with slow.
Qed.

Lemma equality_in_less {o} :
  forall lib (u v a b c d : @CTerm o),
    equality lib u v (mkc_less a b c d)
    <=>
    {ka : Z
     , {kb : Z
        , a ===>(lib) (mkc_integer ka)
        # b ===>(lib) (mkc_integer kb)
        # (
            ((ka < kb)%Z # equality lib u v c)
            {+}
            ((kb <= ka)%Z # equality lib u v d)
          )}}.
Proof.
  introv.

  split; intro k; exrepnd.

  - applydup @inhabited_implies_tequality in k.
    apply types_converge in k0.
    spcast.
    apply hasvaluec_mkc_less in k0.
    exrepnd.

    exists k1 k0; dands; spcast; eauto with slow;
    try (complete (apply computes_to_valc_iff_reduces_toc; dands; eauto with slow)).

    assert (cequivc lib
                    (mkc_less a b c d)
                    (mkc_less (mkc_integer k1) (mkc_integer k0) c d)) as c1.
    { apply reduces_toc_implies_cequivc.
      destruct_cterms; allunfold @reduces_toc; allunfold @computes_to_valc; allsimpl.
      apply reduce_to_prinargs_comp; eauto with slow.
      allunfold @computes_to_value; sp; eauto with slow. }

    repndors; repnd.

    + left; dands; auto.

      assert (cequivc lib
                      (mkc_less (mkc_integer k1) (mkc_integer k0) c d)
                      c) as c2.
      { apply reduces_toc_implies_cequivc.
        destruct_cterms; unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl.
        dcwf h; simpl.
        unfold compute_step_comp; simpl; boolvar; tcsp; try omega. }

      apply cequivc_sym in c1.
      apply cequivc_sym in c2.
      rwg c2.
      rwg c1; auto.

    + right; dands; auto.

      assert (cequivc lib
                      (mkc_less (mkc_integer k1) (mkc_integer k0) c d)
                      d) as c2.
      { apply reduces_toc_implies_cequivc.
        destruct_cterms; unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl.
        dcwf h; simpl.
        unfold compute_step_comp; simpl; boolvar; tcsp; try omega. }

      apply cequivc_sym in c1.
      apply cequivc_sym in c2.
      rwg c2.
      rwg c1; auto.

  - spcast.
    assert (cequivc lib
                    (mkc_less a b c d)
                    (mkc_less (mkc_integer ka) (mkc_integer kb) c d)) as c1.
    { apply reduces_toc_implies_cequivc.
      destruct_cterms; allunfold @reduces_toc; allunfold @computes_to_valc; allsimpl.
      apply reduce_to_prinargs_comp; eauto with slow. }

    rwg c1.

    repndors; repnd.

    + assert (cequivc lib
                      (mkc_less (mkc_integer ka) (mkc_integer kb) c d)
                      c) as c2.
      { apply reduces_toc_implies_cequivc.
        destruct_cterms; unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl.
        dcwf h; simpl.
        unfold compute_step_comp; simpl; boolvar; tcsp; try omega. }

      rwg c2; auto.

    + assert (cequivc lib
                      (mkc_less (mkc_integer ka) (mkc_integer kb) c d)
                      d) as c2.
      { apply reduces_toc_implies_cequivc.
        destruct_cterms; unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl.
        dcwf h; simpl.
        unfold compute_step_comp; simpl; boolvar; tcsp; try omega. }

      rwg c2; auto.
Qed.

Lemma equality_in_true {o} :
  forall lib (u v : @CTerm o),
    equality lib u v mkc_true
    <=>
    (u ===>(lib) mkc_axiom
     # v ===>(lib) mkc_axiom).
Proof.
  introv.
  rw @mkc_true_eq.
  rw <- @equality_in_approx; split; intro k; dands; repnd; spcast; auto.
  unfold approxc; simpl.
  apply approx_decomp_axiom.
Qed.

Lemma equality_in_less_than {o} :
  forall lib (u v a b : @CTerm o),
    equality lib u v (mkc_less_than a b)
    <=>
    {ka : Z
     , {kb : Z
        , u ===>(lib) mkc_axiom
        # v ===>(lib) mkc_axiom
        # a ===>(lib) (mkc_integer ka)
        # b ===>(lib) (mkc_integer kb)
        # (ka < kb)%Z}}.
Proof.
  introv.
  rw @mkc_less_than_eq.
  rw @equality_in_less.
  split; intro k; exrepnd; spcast.
  - repndors; repnd.
    + apply equality_in_true in k1; repnd; spcast.
      exists ka kb; dands; spcast; auto.
    + apply equality_in_false in k1; sp.
  - exists ka kb; dands; spcast; auto.
    left; dands; auto.
    apply equality_in_true; dands; spcast; auto.
Qed.

Lemma inhabited_less_than {o} :
  forall lib (a b : @CTerm o),
    inhabited_type lib (mkc_less_than a b)
    <=>
    {ka : Z
     , {kb : Z
        , a ===>(lib) (mkc_integer ka)
        # b ===>(lib) (mkc_integer kb)
        # (ka < kb)%Z}}.
Proof.
  introv.
  unfold inhabited_type; split; intro k; exrepnd; spcast.
  - rw @equality_in_less_than in k0; exrepnd; spcast.
    exists ka kb; dands; spcast; auto.
  - exists (@mkc_axiom o).
    apply equality_in_less_than.
    exists ka kb; dands; spcast; auto;
    apply computes_to_valc_refl; eauto with slow.
Qed.

Lemma tequality_mkc_less_aux {o} :
  forall lib (a b c d e f g h : @CTerm o) ka kb ke kf,
    computes_to_valc lib a (mkc_integer ka)
    -> computes_to_valc lib b (mkc_integer kb)
    -> computes_to_valc lib e (mkc_integer ke)
    -> computes_to_valc lib f (mkc_integer kf)
    -> (tequality lib (mkc_less a b c d) (mkc_less e f g h)
        <=>
        (
          ((ka < kb)%Z # (ke < kf)%Z # tequality lib c g)
          [+]
          ((kb <= ka)%Z # (kf <= ke)%Z # tequality lib d h)
          [+]
          ((ka < kb)%Z # (kf <= ke)%Z # tequality lib c h)
          [+]
          ((kb <= ka)%Z # (ke < kf)%Z # tequality lib d g)
        )
       ).
Proof.
  introv ca cb ce cf.

  assert (cequivc lib
                  (mkc_less a b c d)
                  (mkc_less (mkc_integer ka) (mkc_integer kb) c d)) as c1.
  { apply reduces_toc_implies_cequivc.
    destruct_cterms; allunfold @reduces_toc; allunfold @computes_to_valc; allsimpl.
    apply reduce_to_prinargs_comp; eauto with slow. }

  assert (cequivc lib
                  (mkc_less e f g h)
                  (mkc_less (mkc_integer ke) (mkc_integer kf) g h)) as c2.
  { apply reduces_toc_implies_cequivc.
    destruct_cterms; allunfold @reduces_toc; allunfold @computes_to_valc; allsimpl.
    apply reduce_to_prinargs_comp; eauto with slow. }

  split; intro k; repnd.

  - destruct (Z_lt_ge_dec ka kb); destruct (Z_lt_ge_dec ke kf).

    + left; dands; auto.

      assert (cequivc lib
                      (mkc_less (mkc_integer ka) (mkc_integer kb) c d)
                      c) as c3.
      { apply reduces_toc_implies_cequivc.
        destruct_cterms; unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl.
        dcwf h; simpl.
        unfold compute_step_comp; simpl; boolvar; tcsp; try omega. }

      assert (cequivc lib
                      (mkc_less (mkc_integer ke) (mkc_integer kf) g h)
                      g) as c4.
      { apply reduces_toc_implies_cequivc.
        destruct_cterms; unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl.
        dcwf h; simpl.
        unfold compute_step_comp; simpl; boolvar; tcsp; try omega. }

      apply cequivc_sym in c1.
      apply cequivc_sym in c2.
      apply cequivc_sym in c3.
      apply cequivc_sym in c4.
      rwg c3.
      rwg c4.
      rwg c1.
      rwg c2; auto.

    + right; right; left; dands; auto; try omega.

      assert (cequivc lib
                      (mkc_less (mkc_integer ka) (mkc_integer kb) c d)
                      c) as c3.
      { apply reduces_toc_implies_cequivc.
        destruct_cterms; unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl.
        dcwf h; simpl.
        unfold compute_step_comp; simpl; boolvar; tcsp; try omega. }

      assert (cequivc lib
                      (mkc_less (mkc_integer ke) (mkc_integer kf) g h)
                      h) as c4.
      { apply reduces_toc_implies_cequivc.
        destruct_cterms; unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl.
        dcwf h; simpl.
        unfold compute_step_comp; simpl; boolvar; tcsp; try omega. }

      apply cequivc_sym in c1.
      apply cequivc_sym in c2.
      apply cequivc_sym in c3.
      apply cequivc_sym in c4.
      rwg c3.
      rwg c4.
      rwg c1.
      rwg c2; auto.

    + right; right; right; dands; auto; try omega.

      assert (cequivc lib
                      (mkc_less (mkc_integer ka) (mkc_integer kb) c d)
                      d) as c3.
      { apply reduces_toc_implies_cequivc.
        destruct_cterms; unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl.
        dcwf h; simpl.
        unfold compute_step_comp; simpl; boolvar; tcsp; try omega. }

      assert (cequivc lib
                      (mkc_less (mkc_integer ke) (mkc_integer kf) g h)
                      g) as c4.
      { apply reduces_toc_implies_cequivc.
        destruct_cterms; unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl.
        dcwf h; simpl.
        unfold compute_step_comp; simpl; boolvar; tcsp; try omega. }

      apply cequivc_sym in c1.
      apply cequivc_sym in c2.
      apply cequivc_sym in c3.
      apply cequivc_sym in c4.
      rwg c3.
      rwg c4.
      rwg c1.
      rwg c2; auto.

    + right; left; dands; auto; try omega.

      assert (cequivc lib
                      (mkc_less (mkc_integer ka) (mkc_integer kb) c d)
                      d) as c3.
      { apply reduces_toc_implies_cequivc.
        destruct_cterms; unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl.
        dcwf h; simpl.
        unfold compute_step_comp; simpl; boolvar; tcsp; try omega. }

      assert (cequivc lib
                      (mkc_less (mkc_integer ke) (mkc_integer kf) g h)
                      h) as c4.
      { apply reduces_toc_implies_cequivc.
        destruct_cterms; unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl.
        dcwf h; simpl.
        unfold compute_step_comp; simpl; boolvar; tcsp; try omega. }

      apply cequivc_sym in c1.
      apply cequivc_sym in c2.
      apply cequivc_sym in c3.
      apply cequivc_sym in c4.
      rwg c3.
      rwg c4.
      rwg c1.
      rwg c2; auto.

  - rwg c1.
    rwg c2.
    clear c1 c2 ca cb ce cf.
    repndors; exrepnd.

    + assert (cequivc lib
                      (mkc_less (mkc_integer ka) (mkc_integer kb) c d)
                      c) as c3.
      { apply reduces_toc_implies_cequivc.
        destruct_cterms; unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl.
        dcwf h; simpl.
        unfold compute_step_comp; simpl; boolvar; tcsp; try omega. }

      assert (cequivc lib
                      (mkc_less (mkc_integer ke) (mkc_integer kf) g h)
                      g) as c4.
      { apply reduces_toc_implies_cequivc.
        destruct_cterms; unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl.
        dcwf h; simpl.
        unfold compute_step_comp; simpl; boolvar; tcsp; try omega. }

      rwg c3.
      rwg c4; auto.

    + assert (cequivc lib
                      (mkc_less (mkc_integer ka) (mkc_integer kb) c d)
                      d) as c3.
      { apply reduces_toc_implies_cequivc.
        destruct_cterms; unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl.
        dcwf h; simpl.
        unfold compute_step_comp; simpl; boolvar; tcsp; try omega. }

      assert (cequivc lib
                      (mkc_less (mkc_integer ke) (mkc_integer kf) g h)
                      h) as c4.
      { apply reduces_toc_implies_cequivc.
        destruct_cterms; unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl.
        dcwf h; simpl.
        unfold compute_step_comp; simpl; boolvar; tcsp; try omega. }

      rwg c3.
      rwg c4; auto.

    + assert (cequivc lib
                      (mkc_less (mkc_integer ka) (mkc_integer kb) c d)
                      c) as c3.
      { apply reduces_toc_implies_cequivc.
        destruct_cterms; unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl.
        dcwf h; simpl.
        unfold compute_step_comp; simpl; boolvar; tcsp; try omega. }

      assert (cequivc lib
                      (mkc_less (mkc_integer ke) (mkc_integer kf) g h)
                      h) as c4.
      { apply reduces_toc_implies_cequivc.
        destruct_cterms; unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl.
        dcwf h; simpl.
        unfold compute_step_comp; simpl; boolvar; tcsp; try omega. }

      rwg c3.
      rwg c4; auto.

    + assert (cequivc lib
                      (mkc_less (mkc_integer ka) (mkc_integer kb) c d)
                      d) as c3.
      { apply reduces_toc_implies_cequivc.
        destruct_cterms; unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl.
        dcwf h; simpl.
        unfold compute_step_comp; simpl; boolvar; tcsp; try omega. }

      assert (cequivc lib
                      (mkc_less (mkc_integer ke) (mkc_integer kf) g h)
                      g) as c4.
      { apply reduces_toc_implies_cequivc.
        destruct_cterms; unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl.
        dcwf h; simpl.
        unfold compute_step_comp; simpl; boolvar; tcsp; try omega. }

      rwg c3.
      rwg c4; auto.
Qed.

Lemma tequality_mkc_less {o} :
  forall lib (a b c d e f g h : @CTerm o),
    tequality lib (mkc_less a b c d) (mkc_less e f g h)
    <=>
    {ka : Z
     , {kb : Z
     , {ke : Z
     , {kf : Z
        , a ===>(lib) (mkc_integer ka)
        # b ===>(lib) (mkc_integer kb)
        # e ===>(lib) (mkc_integer ke)
        # f ===>(lib) (mkc_integer kf)
        # (
            ((ka < kb)%Z # (ke < kf)%Z # tequality lib c g)
            {+}
            ((kb <= ka)%Z # (kf <= ke)%Z # tequality lib d h)
            {+}
            ((ka < kb)%Z # (kf <= ke)%Z # tequality lib c h)
            {+}
            ((kb <= ka)%Z # (ke < kf)%Z # tequality lib d g)
          )}}}}.
Proof.
  introv.

  split; intro k; exrepnd.

  - applydup @tequality_refl in k.
    applydup @tequality_sym in k.
    apply tequality_refl in k1.
    allrw @fold_type.
    apply types_converge in k0.
    apply types_converge in k1.
    spcast.

    apply hasvaluec_mkc_less in k0.
    apply hasvaluec_mkc_less in k1.
    exrepnd.

    exists k6 k0 k2 k1; dands; spcast; eauto with slow;
    try (complete (apply computes_to_valc_iff_reduces_toc; dands; eauto with slow)).

    pose proof (tequality_mkc_less_aux
                  lib a b c d e f g h k6 k0 k2 k1) as p.
    repeat (autodimp p hyp);
    try (complete (apply computes_to_valc_iff_reduces_toc; dands; eauto with slow)).
    apply p in k; sp.

  - pose proof (tequality_mkc_less_aux
                  lib a b c d e f g h ka kb ke kf) as p.
    spcast.
    repeat (autodimp p hyp).
    apply p.

    destruct (Z_lt_ge_dec ka kb); destruct (Z_lt_ge_dec ke kf).

    + left; dands; auto.
      repndors; repnd; try omega; auto.

    + right; right; left; dands; auto; try omega.
      repndors; repnd; try omega; auto.

    + right; right; right; dands; auto; try omega.
      repndors; repnd; try omega; auto.

    + right; left; dands; auto; try omega.
      repndors; repnd; try omega; auto.
Qed.

Lemma true_not_equal_to_false {o} :
  forall (lib : @library o),
    !tequality lib mkc_true mkc_false.
Proof.
  introv teq.
  unfold tequality, nuprl in teq; exrepnd.
  inversion teq0; subst; try not_univ.
  - duniv j h.
    allrw @univi_exists_iff; exrepd; spcast; repeat computes_to_value_isvalue.
  - allunfold @per_approx; exrepnd; spcast; repeat computes_to_value_isvalue.
    match goal with
      | [ H : computes_to_valc ?a ?b ?c |- _ ] => rename H into k
    end.

    apply @computes_to_valc_isvalue_eq in k; try (apply iscvalue_mkc_true).
    allrw @mkc_true_eq.
    allrw @mkc_false_eq.
    allapply @mkc_approx_eq; repnd; subst.

    match goal with
      | [ H : _ <=> _ |- _ ] => rename H into h
    end.
    destruct h.
    destruct c as [k]; spcast.

    { unfold approxc; simpl.
      apply approx_decomp_axiom. }

    apply not_axiom_approxc_bot in k; sp.
Qed.

Lemma type_mkc_true {o} :
  forall (lib : @library o), type lib mkc_true.
Proof.
  introv; rw @mkc_true_eq.
  apply tequality_mkc_approx; sp.
Qed.

Lemma tequality_mkc_less_than {o} :
  forall lib (a b c d : @CTerm o),
    tequality lib (mkc_less_than a b) (mkc_less_than c d)
    <=>
    {ka : Z
     , {kb : Z
     , {kc : Z
     , {kd : Z
        , a ===>(lib) (mkc_integer ka)
        # b ===>(lib) (mkc_integer kb)
        # c ===>(lib) (mkc_integer kc)
        # d ===>(lib) (mkc_integer kd)
        # (
            ((ka < kb)%Z # (kc < kd)%Z)
            {+}
            ((kb <= ka)%Z # (kd <= kc)%Z)
          )}}}}.
Proof.
  introv.
  allrw @mkc_less_than_eq.
  rw (tequality_mkc_less
        lib a b mkc_true mkc_false c d mkc_true mkc_false).

  split; intro k; exrepnd.

  - exists ka kb ke kf; dands; auto.
    repndors; repnd; tcsp.

    + apply true_not_equal_to_false in k1; sp.

    + apply tequality_sym in k1.
      apply true_not_equal_to_false in k1; sp.

  - exists ka kb kc kd; dands; auto.
    repndors; repnd; tcsp.

    left; sp.
    apply type_mkc_true.
Qed.

Lemma equality_in_le {o} :
  forall lib (u v a b : @CTerm o),
    equality lib u v (mkc_le a b)
    <=>
    {ka : Z
     , {kb : Z
        , a ===>(lib) (mkc_integer ka)
        # b ===>(lib) (mkc_integer kb)
        # (ka <= kb)%Z}}.
Proof.
  introv.
  rw @mkc_le_eq.
  rw @equality_in_not.
  rw @tequality_mkc_less_than.
  rw @inhabited_less_than.
  split; intro k; exrepnd; spcast; dands.
  - repeat computes_to_eqval.
    exists kb ka; dands; spcast; auto.
    repndors; repnd; tcsp.
    destruct k.
    exists ka kb; dands; spcast; auto.
  - exists kb ka kb ka; dands; spcast; auto.
  - intro h; exrepnd; spcast.
    repeat computes_to_eqval.
    omega.
Qed.

Lemma inhabited_le {o} :
  forall lib (a b : @CTerm o),
    inhabited_type lib (mkc_le a b)
    <=>
    {ka : Z
     , {kb : Z
        , a ===>(lib) (mkc_integer ka)
        # b ===>(lib) (mkc_integer kb)
        # (ka <= kb)%Z}}.
Proof.
  introv.
  unfold inhabited_type; split; intro k; exrepnd; spcast.
  - apply equality_in_le in k0; exrepnd; spcast.
    exists ka kb; dands; spcast; auto.
  - exists (@mkc_axiom o).
    apply equality_in_le.
    exists ka kb; dands; spcast; auto.
Qed.

Lemma tequality_mkc_le {o} :
  forall lib (a b c d : @CTerm o),
    tequality lib (mkc_le a b) (mkc_le c d)
    <=>
    {ka : Z
     , {kb : Z
     , {kc : Z
     , {kd : Z
        , a ===>(lib) (mkc_integer ka)
        # b ===>(lib) (mkc_integer kb)
        # c ===>(lib) (mkc_integer kc)
        # d ===>(lib) (mkc_integer kd)
        # (
            ((ka <= kb)%Z # (kc <= kd)%Z)
            {+}
            ((kb < ka)%Z # (kd < kc)%Z)
          )}}}}.
Proof.
  introv.
  allrw @mkc_le_eq.
  rw @tequality_not.
  rw @tequality_mkc_less_than.

  split; intro k; exrepnd.

  - exists kb ka kd kc; dands; auto.
    repndors; repnd; tcsp.

  - exists kb ka kd kc; dands; auto.
    repndors; repnd; tcsp.
Qed.

Hint Resolve computes_to_valc_refl : slow.

Lemma tequality_int {p} : forall lib, @tequality p lib mkc_int mkc_int.
Proof.
  introv.
  exists (@equality_of_int p lib).
  apply CL_int; split; dands; spcast; eauto 3 with slow.
Qed.
Hint Resolve tequality_int : slow.

Hint Rewrite @mkcv_le_substc   : slow.
Hint Rewrite @substc_mkcv_zero : slow.

Lemma tnat_type {o} : forall lib, @type o lib mkc_tnat.
Proof.
  introv.
  rw @mkc_tnat_eq.
  apply tequality_set; dands; eauto 3 with slow.
  introv ea.
  autorewrite with slow.
  apply tequality_mkc_le.
  apply equality_in_int in ea.
  unfold equality_of_int in ea; exrepnd; spcast.
  exists 0%Z k 0%Z k.
  rw @mkc_zero_eq; rw @mkc_nat_eq; simpl.
  dands; spcast; auto; eauto 3 with slow.
  destruct (Z_lt_le_dec k 0); tcsp.
Qed.

(*

  We could also have defined this type using 0 < y.
  I used 1 <= y because the proofs will be similar to the ones for tnat.

 *)
Definition mk_tnatp {o} := @mk_set o mk_int nvary (mk_le mk_one (mk_var nvary)).

Lemma isprog_tnatp {o} : @isprog o mk_tnatp.
Proof.
  rw <- @isprog_set_iff.
  dands; eauto 3 with slow.
Qed.

Definition mkc_tnatp {o} : @CTerm o := exist isprog mk_tnatp isprog_tnatp.

Lemma mkc_tnatp_eq {o} :
  @mkc_tnatp o = mkc_set mkc_int nvary (mkcv_le [nvary] (mkcv_one [nvary]) (mkc_var nvary)).
Proof.
  apply cterm_eq; simpl; sp.
Qed.

Lemma mkcv_one_substc {o} :
  forall v (t : @CTerm o),
    substc t v (mkcv_one [v]) = mkc_one.
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl; sp.
Qed.

(*
Lemma nuprl_tnatp {o} :
  forall lib,
  nuprl
    lib
    mkc_tnatp
    mkc_tnatp
    (fun (t t' : @CTerm o) =>
       { _ : equality_of_int lib t t'
                             &
                             inhabited
                             (fun _ _ : @CTerm o =>
                                forall u v : @CTerm o,
                                  (forall k : Z,
                                     computes_to_valc lib t (mkc_integer k) ->
                                     if (k <? 1)%Z
                                     then u ===>(lib) mkc_axiom # v ===>(lib) mkc_axiom
                                     else False) -> False)}).
Proof.
  introv.
  rw @mkc_tnatp_eq.
  apply CL_set; fold (@nuprl o).
  unfold per_set.
  exists (@equality_of_int o lib).
  exists
    (fun (a a' : @CTerm o)
         (e : equality_of_int lib a a')
         (t t' : @CTerm o) =>
       forall (u v : @CTerm o),
         (forall k,
            computes_to_valc lib a (mkc_integer k)
            -> if (k <? 1)%Z
               then u ===>(lib) mkc_axiom # v ===>(lib) mkc_axiom
               else False)
         -> False);
    dands; auto.

  - unfold type_family.
    eexists; eexists; eexists; eexists; eexists; eexists;
    dands; auto; spcast; try (fold nuprl).

    + apply computes_to_valc_refl; apply iscvalue_mkc_set.

    + apply computes_to_valc_refl; apply iscvalue_mkc_set.

    + apply nuprl_int.

    + introv e.
      allrw @mkcv_le_substc.
      allrw @mkcv_one_substc.
      allrw @mkc_var_substc.
      allrw @mkc_le_eq.
      unfold equality_of_int in e; exrepnd; spcast.

      apply CL_func.
      unfold per_func.
      exists (fun t t' : @CTerm o =>
                if (k <? 1)%Z
                then t ===>(lib) mkc_axiom # t' ===>(lib) mkc_axiom
                else False).
      exists (fun (a a' : @CTerm o) (e : if (k <? 1)%Z
                            then a ===>(lib) mkc_axiom # a' ===>(lib) mkc_axiom
                            else False) (t t' : @CTerm o) => False).
      dands; auto.

      * unfold type_family.
        eexists; eexists; eexists; eexists; eexists; eexists;
        dands; auto; spcast; try (fold nuprl).

        unfold mkc_not.
        rw <- @fold_mkc_fun.
        apply computes_to_valc_refl.
        apply iscvalue_mkc_function.

        unfold mkc_not.
        rw <- @fold_mkc_fun.
        apply computes_to_valc_refl.
        apply iscvalue_mkc_function.

        remember ((k <? 1)%Z); symmetry in Heqb; destruct b.

        apply Z.ltb_lt in Heqb.

        pose proof (mkc_less_than_comp1 lib a mkc_one k 1) as h1; repeat (autodimp h1 hyp); try omega.
        unfold computes_to_valc; simpl; unfold mk_one, mk_nat; simpl.
        apply computes_to_value_isvalue_refl; apply isvalue_mk_integer.

        pose proof (mkc_less_than_comp1 lib a' mkc_one k 1) as h2; repeat (autodimp h2 hyp); try omega.
        unfold computes_to_valc; simpl; unfold mk_one, mk_nat; simpl.
        apply computes_to_value_isvalue_refl; apply isvalue_mk_integer.

        apply nuprl_value_respecting_left with (t1 := mkc_true).
        apply nuprl_value_respecting_right with (t2 := mkc_true).
        apply nuprl_mkc_true.
        apply cequivc_sym; apply computes_to_valc_implies_cequivc; sp.
        apply cequivc_sym; apply computes_to_valc_implies_cequivc; sp.

        apply Z.ltb_ge in Heqb.

        pose proof (mkc_less_than_comp2 lib a mkc_one k 1) as h1; repeat (autodimp h1 hyp); try omega.
        unfold computes_to_valc; simpl; unfold mk_one, mk_nat; simpl.
        apply computes_to_value_isvalue_refl; apply isvalue_mk_integer.

        pose proof (mkc_less_than_comp2 lib a' mkc_one k 1) as h2; repeat (autodimp h2 hyp); try omega.
        unfold computes_to_valc; simpl; unfold mk_zero, mk_nat; simpl.
        apply computes_to_value_isvalue_refl; apply isvalue_mk_integer.

        apply nuprl_computes_left with (t1 := mkc_false); auto.
        apply nuprl_computes_right with (t2 := mkc_false); auto.
        rw @mkc_false_eq.
        apply CL_approx.
        unfold per_approx.
        eexists; eexists; eexists; eexists; dands; auto; spcast.
        apply computes_to_valc_refl; apply iscvalue_mkc_approx.
        apply computes_to_valc_refl; apply iscvalue_mkc_approx.
        introv; split; intro j; repnd; sp; spcast.
        apply not_axiom_approxc_bot in j; auto.

        introv e; simphyps.
        allrw @csubst_mk_cv.
        rw @mkc_void_eq_mkc_false; rw @mkc_false_eq.
        apply CL_approx.
        unfold per_approx.
        eexists; eexists; eexists; eexists; dands; auto; spcast.
        apply computes_to_valc_refl; apply iscvalue_mkc_approx.
        apply computes_to_valc_refl; apply iscvalue_mkc_approx.
        sp; split; intro j; repnd; sp; spcast.
        apply not_axiom_approxc_bot in j; auto.

      * intros; split; intro j; introv m.

        apply j with (u := a0) (v := a'0); auto.
        introv c.
        pose proof (computes_to_valc_eq lib a (mkc_integer k) (mkc_integer k0)) as e;
          repeat (autodimp e hyp).
        inversion e; subst; GC; sp.

        pose proof (m k) as l; autodimp l hyp.
        apply j in l; sp.

  - introv.
    split; intro k; exrepnd.
    exists v; sp.
    exists e; sp.
Qed.
*)

Lemma mkc_one_eq {o} :
  @mkc_one o = mkc_nat 1.
Proof.
  apply cterm_eq; simpl; auto.
Qed.

Lemma tnatp_type {o} : forall lib, @type o lib mkc_tnatp.
Proof.
  introv.
  rw @mkc_tnatp_eq.
  apply tequality_set; dands; eauto 3 with slow.
  introv ea.
  autorewrite with slow.
  apply tequality_mkc_le.
  apply equality_in_int in ea.
  unfold equality_of_int in ea; exrepnd; spcast.
  exists 1%Z k 1%Z k.
  rw @mkc_one_eq; rw @mkc_nat_eq; simpl.
  dands; spcast; auto; eauto 3 with slow.
  destruct (Z_lt_le_dec k 1); tcsp.
Qed.

Definition reducek_pair {o} lib (t1 t2 : @NTerm o) (k : Z) (n : nat) :=
    reduces_in_atmost_k_steps lib t1 (mk_integer k) n
  # reduces_in_atmost_k_steps lib t2 (mk_integer k) n.

Definition equality_of_int_p_2 {o} lib (n m : @NTerm o) :=
  {x : Z # nat , reducek_pair lib n m (fst x) (snd x)}.

Definition equality_of_int_p_2_c {o} lib (n m : @CTerm o) :=
  equality_of_int_p_2 lib (get_cterm n) (get_cterm m).

Lemma equality_of_int_imp1 {o} :
  forall lib (n m : @CTerm o),
    equality_of_int lib n m
    <-> equality_of_int_p_2_c lib n m.
Proof.
  introv; split.
  - introv e.
    unfold equality_of_int in e; exrepnd; spcast.
    allunfold @computes_to_valc; allsimpl.
    allunfold @computes_to_value; repnd.
    allunfold @reduces_to; exrepnd.
    allunfold @reduces_in_atmost_k_steps.
    pose proof (no_change_after_value2 lib
                  (get_cterm n) k1 (mk_integer k) e2 e1 (Peano.max k1 k0)) as h1.
    autodimp h1 hyp; try (apply max_prop1).
    pose proof (no_change_after_value2 lib
                (get_cterm m) k0 (mk_integer k) e4 e0 (Peano.max k1 k0)) as h2.
    autodimp h2 hyp; try (apply max_prop2).
    exists ((k,Peano.max k1 k0)); simpl; sp.
    unfold reducek_pair; sp.
  - introv e.
    unfold equality_of_int.
    unfold equality_of_int_p_2_c, equality_of_int_p_2, reducek_pair in e.
    exrepnd; allsimpl.
    exists x0; dands; spcast;
    unfold computes_to_valc, computes_to_value; simpl;
    dands; try (apply isvalue_mk_integer);
    exists x; auto.
Qed.

Lemma compute_step_dec {o} :
  forall lib (t : @NTerm o),
    {u : NTerm $ compute_step lib t = csuccess u}
    [+]
    !{u : NTerm $ compute_step lib t = csuccess u}.
Proof.
  introv.
  remember (compute_step lib t); destruct c.
  - left.
    exists n; sp.
  - right; intro k; exrepnd; inversion k0.
Qed.

(*
Lemma reduces_in_atmost_k_steps_dec {o} :
  forall lib (pc : dec_consts o) k (t1 t2 : @NTerm o),
    reduces_in_atmost_k_steps lib t1 t2 k [+] !(reduces_in_atmost_k_steps lib t1 t2 k).
Proof.
  induction k; introv.

  - rw @reduces_in_atmost_k_steps_0.
    pose proof (deq_nterm pc t1 t2) as h; sp.

  - rw @reduces_in_atmost_k_steps_S.
    pose proof (compute_step_dec lib t1) as h.
    dorn h.

    + exrepnd.
      pose proof (IHk u t2) as j.
      dorn j.

      * left.
        exists u; sp.

      * right.
        intro c; exrepnd.
        rw h0 in c1; inversion c1; subst; sp.

    + right; intro j; exrepnd.
      apply h.
      exists u; sp.
Qed.
*)

Lemma deq_nterm_int {p} :
  forall (t : @NTerm p) z, {t = mk_integer z} + {t <> mk_integer z}.
Proof.
  introv.
  nterm_ind1 t as [v1|f1 ind|o1 lbt1 Hind] Case; intros.

  - Case "vterm".
    right; intro k; inversion k.

  - Case "sterm".
    right; intro k; inversion k.

  - Case "oterm".
    destruct o1; try (complete (right; intro k; inversion k)).
    destruct c; try (complete (right; intro k; inversion k)).
    destruct lbt1; try (complete (right; intro k; inversion k)).
    assert ({z < z0} + {z > z0} + {z = z0})%Z as h by (apply Z_dec).
    destruct h as [ h | h ]; subst.
    destruct h as [ h | h ]; sp; right; sp; inversion H; omega.
    left; sp.
Qed.

Lemma reduces_in_atmost_k_steps_int_dec {o} :
  forall lib k (t : @NTerm o) z,
    reduces_in_atmost_k_steps lib t (mk_integer z) k
    [+]
    !(reduces_in_atmost_k_steps lib t (mk_integer z) k).
Proof.
  induction k; introv.

  - rw @reduces_in_atmost_k_steps_0.
    pose proof (deq_nterm_int t z) as h; sp.

  - rw @reduces_in_atmost_k_steps_S.
    pose proof (compute_step_dec lib t) as h.
    dorn h.

    + exrepnd.
      pose proof (IHk u z) as j.
      dorn j.

      * left.
        exists u; sp.

      * right.
        intro c; exrepnd.
        rw h0 in c1; inversion c1; subst; sp.

    + right; intro j; exrepnd.
      apply h.
      exists u; sp.
Qed.

Lemma reducek_pair_dec {o} :
  forall lib (t1 t2 : @NTerm o) z n,
    reducek_pair lib t1 t2 z n [+] !(reducek_pair lib t1 t2 z n).
Proof.
  introv.
  unfold reducek_pair.
  pose proof (reduces_in_atmost_k_steps_int_dec lib n t1 z) as h1.
  pose proof (reduces_in_atmost_k_steps_int_dec lib n t2 z) as h2.
  dorn h1; dorn h2.
  - left; sp.
  - right; sp.
  - right; sp.
  - right; sp.
Qed.

(*

  The following is an adaptation of:
     http://coq.inria.fr/stdlib/Coq.Logic.ConstructiveEpsilon.html
  This is required to prove equality_of_int_imp_t without using
  the indefinite_description axiom.

*)

Inductive before_witness (P : Z -> nat -> Prop) (k : nat) : Prop :=
  | stop_pos : forall (z n : nat), k = z + n -> P (Z.of_nat z) n -> before_witness P k
  | stop_neg : forall z n, k = z + n -> P (Z.opp (Z.of_nat z)) n -> before_witness P k
  | next : before_witness P (S k) -> before_witness P k.

Fixpoint O_witness
         (P : Z -> nat -> Prop)
         (k : nat) : before_witness P k -> before_witness P 0 :=
  match k return (before_witness P k -> before_witness P 0) with
    | 0 => fun b => b
    | S n => fun b => O_witness P n (next P n b)
  end.

Definition inv_before_witness :
  forall (P : Z -> nat -> Prop) (k : nat),
    before_witness P k
    -> (forall z n : nat, k = z + n -> ~ P (Z.of_nat z) n # ~ P (Z.opp (Z.of_nat z)) n)
    -> before_witness P (S k) :=
  fun P k b =>
    match b
          in before_witness _ _
          return (forall z n, k = z + n -> ~ P (Z.of_nat z) n # ~ P (Z.opp (Z.of_nat z)) n)
                 -> before_witness P (S k) with
      | stop_pos _ _ z n e p => fun f => match fst (f z n e) p with end
      | stop_neg _ _ z n e p => fun f => match snd (f z n e) p with end
      | next _ _ b => fun _ => b
    end.

Lemma leS:
  forall n m : nat, n <= S m -> n <= m [+] n = S m.
Proof.
  introv; revert n.
  induction m; simpl; introv e.
  - destruct n; sp.
    destruct n; sp.
    provefalse.
    inversion e as [|x h].
    inversion h.
  - apply leb_correct in e.
    destruct n; allsimpl.
    + left; omega.
    + apply leb_complete in e.
      apply IHm in e; dorn e.
      left; omega.
      right; omega.
Qed.

(* This is the crux of linear_search *)
Lemma P_search :
  forall (P : Z -> nat -> Prop)
         (dec : forall z n, P z n [+] !P z n)
         (k : nat),
    {x : Z # nat & P (fst x) (snd x)}
    [+]
    (forall z n : nat, k = (z + n)%nat -> ~ P (Z.of_nat z) n # ~ P (Z.opp (Z.of_nat z)) n).
Proof.
  intros P dec k.

  assert (forall k z,
            {x : Z # nat & P (fst x) (snd x)}
              [+]
              (forall n : nat, n <= k -> ~ P (Z.of_nat z) n # ~ P (Z.opp (Z.of_nat z)) n)) as hyp1.
  clear k.
  introv.
  induction k.
  pose proof (dec (Z.of_nat z) 0) as h.
  dorn h.
  left; exists (Z.of_nat z,0); simpl; sp.
  pose proof (dec (Z.opp (Z.of_nat z)) 0) as j.
  dorn j.
  left; exists (Z.opp (Z.of_nat z),0); simpl; sp.
  right; introv e.
  assert (n = 0) by omega; subst; simpl; sp.
  dorn IHk.
  left; auto.
  pose proof (dec (Z.of_nat z) (S k)) as h.
  dorn h.
  left; exists (Z.of_nat z,S k); simpl; sp.
  pose proof (dec (Z.opp (Z.of_nat z)) (S k)) as j.
  dorn j.
  left; exists (Z.opp (Z.of_nat z),S k); simpl; sp.
  right; introv e; simpl.
  apply leS in e.
  dorn e.
  apply IHk in e; sp.
  subst; sp.

  assert (forall k n,
            {x : Z # nat & P (fst x) (snd x)}
              [+]
              (forall z : nat, z <= k -> ~ P (Z.of_nat z) n # ~ P (Z.opp (Z.of_nat z)) n)) as hyp2.
  clear k.
  introv.
  induction k.
  pose proof (dec 0%Z n) as h.
  dorn h.
  left; exists (0%Z,n); simpl; sp.
  right; introv e.
  assert (z = 0) by omega; subst; simpl; sp.
  dorn IHk.
  left; auto.
  pose proof (dec (Z.of_nat (S k)) n) as h.
  dorn h.
  left; exists (Z.of_nat (S k),n); simpl; sp.
  pose proof (dec (Z.opp (Z.of_nat (S k))) n) as j.
  dorn j.
  left; exists (Z.opp (Z.of_nat (S k)),n); simpl; sp.
  right; introv e; simpl.
  apply leS in e.
  dorn e.
  apply IHk in e; sp.
  subst; sp.

  assert ({x : Z # nat & P (fst x) (snd x)}
            [+]
            (forall z n : nat, z <= k -> n <= k -> ~ P (Z.of_nat z) n # ~ P (Z.opp (Z.of_nat z)) n)) as hyp.
  induction k.
  pose proof (dec 0%Z 0) as h.
  dorn h.
  left; exists (0%Z,0); simpl; sp.
  right; introv e1 e2.
  assert (z = 0) by omega; assert (n = 0) by omega; subst; simpl; sp.
  dorn IHk.
  left; auto.
  pose proof (hyp1 (S k) (S k)) as h1.
  dorn h1.
  left; auto.
  pose proof (hyp2 (S k) (S k)) as h2.
  dorn h2.
  left; auto.
  right; introv e1 e2.
  apply leS in e1.
  apply leS in e2.
  dorn e1; dorn e2; subst.
  apply IHk; auto.
  apply h2; auto.
  apply h1; auto.
  apply h1; sp.

  dorn hyp.
  left; auto.
  right.
  introv e; subst.
  apply hyp; omega.
Qed.

Fixpoint linear_search
      (P : Z -> nat -> Prop)
      (dec : forall z n, P z n [+] !P z n)
      (k : nat)
      (b : before_witness P k) : {x : Z # nat & P (fst x) (snd x)} :=
  match P_search P dec k with
    | inl p => p
    | inr a => linear_search P dec (S k) (inv_before_witness P k b a)
  end.

Definition constructive_indefinite_ground_description_nat {o}
           lib (t1 t2 : @CTerm o) :
  equality_of_int_p_2_c lib t1 t2
  -> {x : Z # nat & reducek_pair lib (get_cterm t1) (get_cterm t2) (fst x) (snd x)}.
Proof.
  introv pex.
  apply linear_search with (k := 0).
  apply reducek_pair_dec; auto.
  unfold equality_of_int_p_2_c, equality_of_int_p_2 in pex; auto.
  exrepnd; allsimpl.
  apply O_witness with (k := Z.abs_nat x0 + x).
  pose proof (Zabs.Zabs_dec x0) as h.
  dorn h.
  - apply stop_pos with (z := Z.abs_nat x0) (n := x); auto.
    rw h in pex0.
    rw Znat.Zabs2Nat.id_abs; auto.
  - apply stop_neg with (z := Z.abs_nat x0) (n := x); auto.
    rw h in pex0.
    rw Znat.Zabs2Nat.id_abs; auto.
Qed.

(*

   Thanks to constructive_indefinite_ground_description_nat,
   the following proof does not need the indefinite_description axiom

 *)

Definition equality_of_int_t {o} lib (n m : @CTerm o) :=
  {k : Z | n ===>(lib) (mkc_integer k)
         # m ===>(lib) (mkc_integer k)}.

Lemma equality_of_int_imp_t {o} :
  forall lib (n m : @CTerm o),
    equality_of_int lib n m
    -> equality_of_int_t lib n m.
Proof.
  introv e.
  apply equality_of_int_imp1 in e.
  apply constructive_indefinite_ground_description_nat in e; auto.
  exrepnd; allsimpl.
  unfold equality_of_int_t.
  unfold reducek_pair in e0; repnd.
  exists x0; dands; spcast;
  unfold computes_to_valc, computes_to_value; simpl;
  dands; try (apply isvalue_mk_integer);
  exists x; auto.
Qed.

(*
Here is the alternative that uses the indefinite_description axiom.

Axiom indefinite_description :
  forall (A : Type) (P : A -> Prop),
    ex P -> sig P.

Lemma equality_of_int_imp_t :
  forall n m,
    equality_of_int n m
    -> equality_of_int_t n m.
Proof.
  introv e.
  unfold equality_of_int in e.
  unfold equality_of_int_t.
  apply indefinite_description; auto.
Qed.
*)

Definition equality_of_int_tt {o} lib (n m : @CTerm o) :=
  {k : Z & computes_to_valc lib n (mkc_integer k)
         # computes_to_valc lib m (mkc_integer k)}.

Lemma equality_of_int_imp_tt {o} :
  forall lib (n m : @CTerm o),
    equality_of_int lib n m
    -> equality_of_int_tt lib n m.
Proof.
  introv e.
  apply equality_of_int_imp1 in e.
  apply constructive_indefinite_ground_description_nat in e; auto.
  exrepnd; allsimpl.
  unfold equality_of_int_tt.
  unfold reducek_pair in e0; repnd.
  exists x0; dands; spcast;
  unfold computes_to_valc, computes_to_value; simpl;
  dands; try (apply isvalue_mk_integer);
  exists x; auto.
Qed.

Lemma tequality_mkc_natk {o} :
  forall lib (t1 t2 : @CTerm o),
    tequality lib (mkc_natk t1) (mkc_natk t2)
    <=> {k1 : Z , {k2 : Z
         , t1 ===>(lib) (mkc_integer k1)
         # t2 ===>(lib) (mkc_integer k2)
         # (forall (k : Z), (0 <= k)%Z -> ((k < k1)%Z # (k < k2)%Z){+}(k1 <= k)%Z # (k2 <= k)%Z) }}.
Proof.
  introv.
  allrw @mkc_natk_eq.
  allrw @tequality_set.

  split; intro k; repnd.

  - clear k0.

    assert (forall a a' : CTerm,
              equality lib a a' mkc_int
              -> tequality
                   lib
                   (mkc_prod (mkc_le mkc_zero a) (mkc_less_than a t1))
                   (mkc_prod (mkc_le mkc_zero a') (mkc_less_than a' t2))) as h1.
    { introv ei.
      applydup k in ei.
      eapply tequality_respects_alphaeqc_left in ei0;[|apply mkcv_prod_substc].
      eapply tequality_respects_alphaeqc_right in ei0;[|apply mkcv_prod_substc].
      allrw @mkcv_le_substc2.
      allrw @mkcv_zero_substc.
      allrw @mkcv_less_than_substc.
      allrw @mkc_var_substc.
      allrw @csubst_mk_cv.
      auto. }
    clear k.

    assert (forall (k : Z),
              (0 <= k)%Z
              -> {k1 : Z , {k2 : Z
                  , t1 ===>(lib) (mkc_integer k1)
                  # t2 ===>(lib) (mkc_integer k2)
                  # ((k < k1)%Z # (k < k2)%Z){+}(k1 <= k)%Z # (k2 <= k)%Z }}) as h2.
    { introv le0k.
      pose proof (h1 (mkc_integer k) (mkc_integer k)) as h.
      autodimp h hyp.
      { apply equality_in_int; unfold equality_of_int; exists k; dands; spcast; auto;
        apply computes_to_valc_refl; eauto with slow. }
      allrw @tequality_mkc_prod; repnd.
      allrw @inhabited_le.
      allrw @tequality_mkc_less_than.
      clear h0 (* trivial *).
      autodimp h hyp.
      { exists 0%Z k; dands; auto; spcast; tcsp; allrw @mkc_zero_eq; allrw @mkc_nat_eq;
        allsimpl; apply computes_to_valc_refl; eauto with slow. }
      exrepnd; spcast.
      apply computes_to_valc_isvalue_eq in h0; eauto with slow; ginv.
      apply computes_to_valc_isvalue_eq in h4; eauto with slow; ginv.
      exists kb kd; dands; spcast; auto. }
    clear h1.

    pose proof (h2 0%Z) as h; autodimp h hyp; tcsp; exrepnd; spcast.
    exists k1 k2; dands; spcast; tcsp.
    introv i.
    apply h2 in i; exrepnd; spcast.
    repeat computes_to_eqval; auto.

  - dands.
    { apply tequality_int. }
    introv ei.
    exrepnd; spcast.

    apply equality_in_int in ei.
    apply equality_of_int_imp_tt in ei.
    unfold equality_of_int_tt in ei; exrepnd.

    eapply tequality_respects_alphaeqc_left;[apply alphaeqc_sym; apply mkcv_prod_substc|].
    eapply tequality_respects_alphaeqc_right;[apply alphaeqc_sym; apply mkcv_prod_substc|].
    allrw @mkcv_le_substc2.
    allrw @mkcv_less_than_substc.
    allrw @mkc_var_substc.
    allrw @mkcv_zero_substc.
    allrw @csubst_mk_cv.

    apply tequality_mkc_prod; dands.
    { apply tequality_mkc_le.
      exists 0%Z k 0%Z k.
      dands; tcsp; spcast; auto;
      try (rw @mkc_zero_eq; rw @mkc_nat_eq; simpl;
           apply computes_to_valc_refl; eauto with slow).
      destruct (Z_lt_le_dec k 0); tcsp. }

    introv inh.
    allrw @inhabited_le; exrepnd; spcast.
    apply computes_to_valc_isvalue_eq in inh0; eauto with slow.
    rw @mkc_zero_eq in inh0; rw @mkc_nat_eq in inh0; ginv.
    computes_to_eqval.
    apply tequality_mkc_less_than.
    exists k k1 k k2; dands; spcast; tcsp.
Qed.

Lemma type_mkc_natk {o} :
  forall lib (t : @CTerm o),
    type lib (mkc_natk t)
    <=> {k : Z , t ===>(lib) (mkc_integer k)}.
Proof.
  introv.
  rw @tequality_mkc_natk; split; introv h; exrepnd; spcast; repeat computes_to_eqval.
  - exists k1; spcast; auto.
  - exists k k; dands; spcast; auto.
    introv i.
    destruct (Z_lt_le_dec k0 k); tcsp.
Qed.

Lemma type_mkc_le {o} :
  forall lib (a b : @CTerm o),
  type lib (mkc_le a b) <=>
       (exists ka kb
        , (a) ===>( lib)(mkc_integer ka)
        # (b) ===>( lib)(mkc_integer kb)).
Proof.
  introv.
  rw @tequality_mkc_le; split; intro h; exrepnd; spcast; repeat computes_to_eqval.
  - exists ka kb; dands; spcast; auto.
  - exists ka kb ka kb; dands; spcast; auto.
    destruct (Z_lt_le_dec kb ka); tcsp.
Qed.

Lemma type_mkc_less_than {o} :
  forall lib (a b : @CTerm o),
    type lib (mkc_less_than a b) <=>
         (exists ka kb
          , (a) ===>( lib)(mkc_integer ka)
          # (b) ===>( lib)(mkc_integer kb)).
Proof.
  introv.
  rw @tequality_mkc_less_than; split; intro h; exrepnd; spcast; repeat computes_to_eqval.
  - exists ka kb; dands; spcast; auto.
  - exists ka kb ka kb; dands; spcast; auto.
    destruct (Z_lt_le_dec ka kb); tcsp.
Qed.

Lemma equality_in_natk {o} :
  forall lib (a b t : @CTerm o),
    equality lib a b (mkc_natk t)
    <=> {m : nat , {k : Z
         , a ===>(lib) (mkc_nat m)
         # b ===>(lib) (mkc_nat m)
         # t ===>(lib) (mkc_integer k)
         # (Z.of_nat m < k)%Z }} .
Proof.
  introv.
  rw @mkc_natk_eq.
  rw @equality_in_set.

  split; intro h; exrepnd; dands.

  - clear h0.
    allrw @equality_in_int.
    unfold equality_of_int in h1; exrepnd; spcast.
    eapply inhabited_type_respects_alphaeqc in h;[|apply mkcv_prod_substc].
    allrw @mkcv_le_substc2.
    allrw @mkcv_less_than_substc.
    allrw @mkc_var_substc.
    allrw @mkcv_zero_substc.
    allrw @csubst_mk_cv.
    allrw @inhabited_prod; repnd.
    allrw @inhabited_le; exrepnd; spcast.
    apply computes_to_valc_isvalue_eq in h5; eauto with slow.
    rw @mkc_zero_eq in h5; rw @mkc_nat_eq in h5; ginv.
    computes_to_eqval.
    allrw @inhabited_less_than; exrepnd; spcast.
    computes_to_eqval.
    exists (Z.to_nat k) kb; dands; spcast; tcsp;
    try (complete (rw @mkc_nat_eq; rw Znat.Z2Nat.id; auto)).
    rw Znat.Z2Nat.id; auto.

  - introv ei.
    allrw @equality_in_int.
    unfold equality_of_int in ei; exrepnd; spcast.
    eapply tequality_respects_alphaeqc_left;[apply alphaeqc_sym; apply mkcv_prod_substc|].
    eapply tequality_respects_alphaeqc_right;[apply alphaeqc_sym; apply mkcv_prod_substc|].
    allrw @mkcv_le_substc2.
    allrw @mkcv_less_than_substc.
    allrw @mkc_var_substc.
    allrw @mkcv_zero_substc.
    allrw @csubst_mk_cv.
    allrw @tequality_mkc_prod; dands.

    + allrw @tequality_mkc_le.
      exists 0%Z k0 0%Z k0.
      dands; tcsp; spcast; auto;
      try (rw @mkc_zero_eq; rw @mkc_nat_eq; simpl;
           apply computes_to_valc_refl; eauto with slow).
      destruct (Z_lt_le_dec k0 0); tcsp.

    + introv inh.
      allrw @inhabited_le; exrepnd; spcast.
      computes_to_eqval.
      apply computes_to_valc_isvalue_eq in inh0; eauto with slow.
      rw @mkc_zero_eq in inh0; rw @mkc_nat_eq in inh0; ginv.
      apply tequality_mkc_less_than.
      exists k0 k k0 k; dands; spcast; auto.
      destruct (Z_lt_le_dec k0 k); tcsp.

  - spcast.
    apply equality_in_int; unfold equality_of_int.
    exists (Z.of_nat m); dands; spcast; auto.

  - spcast.
    eapply inhabited_type_respects_alphaeqc;[apply alphaeqc_sym; apply mkcv_prod_substc|].
    allrw @mkcv_le_substc2.
    allrw @mkcv_less_than_substc.
    allrw @mkc_var_substc.
    allrw @mkcv_zero_substc.
    allrw @csubst_mk_cv.
    apply inhabited_prod.
    allrw @type_mkc_le.
    allrw @type_mkc_less_than.
    allrw @inhabited_le.
    allrw @inhabited_less_than.
    dands.

    + exists 0%Z (Z.of_nat m); dands; spcast.
      * rw @mkc_zero_eq; rw @mkc_nat_eq; simpl; apply computes_to_valc_refl; eauto with slow.
      * allrw @mkc_nat_eq; auto.

    + exists (Z.of_nat m) k; dands; spcast; auto.

    + exists 0%Z (Z.of_nat m); dands; spcast; tcsp; try omega.
      rw @mkc_zero_eq; rw @mkc_nat_eq; simpl; apply computes_to_valc_refl; eauto with slow.

    + exists (Z.of_nat m) k; dands; spcast; auto.
Qed.

Lemma computes_to_valc_implies_reduces_toc {o} :
  forall lib (t1 t2 : @CTerm o),
    computes_to_valc lib t1 t2
    -> reduces_toc lib t1 t2.
Proof.
  introv comp.
  allrw @computes_to_valc_iff_reduces_toc; sp.
Qed.
Hint Resolve computes_to_valc_implies_reduces_toc : slow.

Lemma cequivc_mkc_isl {o} :
  forall lib (t u : @CTerm o),
    cequivc lib t u
    -> cequivc lib (mkc_isl t) (mkc_isl u).
Proof.
  introv c.
  destruct_cterms.
  allunfold @cequivc; allsimpl.
  unfold mk_isl, mk_ite.
  apply cequiv_congruence; fold_terms.
  - unfold cequiv_bts, lblift; simpl; dands; auto.
    introv k.
    repeat (destruct n; tcsp; try omega); clear k; unfold selectbt; simpl;
    try (fold (bcequiv lib)); eauto with slow.
    + apply bcequiv_nobnd; eauto 3 with slow.
    + apply bcequiv_refl.
      apply wf_bterm_iff; eauto 3 with slow.
    + apply bcequiv_refl.
      apply wf_bterm_iff; eauto 3 with slow.
  - apply isprogram_decide_iff2; dands; eauto 3 with slow.
  - apply isprogram_decide_iff2; dands; eauto 3 with slow.
Qed.

Lemma cequivc_mkc_assert {o} :
  forall lib (t u : @CTerm o),
    cequivc lib t u
    -> cequivc lib (mkc_assert t) (mkc_assert u).
Proof.
  introv c.
  destruct_cterms.
  allunfold @cequivc; allsimpl.
  unfold mk_assert, mk_ite.
  apply cequiv_congruence; fold_terms.
  - unfold cequiv_bts, lblift; simpl; dands; auto.
    introv k.
    repeat (destruct n; tcsp; try omega); clear k; unfold selectbt; simpl;
    try (fold (bcequiv lib)); eauto with slow.
    + apply bcequiv_nobnd; eauto 3 with slow.
    + apply bcequiv_refl.
      apply wf_bterm_iff; eauto 3 with slow.
    + apply bcequiv_refl.
      apply wf_bterm_iff; eauto 3 with slow.
  - apply isprogram_decide_iff2; dands; eauto 3 with slow.
  - apply isprogram_decide_iff2; dands; eauto 3 with slow.
Qed.

Lemma computes_to_valc_inl_implies_cequivc_isl_tt {o} :
  forall lib (t u : @CTerm o),
    computes_to_valc lib t (mkc_inl u)
    -> cequivc lib (mkc_isl t) tt.
Proof.
  introv comp.
  eapply cequivc_trans;
    [apply cequivc_mkc_isl;
      apply computes_to_valc_implies_cequivc;
      exact comp|].
  apply computes_to_valc_implies_cequivc; clear comp t.
  destruct_cterms.
  unfold computes_to_valc; simpl.
  unfold computes_to_value; dands; eauto 3 with slow.
Qed.

Lemma computes_to_valc_inr_implies_cequivc_isl_ff {o} :
  forall lib (t u : @CTerm o),
    computes_to_valc lib t (mkc_inr u)
    -> cequivc lib (mkc_isl t) ff.
Proof.
  introv comp.
  eapply cequivc_trans;
    [apply cequivc_mkc_isl;
      apply computes_to_valc_implies_cequivc;
      exact comp|].
  apply computes_to_valc_implies_cequivc; clear comp t.
  destruct_cterms.
  unfold computes_to_valc; simpl.
  unfold computes_to_value; dands; eauto 3 with slow.
Qed.

Lemma implies_isl_in_bool {o} :
  forall lib (A B a b : @CTerm o),
    equality lib a b (mkc_union A B)
    -> equality lib (mkc_isl a) (mkc_isl b) mkc_bool.
Proof.
  introv e.
  apply equality_mkc_union in e; exrepnd.
  apply equality_in_bool.
  repndors; exrepnd; spcast;[left|right]; dands; spcast.
  - eapply computes_to_valc_inl_implies_cequivc_isl_tt; eauto.
  - eapply computes_to_valc_inl_implies_cequivc_isl_tt; eauto.
  - eapply computes_to_valc_inr_implies_cequivc_isl_ff; eauto.
  - eapply computes_to_valc_inr_implies_cequivc_isl_ff; eauto.
Qed.

Lemma tt_not_approx_ff {o} :
  forall (lib : @library o), !approx lib mk_btrue mk_bfalse.
Proof.
  introv apr.
  inversion apr as [cl]; clear apr.
  unfold close_comput in cl; repnd.
  unfold close_compute_val in cl2.
  pose proof (cl2 (NInj NInl) [nobnd mk_axiom]) as h; fold_terms.
  autodimp h hyp; eauto 3 with slow.
  exrepnd.
  apply computes_to_value_isvalue_eq in h1; ginv; eauto 3 with slow.
Qed.

Lemma tt_not_cequiv_ff {o} :
  forall (lib : @library o), !cequiv lib mk_btrue mk_bfalse.
Proof.
  introv ceq.
  apply cequiv_le_approx in ceq.
  apply tt_not_approx_ff in ceq; sp.
Qed.

Lemma tt_not_cequivc_ff {o} :
  forall (lib : @library o), !cequivc lib tt ff.
Proof.
  introv.
  unfold cequivc; simpl.
  apply tt_not_cequiv_ff.
Qed.

Lemma equality_tt_in_bool_implies_cequiv {o} :
  forall lib (t : @CTerm o),
    equality lib t tt mkc_bool
    -> ccequivc lib t tt.
Proof.
  introv e.
  apply equality_in_bool in e; repndors; repnd; spcast; eauto with slow.
  apply tt_not_cequivc_ff in e; sp.
Qed.

Lemma isprogram_mk_assert {o} :
  forall (t : @NTerm o),
    isprogram (mk_assert t) <=> isprogram t.
Proof.
  introv.
  unfold mk_assert.
  rw @isprogram_decide_iff2; split; intro k; repnd; tcsp; dands; auto;
  apply isprog_vars_isprogrambt;
  apply isprog_vars_if_isprog; eauto 3 with slow.
Qed.

Lemma mkc_assert_tt {o} :
  forall (lib : @library o), cequivc lib (mkc_assert tt) mkc_unit.
Proof.
  introv.
  unfold cequivc; simpl.
  apply reduces_to_implies_cequiv; eauto 3 with slow.
  apply isprogram_mk_assert.
  apply isprogram_inl; eauto with slow.
Qed.

Lemma inhabited_type_mkc_unit {o} :
  forall (lib : @library o), inhabited_type lib mkc_unit.
Proof.
  introv.
  unfold inhabited_type.
  exists (@mkc_axiom o).
  apply equality_in_unit; dands; spcast;
  apply computes_to_valc_refl; eauto with slow.
Qed.
Hint Resolve inhabited_type_mkc_unit : slow.

Lemma equality_mkc_inl_implies {o} :
  forall lib (t1 t2 A B : @CTerm o),
    equality lib (mkc_inl t1) (mkc_inl t2) (mkc_union A B)
    -> equality lib t1 t2 A.
Proof.
  introv e.
  apply equality_mkc_union in e; repnd.
  repndors; exrepnd; spcast;
  apply computes_to_valc_isvalue_eq in e2; eauto 3 with slow;
  apply computes_to_valc_isvalue_eq in e4; eauto 3 with slow;
  eqconstr e2; eqconstr e4; auto.
Qed.

Lemma type_tnat {o} :
  forall (lib : @library o), type lib mkc_tnat.
Proof.
  introv.
  rw @mkc_tnat_eq.
  apply tequality_set; dands; auto.
  { apply tequality_int. }

  introv e.
  allrw @substc_mkcv_le.
  allrw @substc_mkcv_zero.
  allrw @mkc_var_substc.
  apply equality_in_int in e.
  unfold equality_of_int in e; exrepnd; spcast.

  apply tequality_mkc_le.
  exists (0%Z) k (0%Z) k; dands; spcast; tcsp.

  - unfold computes_to_valc; simpl.
    unfold computes_to_value; dands; eauto with slow.

  - unfold computes_to_valc; simpl.
    unfold computes_to_value; dands; eauto with slow.

  - destruct (Z_le_gt_dec 0 k); tcsp.
    right; dands; omega.
Qed.
Hint Resolve type_tnat : slow.

Definition equality_of_nat {p} lib (n m : @CTerm p) :=
  {k : nat , n ===>(lib) (mkc_nat k)
           # m ===>(lib) (mkc_nat k)}.

Lemma equality_in_tnat {o} :
  forall lib (a b : @CTerm o),
    equality lib a b mkc_tnat
    <=> equality_of_nat lib a b.
Proof.
  introv.
  rw @mkc_tnat_eq.
  rw @equality_in_set.
  rw @equality_in_int.
  unfold equality_of_int, equality_of_nat.
  rw @substc_mkcv_le.
  rw @substc_mkcv_zero.
  rw @mkc_var_substc.
  rw @inhabited_le.
  split; introv k; exrepnd; spcast; dands;
  repeat computes_to_eqval;
  computes_to_value_isvalue; ginv.
  - inversion k2; subst.
    apply Wf_Z.Z_of_nat_complete in k3; exrepnd; subst.
    exists n; dands; spcast; auto.
  - introv e.
    allrw @substc_mkcv_le.
    allrw @substc_mkcv_zero.
    allrw @mkc_var_substc.
    apply equality_in_int in e.
    unfold equality_of_int in e; exrepnd; spcast.
    apply tequality_mkc_le.
    exists (0%Z) k (0%Z) k; dands; spcast; auto;
    try (complete (unfold computes_to_valc; simpl;
                   unfold computes_to_value; dands;
                   eauto with slow)).
    destruct (Z_le_gt_dec 0 k); sp.
    right; sp; omega.
  - exists (Z.of_nat k0); dands; spcast; auto.
  - exists (0%Z) (Z.of_nat k0); dands; spcast; auto;
    try omega;
    try (complete (unfold computes_to_valc; simpl;
                   unfold computes_to_value; dands;
                   eauto with slow)).
Qed.

Lemma equality_in_int_and_inhabited_le_implies_equality_in_nat {o} :
  forall lib (a b : @CTerm o),
    equality lib a b mkc_int
    -> inhabited_type lib (mkc_le mkc_zero a)
    -> equality lib a b mkc_tnat.
Proof.
  introv e inh.
  apply equality_in_tnat.
  apply equality_in_int in e.
  apply inhabited_le in inh.
  unfold equality_of_nat.
  unfold equality_of_int in e.
  exrepnd; spcast.
  repeat computes_to_eqval.
  computes_to_value_isvalue; ginv.
  inversion inh0; subst.
  apply Wf_Z.Z_of_nat_complete in inh1; exrepnd; subst.
  exists n; dands; spcast; auto.
Qed.

Lemma equality_of_nat_implies_equality_of_int {o} :
  forall lib (t1 t2 : @CTerm o),
    equality_of_nat lib t1 t2
    -> equality_of_int lib t1 t2.
Proof.
  introv e.
  unfold equality_of_nat in e; exrepnd; spcast.
  unfold equality_of_int.
  allrw @mkc_nat_eq.
  exists (Z.of_nat k); dands; spcast; auto.
Qed.

Lemma equality_in_int_implies_cequiv {o} :
  forall lib (a b : @CTerm o),
    equality lib a b mkc_int
    -> cequivc lib a b.
Proof.
  introv e.
  apply equality_in_int in e.
  apply equality_of_int_imp_tt in e.
  unfold equality_of_int_tt in e; exrepnd.
  destruct_cterms; allunfold @computes_to_valc; allunfold @cequivc; allsimpl.
  allunfold @computes_to_value; repnd.
  apply (cequiv_trans _ _ (mk_integer k)).
  - apply reduces_to_implies_cequiv; auto.
    apply isprogram_eq; auto.
  - apply cequiv_sym.
    apply reduces_to_implies_cequiv; auto.
    apply isprogram_eq; auto.
Qed.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From fourcolor Require Import cfmap cfreducible configurations.
From fourcolor Require Import job323to383 job384to398 job399to438.
From fourcolor Require Import job439to465 job466to485.

(******************************************************************************)
(* Reducibility of configurations number 323 to 485, whose indices in         *)
(* the_configs range over segment [322, 485).                                 *)
(******************************************************************************)

Lemma red322to485 : reducible_in_range 322 485 the_configs.
Proof.
CatReducible red322to383 red383to398 red398to438 red438to465 red465to485.
Qed.


(*

  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

*)

Require Export sequents_atom_tacs.
Require Export rules_struct.

Lemma utok_ren_cseq_thin_hyps {o} :
  forall H J C t wg cg c wfs ct ce D deq fresh
         (f : @utok_ren_cseq
                (set_dset_string o)
                (mk_dset D deq fresh)
                (mk_wcseq ((H ++ J) ||- (mk_concl C t))
                          (ext_wf_cseq (H ++ J) ||- (mk_concl C t) wg cg c))),
    @utok_ren_cseq
      (set_dset_string o)
      (mk_dset D deq fresh)
      (mk_wcseq (H) ||- (mk_concl C t) (wfs, (ct, ce))).
Proof.
  introv f.
  intro p; exrepnd; simpl in p0.
  assert (dset_member
            x
            (get_utokens_cseq
               (mk_wcseq (H ++ J) ||- (mk_concl C t)
                         (ext_wf_cseq (H ++ J) ||- (mk_concl C t) wg cg c)))) as m.
  (* -- begin proof of m *)
  allrw @dset_member_iff.
  allunfold @get_utokens_cseq; allsimpl.
  allunfold @get_utokens_ctseq; allsimpl.
  allunfold @get_utokens_seq; allsimpl.
  allunfold @get_utokens_bseq; allsimpl.
  allrw @get_utokens_bhyps_app; allrw in_app_iff; sp.
  (* -- end proof of m *)
  pose proof (f (existT _ x m)); auto.
Defined.

Lemma rule_thin_hyps_atom_true {o} :
  forall lib (H J : @barehypotheses (s2s o))
         (C t : NTerm),
    rule_atom_true lib (rule_thin_hyps H J C t).
Proof.
  introv.
  unfold rule_atom_true, closed_type_baresequent, closed_extract_baresequent.
  introv cargs hyps; allsimpl.

  clear cargs.
  dLin_hyp.
  destruct Hyp as [wf1 hyp1].
  destruct wf1 as [wfs wf1].
  destruct wf1 as [ct ce].
  allsimpl.

  assert (closed_extract (H ++ J) (mk_concl C t))
    as c by (wfseq; apply covered_app_weak_l; auto).
  exists c.

  unfold sequent_atom_true.
  introv kelts; introv.

  pose proof (replace_utokens_cseq_mk_wcseq
                ((H ++ J) ||- (mk_concl C t))
                (ext_wf_cseq (H ++ J) ||- (mk_concl C t) wg cg c)
                f) as e; exrepnd.
  rw e0; clear e0.

  revert w'.
  unfold replace_utokens_bseq; introv; allsimpl.
  foldseq.

  revert w'.
  rw @replace_utokens_bhyps_app; introv.

  destruct w' as [wsr w']; destruct w' as [ctr cer]; allsimpl.

  pose proof (rule_thin_hyps_true
                (replace_utokens_library lib fl)
                (replace_utokens_bhyps
                   H
                   (utok_ren_bhyps_app_2bhyps1
                      H J
                      (utok_ren_bseq_2h (H ++ J) ||- (mk_concl C t) f)))
                (replace_utokens_bhyps
                   J
                   (utok_ren_bhyps_app_2bhyps2
                      H J
                      (utok_ren_bseq_2h (H ++ J) ||- (mk_concl C t) f)))
                (replace_utokens_t
                   C
                   (utok_ren_concle_2t
                      C t
                      (utok_ren_bseq_2c (H ++ J) ||- (mk_concl C t) f)))
                (replace_utokens_t
                   t
                   (utok_ren_concle_2e
                      C t
                      (utok_ren_bseq_2c (H ++ J) ||- (mk_concl C t) f)))
                wsr
                ctr
                (args_constraints_nil _)) as h; simpl in h.

  repeat (autodimp h hyp).

  - clear cer ctr wsr.
    introv h.
    dorn h; tcsp; subst.
    pose proof (hyp1 k D deq fresh kelts) as h; clear hyp1.

    pose proof (h (utok_ren_cseq_thin_hyps
                     H J C t wg cg c wfs ct ce D deq fresh f)
                  fl) as hh; clear h.

    pose proof (replace_utokens_cseq_mk_wcseq
                  ((H) ||- (mk_concl C t))
                  (wfs,(ct,ce))
                  (utok_ren_cseq_thin_hyps
                     H J C t wg cg c wfs ct ce D deq fresh f)) as e; exrepnd.
    rw e0 in hh; clear e0.
    allunfold @replace_utokens_bseq; allsimpl.
    foldseq.
    rw <- @sequent_true_eq_VR in hh.

    assert (eq_utok_ren_bhyps
              H
              (utok_ren_bseq_2h
                 ((H) ||- (mk_concl C t))
                 (utok_ren_cseq_thin_hyps H J C t wg cg c wfs ct ce D deq fresh f))
              (utok_ren_bhyps_app_2bhyps1
                 H J
                 (utok_ren_bseq_2h (H ++ J) ||- (mk_concl C t) f))) as e1.
    introv; exrepnd; simpl.
    gen_s2s; PI2.

    assert (eq_utok_ren
              C
              (utok_ren_concle_2t
                 C t
                 (utok_ren_bseq_2c (H) ||- (mk_concl C t)
                                   (utok_ren_cseq_thin_hyps H J C t wg cg c wfs ct
                                                            ce D deq fresh f)))
              (utok_ren_concle_2t
                 C t
                 (utok_ren_bseq_2c (H ++ J) ||- (mk_concl C t) f))
           ) as e2.
    introv; exrepnd; simpl.
    gen_s2s; PI2.

    assert (eq_utok_ren
              t
              (utok_ren_concle_2e
                 C t
                 (utok_ren_bseq_2c (H) ||- (mk_concl C t)
                                   (utok_ren_cseq_thin_hyps H J C t wg cg c wfs ct
                                                            ce D deq fresh f)))
              (utok_ren_concle_2e
                 C t
                 (utok_ren_bseq_2c (H ++ J) ||- (mk_concl C t) f))
           ) as e3.
    introv; exrepnd; simpl.
    gen_s2s; PI2.

    rw <- (replace_utokens_bhyps_eq H _ _ e1).
    rw <- (replace_utokens_t_eq C _ _ e2).
    rw <- (replace_utokens_t_eq t _ _ e3).
    exists w'; auto.

  - exrepnd.
    allunfold @closed_extract_baresequent; allsimpl; PI2.
    unfold ext_wf_cseq in h0.
    rw @sequent_true_eq_VR in h0; auto.
Qed.


(*

  Copyright 2014 Cornell University

  This file is part of CFGV project.

  CFGV 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.

  CFGV 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 CFGV.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/CFGVLFMTP2014/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Import CFGV.

(** Now, specialize the previous CFGV to
  CFGVs where the symbols are denoted by strings.
  The goal is to make the specification
  of a [StringCFGV] to be as close as that to
  paper-pen presentations, i.e. the user has to
  specify the minimal amount of information ans
  proofs are filled automatically.
  We have a decision procedure that takes a [StringCFGV]
  and either produces [CFGV] or produces a proof that
  something is wrong with the input*)

Record StringVarSpec := mksvs {
  vname : String.string;
  subTNonTerminal : String.string;
  vSemType :{T:Type $ VarType}
}.

Record Terminal := mkst {
  tname : String.string;
  tSemType :  Type
}.

Record TermProd := mkp {
  pname : String.string;
  tpLhs : String.string;
  prhs : list String.string
}.

Record BindingInfo := mkbind {
  binder : nat;
  bindee : nat
}.

Record StringCFGV := mk_ott {
  (** all the lists below should have distinct elements *)
  VarSymes : list StringVarSpec;
  Terminals : list Terminal;
  TNonTerminals : list String.string;
  Patterns : list String.string;
  (** lhs and elements of rhs of the 3 kinds of
    production rules below must be members
    of one of the lists above,
    with some restrictions noted below *)
  PatProds : list TermProd;
  Embeddings : list TermProd;
  GProds : list (TermProd * (list BindingInfo))
}.

Hint Resolve String.string_dec : Deq.
Definition stSubset (l r : list String.string) : [univ]
  := (diff  String.string_dec r l = []).

Definition stMinus (l r : list String.string)
    : list String.string
  := (diff  String.string_dec r l).

Example exxxxxxx: stSubset ["hello"] ["hello", "how"].
Proof.  refl.
Qed.

Definition ProdRhs (sg :StringCFGV) :=
  (TNonTerminals sg) ++ (Patterns sg) ++
  (map vname (VarSymes sg))
  ++ (map tname (Terminals sg)).

Definition PatProdRhs (sg :StringCFGV) :=
  (Patterns sg) ++
  (map vname (VarSymes sg))
  ++ (map tname (Terminals sg)).

(*  no_repeats (VarSymes sg)
  # no_repeats (Terminals sg)
  # no_repeats (TNonTerminals sg)
  # no_repeats (Patterns sg) *)

(** We can now use coq's definitional equality to
    check the properties required to get a [CFGV]
    from [StringCFGV]. The idea is that
    for concrete [StringCFGV]s
    the proof of the predicate below should
    just be a tuple of [eq_refl].*)
Definition GoodStringCFGV (sg :StringCFGV) :=
  []= (stMinus (map tpLhs (PatProds sg)) (Patterns sg))
      ++ (stMinus (flat_map prhs (PatProds sg)) (PatProdRhs sg))
      ++ (stMinus (map tpLhs (Embeddings sg)) (Patterns sg))
      ++ (stMinus (flat_map prhs (Embeddings sg)) (TNonTerminals sg)).


From Coq Require Import Lists.List.
From Coq Require Import Numbers.NatInt.NZLog.
From Coq Require Import Strings.String.

From Ornamental Require Import Ornaments.

Set DEVOID search prove equivalence. (* <-- Correctness proofs for search *)
Set DEVOID lift type. (* <-- Prettier types than the ones Coq infers *)

Module SCS.

  Definition sort (n : nat) := Type.

End SCS.

Preprocess Module SCS as SCS'.

  (* Axiom error : forall (a : Type), String.string -> a. *)

  Definition String := String.string.

  Definition Unit        := tt.
  Definition UnitType    := unit.
  Definition UnitType__rec := unit_rect.

  Definition Bool   := bool.
  Definition Eq     := identity.
  Definition Eq__rec  := identity_rect.
  Definition Refl   := identity_refl.
  Definition True      := true.
  Definition ite (a : Type) (b : Bool) (t e : a) : a := if b then t else e.
  Definition and    := andb.
  Definition False      := false.
  Definition not      := negb.
  Definition or     := orb.
  Definition xor    := xorb.
  Definition boolEq := Coq.Bool.Bool.eqb.
  Theorem boolEq__eq (b1 b2:Bool) : Eq Bool (boolEq b1 b2) (ite Bool b1 b2 (not b2)).
  Proof.
    destruct b1, b2; reflexivity.
  Qed.

  Definition coerce (a b : sort 0) (eq : Eq (sort 0) a b) (x : a) : b :=
    match eq in identity _ a' return a' with
    | identity_refl _ => x
    end
  .

  (** Typeclass for `eq` **)
(* NOTE: SAW core prelude's eq is not being used much by the translation at the *)
 (* moment, so we skip it.  The following type class declaration could be used if *)
 (* one wanted to translate `eq`.  However, it would require more work in the *)
 (* translation, because calls to `eq T a b` in SAW must be translated to either `eq *)
 (* a b` or `@eq T _ a b`, where the underscore stands for the dictionary.  As a *)
 (* result, this would not be an identifier-to-identifier translation, but rather a *)
 (* term-to-term translation, and would require knowing the number of arguments *)
 (* expected before the dicitonary. *)
(* *)
 (* Class eqClass `(a : Type) := *)
 (*   { *)
 (*     eq : a -> a -> bool; *)
 (*     eq_refl : forall (x : a), Eq Bool (eq x x) True; *)
 (*   }. *)

 (* Global Instance eqClassBool : eqClass Bool := *)
 (*   { *)
 (*     eq := boolEq; *)
 (*   }. *)
 (* + destruct x; reflexivity. *)
 (* Defined. *)

 (* Theorem eq_Bool : Eq (Bool -> Bool -> Bool) eq boolEq. *)
 (* Proof. *)
 (*   reflexivity. *)
 (* Qed. *)

 (* Global Instance eqClass_sawVec (n : nat) (a : Type) `(A : eqClass a) : eqClass (sawVec n a) := *)
 (*   { *)
 (*     eq := Vector.eqb _ eq; *)
 (*   }. *)
 (* + induction 0 as [|? ? ? IH]. *)
 (*   - reflexivity. *)
 (*   - simpl. *)
 (*     rewrite eq_refl. *)
 (*     rewrite IH. *)
 (*     reflexivity. *)
 (* Defined. *)
 (* *)

(* SAW's prelude defines iteDep as a Bool eliminator whose arguments are *)
 (* reordered to look more like if-then-else. *)
  Definition iteDep (P : Bool -> Type) (b : Bool) : P True -> P False -> P b :=
    fun PTrue PFalse => bool_rect P PTrue PFalse b.

  Definition ite_eq_iteDep : forall (a : Type) (b : Bool) (x y : a),
      @identity a (ite a b x y) (iteDep (fun _ => a) b x y).
  Proof.
    reflexivity.
  Defined.

  Definition iteDep_True : forall (p : Bool -> Type), forall (f1 : p True), forall (f2 : p False), (@identity (p True) (iteDep p True f1 f2)) f1.
  Proof.
    reflexivity.
  Defined.

  Definition iteDep_False : forall (p : Bool -> Type), forall (f1 : p True), forall (f2 : p False), (@identity (p False) (iteDep p False f1 f2)) f2.
  Proof.
    reflexivity.
  Defined.

  Definition not__eq (b : Bool) : @identity Bool (not b) (ite Bool b False True).
  Proof.
    reflexivity.
  Defined.

  Definition and__eq (b1 b2 : Bool) : @identity Bool (and b1 b2) (ite Bool b1 b2 False).
  Proof.
    reflexivity.
  Defined.

  Definition or__eq (b1 b2 : Bool) : @identity Bool (or b1 b2) (ite Bool b1 True b2).
  Proof.
    reflexivity.
  Defined.

  Definition xor__eq (b1 b2 : Bool) : @identity Bool (xor b1 b2) (ite Bool b1 (not b2) b2).
  Proof.
    destruct b1; destruct b2; reflexivity.
  Defined.

(* *)
 (* Definition eq__eq (b1 b2 : Bool) : @identity Bool (eq b1 b2) (ite Bool b1 b2 (not b2)). *)
 (* Proof. *)
 (*   destruct b1; destruct b2; reflexivity. *)
 (* Defined. *)
 (* *)

  Theorem ite_bit (b c d : Bool) : Eq Bool (ite Bool b c d) (and (or (not b) c) (or b d)).
  Proof.
    destruct b, c, d; reflexivity.
  Qed.

  (* TODO: doesn't actually coerce *)
  Definition sawCoerce {T : Type} (a b : Type) (_ : T) (x : a) := x.

  (* TODO: doesn't actually coerce *)
  Definition sawUnsafeCoerce (a b : Type) (x : a) := x.

  Definition Nat := nat.
  Definition Nat_rect := nat_rect.

  (* Definition minNat := Nat.min. *)

  Definition uncurry (a b c : Type) (f : a -> b -> c) (p : a * (b * unit)) : c  :=
    f (fst p) (fst (snd p)).

  Definition widthNat (n : Nat) : Nat := 1 + Nat.log2 n.

  Definition divModNat (x y : Nat) : (Nat * Nat) :=
    match y with
    | 0 => (y, y)
    | S y'=>
      let (p, q) := Nat.divmod x y' 0 y' in
      (p, y' - q)
    end.

  Definition id := @id.
  Definition PairType := prod.
  Definition PairValue := @pair.
  Definition Pair__rec := prod_rect.
  Definition fst {A B} := @fst A B.
  Definition snd {A B} := @snd A B.
  Definition Zero := O.
  Definition Succ := S.

End SCS.

Preprocess Module SCS as SCS'.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From fourcolor Require Import cfmap cfreducible configurations.

(******************************************************************************)
(* Reducibility of configurations number 299 to 302, whose indices in         *)
(* the_configs range over segment [298, 302).                                 *)
(******************************************************************************)

Lemma red298to302 : reducible_in_range 298 302 the_configs.
Proof. CheckReducible. Qed.


(* *********************************************************************)
(*                                                                     *)
(*             The Quantitative CompCert verified compiler             *)
(*                                                                     *)
(*                 Tahina Ramananandro, Yale University                *)
(*                                                                     *)
(*  This file is derived from the backend/Mach.v file of the           *)
(*  CompCert 1.13 verified compiler by Xavier Leroy, INRIA.            *)
(*  The CompCert verified compiler is                                  *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  The original file is           *)
(*  distributed                                                        *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*  According to this license, this modified version is distributed    *)
(*  under a similar license (see LICENSE for details).                 *)
(*                                                                     *)
(* *********************************************************************)

(** The [Mach2] intermediate language.

    As explained in Section 3.2 of our PLDI 2014 paper, [Mach2] and
    [Mach] have the same abstract syntax. [Mach2] is just a
    reinterpretation of [Mach] with a finite stack space. Stack frames
    of all function calls are merged together into a single
    whole-program stack block.

*)

Require Import Memory.
Require Import AST.
Require Import Values.
Require Import Events.
Require Import Coqlib.
Require Import Locations.
Require Import Globalenvs.
Require Import Op.
Require Import Integers.
Require Import Conventions.
Require Import Smallstep.
Require Import Mach.
Require Import Stackbounds.

Section WITHRAO.

Variable external_event_needs: event -> Z.

Variable return_address_offset: function -> code -> int -> Prop.

Section RELSEM.

Variable ge: genv.

Inductive stackframe: Type :=
  | Stackframe:
      forall (f: block)       (**r pointer to calling function *)
             (retaddr: int)   (**r Asm return address in calling function (needed to show that the code [c] below can be compiled to some assembly code)  *)
             (c: code),       (**r program point in calling function *)
      stackframe.

Inductive state: Type :=
  | State:
      forall (stack: list stackframe)  (**r call stack *)
             (f: block)                (**r pointer to current function *)
             (sp: val)                 (**r stack pointer *)
             (c: code)                 (**r current program point *)
             (rs: regset)              (**r register state *)
             (m: mem),                 (**r memory state *)
      state
  | Callstate:
      forall
             (sp: val)                 (**r stack pointer *)
             (stack: list stackframe)  (**r call stack *)
             (f: block)                (**r pointer to function to call *)
             (rs: regset)              (**r register state *)
             (m: mem),                 (**r memory state *)
      state
  | Returnstate:
      forall
             (sp: val)                 (**r stack pointer *)
             (stack: list stackframe)  (**r call stack *)
             (rs: regset)              (**r register state *)
             (m: mem),                 (**r memory state *)
      state.

Inductive step: state -> trace -> state -> Prop :=
  | exec_Mlabel:
      forall s f sp lbl c rs m,
      step (State s f sp (Mlabel lbl :: c) rs m)
        E0 (State s f sp c rs m)
  | exec_Mgetstack:
      forall s f sp ofs ty dst c rs m v,
      load_stack m sp ty ofs = Some v ->
      step (State s f sp (Mgetstack ofs ty dst :: c) rs m)
        E0 (State s f sp c (rs#dst <- v) m)
  | exec_Msetstack:
      forall s f sp src ofs ty c rs m m',
      store_stack m sp ty ofs (rs src) = Some m' ->
      step (State s f sp (Msetstack src ofs ty :: c) rs m)
        E0 (State s f sp c (undef_setstack rs) m')
  | exec_Mgetparam:
      forall s fb f sp psp ofs ty dst c rs m v,
      Genv.find_funct_ptr ge fb = Some (Internal f) ->
      psp = Val.add sp (Vint (Int.repr (f.(fn_stacksize) + size_chunk Mint32))) ->
      load_stack m psp ty ofs = Some v ->
      step (State s fb sp (Mgetparam ofs ty dst :: c) rs m)
        E0 (State s fb sp c (rs # IT1 <- Vundef # dst <- v) m)
  | exec_Mop:
      forall s f sp op args res c rs m v,
      eval_operation ge sp op rs##args m = Some v ->
      step (State s f sp (Mop op args res :: c) rs m)
        E0 (State s f sp c ((undef_op op rs)#res <- v) m)
  | exec_Mload:
      forall s f sp chunk addr args dst c rs m a v,
      eval_addressing ge sp addr rs##args = Some a ->
      Mem.loadv chunk m a = Some v ->
      step (State s f sp (Mload chunk addr args dst :: c) rs m)
        E0 (State s f sp c ((undef_temps rs)#dst <- v) m)
  | exec_Mstore:
      forall s f sp chunk addr args src c rs m m' a,
      eval_addressing ge sp addr rs##args = Some a ->
      Mem.storev chunk m a (rs src) = Some m' ->
      step (State s f sp (Mstore chunk addr args src :: c) rs m)
        E0 (State s f sp c (undef_temps rs) m')
  | exec_Mcall:
      forall s fb sp spp sig ros c rs m m' f f' ra,
      find_function_ptr ge ros rs = Some f' ->
      Genv.find_funct_ptr ge fb = Some (Internal f) ->
      spp = Val.sub sp (Vint (Int.repr (size_chunk Mint32))) ->
      Mem.storev Mint32 m spp (Vptr fb ra) = Some m' ->
      return_address_offset f c ra ->
      step (State s fb sp (Mcall sig ros :: c) rs m)
        E0 (Callstate spp (Stackframe fb ra c :: s)
                       f' rs m')
  | exec_Mtailcall:
      forall s fb sp spp sig ros c rs m f f',
      find_function_ptr ge ros rs = Some f' ->
      Genv.find_funct_ptr ge fb = Some (Internal f) ->
      spp = Val.add sp (Vint (Int.repr (f.(fn_stacksize)))) ->
      forall FID (HFID: FID = f.(fn_id)),
      step (State s fb sp (Mtailcall sig ros :: c) rs m)
        (Event_return FID :: E0) (Callstate spp s f' rs m)
  | exec_Mbuiltin:
      forall s f sp rs m ef args res b t v m',
      external_call ef ge rs##args m t v m' ->
      forall NEED: forall s o, sp = Vptr s o ->
                               Mem.range_perm m s (Int.unsigned o - size_chunk Mint32 - trace_needs external_event_needs t) (Int.unsigned o - size_chunk Mint32) Cur Freeable (* must have enough stack space for external function *),
      step (State s f sp (Mbuiltin ef args res :: b) rs m)
         t (State s f sp b ((undef_temps rs)#res <- v) m')
  | exec_Mannot:
      forall s f sp rs m ef args b vargs t v m',
      annot_arguments rs m sp args vargs ->
      external_call ef ge vargs m t v m' ->
      forall NEED: forall s o, sp = Vptr s o ->
                               Mem.range_perm m s (Int.unsigned o - size_chunk Mint32 - trace_needs external_event_needs t) (Int.unsigned o - size_chunk Mint32) Cur Freeable (* must have enough stack space for external function *),
      step (State s f sp (Mannot ef args :: b) rs m)
         t (State s f sp b rs m')
  | exec_Mgoto:
      forall s fb f sp lbl c rs m c',
      Genv.find_funct_ptr ge fb = Some (Internal f) ->
      find_label lbl f.(fn_code) = Some c' ->
      step (State s fb sp (Mgoto lbl :: c) rs m)
        E0 (State s fb sp c' rs m)
  | exec_Mcond_true:
      forall s fb f sp cond args lbl c rs m c',
      eval_condition cond rs##args m = Some true ->
      Genv.find_funct_ptr ge fb = Some (Internal f) ->
      find_label lbl f.(fn_code) = Some c' ->
      step (State s fb sp (Mcond cond args lbl :: c) rs m)
        E0 (State s fb sp c' (undef_temps rs) m)
  | exec_Mcond_false:
      forall s f sp cond args lbl c rs m,
      eval_condition cond rs##args m = Some false ->
      step (State s f sp (Mcond cond args lbl :: c) rs m)
        E0 (State s f sp c (undef_temps rs) m)
  | exec_Mjumptable:
      forall s fb f sp arg tbl c rs m n lbl c',
      rs arg = Vint n ->
      list_nth_z tbl (Int.unsigned n) = Some lbl ->
      Genv.find_funct_ptr ge fb = Some (Internal f) ->
      find_label lbl f.(fn_code) = Some c' ->
      step (State s fb sp (Mjumptable arg tbl :: c) rs m)
        E0 (State s fb sp c' (undef_temps rs) m)
  | exec_Mreturn:
      forall s fb sp psp c rs m f,
      Genv.find_funct_ptr ge fb = Some (Internal f) ->

      (* For function return, instead of freeing the stack frame
         block, the stack pointer goes from the callee's stack frame
         to the caller's stack frame within the single whole-program
         stack block by directly performing pointer arithmetics on the
         stack pointer. Thanks to this pointer arithmetics, no
         additional back link is necessary, as was the case in the
         genuine CompCert.

         The pointer arithmetics here is specific to x86.
       *)

      psp = Val.add sp (Vint (Int.repr f.(fn_stacksize))) ->
      forall FID (HFID: FID = f.(fn_id)),
      step (State s fb sp (Mreturn :: c) rs m)
        (Event_return FID :: E0) (Returnstate psp s rs m)
  | exec_function_internal:
      forall s fb rs m f sp csp,
      Genv.find_funct_ptr ge fb = Some (Internal f) ->

      (* For function call, instead of allocating a new block, the new
         stack frame is obtained within the single whole-program stack
         block by directly performing pointer arithmetics on the stack
         pointer.

         The pointer arithmetics here is specific to x86.
       *)

      csp = Val.sub sp (Vint (Int.repr f.(fn_stacksize))) ->
      forall FID (HFID: FID = f.(fn_id)),
      step (Callstate sp s fb rs m)
        (Event_call FID :: E0) (State s fb csp f.(fn_code) (undef_temps rs) m)
  | exec_function_external:
      forall s fb rs m t rs' ef args res m' sp psp,
      Genv.find_funct_ptr ge fb = Some (External ef) ->
      external_call ef ge args m t res m' ->
      psp = Val.add sp (Vint (Int.repr (size_chunk  Mint32))) ->
      extcall_arguments rs m psp (ef_sig ef) args ->
      rs' = (rs#(loc_result (ef_sig ef)) <- res) ->
      forall NEED: forall s o, sp = Vptr s o ->
                               Mem.range_perm m s (Int.unsigned o - trace_needs external_event_needs t) (Int.unsigned o) Cur Freeable (* must have enough stack space for external function *),
      step (Callstate sp s fb rs m)
         t (Returnstate sp s rs' m')
  | exec_return:
      forall s f fd sp psp ra c rs m,
        psp = Val.add sp (Vint (Int.repr (size_chunk Mint32))) ->
      Mem.loadv Mint32 m sp = Some (Vptr f ra) ->
      Genv.find_funct_ptr ge f = Some (Internal fd) ->
      return_address_offset fd c ra ->
      step (Returnstate sp (Stackframe f ra c :: s) rs m)
        E0 (State s f psp c rs m).

End RELSEM.

Section BOUNDED.

Variable bound: int.

Inductive initial_state (p: program): state -> Prop :=
  | initial_state_intro: forall fb m0,
      let ge := Genv.globalenv p in
      Genv.init_mem p = Some m0 ->
      forall m1 stk,
      Mem.alloc m0 0 (Int.unsigned bound) = (m1, stk) ->
      Genv.find_symbol ge p.(prog_main) = Some fb ->
      initial_state p (Callstate (Vptr stk bound) nil fb (Regmap.init Vundef) m1).

Inductive final_state (p: program): state -> int -> Prop :=
  | final_state_intro: forall sp rs m r,
      rs (loc_result (mksignature nil (Some Tint))) = Vint r ->
      sp = Vptr (Genv.genv_next (Genv.globalenv p)) bound ->
      final_state p (Returnstate sp nil rs m) r.

Definition semantics (p: program) :=
  Semantics (step) (initial_state p) (final_state p) (Genv.globalenv p).

End BOUNDED.

End WITHRAO.


Require Import Raft.
Require Import RaftRefinementInterface.

Require Import CommonTheorems.
Require Import SpecLemmas.
Require Import RefinementSpecLemmas.

Require Import UpdateLemmas.
Local Arguments update {_} {_} {_} _ _ _ _ : simpl never.

Require Import TermSanityInterface.
Require Import LogAllEntriesInterface.

Section LogAllEntries.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {rri : raft_refinement_interface}.
  Context {tsi : term_sanity_interface}.

  Ltac update_destruct :=
    match goal with
      | [ |- context [ update _ ?y _ ?x ] ] => destruct (name_eq_dec y x)
    end.

  Ltac update_destruct_hyp :=
    match goal with
      | [ _ : context [ update _ ?y _ ?x ] |- _ ] => destruct (name_eq_dec y x)
    end.

  Ltac destruct_update :=
    repeat (first [update_destruct_hyp|update_destruct]; subst; rewrite_update).

  Ltac rewrite_goal :=
    match goal with
      | H: _ = _ |- _ => rewrite H
    end.

  Definition no_entries_past_current_term_host_lifted net :=
    forall (h : name) e,
      In e (log (snd (nwState net h))) ->
      eTerm e <= currentTerm (snd (nwState net h)).

  Lemma no_entries_past_current_term_host_lifted_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      no_entries_past_current_term_host_lifted net.
  Proof using tsi rri.
    unfold no_entries_past_current_term_host_lifted.
    pose proof deghost_spec.
    do 4 intro.
    repeat find_reverse_higher_order_rewrite.
    eapply lift_prop; eauto.
    intros.
    find_apply_lem_hyp no_entries_past_current_term_invariant; eauto.
  Qed.

  Lemma handleAppendEntries_currentTerm_monotonic:
    forall h st (d : raft_data)
      (m : msg) (t : term) (n : name) (pli : logIndex)
      (plt : term) (es : list entry) (ci : logIndex),
      handleAppendEntries h st t n pli plt es
                          ci = (d, m) ->
      currentTerm st <= currentTerm d.
  Proof using.
    intros.
    unfold handleAppendEntries in *.
    repeat break_match; simpl in *; do_bool; repeat find_inversion; auto; try omega;
    simpl in *;
    unfold advanceCurrentTerm in *; repeat break_match; do_bool; auto.
  Qed.

  Lemma log_all_entries_append_entries :
    refined_raft_net_invariant_append_entries log_all_entries.
  Proof using tsi rri.
    red. unfold log_all_entries. intros.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    [|copy_eapply_prop_hyp In In; repeat find_rewrite; auto].
    find_copy_apply_lem_hyp handleAppendEntries_currentTerm_monotonic.
    find_eapply_lem_hyp update_elections_data_appendEntries_log_allEntries;
      intuition; eauto; repeat find_rewrite; repeat rewrite_goal; eauto.
    - copy_eapply_prop_hyp In In; repeat find_rewrite; auto.
      find_apply_lem_hyp no_entries_past_current_term_host_lifted_invariant; auto.
      repeat find_rewrite. eauto using le_antisym.
    - subst.
      apply in_app_iff. right.
      find_apply_hyp_hyp.
      find_apply_lem_hyp no_entries_past_current_term_host_lifted_invariant; auto.
      eauto using le_antisym.
    - subst.
      apply in_app_iff.
      left.
      apply in_map_iff. eauto.
    - do_in_app. intuition.
      + subst.
        apply in_app_iff.
        left.
        apply in_map_iff. eauto.
      + subst.
        apply in_app_iff. right.
        find_apply_lem_hyp removeAfterIndex_in.
        find_apply_hyp_hyp.
        find_apply_lem_hyp no_entries_past_current_term_host_lifted_invariant; auto.
        eauto using le_antisym.
  Qed.

  Lemma log_all_entries_append_entries_reply :
    refined_raft_net_invariant_append_entries_reply log_all_entries.
  Proof using tsi rri.
    red. unfold log_all_entries. intros.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    [|copy_eapply_prop_hyp In In; repeat find_rewrite; auto].
    find_copy_apply_lem_hyp handleAppendEntriesReply_log. find_rewrite.
    find_copy_apply_lem_hyp handleAppendEntriesReply_type_term.
    intuition; repeat find_rewrite; copy_eapply_prop_hyp In In; repeat find_rewrite; auto.
    find_apply_lem_hyp no_entries_past_current_term_host_lifted_invariant; auto.
    repeat find_rewrite. eauto using le_antisym.
  Qed.

  Lemma log_all_entries_request_vote :
    refined_raft_net_invariant_request_vote log_all_entries.
  Proof using tsi rri.
    red. unfold log_all_entries. intros.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    [|copy_eapply_prop_hyp In In; repeat find_rewrite; auto].
    find_copy_apply_lem_hyp handleRequestVote_log. find_rewrite.
    find_copy_apply_lem_hyp handleRequestVote_type_term.
    rewrite update_elections_data_requestVote_allEntries.
    intuition; repeat find_rewrite; copy_eapply_prop_hyp In In; repeat find_rewrite; auto.
    find_apply_lem_hyp no_entries_past_current_term_host_lifted_invariant; auto.
    repeat find_rewrite. eauto using le_antisym.
  Qed.

  Lemma log_all_entries_request_vote_reply :
    refined_raft_net_invariant_request_vote_reply log_all_entries.
  Proof using tsi rri.
    red. unfold log_all_entries. intros.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    [|copy_eapply_prop_hyp In In; repeat find_rewrite; auto].
    find_erewrite_lem handleRequestVoteReply_log.
    rewrite update_elections_data_requestVoteReply_allEntries.
    match goal with
      | |- context [handleRequestVoteReply ?h ?st ?h' ?t ?v] =>
        pose proof handleRequestVoteReply_type h st h' t v
             (handleRequestVoteReply h st h' t v)
    end.
    intuition; repeat find_rewrite;
    copy_eapply_prop_hyp In In; repeat find_rewrite; auto.
    find_apply_lem_hyp no_entries_past_current_term_host_lifted_invariant; auto.
    repeat find_rewrite.
    unfold raft_data in *. simpl in *.
    unfold raft_data in *. simpl in *.
    omega.
  Qed.

  Lemma log_all_entries_do_leader :
    refined_raft_net_invariant_do_leader log_all_entries.
  Proof using.
    red. unfold log_all_entries. intros.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    [|copy_eapply_prop_hyp In In; repeat find_rewrite; auto].
    find_copy_apply_lem_hyp doLeader_type; intuition.
    find_apply_lem_hyp doLeader_log. repeat find_rewrite.
    copy_eapply_prop_hyp In In; repeat find_rewrite; auto.
  Qed.

  Lemma log_all_entries_do_generic_server :
    refined_raft_net_invariant_do_generic_server log_all_entries.
  Proof using.
    red. unfold log_all_entries. intros.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    [|copy_eapply_prop_hyp In In; repeat find_rewrite; auto].
    find_copy_apply_lem_hyp doGenericServer_type; intuition.
    find_apply_lem_hyp doGenericServer_log. repeat find_rewrite.
    copy_eapply_prop_hyp In In; repeat find_rewrite; auto.
  Qed.

  Lemma log_all_entries_client_request :
    refined_raft_net_invariant_client_request log_all_entries.
  Proof using.
    red. unfold log_all_entries. intros.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    [|copy_eapply_prop_hyp In In; repeat find_rewrite; auto].
    find_copy_apply_lem_hyp update_elections_data_client_request_log_allEntries.
    find_apply_lem_hyp handleClientRequest_type.
    intuition; repeat find_rewrite;
    [copy_eapply_prop_hyp In In; repeat find_rewrite; auto|].
    break_exists. intuition.
    repeat find_rewrite.  simpl in *. intuition; subst; auto.
    copy_eapply_prop_hyp In In; repeat find_rewrite; auto.
  Qed.

  Lemma log_all_entries_timeout :
    refined_raft_net_invariant_timeout log_all_entries.
  Proof using tsi rri.
    red. unfold log_all_entries. intros.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    [|copy_eapply_prop_hyp In In; repeat find_rewrite; auto].
    find_copy_apply_lem_hyp handleTimeout_log_same.
    rewrite update_elections_data_timeout_allEntries.
    find_apply_lem_hyp handleTimeout_type_strong.
    intuition; repeat find_rewrite;
    copy_eapply_prop_hyp In In; repeat find_rewrite; auto.
    find_apply_lem_hyp no_entries_past_current_term_host_lifted_invariant; auto.
    repeat find_rewrite.
    unfold raft_data in *. simpl in *.
    unfold raft_data in *. simpl in *.
    omega.
  Qed.

  Lemma log_all_entries_reboot :
    refined_raft_net_invariant_reboot log_all_entries.
  Proof using.
    red. unfold log_all_entries. intros.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    simpl in *. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto;
    copy_eapply_prop_hyp In In; repeat find_rewrite; auto.
  Qed.

  Lemma log_all_entries_init :
    refined_raft_net_invariant_init log_all_entries.
  Proof using.
    red. unfold log_all_entries. intros.
    simpl in *. intuition.
  Qed.

  Lemma log_all_entries_state_same_packet_subset :
    refined_raft_net_invariant_state_same_packet_subset log_all_entries.
  Proof using.
    red. unfold log_all_entries. intros.
    simpl in *.
    repeat find_reverse_higher_order_rewrite.
    copy_eapply_prop_hyp In In; repeat find_rewrite; auto.
  Qed.

  Theorem log_all_entries_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      log_all_entries net.
  Proof using tsi rri.
    intros. apply refined_raft_net_invariant; auto.
    - apply log_all_entries_init.
    - apply log_all_entries_client_request.
    - apply log_all_entries_timeout.
    - apply log_all_entries_append_entries.
    - apply log_all_entries_append_entries_reply.
    - apply log_all_entries_request_vote.
    - apply log_all_entries_request_vote_reply.
    - apply log_all_entries_do_leader.
    - apply log_all_entries_do_generic_server.
    - apply log_all_entries_state_same_packet_subset.
    - apply log_all_entries_reboot.
  Qed.

  Instance laei : log_all_entries_interface.
  split.
  auto using log_all_entries_invariant.
  Qed.
End LogAllEntries.