(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	                       Products                   		     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export Limit.
Require Export Discr.
Require Export Products.

Set Implicit Arguments.
Unset Strict Implicit.

(* Foncteur de I~ (cate'gorie discrete obtenue a` partir de I) vers C *)

Section products_limit_def.

Variables (C : Category) (I : Type) (a : I -> C).

Definition FunDiscr_ob (i : Discr I) := a i.

Definition FunDiscr_arrow (i j : Discr I) (f : i --> j) :=
  match f in (Discr_mor d d0) return (Carrier (a d --> a d0)) with
  | Build_Discr_mor k => Id (a k)
  end.

Lemma FunDiscr_map_law :
 forall i j : I, Map_law (FunDiscr_arrow (i:=i) (j:=j)).
Proof.
unfold Map_law in |- *.
intros i j f; elim f; intros k f1 H.
apply
 (Discr_mor_ind1
    (P:=fun f1 : Discr_mor k k =>
        FunDiscr_arrow (Build_Discr_mor k) =_S FunDiscr_arrow f1)).
simpl in |- *; apply Refl.
Qed.

Canonical Structure FunDiscr_map (i j : Discr I) :=
  Build_Map (FunDiscr_map_law (i:=i) (j:=j)).

Lemma FunDiscr_comp_law : Fcomp_law FunDiscr_map.
Proof.
unfold Fcomp_law in |- *; intros i j k f.
elim f; simpl in |- *.
intros i' g; elim g; simpl in |- *.
intro i''; unfold Comp in |- *; apply (Prf_idr (c:=C)).
Qed.

Lemma FunDiscr_id_law : Fid_law FunDiscr_map.
Proof.
unfold Fid_law in |- *; simpl in |- *.
intro i; apply Refl.
Qed.

Canonical Structure FunDiscr :=
  Build_Functor FunDiscr_comp_law FunDiscr_id_law.

(* produit d'une famille d'objets *)

SubClass Product1 := Limit FunDiscr.

Variable l : Product1.

(* ||ai *)

Definition Pi1 := Lim l.

(* pi : ||ai -> ai *)

Definition Proj1 (i : I) : Pi1 --> a i := Limiting_cone l i.

(* construire a` partir d'une famille fj:c->ai, une NT tau:Delta(c)->F *)

 Section pd1_diese_def.

 Variables (c : C) (f : forall j : I, c --> FunDiscr j).

 Definition Product_tau (j : Discr I) := f j.

 Lemma Product_tau_cone_law : Cone_law Product_tau.
 Proof.
 unfold Cone_law, Product_tau in |- *; simpl in |- *.
 intros a' b g; elim g; simpl in |- *; intro i.
 unfold FMor in |- *; simpl in |- *.
 apply Idr.
 Qed.

 Definition Product_nt := Build_Cone Product_tau_cone_law.

 Definition Pd1_diese : c --> Pi1 := Lim_diese l Product_nt.

 End pd1_diese_def.

Lemma Prf_pd1_law1 : Product_law1 Proj1 Pd1_diese.
Proof.
unfold Product_law1, Product_eq in |- *; intros c f j.
apply Sym; apply (Prf_limit1 l (Product_nt f) j).
Qed.

Lemma Prf_pd1_law2 : Product_law2 Proj1 Pd1_diese.
Proof.
unfold Product_law2, Product_eq in |- *; intros c f g H.
unfold Pd1_diese in |- *; apply (Prf_limit2 l).

unfold Limit_eq in |- *; simpl in |- *; unfold Product_tau in |- *;
 simpl in |- *.
intro i; apply Sym; apply (H i).
Qed.

Canonical Structure Product1_to_Product :=
  Build_Product Prf_pd1_law1 Prf_pd1_law2.

End products_limit_def.

Coercion Product1_to_Product : Product1 >-> Product.


(*

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

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

*)

Require Export Coq.Logic.ConstructiveEpsilon.
Require Export stronger_continuity_defs.
Require Export stronger_continuity_defs0.
Require Export per_props_atom.
Require Export terms5.

Lemma equality_mkc_union_tnat_unit {o} :
  forall lib (a b : @CTerm o),
    equality lib a b (mkc_union mkc_tnat mkc_unit)
    <=>
    ({k : nat
      , ccequivc lib a (mkc_inl (mkc_nat k))
      # ccequivc lib b (mkc_inl (mkc_nat k))}
     {+}
     (ccequivc lib a (mkc_inr mkc_axiom)
      # ccequivc lib b (mkc_inr mkc_axiom))).
Proof.
  introv.
  rw @equality_mkc_union.
  split; intro k; exrepnd; repndors; exrepnd; spcast; dands; eauto 3 with slow.

  - allrw @equality_in_tnat.
    allunfold @equality_of_nat; exrepnd; spcast.
    left.
    exists k; dands; spcast.
    + eapply cequivc_trans;[apply computes_to_valc_implies_cequivc; exact k2|].
      apply cequivc_mkc_inl_if.
      apply computes_to_valc_implies_cequivc; auto.
    + eapply cequivc_trans;[apply computes_to_valc_implies_cequivc; exact k4|].
      apply cequivc_mkc_inl_if.
      apply computes_to_valc_implies_cequivc; auto.

  - allrw @equality_in_unit; repnd; spcast.
    right; dands; spcast.
    + eapply cequivc_trans;[apply computes_to_valc_implies_cequivc; exact k2|].
      apply cequivc_mkc_inr_if.
      apply computes_to_valc_implies_cequivc; auto.
    + eapply cequivc_trans;[apply computes_to_valc_implies_cequivc; exact k4|].
      apply cequivc_mkc_inr_if.
      apply computes_to_valc_implies_cequivc; auto.

  - left.
    apply cequivc_sym in k2; apply cequivc_mkc_inl_implies in k2.
    apply cequivc_sym in k1; apply cequivc_mkc_inl_implies in k1.
    exrepnd.
    exists b1 b0; dands; spcast; auto.
    eapply equality_respects_cequivc_left;[exact k4|].
    eapply equality_respects_cequivc_right;[exact k3|].
    apply equality_in_tnat.
    unfold equality_of_nat.
    exists k0; dands; spcast; auto;
    apply computes_to_valc_refl; eauto 3 with slow.

  - right.
    apply cequivc_sym in k0; apply cequivc_mkc_inr_implies in k0.
    apply cequivc_sym in k; apply cequivc_mkc_inr_implies in k.
    exrepnd.
    exists b1 b0; dands; spcast; auto.
    eapply equality_respects_cequivc_left;[exact k3|].
    eapply equality_respects_cequivc_right;[exact k1|].
    apply equality_in_unit.
    dands; spcast;
    apply computes_to_valc_refl; eauto 3 with slow.
Qed.

Lemma equality_in_mkc_texc {o} :
  forall lib (a b N E : @CTerm o),
    equality lib a b (mkc_texc N E)
    <=> {n1 : CTerm
         , {n2 : CTerm
         , {e1 : CTerm
         , {e2 : CTerm
         , a ===e>(lib,n1) e1
         # b ===e>(lib,n2) e2
         # equality lib n1 n2 N
         # equality lib e1 e2 E }}}}.
Proof.
  introv.
  split; introv k; exrepnd; spcast.

  - unfold equality in k; exrepnd.
    inversion k1; subst; try not_univ.
    clear k1.
    match goal with
      | [ H : per_texc _ _ _ _ _ |- _ ] => rename H into p
    end.
    allunfold @per_texc; exrepnd; spcast; computes_to_value_isvalue.
    apply p1 in k0.
    unfold per_texc_eq in k0; exrepnd; spcast.
    exists n1 n2 e1 e2; dands; spcast; auto.

    + eapply eq_equality1; eauto.

    + eapply eq_equality1; eauto.

  - allunfold @equality; exrepnd.
    rename eq0 into eqn.
    rename eq into eqe.
    exists (per_texc_eq lib eqn eqe).
    dands; auto.

    + apply CL_texc.
      unfold per_texc.
      exists eqn eqe N N E E.
      dands; spcast; auto;
      try (apply computes_to_valc_refl; apply iscvalue_mkc_texc).

    + unfold per_texc_eq.
      exists n1 n2 e1 e2; dands; spcast; auto.
Qed.

Lemma tequality_mkc_texc {o} :
  forall lib (N1 E1 N2 E2 : @CTerm o),
    tequality lib (mkc_texc N1 E1) (mkc_texc N2 E2)
    <=> (tequality lib N1 N2 # tequality lib E1 E2).
Proof.
  introv; split; intro teq; repnd.

  - unfold tequality in teq; exrepnd.
    inversion teq0; try not_univ; allunfold @per_texc; exrepnd.
    computes_to_value_isvalue; sp; try (complete (spcast; sp)).
    + exists eqn; sp.
    + exists eqe; sp.

  - unfold tequality in teq0; exrepnd.
    rename eq into eqn.
    unfold tequality in teq; exrepnd.
    rename eq into eqe.
    exists (per_texc_eq lib eqn eqe); apply CL_texc; unfold per_texc.
    exists eqn eqe N1 N2 E1 E2; sp; spcast;
    try (apply computes_to_valc_refl; apply iscvalue_mkc_texc).
Qed.

Lemma disjoint_nat_exc {o} :
  forall lib (a b : @CTerm o),
    disjoint_types lib mkc_tnat (mkc_texc a b).
Proof.
  introv mem; repnd.

  allrw @equality_in_tnat.
  allunfold @equality_of_nat; exrepnd; spcast; GC.

  allrw @equality_in_mkc_texc; exrepnd; spcast.
  eapply computes_to_valc_and_excc_false in mem0; eauto.
Qed.

Lemma tequality_mkc_singleton_uatom {o} :
  forall lib (n1 n2 : @get_patom_set o),
    tequality lib (mkc_singleton_uatom n1) (mkc_singleton_uatom n2)
    <=> n1 = n2.
Proof.
  introv.
  unfold mkc_singleton_uatom.
  rw @tequality_set; split; introv k; repnd; subst; tcsp.

  - clear k0.
    pose proof (k (mkc_utoken n1) (mkc_utoken n1)) as h; clear k.
    autodimp h hyp.
    { apply equality_in_uatom_iff.
      exists n1; dands; spcast;
      try (apply computes_to_valc_refl; apply iscvalue_mkc_utoken). }
    allrw @mkcv_cequiv_substc.
    allrw @mkc_var_substc.
    allrw @mkcv_utoken_substc.
    allrw @tequality_mkc_cequiv.
    destruct h as [h h2]; clear h2.
    autodimp h hyp; spcast; eauto 3 with slow.
    allrw @cequivc_mkc_utoken; auto.

  - dands;[apply tequality_uatom|].
    introv e.
    apply equality_in_uatom_iff in e; exrepnd; spcast.
    allrw @mkcv_cequiv_substc.
    allrw @mkc_var_substc.
    allrw @mkcv_utoken_substc.
    allrw @tequality_mkc_cequiv.
    allapply @computes_to_valc_implies_cequivc.
    split; intro k; spcast.
    + eapply cequivc_trans in k;[|apply cequivc_sym;exact e1].
      allrw @cequivc_mkc_utoken; subst; auto.
    + eapply cequivc_trans in k;[|apply cequivc_sym;exact e0].
      allrw @cequivc_mkc_utoken; subst; auto.
Qed.

Lemma tequality_mkc_ntexc {o} :
  forall lib n1 n2 (E1 E2 : @CTerm o),
    tequality lib (mkc_ntexc n1 E1) (mkc_ntexc n2 E2)
    <=> (n1 = n2 # tequality lib E1 E2).
Proof.
  introv.
  unfold mkc_ntexc.
  rw @tequality_mkc_texc.
  rw @tequality_mkc_singleton_uatom; auto.
Qed.

Lemma type_mkc_ntexc {o} :
  forall lib n (E : @CTerm o),
    type lib (mkc_ntexc n E) <=> (type lib E).
Proof.
  introv.
  rw @tequality_mkc_ntexc; split; sp.
Qed.

Lemma inhabited_type_mkc_cequiv {o} :
  forall lib (t1 t2 : @CTerm o),
    inhabited_type lib (mkc_cequiv t1 t2) <=> ccequivc lib t1 t2.
Proof.
  introv.
  unfold inhabited_type; split; introv k; exrepnd.

  - allunfold @member; allunfold @equality; allunfold @nuprl; exrepnd.
    inversion k0; subst; try not_univ.

    allunfold @per_cequiv; sp.
    uncast; computes_to_value_isvalue.
    discover; sp.

  - exists (@mkc_axiom o).
    apply member_cequiv_iff; auto.
Qed.

Lemma equality_in_mkc_singleton_uatom {o} :
  forall lib a b (n : @get_patom_set o),
    equality lib a b (mkc_singleton_uatom n)
    <=> (a ===>(lib) (mkc_utoken n) # b ===>(lib) (mkc_utoken n)).
Proof.
  introv.
  unfold mkc_singleton_uatom.
  rw @equality_in_set.
  allrw @mkcv_cequiv_substc.
  allrw @mkc_var_substc.
  allrw @mkcv_utoken_substc.
  allrw @inhabited_type_mkc_cequiv.
  allrw @equality_in_uatom_iff.
  split; intro k; exrepnd; spcast; dands; tcsp.

  - eapply close_type_sys_per_ffatom.cequivc_utoken in k;[|exact k1].
    apply computes_to_valc_isvalue_eq in k; try (eqconstr k); eauto 3 with slow.
    dands; spcast; auto.

  - eapply close_type_sys_per_ffatom.cequivc_utoken in k;[|exact k1].
    apply computes_to_valc_isvalue_eq in k; try (eqconstr k); eauto 3 with slow.
    dands; spcast; auto.

  - introv e.
    allrw @mkcv_cequiv_substc.
    allrw @mkc_var_substc.
    allrw @mkcv_utoken_substc.
    allrw @equality_in_uatom_iff; exrepnd; spcast.
    apply tequality_mkc_cequiv.
    allapply @computes_to_valc_implies_cequivc.
    split; intro h; spcast.
    + eapply cequivc_trans in h;[|apply cequivc_sym;exact e1].
      allrw @cequivc_mkc_utoken; subst; auto.
    + eapply cequivc_trans in h;[|apply cequivc_sym;exact e0].
      allrw @cequivc_mkc_utoken; subst; auto.

  - exists n; dands; spcast; auto.

  - spcast.
    allapply @computes_to_valc_implies_cequivc; auto.
Qed.

Lemma equality_in_mkc_ntexc {o} :
  forall lib n (a b E : @CTerm o),
    equality lib a b (mkc_ntexc n E)
    <=> {n1 : CTerm
         , {n2 : CTerm
         , {e1 : CTerm
         , {e2 : CTerm
         , n1 ===>(lib) (mkc_utoken n)
         # n2 ===>(lib) (mkc_utoken n)
         # a ===e>(lib,n1) e1
         # b ===e>(lib,n2) e2
         # equality lib e1 e2 E }}}}.
Proof.
  introv.
  rw @equality_in_mkc_texc; split; intro k; exrepnd; spcast.

  - allrw @equality_in_mkc_singleton_uatom; repnd; spcast.
    exists n1 n2 e1 e2; dands; spcast; auto.

  - exists n1 n2 e1 e2; dands; spcast; auto.
    allrw @equality_in_mkc_singleton_uatom; dands; spcast; auto.
Qed.

Lemma equality_in_natE {o} :
  forall lib n (a b : @CTerm o),
    equality lib a b (natE n)
    <=> (equality_of_nat lib a b
         {+} (ccequivc lib a (spexcc n) # ccequivc lib b (spexcc n))).
Proof.
  introv.
  unfold natE, with_nexc_c.

  pose proof (equality_in_disjoint_bunion lib a b mkc_tnat (mkc_ntexc n mkc_unit)) as h.
  autodimp h hyp.
  { unfold mkc_ntexc; apply disjoint_nat_exc. }
  rw h; clear h.
  rw @type_mkc_ntexc.

  split; intro k; repnd; dands; eauto 3 with slow; repndors; tcsp;
  allrw @equality_in_tnat;
  allrw @equality_in_mkc_ntexc;
  exrepnd; spcast; tcsp;
  allrw @equality_in_unit;
  repnd; spcast.

  - allapply @computes_to_excc_implies_cequivc.
    allapply @computes_to_valc_implies_cequivc.
    right; dands; spcast.
    + eapply cequivc_trans;[exact k5|].
      unfold spexc.
      apply cequivc_mkc_exception; auto.
    + eapply cequivc_trans;[exact k6|].
      unfold spexc.
      apply cequivc_mkc_exception; auto.

  - left; allrw @equality_in_tnat; auto.

  - right; allrw @equality_in_mkc_ntexc.
    allunfold @spexc.
    apply cequivc_sym in k0; apply cequivc_sym in k.
    apply cequivc_exception_implies in k0.
    apply cequivc_exception_implies in k.
    exrepnd.
    allapply @cequivc_axiom_implies.
    allapply @cequivc_utoken_implies.
    exists x0 x c0 c; dands; spcast; auto.
    allrw @equality_in_unit; dands; spcast; auto.
Qed.

Lemma equality_in_tnat_nat {o} :
  forall (lib : @library o) n, equality lib (mkc_nat n) (mkc_nat n) mkc_tnat.
Proof.
  introv.
  apply equality_in_tnat; unfold equality_of_nat; exists n.
  dands; spcast; apply computes_to_valc_refl; eauto 3 with slow.
Qed.
Hint Resolve equality_in_tnat_nat : slow.

Definition equality_of_nat_tt {o} lib (n m : @CTerm o) :=
  {k : nat & computes_to_valc lib n (mkc_nat k)
           # computes_to_valc lib m (mkc_nat k)}.

Lemma dec_reduces_ksteps_excc {o} :
  forall lib k (t v : @CTerm o),
    (forall x, decidable (x = get_cterm v))
    -> decidable (reduces_ksteps_excc lib t v k).
Proof.
  introv d.
  destruct_cterms; allsimpl.
  pose proof (dec_reduces_in_atmost_k_steps_exc lib k x0 x d) as h.
  destruct h as [h|h];[left|right].
  - spcast; tcsp.
  - intro r; spcast; tcsp.
Qed.

Lemma reduces_ksteps_excc_spexcc_decompose {o} :
  forall lib (k : nat) a (t : @CTerm o),
    reduces_ksteps_excc lib t (spexcc a) k
    -> {k1 : nat
        & {k2 : nat
        & {k3 : nat
        & {a' : CTerm
        & {e' : CTerm
        & k1 + k2 + k3 <= k
        # reduces_in_atmost_k_stepsc lib t (mkc_exception a' e') k1
        # reduces_in_atmost_k_stepsc lib a' (mkc_utoken a) k2
        # reduces_in_atmost_k_stepsc lib e' mkc_axiom k3 }}}}}.
Proof.
  introv r.
  pose proof (dec_reduces_in_atmost_k_steps_excc lib k t (spexcc a)) as h; allsimpl.
  try (fold (spexc a) in h).
  autodimp h hyp; eauto 3 with slow.
  destruct h as [d|d].
  - apply reduces_in_atmost_k_steps_excc_decompose in d; eauto 2 with slow.
  - provefalse; spcast; sp.
Qed.

Lemma reduces_ksteps_excc_impossible1 {o} :
  forall lib k1 k2 (t : @CTerm o) a n,
    reduces_ksteps_excc lib t (spexcc a) k1
    -> reduces_ksteps_excc lib t (mkc_nat n) k2
    -> False.
Proof.
  introv r1 r2; spcast.
  eapply reduces_in_atmost_k_steps_excc_impossible1 in r1; eauto.
Qed.

Lemma dec_reduces_ksteps_excc_nat {o} :
  forall lib k (t : @CTerm o),
    decidable {n : nat & reduces_ksteps_excc lib t (mkc_nat n) k}.
Proof.
  introv; destruct_cterms; allsimpl.
  pose proof (dec_reduces_in_atmost_k_steps_exc_nat lib k x) as h.
  destruct h as [h|h];[left|right].
  - exrepnd; exists n; spcast; tcsp.
  - intro r; exrepnd; destruct h; exists n; spcast; tcsp.
Qed.

Lemma equality_in_natE_implies {o} :
  forall lib (t u : @CTerm o) a,
    equality lib t u (natE a)
    -> equality_of_nat_tt lib t u
       [+] (cequivc lib t (spexcc a) # cequivc lib u (spexcc a)).
Proof.
  introv equ.

  assert {k : nat
          , {m : nat
          , (reduces_ksteps_excc lib t (mkc_nat m) k
             # reduces_ksteps_excc lib u (mkc_nat m) k)
            {+} (reduces_ksteps_excc lib t (spexcc a) k
                  # reduces_ksteps_excc lib u (spexcc a) k)}} as j.
  { apply equality_in_natE in equ.
    repndors.

    - unfold equality_of_nat in equ; exrepnd; spcast.
      allrw @computes_to_valc_iff_reduces_in_atmost_k_stepsc; exrepnd.
      exists (Peano.max k0 k1) k.
      left; dands; spcast.

      + apply (reduces_in_atmost_k_stepsc_le _ _ _ _ (Peano.max k0 k1)) in equ4; eauto 3 with slow;
        try (apply Nat.le_max_l; auto).
        apply reduces_in_atmost_k_steps_excc_can in equ4; tcsp.

      + apply (reduces_in_atmost_k_stepsc_le _ _ _ _ (Peano.max k0 k1)) in equ2; eauto 3 with slow;
        try (apply Nat.le_max_r; auto).
        apply reduces_in_atmost_k_steps_excc_can in equ2; tcsp.

    - repnd; spcast.
      apply cequivc_spexcc in equ0.
      apply cequivc_spexcc in equ.
      exrepnd.
      allrw @computes_to_valc_iff_reduces_in_atmost_k_stepsc; exrepnd.
      allrw @computes_to_excc_iff_reduces_in_atmost_k_stepsc; exrepnd.

      exists (Peano.max (k3 + k + k0) (k4 + k1 + k2)) 0.
      right; dands; spcast.

      + apply (reduces_in_atmost_k_steps_excc_le_exc _ (k3 + k + k0));
        eauto 3 with slow; tcsp;
        try (apply Nat.le_max_l; auto).
        pose proof (reduces_in_atmost_k_steps_excc_exception
                      lib k k0 n0 e0 (mkc_utoken a) mkc_axiom) as h.
        repeat (autodimp h hyp); tcsp; exrepnd.
        pose proof (reduces_in_atmost_k_steps_excc_trans2
                      lib k3 i
                      t
                      (mkc_exception n0 e0)
                      (mkc_exception (mkc_utoken a) mkc_axiom)) as q.
        repeat (autodimp q hyp); exrepnd.
        apply (reduces_in_atmost_k_steps_excc_le_exc _ i0); tcsp; try omega.

      + apply (reduces_in_atmost_k_steps_excc_le_exc _ (k4 + k1 + k2));
        eauto 3 with slow; tcsp;
        try (apply Nat.le_max_r; auto).
        pose proof (reduces_in_atmost_k_steps_excc_exception
                      lib k1 k2 n e (mkc_utoken a) mkc_axiom) as h.
        repeat (autodimp h hyp); tcsp; exrepnd.
        pose proof (reduces_in_atmost_k_steps_excc_trans2
                      lib k4 i
                      u
                      (mkc_exception n e)
                      (mkc_exception (mkc_utoken a) mkc_axiom)) as q.
        repeat (autodimp q hyp); exrepnd.
        apply (reduces_in_atmost_k_steps_excc_le_exc _ i0); tcsp; try omega.
  }

  apply (constructive_indefinite_ground_description nat (fun x => x) (fun x => x))
    in j; auto.

  { exrepnd.
    apply (constructive_indefinite_ground_description nat (fun x => x) (fun x => x))
      in j0; auto.

    - exrepnd.
      pose proof (dec_reduces_ksteps_excc lib x t (mkc_nat x0)) as h.
      autodimp h hyp; simpl; eauto 3 with slow.
      pose proof (dec_reduces_ksteps_excc lib x t (spexcc a)) as q.
      autodimp q hyp; simpl; try (fold (spexc a)); eauto 3 with slow.
      pose proof (dec_reduces_ksteps_excc lib x u (mkc_nat x0)) as j.
      autodimp j hyp; simpl; eauto 3 with slow.
      pose proof (dec_reduces_ksteps_excc lib x u (spexcc a)) as l.
      autodimp l hyp; simpl; try (fold (spexc a)); eauto 3 with slow.

      destruct h as [h|h];
      destruct q as [q|q];
      destruct j as [j|j];
      destruct l as [l|l];
      try (complete (eapply reduces_ksteps_excc_impossible1 in h;[|exact q]; tcsp));
      try (complete (eapply reduces_ksteps_excc_impossible1 in j;[|exact l]; eauto; tcsp));
      try (complete (provefalse; repndors; repnd; tcsp)).

      { left; exists x0; dands; split; simpl; eauto 3 with slow; exists x; spcast;
        apply reduces_in_atmost_k_steps_excc_can_implies in h;
        apply reduces_in_atmost_k_steps_excc_can_implies in j;
        allunfold @reduces_in_atmost_k_stepsc; allsimpl;
        allrw @get_cterm_apply; tcsp. }

      { right.
        apply reduces_ksteps_excc_spexcc_decompose in q.
        apply reduces_ksteps_excc_spexcc_decompose in l.
        exrepnd.
        allunfold @reduces_in_atmost_k_stepsc; allsimpl.
        allrw @get_cterm_apply; allsimpl.
        allrw @get_cterm_mkc_exception; allsimpl.
        dands;
          apply cequiv_spexc_if;
          try (apply isprog_apply);
          try (apply isprog_mk_nat);
          eauto 3 with slow.
        - exists (get_cterm a'0) (get_cterm e'0); dands; eauto 3 with slow.
          unfold computes_to_exception; exists k0; auto.
        - exists (get_cterm a') (get_cterm e'); dands; eauto 3 with slow.
          unfold computes_to_exception; exists k1; auto. }

    - clear j0.
      introv.

      pose proof (dec_reduces_ksteps_excc lib x t (mkc_nat x0)) as h.
      autodimp h hyp; simpl; eauto 3 with slow.
      pose proof (dec_reduces_ksteps_excc lib x t (spexcc a)) as q.
      autodimp q hyp; simpl; try (fold (spexc a)); eauto 3 with slow.
      pose proof (dec_reduces_ksteps_excc lib x u (mkc_nat x0)) as j.
      autodimp j hyp; simpl; eauto 3 with slow.
      pose proof (dec_reduces_ksteps_excc lib x u (spexcc a)) as l.
      autodimp l hyp; simpl; try (fold (spexc a)); eauto 3 with slow.

      destruct h as [h|h];
        destruct q as [q|q];
        destruct j as [j|j];
        destruct l as [l|l];
        tcsp;
        try (complete (right; intro xx; repndors; repnd; tcsp)).
  }

  { clear j; introv.

    pose proof (dec_reduces_ksteps_excc_nat lib x t) as h.
    pose proof (dec_reduces_ksteps_excc lib x t (spexcc a)) as q.
    autodimp q hyp; simpl; try (fold (spexc a)); eauto 3 with slow.
    pose proof (dec_reduces_ksteps_excc_nat lib x u) as j.
    pose proof (dec_reduces_ksteps_excc lib x u (spexcc a)) as l.
    autodimp l hyp; simpl; try (fold (spexc a)); eauto 3 with slow.

    destruct h as [h|h];
      destruct q as [q|q];
      destruct j as [j|j];
      destruct l as [l|l];
      exrepnd;
      try (destruct (deq_nat n0 n) as [d|d]); subst;
      tcsp;
      try (complete (eapply reduces_ksteps_excc_impossible1 in h0; eauto; tcsp));
      try (complete (eapply reduces_ksteps_excc_impossible1 in j0; eauto; tcsp));
      try (complete (provefalse; repndors; repnd; tcsp));
      try (complete (right; intro xx; exrepnd; repndors; repnd; tcsp;
                     try (complete (destruct h; eexists; eauto));
                     try (complete (destruct j; eexists; eauto))));
      try (complete (left; exists n; left; tcsp));
      try (complete (left; exists 0; right; tcsp)).

    right; intro xx; exrepnd; repndors; repnd; tcsp; spcast.
    allunfold @reduces_in_atmost_k_steps_excc; allsimpl.
    allunfold @reduces_in_atmost_k_steps_exc.
    rw xx1 in h0.
    rw xx0 in j0.
    inversion h0.
    inversion j0.
    allapply Znat.Nat2Z.inj; subst; tcsp.
  }
Qed.

Lemma tequality_with_nexc_c {o} :
  forall lib a1 a2 (T1 T2 E1 E2 : @CTerm o),
    tequality lib (with_nexc_c a1 T1 E1) (with_nexc_c a2 T2 E2)
    <=> (a1 = a2 # tequality lib T1 T2 # tequality lib E1 E2).
Proof.
  introv.
  unfold with_nexc_c.
  rw @tequality_bunion.
  rw @tequality_mkc_texc.
  rw @tequality_mkc_singleton_uatom.
  split; sp.
Qed.

Lemma tequality_natE {o} :
  forall lib (a1 a2 : @get_patom_set o),
    tequality lib (natE a1) (natE a2) <=> a1 = a2.
Proof.
  introv.
  unfold natE.
  rw @tequality_with_nexc_c.
  allrw @fold_type.
  split; intro k; repnd; dands; eauto with slow.
Qed.

Lemma type_natE {o} :
  forall lib (a : @get_patom_set o),
    type lib (natE a).
Proof.
  introv.
  rw @tequality_natE; auto.
Qed.
Hint Resolve type_natE : slow.

Lemma disjoint_nat_unit {o}:
  forall (lib : @library o),
    disjoint_types lib mkc_tnat mkc_unit.
Proof.
  introv mem; repnd.
  allrw @equality_in_tnat.
  allrw @equality_in_unit.
  allunfold @equality_of_nat; exrepnd; spcast; GC.
  computes_to_eqval.
Qed.
Hint Resolve disjoint_nat_unit : slow.

Definition equality_of_nat2 {p} lib (t1 t2 : @CTerm p) :=
  {j : nat
   , {n : nat
   , reduces_kstepsc lib t1 (mkc_nat n) j
   # reduces_kstepsc lib t2 (mkc_nat n) j}}.

Lemma equality_of_nat_implies_nat2 {o} :
  forall lib (t1 t2 : @CTerm o),
    equality_of_nat lib t1 t2 -> equality_of_nat2 lib t1 t2.
Proof.
  introv e.
  unfold equality_of_nat in e; exrepnd; spcast.
  allrw @computes_to_valc_iff_reduces_in_atmost_k_stepsc; exrepnd.
  exists (Peano.max k1 k0); exists k; dands; spcast.
  - eapply reduces_in_atmost_k_stepsc_le;[|idtac|exact e4]; auto;
    apply Nat.le_max_r; auto.
  - eapply reduces_in_atmost_k_stepsc_le;[|idtac|exact e2]; auto;
    apply Nat.le_max_l; auto.
Qed.

Lemma equality_of_nat2_implies_nat {o} :
  forall lib (t1 t2 : @CTerm o),
    equality_of_nat2 lib t1 t2 -> equality_of_nat lib t1 t2.
Proof.
  introv e.
  unfold equality_of_nat2 in e; exrepnd; spcast.
  exists n; dands; spcast;
  apply computes_to_valc_iff_reduces_in_atmost_k_stepsc;
  dands; eauto 3 with slow.
Qed.

Lemma dec_reduces_kstepsc {o} :
  forall lib k (t v : @CTerm o),
    (forall x, decidable (x = get_cterm v))
    -> decidable (reduces_kstepsc lib t v k).
Proof.
  introv d.
  destruct_cterms; allsimpl.
  pose proof (dec_reduces_in_atmost_k_steps lib k x0 x d) as h.
  destruct h as [h|h];[left|right].
  - spcast; tcsp.
  - intro r; spcast; tcsp.
Qed.

Lemma equality_of_nat_imp_tt {o} :
  forall lib (n m : @CTerm o),
    equality_of_nat lib n m
    -> equality_of_nat_tt lib n m.
Proof.
  introv e.
  unfold equality_of_nat_tt.
  apply equality_of_nat_implies_nat2 in e.
  unfold equality_of_nat2 in e.
  apply (constructive_indefinite_ground_description nat (fun x => x) (fun x => x))
    in e; auto.

  - exrepnd.
    apply (constructive_indefinite_ground_description nat (fun x => x) (fun x => x))
      in e0; auto.

    + exrepnd.
      exists x0; dands; auto;
      apply computes_to_valc_iff_reduces_in_atmost_k_stepsc;
      dands; eauto 3 with slow; exists x; spcast; auto.

    + clear e0.
      introv.
      pose proof (dec_reduces_kstepsc lib x n (mkc_nat x0)) as h; allsimpl.
      autodimp h hyp; eauto 3 with slow.
      pose proof (dec_reduces_kstepsc lib x m (mkc_nat x0)) as q; allsimpl.
      autodimp q hyp; eauto 3 with slow.
      destruct h as [h|h]; destruct q as [q|q]; tcsp;
      try (complete (right; intro r; repnd; tcsp)).

  - clear e.
    introv.
    remember (compute_at_most_k_steps lib x (get_cterm n)) as c1; symmetry in Heqc1.
    remember (compute_at_most_k_steps lib x (get_cterm m)) as c2; symmetry in Heqc2.
    destruct c1, c2.

    + destruct (decidable_ex_mk_nat n0) as [h|h]; exrepnd.

      * rw h0 in Heqc1; clear h0.
        destruct (decidable_ex_mk_nat n1) as [q|q]; exrepnd.

        { rw q0 in Heqc2; clear q0.
          destruct (deq_nat n2 n3) as [d|d].

          - subst.
            left; exists n3; dands; spcast; auto.

          - right; intro r; exrepnd; spcast.
            allunfold @reduces_in_atmost_k_stepsc; allsimpl.
            allunfold @reduces_in_atmost_k_steps.
            rw Heqc1 in r1.
            rw Heqc2 in r0.
            inversion r1 as [c1].
            inversion r0 as [c2].
            allapply Znat.Nat2Z.inj; subst; tcsp.
        }

        { right; intro r; exrepnd; spcast.
          allunfold @reduces_in_atmost_k_stepsc; allsimpl.
          allunfold @reduces_in_atmost_k_steps.
          rw Heqc1 in r1.
          rw Heqc2 in r0.
          inversion r1 as [c1].
          inversion r0 as [c2].
          allapply Znat.Nat2Z.inj; subst; tcsp.
          destruct q; exists n3; auto.
        }

      * right; intro r; exrepnd; spcast.
        allunfold @reduces_in_atmost_k_stepsc; allsimpl.
        allunfold @reduces_in_atmost_k_steps.
        rw Heqc1 in r1.
        rw Heqc2 in r0.
        inversion r1 as [c1].
        inversion r0 as [c2].
        allapply Znat.Nat2Z.inj; subst; tcsp.
        destruct h; exists n2; auto.

    + right; intro r; exrepnd; spcast.
      allunfold @reduces_in_atmost_k_stepsc; allsimpl.
      allunfold @reduces_in_atmost_k_steps.
      rw Heqc1 in r1.
      rw Heqc2 in r0.
      ginv.

    + right; intro r; exrepnd; spcast.
      allunfold @reduces_in_atmost_k_stepsc; allsimpl.
      allunfold @reduces_in_atmost_k_steps.
      rw Heqc1 in r1.
      rw Heqc2 in r0.
      ginv.

    + right; intro r; exrepnd; spcast.
      allunfold @reduces_in_atmost_k_stepsc; allsimpl.
      allunfold @reduces_in_atmost_k_steps.
      rw Heqc1 in r1.
      rw Heqc2 in r0.
      ginv.
Qed.

Lemma member_bunion_nat_unit_implies_cis_spcan_not_atom {o} :
  forall lib (t : @CTerm o) a,
    member lib t (mkc_bunion mkc_tnat mkc_unit)
    -> cis_spcan_not_atom lib t a.
Proof.
  introv mem.
  apply @equality_in_disjoint_bunion in mem; eauto 3 with slow.
  repnd.
  clear mem0 mem1.
  repndors.
  - apply equality_in_tnat in mem.
    unfold equality_of_nat in mem; exrepnd; spcast.
    exists (@mkc_nat o k); dands; spcast; simpl; tcsp.
  - apply equality_in_unit in mem; repnd; spcast.
    exists (@mkc_axiom o); dands; spcast; simpl; tcsp.
Qed.

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


Require Import
        Fiat.Computation
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.Notations
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.Common.WordFacts
        Fiat.Narcissus.Formats.WordOpt
        Fiat.Narcissus.BaseFormats.

Section Checksum.

  Variable A : Type. (* Type of data to be formatd. *)
  Variable B : Type. (* Type of formatd values. *)
  Variable monoid : Monoid B. (* Record of operations on formatd values. *)
  Variable monoid_opt : QueueMonoidOpt monoid bool.

  (*Variable calculate_checksum : B -> B -> B. (* Function to compute checksums. *) *)

  Variable checksum_sz : nat.
  Variable checksum_Valid : nat -> B -> Prop.  (* Property of properly checksummed formatd values. *)
  Variable checksum_Valid_dec :         (* Checksum validity should be decideable . *)
    forall n b, {checksum_Valid n b} + {~ checksum_Valid n b}.
  (*Variable checksum_OK :
    forall b ext, checksum_Valid (bin_measure (mappend b (calculate_checksum b)))
                                 (mappend (mappend b (calculate_checksum b)) ext).
  Variable checksum_commute :
    forall b b', calculate_checksum (mappend b b') = calculate_checksum (mappend b' b).
  Variable checksum_Valid_commute :
    forall b b' ext, checksum_Valid (bin_measure (mappend b b')) (mappend (mappend b b') ext) <->
                     checksum_Valid (bin_measure (mappend b' b)) (mappend (mappend b' b) ext). *)
  Variable cache : Cache.
  Context {cacheAddNat : CacheAdd cache nat}.

  Open Scope comp_scope.

  Definition format_checksum c := encode_word' checksum_sz c mempty.

  Definition composeChecksum
             (format1 : FormatM A B)
             (format2 : FormatM A B)
             (a : A) (ctx : _) :=
    `(p, ctx) <- format1 a ctx;
    `(q, ctx) <- format2 a (addE ctx checksum_sz);
    c <- { c : word checksum_sz | forall ext,
             checksum_Valid
               (bin_measure (mappend p (mappend (format_checksum c) q)))
               (mappend (mappend p (mappend (format_checksum c) q)) ext) };
    ret (mappend p (mappend (format_checksum c) q), ctx)%comp.

  Lemma composeChecksum_format_correct
        {P  : CacheDecode -> Prop}
        {P_inv : (CacheDecode -> Prop) -> Prop}
        (decodeChecksum := decode_unused_word (sz := checksum_sz))
        (P_inv_pf :
           cache_inv_Property P (fun P => P_inv P))
        (predicate : A -> Prop)
        (format1 format2 : A -> CacheFormat -> Comp (B * CacheFormat))
        (formatd_A_measure : B -> nat)
        (formatd_A_measure_OK :
           forall a ctx ctx' ctx'' b b' b'' ext,
             computes_to (format1 a ctx) (b, ctx')
             -> computes_to (format2 a (addE ctx' checksum_sz)) (b'', ctx'')
             -> predicate a
             -> bin_measure (mappend b (mappend (format_checksum b') b''))
                = formatd_A_measure (mappend (mappend b (mappend (format_checksum b') b'')) ext))
        (decodeA : B -> CacheDecode -> option (A * B * CacheDecode))
        (decodeA_pf :
           cache_inv_Property P P_inv
           -> CorrectDecoder
                monoid
                predicate
                predicate
                eq
                (format1 ++ format_unused_word checksum_sz ++ format2) decodeA P
                (format1 ++ format_unused_word checksum_sz ++ format2))
        (checksum_Valid_chk :
           forall data x x0 x1 x2 ext ext' env c,
             predicate data
             -> format1 data env ↝ (x, x0)
             -> format2 data (addE x0 checksum_sz) ↝ (x1, x2)
             -> checksum_Valid (bin_measure (mappend x (mappend (format_checksum c) x1))) (mappend (mappend x (mappend (format_checksum c) x1)) ext)
             -> checksum_Valid (bin_measure (mappend x (mappend (format_checksum c) x1))) (mappend (mappend x (mappend (format_checksum c) x1)) ext'))
        (*checksum_Valid_chk :
           forall env xenv' data ext c0 c1 x x0 x1 x2 x3,
             checksum_Valid
               (bin_measure (mappend x (mappend x3 x1)))
               (mappend x (mappend x3 (mappend x1 ext)))
             -> predicate data
             -> format1 (project data) env ↝ (x, x0)
             -> predicate' (project data)
             -> decodeChecksum (mappend x3 (mappend x1 ext)) c0 = Some (tt, mappend x1 ext, c1)
             -> decode2 (project data) (mappend x1 ext) c1 = Some (data, ext, xenv')
             -> format2 data (snd (x, x0)) ↝ (x1, x2)
             -> mappend x (mappend x3 (mappend x1 ext)) = mappend x (mappend (calculate_checksum x x1) (mappend x1 ext))*)
    : CorrectDecoder
        monoid
        predicate
        predicate
        eq
        (composeChecksum format1 format2)
        (fun (bin : B) (env : CacheDecode) =>
           if checksum_Valid_dec (formatd_A_measure bin) bin then
             decodeA bin env
           else None)
        P
        (composeChecksum format1 format2).
  Proof.
    unfold cache_inv_Property in *; split.
    { intros env env' xenv data bin ext ? env_pm pred_pm com_pf.
      unfold composeChecksum, Bind2 in com_pf; computes_to_inv; destruct v;
        destruct v0.
      simpl in *.
      find_if_inside.
      - intuition.
        assert
          ((format1 ++ format_unused_word checksum_sz ++ format2) data env ∋ (bin, xenv)).
        { unfold sequence_Format, compose.
          computes_to_econstructor; try eassumption; simpl.
          eapply refineEquiv_bind2_bind.
          computes_to_econstructor.
          + instantiate (1 := (format_checksum v1, _)).
            apply unfold_computes.
            unfold format_unused_word, Compose_Format.
            eexists _; split; eauto;
              repeat computes_to_econstructor.
            apply unfold_computes; eauto.
          + eapply refineEquiv_bind2_bind.
            computes_to_econstructor; eauto.
            eapply refineEquiv_bind2_unit.
            simpl; rewrite com_pf'''; eauto. }
        eapply H in H0; destruct_ex; split_and.
        rewrite H1; eexists _, _; intuition eauto.
        subst.
        unfold composeChecksum; computes_to_econstructor; eauto.
        computes_to_econstructor; eauto.
        computes_to_econstructor; eauto.
        simpl; rewrite <- com_pf'''; computes_to_econstructor.
        eauto.
        eauto.
        eauto.
      - destruct n.
        injections.
        erewrite <- formatd_A_measure_OK; eauto.
    }
    { intros.
      find_if_inside; try discriminate.
      - eapply decodeA_pf in H1; intuition eauto.
        destruct H3 as [? [? [? [? [? ?] ] ] ] ].
        subst.
        unfold sequence_Format, compose, Bind2 in H3.
        computes_to_inv; subst.
        destruct v0; destruct v2; destruct v3; simpl in *.
        unfold composeChecksum, Bind2.
        unfold format_unused_word, Compose_Format in H3'.
        apply (proj1 (unfold_computes _ _)) in H3'; simpl in H3'.
        destruct_ex; intuition.
        unfold format_word in H7; computes_to_inv; injections.
        eexists _, _; split.
        computes_to_econstructor; eauto.
        computes_to_econstructor; simpl; eauto.
        computes_to_econstructor.
        computes_to_econstructor; simpl.
        intros; eapply checksum_Valid_chk.
        eassumption.
        eassumption.
        eassumption.
        erewrite formatd_A_measure_OK; eauto.
        computes_to_econstructor.
        intuition.
    }
  Qed.

  Lemma composeChecksum_format_correct'
        {P  : CacheDecode -> Prop}
        {P_inv P_invM : (CacheDecode -> Prop) -> Prop}
        (decodeChecksum := decode_unused_word (sz := checksum_sz))
        (P_inv_pf :
           cache_inv_Property P (fun P => P_inv P /\ P_invM P))
        (predicate : A -> Prop)
        (format1 format2 : FormatM A B)
        (subformat : FormatM A B)
        (decode_measure : DecodeM (nat * B) B)
        (view : A -> nat -> Prop)
        View_Predicate
        view_format
        (decode_measure_OK
           : cache_inv_Property P P_invM ->
             CorrectRefinedDecoder monoid predicate View_Predicate
                                   view
                                   (format1 ++ format_unused_word checksum_sz ++ format2)
                                   subformat
                                   decode_measure P
                                   view_format
             /\ Prefix_Format _ (format1 ++ format_unused_word checksum_sz ++ format2) subformat)
        (view_OK : forall s v,
            view s v ->
            forall env t1 t2 (w : word checksum_sz),
              predicate s
              -> format1 s env t1
              -> format2 s (addE (snd t1) checksum_sz) t2
              -> bin_measure (fst t1) + (bin_measure (format_checksum w)
                                         + bin_measure (fst t2)) = v)
        (decodeA : B -> CacheDecode -> option (A * B * CacheDecode))
        (decodeA_pf :
           cache_inv_Property P P_inv
           -> CorrectDecoder
                monoid
                predicate
                predicate
                eq
                (format1 ++ format_unused_word checksum_sz ++ format2) decodeA P
                (format1 ++ format_unused_word checksum_sz ++ format2))
        (checksum_Valid_chk :
           forall data x x0 x1 x2 ext ext' env c,
             predicate data
             -> format1 data env ↝ (x, x0)
             -> format2 data (addE x0 checksum_sz) ↝ (x1, x2)
             -> checksum_Valid (bin_measure (mappend x (mappend (format_checksum c) x1))) (mappend (mappend x (mappend (format_checksum c) x1)) ext)
             -> checksum_Valid (bin_measure (mappend x (mappend (format_checksum c) x1))) (mappend (mappend x (mappend (format_checksum c) x1)) ext'))
    : CorrectDecoder
        monoid
        predicate
        predicate
        eq
        (composeChecksum format1 format2)
        (fun (bin : B) (env : CacheDecode) =>
           `(n, _, _) <- decode_measure bin env;
           if checksum_Valid_dec n bin then
             decodeA bin env
           else None)
        P
        (composeChecksum format1 format2).
  Proof.
    unfold cache_inv_Property in *; split.
    { intros env env' xenv data bin ext ? env_pm pred_pm com_pf.
      specialize (decode_measure_OK (proj2 P_inv_pf)).
      assert
          ((format1 ++ format_unused_word checksum_sz ++ format2) data env ∋ (bin, xenv)).
        { unfold composeChecksum, sequence_Format, compose,
            Bind2 in *.
          computes_to_inv.
          repeat (computes_to_econstructor; try eassumption; simpl).
          eexists _; split; eauto;
            repeat computes_to_econstructor.
          apply unfold_computes; eauto.
          simpl; eauto.
          simpl.
          rewrite <- com_pf'''; computes_to_econstructor. }
        generalize H as H'; intro.
        unfold Prefix_Format in decode_measure_OK.
        eapply (proj2 decode_measure_OK) in H; eauto.
        destruct H as [? [? [? [bin_eq com_pf0] ] ] ].
        destruct_ex; split_and; subst.
        eapply H in com_pf0; eauto.
        destruct_ex; split_and.
        rewrite <- (mappend_assoc).
        setoid_rewrite H4 ; simpl.
        simpl in *.
        find_if_inside.
      - intuition.
        eapply H7 in H'; destruct_ex; split_and.
        rewrite mappend_assoc.
        rewrite H10; eexists _, _; intuition eauto.
        subst. eauto.
        eauto.
        eauto.
        eauto.
      - destruct n.
        unfold composeChecksum, sequence_Format, Bind2 in com_pf;
          computes_to_inv; destruct v; destruct v0; injections.
        simpl in com_pf''.
        rewrite unfold_computes in H5.
        rewrite mappend_assoc, <- H6.
        rewrite unfold_computes in com_pf, com_pf'.
        destruct H5.
        eapply view_OK in H3; eauto.
        simpl in H3.
        rewrite <- H3.
        repeat setoid_rewrite mappend_measure in com_pf''.
        eauto. }
    { intros.
      destruct (decode_measure t env') as [ [ [? ?] ?] | ] eqn: ? ;
        simpl in *; try discriminate.
      find_if_inside; try discriminate.
      - eapply decodeA_pf in H1; intuition eauto.
        destruct H5 as [? [? [? [? [? ?] ] ] ] ].
        rename H8 into H'.
        specialize (H' _ _ _ _ H5).
        subst.
        unfold sequence_Format, compose, Bind2 in H5.
        computes_to_inv; subst.
        destruct v0; destruct v2; destruct v3; simpl in *.
        unfold composeChecksum, Bind2.
        unfold format_unused_word, Compose_Format in H5'.
        apply (proj1 (unfold_computes _ _)) in H5'; simpl in H5'.
        destruct_ex; intuition.
        unfold format_word in H11; computes_to_inv; injections.
        eexists _, _; split.
        computes_to_econstructor; eauto.
        computes_to_econstructor; simpl; eauto.
        computes_to_econstructor.
        computes_to_econstructor; simpl.
        intros; eapply checksum_Valid_chk.
        eassumption.
        eassumption.
        eassumption.
        2: computes_to_econstructor.
        2: intuition.
        generalize Heqo as H'; intro.
        eapply H7 in Heqo; eauto.
        split_and; destruct_ex; split_and.
        rewrite unfold_computes in H14.
        fold (format_checksum x4) in H8.
        rewrite <- H8 in c0.
        2: rewrite <- H8; reflexivity.
        instantiate (1 := t').
        replace (bin_measure (mappend b0 (mappend (format_checksum x4) b2))) with n.
        eauto.
        rewrite <- H8 in H'.
        eapply H7 in H13.
        destruct_ex; split_and.
        rewrite H8 in H'.
        rewrite <- mappend_assoc in H'.
        rewrite H16 in H'.
        injections.
        destruct H18.
        rewrite unfold_computes in H5; rewrite unfold_computes in H5''0.
        eapply view_OK in H14; eauto.
        rewrite <- H14.
        simpl.
        repeat setoid_rewrite mappend_measure.
        reflexivity.
        auto.
        auto.
        auto. }
  Qed.

End Checksum.

Notation "format1 'ThenChecksum' c 'OfSize' sz 'ThenCarryOn' format2"
  := (composeChecksum _ _ _ _ sz c _ format1 format2) : format_scope.


Require Export Cfuzzi.Syntax.
Require Export Cfuzzi.BaseDefinitions.
Require Import Coq.Bool.Bool.
Require Import Coq.Lists.List.

Definition st_env := VarMap.t tau.

Inductive welltyped_val : val -> tau -> Prop :=
| welltyped_int : forall z, welltyped_val (v_int z) t_int
| welltyped_bool : forall b, welltyped_val (v_bool b) t_bool
| welltyped_arr_nil : forall t, welltyped_val (v_arr t v_nil) (t_arr t)
| welltyped_arr_cons : forall v vs t, welltyped_val v t
                                 -> welltyped_val (v_arr t vs) (t_arr t)
                                 -> welltyped_val (v_arr t (v_cons v vs)) (t_arr t)
| welltyped_bag_nil : forall t, welltyped_val (v_bag t v_nil) (t_bag t)
| welltyped_bag_cons : forall v vs t, welltyped_val v t
                                 -> welltyped_val (v_bag t vs) (t_bag t)
                                 -> welltyped_val (v_bag t (v_cons v vs)) (t_bag t).

Lemma welltyped_arr_elim:
  forall v t, welltyped_val v (t_arr t)
         -> exists vs, v = v_arr t vs.
Proof.
  intros v t Htyped.
  remember (t_arr t) as t'.
  generalize dependent t.
  induction Htyped;
    try (intros t0 contra; inversion contra).
  - exists v_nil; auto.
  - destruct (IHHtyped2 t0) as [vs' Hvs']; auto.
    subst.
    exists (v_cons v vs').
    inversion Hvs'; subst; auto.
Qed.

Lemma welltyped_bag_elim:
  forall v t, welltyped_val v (t_bag t)
         -> exists vs, v = v_bag t vs.
Proof.
  intros v t Htyped.
  remember (t_bag t) as t'.
  generalize dependent t.
  induction Htyped;
    try (intros t0 contra; inversion contra).
  - exists v_nil; auto.
  - destruct (IHHtyped2 t0) as [vs' Hvs']; auto.
    subst.
    exists (v_cons v vs').
    inversion Hvs'; subst; auto.
Qed.

Lemma tau_default_welltyped :
  forall t, welltyped_val (tau_default_val t) t.
Proof.
  destruct t; constructor.
Qed.

Hint Resolve tau_default_welltyped.

Lemma val_arr_index_nat_welltyped :
  forall t1 t2 vs idx v,
    welltyped_val (v_arr t1 vs) (t_arr t2)
    -> val_arr_index_nat vs idx = Some v
    -> welltyped_val v t2.
Proof.
  intros t1 t2 vs idx v Htyped.
  remember (v_arr t1 vs) as varr.
  remember (t_arr t2) as tarr.
  generalize dependent idx.
  generalize dependent t1.
  generalize dependent t2.
  generalize dependent v.
  generalize dependent vs.
  induction Htyped; try (solve [intros vs v t Harr contra; inversion contra]).
  - intros vs v t2 Hvarr t1 Htarr idx Hv.
    inversion Hvarr.
  - intros vs v t2 Hvarr t1 Htarr idx Hv.
    inversion Hvarr.
  - intros vs v t2 Hvarr t1 Htarr idx Hv.
    inversion Hvarr; inversion Htarr; subst; clear Hvarr; clear Htarr.
    unfold val_arr_index in Hv.
    simpl in Hv; inversion Hv.
  - intros vs' v' t2 Hvarr t1 Htarr idx Hv.
    inversion Hvarr; inversion Htarr; subst; clear Hvarr; clear Htarr.
    destruct idx as [|idx].
    + simpl in Hv; inversion Hv; subst; auto.
    + simpl in Hv; inversion Hv; subst; auto.
      apply IHHtyped2 with (vs0 := vs) (idx := idx) (t3 := t1); auto.
  - intros vs v t2 Hvarr t1 Htarr idx Hv.
    inversion Hvarr; inversion Htarr; subst; clear Hvarr; clear Htarr.
  - intros vs' v' t2 Hvarr t1 Htarr idx Hv.
    inversion Hvarr; inversion Htarr; subst; clear Hvarr; clear Htarr.
Qed.

Lemma val_arr_index_welltyped :
  forall t1 t2 vs idx v,
    welltyped_val (v_arr t1 vs) (t_arr t2)
    -> val_arr_index vs idx = Some v
    -> welltyped_val v t2.
Proof.
  intros t1 t2 vs idx v Htyped Hv.
  destruct idx eqn:Hidx.
  - simpl in Hv; inversion Hv; subst; clear Hv.
    eapply val_arr_index_nat_welltyped; eauto.
  - simpl in Hv; inversion Hv; subst; clear Hv.
    eapply val_arr_index_nat_welltyped; eauto.
  - simpl in Hv; inversion Hv.
Qed.

Lemma val_bag_index_nat_welltyped :
  forall t1 t2 vs idx v,
    welltyped_val (v_bag t1 vs) (t_bag t2)
    -> val_arr_index_nat vs idx = Some v
    -> welltyped_val v t2.
Proof.
  intros t1 t2 vs idx v Htyped.
  remember (v_bag t1 vs) as vbag.
  remember (t_bag t2) as tbag.
  generalize dependent idx.
  generalize dependent t1.
  generalize dependent t2.
  generalize dependent v.
  generalize dependent vs.
  induction Htyped; try (solve [intros vs v t Hbag contra; inversion contra]).
  - intros vs v t2 Hvbag t1 Htbag idx Hv.
    inversion Hvbag.
  - intros vs v t2 Hvbag t1 Htbag idx Hv.
    inversion Hvbag.
  - intros vs v t2 Hvbag t1 Htbag idx Hv.
    inversion Hvbag.
  - intros vs' v' t2 Hvbag t1 Htbag idx Hv.
    inversion Hvbag.
  - intros vs v t2 Hvbag t1 Htbag idx Hv.
    inversion Hvbag; inversion Htbag; subst; clear Hvbag; clear Htbag.
    unfold val_arr_index in Hv.
    simpl in Hv; inversion Hv.
  - intros vs' v' t2 Hvbag t1 Htbag idx Hv.
    inversion Hvbag; inversion Htbag; subst; clear Hvbag; clear Htbag.
    destruct idx as [|idx].
    + simpl in Hv; inversion Hv; subst; auto.
    + simpl in Hv; inversion Hv; subst; auto.
      apply IHHtyped2 with (vs0 := vs) (idx := idx) (t3 := t1); auto.
Qed.

Lemma val_bag_index_welltyped :
  forall t1 t2 vs idx v,
    welltyped_val (v_bag t1 vs) (t_bag t2)
    -> val_arr_index vs idx = Some v
    -> welltyped_val v t2.
Proof.
  intros t1 t2 vs idx v Htyped Hv.
  destruct idx eqn:Hidx.
  - simpl in Hv; inversion Hv; subst; clear Hv.
    eapply val_bag_index_nat_welltyped; eauto.
  - simpl in Hv; inversion Hv; subst; clear Hv.
    eapply val_bag_index_nat_welltyped; eauto.
  - simpl in Hv; inversion Hv.
Qed.

Lemma val_arr_update_nat_welltyped:
  forall t vs idx v vs',
    welltyped_val (v_arr t vs) (t_arr t)
    -> welltyped_val v t
    -> val_arr_update_nat vs idx v = Some vs'
    -> welltyped_val (v_arr t vs') (t_arr t).
Proof.
  intros t vs idx v vs' Htyped.
  remember (v_arr t vs) as varr.
  remember (t_arr t) as tarr.
  generalize dependent idx.
  generalize dependent v.
  generalize dependent vs.
  generalize dependent t.
  generalize dependent vs'.
  induction Htyped;
    try (solve [intros vs' t' Htarr vs Hvarr v idx; inversion Htarr; inversion Hvarr]).
  - intros vs' t' Htarr vs Hvarr v idx.
    intros Hvt Hupdate.
    inversion Htarr; subst; clear Htarr.
    inversion Hvarr; subst; clear Hvarr.
    simpl in Hupdate.
    destruct idx; inversion Hupdate.
  - intros vs' t' Htarr vs2 Hvarr v2 idx.
    intros Hvt Hupdate.
    inversion Htarr; subst; clear Htarr.
    inversion Hvarr; subst; clear Hvarr.
    simpl in Hupdate.
    destruct idx.
    + inversion Hupdate; subst; clear Hupdate.
      constructor; auto.
    + destruct (val_arr_update_nat vs idx v2)
        as [tail|] eqn:Htail; inversion Hupdate; subst; clear Hupdate.
      constructor; auto.
      apply IHHtyped2 with (vs0 := vs) (v := v2) (idx := idx); auto.
  - intros vs' t0 Htarr; inversion Htarr.
Qed.

Lemma val_arr_update_welltyped:
  forall t vs idx v vs',
    welltyped_val (v_arr t vs) (t_arr t)
    -> welltyped_val v t
    -> val_arr_update vs idx v = Some vs'
    -> welltyped_val (v_arr t vs') (t_arr t).
Proof.
  intros t vs idx v vs' Htyped Hvt Harr.
  destruct idx eqn:Hidx;
    try (solve [eapply val_arr_update_nat_welltyped; eauto;
                unfold val_arr_update in *;
                destruct vs; auto; apply Harr]).
  - destruct vs; simpl in Harr; inversion Harr.
Qed.

Lemma val_bag_update_nat_welltyped:
  forall t vs idx v vs',
    welltyped_val (v_bag t vs) (t_bag t)
    -> welltyped_val v t
    -> val_arr_update_nat vs idx v = Some vs'
    -> welltyped_val (v_bag t vs') (t_bag t).
Proof.
  intros t vs idx v vs' Htyped.
  remember (v_bag t vs) as vbag.
  remember (t_bag t) as tbag.
  generalize dependent idx.
  generalize dependent v.
  generalize dependent vs.
  generalize dependent t.
  generalize dependent vs'.
  induction Htyped;
    try (solve [intros vs' t' Htbag vs Hvbag v idx; inversion Htbag; inversion Hvbag]).
  - intros vs' t0 Htbag; inversion Htbag.
  - intros vs' t' Htbag vs Hvbag v idx.
    intros Hvt Hupdate.
    inversion Htbag; subst; clear Htbag.
    inversion Hvbag; subst; clear Hvbag.
    simpl in Hupdate.
    destruct idx; inversion Hupdate.
  - intros vs' t' Htbag vs2 Hvbag v2 idx.
    intros Hvt Hupdate.
    inversion Htbag; subst; clear Htbag.
    inversion Hvbag; subst; clear Hvbag.
    simpl in Hupdate.
    destruct idx.
    + inversion Hupdate; subst; clear Hupdate.
      constructor; auto.
    + destruct (val_arr_update_nat vs idx v2) eqn:Htail; inversion Hupdate; subst; clear Hupdate.
      constructor; auto.
      apply IHHtyped2 with (vs0 := vs) (v := v2) (idx := idx); auto.
Qed.

Lemma val_bag_update_welltyped:
  forall t vs idx v vs',
    welltyped_val (v_bag t vs) (t_bag t)
    -> welltyped_val v t
    -> val_arr_update vs idx v = Some vs'
    -> welltyped_val (v_bag t vs') (t_bag t).
Proof.
  intros t vs idx v vs' Htyped Hvt Hbag.
  destruct idx eqn:Hidx;
    try (solve [eapply val_bag_update_nat_welltyped; eauto;
                unfold val_arr_update in *;
                destruct vs; auto; apply Hbag]).
  - destruct vs; simpl in Hbag; inversion Hbag.
Qed.

Lemma val_arr_from_repeat_tau_default_welltyped:
  forall t n,
    welltyped_val (v_arr t (val_arr_from_list (repeat (tau_default_val t) n))) (t_arr t).
Proof.
  intros t n.
  induction n.
  - simpl. constructor.
  - simpl. constructor; auto.
Qed.

Lemma val_bag_from_repeat_tau_default_welltyped:
  forall t n,
    welltyped_val (v_bag t (val_arr_from_list (repeat (tau_default_val t) n))) (t_bag t).
Proof.
  intros t n.
  induction n.
  - simpl. constructor.
  - simpl. constructor; auto.
Qed.

Lemma val_arr_update_length_nat_welltyped:
  forall t vs n,
    welltyped_val (v_arr t vs) (t_arr t)
    -> welltyped_val (v_arr t (val_arr_update_length_nat t vs n)) (t_arr t).
Proof.
  intros t vs n Htyped.
  remember (v_arr t vs) as Hvarr.
  remember (t_arr t) as Htarr.
  generalize dependent vs.
  generalize dependent t.
  generalize dependent n.
  induction Htyped;
    try (solve [intros n' t' Htarr vs' Hvarr; inversion Htarr; inversion Hvarr]).
  - intros n t' Htarr vs Hvarr.
    inversion Htarr; subst; clear Htarr.
    inversion Hvarr; subst; clear Hvarr.
    destruct n.
    + constructor; auto.
    + simpl. constructor; auto.
      apply val_arr_from_repeat_tau_default_welltyped.
  - intros n t' Htarr vs' Hvarr.
    inversion Htarr; subst; clear Htarr.
    inversion Hvarr; subst; clear Hvarr.
    destruct n.
    + constructor; auto.
    + simpl. constructor; auto.
Qed.

Lemma val_arr_update_length_welltyped:
  forall t vs vs' n,
    welltyped_val (v_arr t vs) (t_arr t)
    -> val_arr_update_length t vs n = Some vs'
    -> welltyped_val (v_arr t vs') (t_arr t).
Proof.
  intros t vs vs' n Htyped Hupdate.
  destruct n eqn:Hn.
  - simpl in Hupdate; inversion Hupdate; subst; clear Hupdate.
    destruct vs; simpl; auto.
    constructor.
  - simpl in Hupdate; inversion Hupdate; subst; clear Hupdate.
    apply val_arr_update_length_nat_welltyped; auto.
  - simpl in Hupdate; inversion Hupdate.
Qed.

Lemma val_bag_update_length_nat_welltyped:
  forall t vs n,
    welltyped_val (v_bag t vs) (t_bag t)
    -> welltyped_val (v_bag t (val_arr_update_length_nat t vs n)) (t_bag t).
Proof.
  intros t vs n Htyped.
  remember (v_bag t vs) as Hvbag.
  remember (t_bag t) as Htbag.
  generalize dependent vs.
  generalize dependent t.
  generalize dependent n.
  induction Htyped;
    try (solve [intros n' t' Htbag vs' Hvbag; inversion Htbag; inversion Hvbag]).
  - intros n t' Htbag vs Hvbag.
    inversion Htbag; subst; clear Htbag.
    inversion Hvbag; subst; clear Hvbag.
    destruct n.
    + constructor; auto.
    + simpl. constructor; auto.
      apply val_bag_from_repeat_tau_default_welltyped.
  - intros n t' Htbag vs' Hvbag.
    inversion Htbag; subst; clear Htbag.
    inversion Hvbag; subst; clear Hvbag.
    destruct n.
    + constructor; auto.
    + simpl. constructor; auto.
Qed.

Lemma val_bag_update_length_welltyped:
  forall t vs vs' n,
    welltyped_val (v_bag t vs) (t_bag t)
    -> val_arr_update_length t vs n = Some vs'
    -> welltyped_val (v_bag t vs') (t_bag t).
Proof.
  intros t vs vs' n Htyped Hupdate.
  destruct n eqn:Hn.
  - simpl in Hupdate; inversion Hupdate; subst; clear Hupdate.
    destruct vs; simpl; auto.
    constructor.
  - simpl in Hupdate; inversion Hupdate; subst; clear Hupdate.
    apply val_bag_update_length_nat_welltyped; auto.
  - simpl in Hupdate; inversion Hupdate.
Qed.

Lemma welltyped_val_uniq : forall v t1 t2,
    welltyped_val v t1
    -> welltyped_val v t2
    -> t1 = t2.
Proof.
  intros v t1 t2 Ht1.
  generalize dependent t2.
  induction Ht1; try (solve [intros t2 Ht2; inversion Ht2; auto]).
Qed.

Inductive welltyped_expr : st_env -> expr -> tau -> Prop :=
| welltyped_lit : forall env z, welltyped_expr env (e_lit z) t_int
| welltyped_var : forall env x t, VarMap.MapsTo x t env -> welltyped_expr env (e_var x) t
| welltyped_add : forall env e1 e2, welltyped_expr env e1 t_int
                               -> welltyped_expr env e2 t_int
                               -> welltyped_expr env (e_add e1 e2) t_int
| welltyped_minus : forall env e1 e2, welltyped_expr env e1 t_int
                                 -> welltyped_expr env e2 t_int
                                 -> welltyped_expr env (e_minus e1 e2) t_int
| welltyped_mult : forall env e1 e2, welltyped_expr env e1 t_int
                                -> welltyped_expr env e2 t_int
                                -> welltyped_expr env (e_mult e1 e2) t_int
| welltyped_div : forall env e1 e2, welltyped_expr env e1 t_int
                               -> welltyped_expr env e2 t_int
                               -> welltyped_expr env (e_div e1 e2) t_int
| welltyped_lt : forall env e1 e2, welltyped_expr env e1 t_int
                              -> welltyped_expr env e2 t_int
                              -> welltyped_expr env (e_lt e1 e2) t_bool
| welltyped_eq : forall env e1 e2 t, welltyped_expr env e1 t
                                -> welltyped_expr env e2 t
                                -> t = t_int \/ t = t_bool
                                -> welltyped_expr env (e_eq e1 e2) t_bool
| welltyped_and : forall env e1 e2, welltyped_expr env e1 t_bool
                               -> welltyped_expr env e2 t_bool
                               -> welltyped_expr env (e_and e1 e2) t_bool
| welltyped_or : forall env e1 e2, welltyped_expr env e1 t_bool
                              -> welltyped_expr env e2 t_bool
                              -> welltyped_expr env (e_or e1 e2) t_bool
| welltyped_arr_index : forall env e1 e2 t, welltyped_expr env e1 (t_arr t)
                                            -> welltyped_expr env e2 t_int
                                            -> welltyped_expr env (e_index e1 e2) t
| welltyped_bag_index : forall env e1 e2 t, welltyped_expr env e1 (t_bag t)
                                            -> welltyped_expr env e2 t_int
                                            -> welltyped_expr env (e_index e1 e2) t
| welltyped_arr_length : forall env e t, welltyped_expr env e (t_arr t)
                                         -> welltyped_expr env (e_length e) t_int
| welltyped_bag_length : forall env e t, welltyped_expr env e (t_bag t)
                                         -> welltyped_expr env (e_length e) t_int
.

Hint Constructors welltyped_expr.

Inductive welltyped : st_env -> cmd -> Prop :=
| welltyped_skip : forall env, welltyped env i_skip
| welltyped_assign : forall env x rhs t,
    VarMap.MapsTo x t env
    -> welltyped_expr env rhs t
    -> welltyped env (i_base_instr (bi_assign x rhs))
| welltyped_laplace : forall env x w center,
    VarMap.MapsTo x t_int env
    -> welltyped_expr env center t_int
    -> welltyped env (i_base_instr (bi_laplace x w center))
| welltyped_arr_index_assign : forall env x eidx erhs t,
    VarMap.MapsTo x (t_arr t) env
    -> welltyped_expr env eidx t_int
    -> welltyped_expr env erhs t
    -> welltyped env (i_base_instr (bi_index_assign x eidx erhs))
| welltyped_bag_index_assign : forall env x eidx erhs t,
    VarMap.MapsTo x (t_bag t) env
    -> welltyped_expr env eidx t_int
    -> welltyped_expr env erhs t
    -> welltyped env (i_base_instr (bi_index_assign x eidx erhs))
| welltyped_arr_length_assign : forall env x erhs t,
    VarMap.MapsTo x (t_arr t) env
    -> welltyped_expr env erhs t_int
    -> welltyped env (i_base_instr (bi_length_assign x erhs))
| welltyped_bag_length_assign : forall env x erhs t,
    VarMap.MapsTo x (t_bag t) env
    -> welltyped_expr env erhs t_int
    -> welltyped env (i_base_instr (bi_length_assign x erhs))
| welltyped_cond : forall env e c1 c2,
    welltyped_expr env e t_bool
    -> welltyped env c1
    -> welltyped env c2
    -> welltyped env (i_cond e c1 c2)
| welltyped_while : forall env e c,
    welltyped_expr env e t_bool
    -> welltyped env c
    -> welltyped env (i_while e c)
| welltyped_seq : forall env c1 c2,
    welltyped env c1
    -> welltyped env c2
    -> welltyped env (i_seq c1 c2).

Hint Constructors welltyped.

Fixpoint welltyped_expr_compute
         (env : st_env) (e : expr) : option tau :=
  match e with
  | e_lit _ => Some t_int
  | e_var x => VarMap.find x env
  | e_add e1 e2 =>
    match welltyped_expr_compute env e1,
          welltyped_expr_compute env e2
    with
    | Some t_int, Some t_int => Some t_int
    | _, _ => None
    end
  | e_minus e1 e2 =>
    match welltyped_expr_compute env e1,
          welltyped_expr_compute env e2
    with
    | Some t_int, Some t_int => Some t_int
    | _, _ => None
    end
  | e_mult e1 e2 =>
    match welltyped_expr_compute env e1,
          welltyped_expr_compute env e2
    with
    | Some t_int, Some t_int => Some t_int
    | _, _ => None
    end
  | e_div e1 e2 =>
    match welltyped_expr_compute env e1,
          welltyped_expr_compute env e2
    with
    | Some t_int, Some t_int => Some t_int
    | _, _ => None
    end
  | e_lt e1 e2 =>
    match welltyped_expr_compute env e1,
          welltyped_expr_compute env e2
    with
    | Some t_int, Some t_int => Some t_bool
    | _, _ => None
    end
  | e_eq e1 e2 =>
    match welltyped_expr_compute env e1,
          welltyped_expr_compute env e2
    with
    | Some t_int, Some t_int => Some t_bool
    | Some t_bool, Some t_bool => Some t_bool
    | _, _ => None
    end
  | e_and e1 e2 =>
    match welltyped_expr_compute env e1,
          welltyped_expr_compute env e2
    with
    | Some t_bool, Some t_bool => Some t_bool
    | _, _ => None
    end
  | e_or e1 e2 =>
    match welltyped_expr_compute env e1,
          welltyped_expr_compute env e2
    with
    | Some t_bool, Some t_bool => Some t_bool
    | _, _ => None
    end
  | e_index e1 e2 =>
    match welltyped_expr_compute env e1,
          welltyped_expr_compute env e2
    with
    | Some (t_arr t), Some t_int => Some t
    | Some (t_bag t), Some t_int => Some t
    | _, _ => None
    end
  | e_length e =>
    match welltyped_expr_compute env e with
    | Some (t_arr t) => Some t_int
    | Some (t_bag t) => Some t_int
    | _ => None
    end
  end.

Definition welltyped_base_instr_compute (env : st_env) (bi : base_instr) : bool :=
  match bi with
  | bi_assign x e => match VarMap.find x env, welltyped_expr_compute env e with
                    | Some tx, Some te => if tau_eqdec tx te then true else false
                    | _, _ => false
                    end
  | bi_laplace x w e => match VarMap.find x env, welltyped_expr_compute env e with
                       | Some t_int, Some t_int => true
                       | _, _ => false
                        end
  | bi_index_assign x eidx erhs => match VarMap.find x env,
                                         welltyped_expr_compute env eidx,
                                         welltyped_expr_compute env erhs
                                   with
                                   | Some (t_arr t), Some t_int, Some t'
                                     => if tau_eqdec t t'
                                        then true
                                        else false
                                   | Some (t_bag t), Some t_int, Some t'
                                     => if tau_eqdec t t'
                                        then true
                                        else false
                                   | _, _, _ => false
                                   end
  | bi_length_assign x erhs => match VarMap.find x env,
                                     welltyped_expr_compute env erhs
                               with
                               | Some (t_arr t), Some t_int
                                 => true
                               | Some (t_bag t), Some t_int
                                 => true
                               | _, _ => false
                               end
  end.

Fixpoint welltyped_cmd_compute (env : st_env) (c : cmd) {struct c} : bool :=
  match c with
  | i_skip => true
  | i_base_instr bi => welltyped_base_instr_compute env bi
  | i_cond e c1 c2 => match welltyped_expr_compute env e with
                     | Some t_bool => welltyped_cmd_compute env c1 && welltyped_cmd_compute env c2
                     | _ => false
                     end
  | i_while e c => match welltyped_expr_compute env e with
                  | Some t_bool => welltyped_cmd_compute env c
                  | _ => false
                  end
  | i_seq c1 c2 => welltyped_cmd_compute env c1 && welltyped_cmd_compute env c2
  end.

Lemma welltyped_expr_if_computed : forall env e t,
    welltyped_expr_compute env e = Some t -> welltyped_expr env e t.
Proof.
  induction e.
  - simpl; intros t H; inversion H; auto.
  - simpl; intros t H; apply VarMap.find_2 in H; auto.
  - intros t Ht;
    destruct (welltyped_expr_compute env e1) eqn:He1;
      destruct (welltyped_expr_compute env e2) eqn:He2;
      simpl in Ht;
      try (rewrite He1 in Ht; try rewrite He2 in Ht);
      inversion Ht as [Ht']; subst; clear Ht;
        [destruct t0; destruct t1; inversion Ht'; subst; clear Ht';
         [constructor; auto]
        | destruct t0; inversion Ht'].
  - intros t Ht;
    destruct (welltyped_expr_compute env e1) eqn:He1;
      destruct (welltyped_expr_compute env e2) eqn:He2;
      simpl in Ht;
      try (rewrite He1 in Ht; try rewrite He2 in Ht);
      inversion Ht as [Ht']; subst; clear Ht;
        [destruct t0; destruct t1; inversion Ht'; subst; clear Ht';
         [constructor; auto]
        | destruct t0; inversion Ht'].
  - intros t Ht;
    destruct (welltyped_expr_compute env e1) eqn:He1;
      destruct (welltyped_expr_compute env e2) eqn:He2;
      simpl in Ht;
      try (rewrite He1 in Ht; try rewrite He2 in Ht);
      inversion Ht as [Ht']; subst; clear Ht;
        [destruct t0; destruct t1; inversion Ht'; subst; clear Ht';
         [constructor; auto]
        | destruct t0; inversion Ht'].
  - intros t Ht;
    destruct (welltyped_expr_compute env e1) eqn:He1;
      destruct (welltyped_expr_compute env e2) eqn:He2;
      simpl in Ht;
      try (rewrite He1 in Ht; try rewrite He2 in Ht);
      inversion Ht as [Ht']; subst; clear Ht;
        [destruct t0; destruct t1; inversion Ht'; subst; clear Ht';
         [constructor; auto]
        | destruct t0; inversion Ht'].
  - intros t Ht;
    destruct (welltyped_expr_compute env e1) eqn:He1;
      destruct (welltyped_expr_compute env e2) eqn:He2;
      simpl in Ht;
      try (rewrite He1 in Ht; try rewrite He2 in Ht);
      inversion Ht as [Ht']; subst; clear Ht;
        [destruct t0; destruct t1; inversion Ht'; subst; clear Ht';
         [constructor; auto]
        | destruct t0; inversion Ht'].
  - intros t Ht;
    destruct (welltyped_expr_compute env e1) eqn:He1;
      destruct (welltyped_expr_compute env e2) eqn:He2;
      simpl in Ht;
      try (rewrite He1 in Ht; try rewrite He2 in Ht);
      inversion Ht as [Ht']; subst; clear Ht.
    + destruct t0; destruct t1; inversion Ht'; subst; clear Ht'.
      eapply welltyped_eq; eauto.
      eapply welltyped_eq; eauto.
    + destruct t0; inversion Ht'; subst.
  - intros t Ht;
    destruct (welltyped_expr_compute env e1) eqn:He1;
      destruct (welltyped_expr_compute env e2) eqn:He2;
      simpl in Ht;
      try (rewrite He1 in Ht; try rewrite He2 in Ht);
      inversion Ht as [Ht']; subst; clear Ht.
    + destruct t0; destruct t1; inversion Ht'; subst; clear Ht'.
      constructor; auto.
    + destruct t0; inversion Ht'; subst.
  - intros t Ht;
    destruct (welltyped_expr_compute env e1) eqn:He1;
      destruct (welltyped_expr_compute env e2) eqn:He2;
      simpl in Ht;
      try (rewrite He1 in Ht; try rewrite He2 in Ht);
      inversion Ht as [Ht']; subst; clear Ht.
    + destruct t0; destruct t1; inversion Ht'; subst; clear Ht'.
      constructor; auto.
    + destruct t0; inversion Ht'; subst.
  - intros t Ht.
    destruct (welltyped_expr_compute env e1) eqn:He1;
      destruct (welltyped_expr_compute env e2) eqn:He2;
      simpl in Ht;
      try (rewrite He1 in Ht; rewrite He2 in Ht; inversion Ht as [Ht']; subst; clear Ht).
    + destruct t0;
        destruct t1; try inversion Ht'; subst; clear Ht'.
      apply welltyped_arr_index; auto.
      apply welltyped_bag_index; auto.
    + destruct t0; try inversion Ht'; subst; clear Ht'.
    + rewrite He1 in Ht; inversion Ht.
    + rewrite He1 in Ht; inversion Ht.
  - intros t Ht.
    simpl in Ht.
    destruct (welltyped_expr_compute env e) eqn:He.
    destruct t0; try inversion Ht; subst; clear Ht.
    apply welltyped_arr_length with (t := t0); auto.
    apply welltyped_bag_length with (t := t0); auto.
    inversion Ht.
Qed.

Lemma welltyped_expr_computed_if_prop : forall env e t,
    welltyped_expr env e t -> welltyped_expr_compute env e = Some t.
Proof.
  intros env e t H.
  induction H.
  - auto.
  - simpl; apply VarMap.find_1; auto.
  - simpl; rewrite IHwelltyped_expr1; rewrite IHwelltyped_expr2; auto.
  - simpl; rewrite IHwelltyped_expr1; rewrite IHwelltyped_expr2; auto.
  - simpl; rewrite IHwelltyped_expr1; rewrite IHwelltyped_expr2; auto.
  - simpl; rewrite IHwelltyped_expr1; rewrite IHwelltyped_expr2; auto.
  - simpl; rewrite IHwelltyped_expr1; rewrite IHwelltyped_expr2; auto.
  - destruct H1; subst; simpl; rewrite IHwelltyped_expr1; rewrite IHwelltyped_expr2; auto.
  - simpl; rewrite IHwelltyped_expr1; rewrite IHwelltyped_expr2; auto.
  - simpl; rewrite IHwelltyped_expr1; rewrite IHwelltyped_expr2; auto.
  - simpl; rewrite IHwelltyped_expr1; rewrite IHwelltyped_expr2; auto.
  - simpl; rewrite IHwelltyped_expr1; rewrite IHwelltyped_expr2; auto.
  - simpl; rewrite IHwelltyped_expr; auto.
  - simpl; rewrite IHwelltyped_expr; auto.
Qed.

Lemma welltyped_expr_iff : forall env e t,
    welltyped_expr env e t <-> welltyped_expr_compute env e = Some t.
Proof.
  split;
  [ apply welltyped_expr_computed_if_prop |
    apply welltyped_expr_if_computed
  ].
Qed.

Lemma welltyped_if_computed : forall env c,
    welltyped_cmd_compute env c = true -> welltyped env c.
Proof.
  intros env c.
  induction c.
  - simpl; auto.
  - destruct b eqn:Hbi.
    + intros H.
      inversion H; subst; clear H.
      destruct (VarMap.find v env) eqn:Htau_v.
      destruct (welltyped_expr_compute env e) eqn:Htau_e.
      destruct (tau_eqdec t t0).
      * subst; apply VarMap.find_2 in Htau_v.
        apply welltyped_expr_iff in Htau_e.
        apply welltyped_assign with (t := t0); auto.
      * inversion H1.
      * inversion H1.
      * inversion H1.
    + intros H.
      inversion H; subst; clear H.
      destruct (VarMap.find v env) eqn:Htau_v.
      destruct (welltyped_expr_compute env e) eqn:Htau_e.
      destruct t; destruct t0; try inversion H1; clear H1;
        apply VarMap.find_2 in Htau_v; apply welltyped_expr_iff in Htau_e.
      * constructor; auto.
      * destruct t; inversion H1.
      * inversion H1.
    + intros H.
      inversion H; subst; clear H.
      destruct (VarMap.find v env) eqn:Hv; try inversion Hv; subst; clear Hv.
      destruct t; try inversion H1; subst; clear H1.
      destruct (welltyped_expr_compute env e) eqn:He;
        destruct (welltyped_expr_compute env e0) eqn:He0;
        inversion H2; subst; clear H2.
      destruct t0; try inversion H1; subst; clear H1.
      destruct (tau_eqdec t t1); try inversion H2; subst; auto.
      apply welltyped_arr_index_assign with (t := t1); auto.
      apply VarMap.find_2 in H0; auto.
      apply welltyped_expr_iff in He; auto.
      apply welltyped_expr_iff in He0; auto.
      destruct t0; inversion H1.
      destruct (welltyped_expr_compute env e) as [et|] eqn:He.
      destruct et; inversion H2; subst; clear H2.
      destruct (welltyped_expr_compute env e0) as [et0|] eqn:He0.
      destruct (tau_eqdec t et0).
      apply welltyped_bag_index_assign with (t := t); auto.
      apply VarMap.find_2 in H0; auto.
      apply welltyped_expr_iff; auto.
      apply welltyped_expr_iff; auto.
      subst; auto.
      inversion H1.
      inversion H1.
      inversion H2.
      inversion H1.
    + simpl; intros H.
      destruct (VarMap.find v env) eqn:Hv; try inversion H; subst; clear H.
      destruct t; try inversion H1; subst; clear H1.
      * destruct (welltyped_expr_compute env e) eqn:Het; try inversion H0; subst; clear H0.
        destruct t0; try inversion H1; subst; clear H1.
        apply welltyped_arr_length_assign with (t := t); auto.
        apply VarMap.find_2; auto.
        apply welltyped_expr_iff; auto.
      * destruct (welltyped_expr_compute env e) eqn:Het; try inversion H0; subst; clear H0.
        destruct t0; try inversion H1; subst; clear H1.
        apply welltyped_bag_length_assign with (t := t); auto.
        apply VarMap.find_2; auto.
        apply welltyped_expr_iff; auto.
  - intros H.
    inversion H; clear H.
    destruct (welltyped_expr_compute env e) eqn:Htau_e.
    destruct t; try inversion H1.
    + apply andb_true_iff in H1; clear H0.
      destruct H1 as [Hc1 Hc2].
      constructor; auto.
      apply welltyped_expr_iff in Htau_e; auto.
    + inversion H1.
  - intros H.
    inversion H; clear H.
    destruct (welltyped_expr_compute env e) eqn:Htau_e.
    destruct t; try inversion H1.
    + apply welltyped_expr_iff in Htau_e.
      constructor; auto.
    + inversion H1.
  - intros H.
    inversion H; clear H.
    apply andb_true_iff in H1.
    destruct H1 as [Hc1 Hc2].
    constructor; auto.
Qed.

Lemma welltyped_computed_if_prop : forall env c,
    welltyped env c -> welltyped_cmd_compute env c = true.
Proof.
  intros env c H.
  induction H; auto.
  - simpl.
    apply welltyped_expr_iff in H0; rewrite H0.
    apply VarMap.find_1 in H; rewrite H.
    destruct (tau_eqdec t t); auto.
  - simpl.
    apply welltyped_expr_iff in H0; rewrite H0.
    apply VarMap.find_1 in H; rewrite H.
    reflexivity.
  - simpl.
    apply welltyped_expr_iff in H0; rewrite H0.
    apply welltyped_expr_iff in H1; rewrite H1.
    apply VarMap.find_1 in H; rewrite H.
    destruct (tau_eqdec t t); try reflexivity.
    exfalso; apply n; auto.
  - simpl.
    apply welltyped_expr_iff in H0; rewrite H0.
    apply welltyped_expr_iff in H1; rewrite H1.
    apply VarMap.find_1 in H; rewrite H.
    destruct (tau_eqdec t t); try reflexivity.
    exfalso; apply n; auto.
  - simpl.
    apply VarMap.find_1 in H; rewrite H.
    apply welltyped_expr_iff in H0; rewrite H0.
    auto.
  - simpl.
    apply VarMap.find_1 in H; rewrite H.
    apply welltyped_expr_iff in H0; rewrite H0.
    auto.
  - simpl.
    apply welltyped_expr_iff in H.
    rewrite IHwelltyped1; rewrite IHwelltyped2.
    rewrite H.
    auto.
  - simpl.
    apply welltyped_expr_iff in H.
    rewrite H; auto.
  - simpl.
    rewrite IHwelltyped1; rewrite IHwelltyped2; auto.
Qed.

Lemma welltyped_iff : forall env c,
    welltyped env c <-> welltyped_cmd_compute env c = true.
Proof.
  split;
  [ apply welltyped_computed_if_prop |
    apply welltyped_if_computed ].
Qed.

Lemma welltyped_expr_uniq : forall env e t1 t2,
    welltyped_expr env e t1
    -> welltyped_expr env e t2
    -> t1 = t2.
Proof.
  intros env e t1 t2.
  rewrite welltyped_expr_iff.
  rewrite welltyped_expr_iff.
  intros Ht1 Ht2.
  rewrite Ht1 in Ht2.
  inversion Ht2; auto.
Qed.

Lemma welltyped_expr_dec : forall env e t,
    {welltyped_expr env e t} + {~(welltyped_expr env e t)}.
Proof.
  intros env e t.
  destruct (welltyped_expr_compute env e) eqn:He.
  destruct (tau_eqdec t t0); subst.
  - apply welltyped_expr_iff in He; left; auto.
  - right; intros contra.
    apply welltyped_expr_iff in He.
    assert (t = t0). {
      eapply welltyped_expr_uniq; eauto.
    }
    apply n; auto.
  - right; intros contra.
    apply welltyped_expr_iff in contra.
    rewrite contra in He.
    inversion He.
Qed.

Lemma welltyped_cmd_dec : forall env c,
    {welltyped env c} + {~(welltyped env c)}.
Proof.
  intros env c.
  destruct (welltyped_cmd_compute env c) eqn:Htyped.
  - apply welltyped_iff in Htyped; left; auto.
  - right; intros contra.
    apply welltyped_iff in contra. rewrite Htyped in contra; inversion contra.
Defined.

Definition is_array (t : tau) :=
  match t with
  | t_arr _ => true
  | _ => false
  end.

Lemma is_array_prop: forall t,
    is_array t = true <-> exists t', t = t_arr t'.
Proof.
  destruct t.
  - split.
    + intros contra; inversion contra.
    + intros contra; destruct contra. inversion H.
  - split.
    + intros contra; inversion contra.
    + intros contra; destruct contra. inversion H.
  - split.
    + intros H. exists t; auto.
    + intros [t' Ht']. auto.
  - split.
    + intros contra; inversion contra.
    + intros contra; destruct contra. inversion H.
Qed.


(** * Well-founded relation on [reachable] *)
Require Import Fiat.Parsers.ContextFreeGrammar.Core Fiat.Parsers.Reachable.All.Reachable.
Require Import Fiat.Parsers.BaseTypes.

Section rel.
  Context {Char} {HSLM : StringLikeMin Char} {predata : @parser_computational_predataT Char} {G : grammar Char}.

  Section size.
    Context {ch : Char} {valid : nonterminals_listT}.
    Definition size_of_reachable_from_item'
               (size_of_reachable_from_productions : forall {pats}, reachable_from_productions G ch valid pats -> nat)
               {it} (p : reachable_from_item G ch valid it) : nat
      := match p with
           | ReachableTerminal _ _ => 0
           | ReachableNonTerminal _ _ p' => S (size_of_reachable_from_productions p')
         end.

    Fixpoint size_of_reachable_from_productions {pats} (p : reachable_from_productions G ch valid pats) : nat
      := match p with
           | ReachableHead _ _ p' => S (size_of_reachable_from_production p')
           | ReachableTail _ _ p' => S (size_of_reachable_from_productions p')
         end
    with size_of_reachable_from_production {pat} (p : reachable_from_production G ch valid pat) : nat
         := match p with
              | ReachableProductionHead _ _ p' => S (size_of_reachable_from_item' (@size_of_reachable_from_productions) p')
              | ReachableProductionTail _ _ p' => S (size_of_reachable_from_production p')
            end.

    Definition size_of_reachable_from_item
               {it} (p : reachable_from_item G ch valid it) : nat
      := @size_of_reachable_from_item' (@size_of_reachable_from_productions) it p.
  End size.
End rel.


From Coq Require Import Arith Psatz Bool String List Nat Program.Equality.

Local Open Scope string_scope.
Local Open Scope nat_scope.
Local Open Scope list_scope.

Require Import DanTrick.StackLanguage.

Ltac invs H :=
  inversion H; subst.

Ltac invc H :=
  invs H; clear H.

Lemma args_stack_sem_preserves_length :
  forall args fenv stk stk' vals,
    args_stack_sem args fenv stk (stk', vals) ->
    List.length args = List.length vals.
Proof.
  induction args; intros.
  - invc H. reflexivity.
  - invc H.
    eapply IHargs in H7.
    simpl. f_equal. assumption.
Qed.

Lemma skip_n_of_mutated_stack :
  forall k n c stk'0 stk',
    k <= n ->
    1 <= k ->
    k <= Datatypes.length stk'0 ->
    stack_mutated_at_index stk' k c stk'0 ->
    skipn n stk'0 = skipn n stk'.
Proof.
  intros k n c stk'0.
  revert k n c.
  induction stk'0; intros.
  - inversion H2.
  - inversion H2.
    + induction n.
      * simpl. subst. inversion H.
      * simpl. invs H2.
        -- reflexivity.
        -- inversion H11.
           inversion H4.
    + subst.
      assert (exists (k': nat), k = S (k')).
      {
        destruct k.
        inversion H5.
        exists k. reflexivity.
      }
      destruct H3. subst.
      assert (exists n', n = S n').
      {
        destruct n.
        inversion H.
        exists n.
        reflexivity.
      }
      destruct H3. subst.
      simpl.
      eapply IHstk'0.
      assert (x <= x0) by intuition.
      eassumption.
      intuition.
      rewrite H7 in H6.
      intuition.
      assert (S x - 1 = x) by intuition.
      rewrite H3 in H11.
      eassumption.
Qed.

Lemma same_after_popping_skipn :
  forall stk1 n stk3 stk',
    stk1 = skipn n stk3 ->
    same_after_popping stk' stk3 n ->
    stk1 = stk'.
Proof.
  intros stk1 n stk3. revert stk3 stk1. induction n; induction stk3; intros.
  - simpl in *.
    invc H0.
    reflexivity.
  - simpl in H. invc H0.
    reflexivity.
  - invc H0.
  - simpl in H.
    inversion H0.
    revert H. subst. intros H.
    eapply IHn.
    + eassumption.
    + eassumption.
Qed.

(* You pop the entire prepended list off, you end up with the other list *)
Lemma same_after_popping_length :
  forall stk stk' stk'' n,
    same_after_popping stk (stk' ++ stk'') n ->
    Datatypes.length stk' = n ->
    stk = stk''.
Proof.
  intros stk stk' stk'' n. revert stk stk' stk''.
  dependent induction n; intros.
  - invs H. rewrite length_zero_iff_nil in H0. subst. auto.
  - invs H. destruct stk'.
    + invs H0.
    + simpl in H1. invs H1. eapply IHn; eauto.
Qed.

Lemma same_after_popping_length1:
  forall stk stk' stk'' n,
    Datatypes.length stk' = n ->
    stk = stk'' ->
    same_after_popping stk (stk' ++ stk'') n.
Proof.
  intros stk stk' stk'' n. revert stk stk' stk''.
  induction n; intros.
  - subst. destruct stk'; [ | simpl in H; inversion H ].
    simpl. constructor. reflexivity.
  - destruct stk'; [ simpl in H; inversion H | ].
    simpl. constructor.
    apply IHn.
    + simpl in H. inversion H. reflexivity.
    + assumption.
Qed.


Require Import Shared.Base Ascii.
Require Export String.

Fixpoint to_string (l : list ascii) :=
  match l with
  | nil => EmptyString
  | x :: xs => String x (to_string xs)
  end.

Fixpoint to_list (s : string) :=
  match s with
  | EmptyString => nil
  | String x xs => x :: (to_list xs)
  end.

Definition rev_string str := (to_string (rev (to_list str))).

Fixpoint name_after_dot' (s : string) (r : string) :=
  match s with
  | EmptyString => r
  | String "#" xs => name_after_dot' xs xs (* see Coq_name in a section *)
  | String "." xs => name_after_dot' xs xs
  | String _ xs => name_after_dot' xs r
  end.

Definition name_after_dot s := name_after_dot' s s.