(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

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

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

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

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

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

*)

Require Export continuity.
Require Export stronger_continuity_defs1.
Require Export stronger_continuity_defs3.
Require Export List.
Require Export list.  (* WTF!! *)

Lemma cequiv_bound_nat_bound {o} :
  forall lib (a : get_patom_set o) (x e z : NVar) (k : nat) (f : @NTerm o),
    (forall t n,
       n < k
       -> computes_to_value lib t (mk_nat n)
       -> {j : nat & computes_to_value lib (mk_apply f t) (mk_nat j)})
    -> cequiv
         lib
         (bound_nat a x e z (bound x (mk_utoken a) (mk_nat k) f))
         (mk_lam x (mk_less (mk_var x) mk_zero (mk_vbot z)
                            (mk_less (mk_var x) (mk_nat k)
                                     (mk_apply f (mk_var x))
                                     (spexc a)))).
Proof.
  introv imp.

Abort.

Lemma cequiv_sp_bound_nat_c_bound_c {o} :
  forall lib v z (e n f : @CTerm o),
    cequivc
      lib
      (sp_bound_nat_c v z (bound_c e n f v))
      (bound2_c v z n f e).
Proof.
  introv.

  apply cequivc_lam; introv.
  allrw @mkcv_less_substc.
  allrw @mkcv_apply_substc.
  allrw @substc_mkcv_zero.
  allrw @mkc_var_substc.
  allrw @csubst_mk_cv.
  allrw @mkcv_vbot_substc.

  eapply cequivc_trans;
    [apply cequivc_mkc_less;
      [apply cequivc_refl
      |apply cequivc_refl
      |apply cequivc_refl
      |apply cequivc_apply_bound_c]
    |].
  rw @boundl_c_eq; auto.
Qed.

Lemma substc_mkcv_axiom {o} :
  forall v (t : @CTerm o),
    substc t v (mkcv_axiom v) = mkc_axiom.
Proof.
  introv; destruct_cterms.
  apply cterm_eq; simpl.
  unfsubst.
Qed.

Lemma spM_in_modulus_fun_type_u {o} :
  forall lib (F : @CTerm o),
    member lib F (mkc_fun nat2nat mkc_tnat)
    -> member lib (spM_c F) modulus_fun_type_u.
Proof.
  introv mF.

  unfold modulus_fun_type_u.
  apply equality_in_function2.
  fold (@modulus_fun_type_u o).
  dands; try (apply type_modulus_fun_type_u).
  introv e.
  rename a into n.
  rename a' into m.
  eapply alphaeqc_preserving_equality;[|apply alphaeqc_sym;apply substc_mkcv_fun].
  allrw @csubst_mk_cv.
  apply equality_in_fun.
  dands.

  - eapply type_respects_alphaeqc;[apply alphaeqc_sym;apply substc_mkcv_fun|].
    allrw @mkcv_tnat_substc.
    apply type_mkc_fun.
    dands.
    + eapply type_respects_alphaeqc;[apply alphaeqc_sym;apply mkcv_natk_substc|].
      rw @mkc_var_substc.
      apply equality_in_tnat in e.
      unfold equality_of_nat in e; exrepnd; spcast.
      apply type_mkc_natk.
      allrw @mkc_nat_eq.
      exists (Z.of_nat k); spcast; auto.
    + introv inh.
      apply type_tnat.

  - introv inh.
      apply tequality_bunion; dands.
      * apply type_tnat.
      * apply type_mkc_unit.

  - introv e1.
    allrw <- @mkc_apply2_eq.
    rename a into f.
    rename a' into g.
    eapply alphaeqc_preserving_equality in e1;[|apply substc_mkcv_fun].
    eapply alphaeqc_preserving_equality in e1;
      [|apply alphaeqc_mkc_fun;[apply mkcv_natk_substc|apply alphaeqc_refl] ].
    allrw @mkcv_tnat_substc.
    allrw @mkc_var_substc.

    apply equality_in_tnat in e.
    unfold equality_of_nat in e; exrepnd; spcast.

    (* let's get rid of [n] and [m] now *)
    eapply cequivc_preserving_equality in e1;
      [|apply cequivc_mkc_fun;[|apply cequivc_refl];
        apply cequivc_mkc_natk;
        apply computes_to_valc_implies_cequivc; exact e2].

    fold (@natk2nat o (mkc_nat k)) in e1.

    eapply equality_respects_cequivc_left;
      [apply implies_cequivc_apply2;[apply cequivc_refl|idtac|apply cequivc_refl];
       apply cequivc_sym; apply computes_to_valc_implies_cequivc; exact e2|].

    eapply equality_respects_cequivc_right;
      [apply implies_cequivc_apply2;[apply cequivc_refl|idtac|apply cequivc_refl];
       apply cequivc_sym; apply computes_to_valc_implies_cequivc; exact e0|].

    clear dependent n.
    clear dependent m.

    (* let's beta-reduce *)
    eapply equality_respects_cequivc_left;
      [apply cequivc_sym; apply cequivc_apply2_spM_c|].
    eapply equality_respects_cequivc_right;
      [apply cequivc_sym; apply cequivc_apply2_spM_c|].

    (* now let's apply bound to [f] and [g] *)
    pose proof (equality_in_natk2nat_implies_equality_bound lib f g k e1) as h.
    allrw @test_c_eq.

    destruct (fresh_atom o (getc_utokens F ++ getc_utokens f ++ getc_utokens g)) as [a nia].
    allrw in_app_iff; allrw not_over_or; repnd.

    (* let's get rid of fresh in the conclusion *)
    assert (equality
              lib
              (substc (mkc_utoken a) nvare (test_try2_cv F nvarc nvarx nvarz nvare (mkc_nat k) f))
              (substc (mkc_utoken a) nvare (test_try2_cv F nvarc nvarx nvarz nvare (mkc_nat k) g))
              (mkc_bunion mkc_tnat mkc_unit)) as equ;
      [|pose proof (cequivc_fresh_subst2 lib nvare (test_try2_cv F nvarc nvarx nvarz nvare (mkc_nat k) f) a) as h1;
         repeat (autodimp h1 hyp);
         [ destruct_cterms; allsimpl;
           allunfold @getcv_utokens; allunfold @getc_utokens; allsimpl; allrw app_nil_r;
           allrw in_app_iff; tcsp
         | apply equality_refl in equ; apply member_bunion_nat_unit_implies_cis_spcan_not_atom; auto
         |];
         pose proof (cequivc_fresh_subst2 lib nvare (test_try2_cv F nvarc nvarx nvarz nvare (mkc_nat k) g) a) as h2;
         repeat (autodimp h2 hyp);
         [ destruct_cterms; allsimpl;
           allunfold @getcv_utokens; allunfold @getc_utokens; allsimpl; allrw app_nil_r;
           allrw in_app_iff; tcsp
         | apply equality_sym in equ; apply equality_refl in equ; apply member_bunion_nat_unit_implies_cis_spcan_not_atom; auto
         |];
         spcast;
         eapply equality_respects_cequivc_left;[apply cequivc_sym;exact h1|];
         eapply equality_respects_cequivc_right;[apply cequivc_sym;exact h2|];
         complete auto
      ].

    repeat (rw @substc_test_try2_cv).

    pose proof (h a nvarx) as q.
    clear h.

    pose proof (apply_nat2natE_aux2
                  lib F
                  (bound_c (mkc_utoken a) (mkc_nat k) f nvarx)
                  (bound_c (mkc_utoken a) (mkc_nat k) g nvarx)
                  a nvarx nvarz) as ee.
    repeat (autodimp ee hyp); try (complete (intro xx; ginv));[].
    clear q.

    eapply equality_respects_cequivc_left in ee;
      [|apply implies_cequivc_apply;
         [apply cequivc_refl
         |apply cequiv_sp_bound_nat_c_bound_c]
      ].

    eapply equality_respects_cequivc_right in ee;
      [|apply implies_cequivc_apply;
         [apply cequivc_refl
         |apply cequiv_sp_bound_nat_c_bound_c]
      ].

    apply equality_in_natE_implies in ee; repndors.

    { unfold equality_of_nat_tt in ee; exrepnd.
      eapply equality_respects_cequivc_left;
        [apply cequivc_sym;
          apply computes_to_valc_implies_cequivc;
          eapply computes_to_valc_mkc_try;
          [exact ee1|apply computes_to_pkc_refl;apply mkc_utoken_eq_pk2termc]
        |].
      eapply equality_respects_cequivc_right;
        [apply cequivc_sym;
          apply computes_to_valc_implies_cequivc;
          eapply computes_to_valc_mkc_try;
          [exact ee0|apply computes_to_pkc_refl;apply mkc_utoken_eq_pk2termc]
        |].
      apply equality_in_disjoint_bunion; eauto 3 with slow.
      dands; eauto 3 with slow. }

    { repnd.
      eapply equality_respects_cequivc_left;
        [apply cequivc_sym;
          apply simpl_cequivc_mkc_try;
          [exact ee0|apply cequivc_refl]
        |].
      eapply equality_respects_cequivc_right;
        [apply cequivc_sym;
          apply simpl_cequivc_mkc_try;
          [exact ee|apply cequivc_refl]
        |].

      eapply equality_respects_cequivc_left;
        [apply cequivc_sym;
          apply reduces_toc_implies_cequivc;
          apply reduces_toc_mkc_try_exc
        |].
      eapply equality_respects_cequivc_right;
        [apply cequivc_sym;
          apply reduces_toc_implies_cequivc;
          apply reduces_toc_mkc_try_exc
        |].

      allrw @substc_mkcv_axiom.
      apply equality_in_disjoint_bunion; eauto 3 with slow.
      dands; eauto 3 with slow.
      right.
      apply equality_in_unit; dands; spcast; apply computes_to_valc_refl; eauto 3 with slow. }
Qed.

Definition get_ints_from_computes_to_value {o}
           (lib : @library o)
           (t u : @NTerm o)
           (comp : computes_to_value lib t u) : list Z :=
  match comp with
    | (c,_) => get_ints_from_computation lib t u c
  end.

Definition get_ints_from_computes_to_valc {o}
           (lib : @library o)
           (t u : @CTerm o)
           (comp : computes_to_valc lib t u) : list Z :=
  get_ints_from_computes_to_value lib (get_cterm t) (get_cterm u) comp.

Lemma cequivc_nat {o} :
  forall lib (t t' : @CTerm o) (n : nat),
    computes_to_valc lib t (mkc_nat n)
    -> cequivc lib t t'
    -> computes_to_valc lib t' (mkc_nat n).
Proof.
  introv comp ceq; destruct_cterms;
  allunfold @computes_to_valc; allunfold @cequivc; allsimpl.
  eapply cequiv_nat; eauto.
Qed.

Definition force_nat {o} (arg : @NTerm o) x z (f : @NTerm o) :=
  mk_cbv arg x (mk_less (mk_var x)
                        mk_zero
                        (mk_vbot z)
                        (mk_apply f (mk_var x))).

Definition force_nat_c {o} (arg : @CTerm o) x z (f : @CTerm o) : CTerm :=
  mkc_cbv
    arg
    x
    (mkcv_less
       [x]
       (mkc_var x)
       (mkcv_zero [x])
       (mkcv_vbot [x] z)
       (mkcv_apply [x] (mk_cv [x] f) (mkc_var x))).

Lemma get_cterm_force_nat_c {o} :
  forall (arg : @CTerm o) x z f,
    get_cterm (force_nat_c arg x z f)
    = force_nat (get_cterm arg) x z (get_cterm f).
Proof.
  introv; destruct_cterms; simpl; auto.
Qed.

Definition lam_force_nat_c {o} x z (f : @CTerm o) : CTerm :=
  mkc_lam
    x
    (mkcv_cbv
       [x]
       (mkc_var x)
       x
       (mkcv_dup1
          x
          (mkcv_less
             [x]
             (mkc_var x)
             (mkcv_zero [x])
             (mkcv_vbot [x] z)
             (mkcv_apply [x] (mk_cv [x] f) (mkc_var x))))).

Lemma cequivc_mkc_apply_lam_force_nat_c {o} :
  forall lib x z (f arg : @CTerm o),
    cequivc
      lib
      (mkc_apply (lam_force_nat_c x z f) arg)
      (force_nat_c arg x z f).
Proof.
  introv.
  eapply cequivc_trans;[unfold lam_force_nat_c;apply cequivc_beta|].
  rw @mkcv_cbv_substc_same.
  rw @mkc_var_substc.
  rw @mkcv_cont1_dup1; eauto 3 with slow.
Qed.

Lemma equality_lam_force_nat_c_in_nat2nat {o} :
  forall lib x z (f : @CTerm o),
    member lib f nat2nat
    -> equality lib f (lam_force_nat_c x z f) nat2nat.
Proof.
  introv mem.
  apply equality_in_fun; dands; eauto 3 with slow.
  introv equ.
  apply equality_in_tnat in equ.
  unfold equality_of_nat in equ; exrepnd; spcast.

  eapply equality_respects_cequivc_left;
    [apply cequivc_sym;
      apply implies_cequivc_apply;
      [apply cequivc_refl
      |apply computes_to_valc_implies_cequivc;exact equ1]
    |].

  eapply equality_respects_cequivc_right;
    [apply cequivc_sym;apply cequivc_mkc_apply_lam_force_nat_c|].

  unfold force_nat_c.
  eapply equality_respects_cequivc_right;
    [apply cequivc_sym;apply simpl_cequivc_mkc_cbv;
     apply computes_to_valc_implies_cequivc;exact equ0|].
  eapply equality_respects_cequivc_right;
    [apply cequivc_sym;apply cequivc_mkc_cbv|]; eauto 3 with slow;[].
  rw @mkcv_less_substc.
  rw @substc_mkcv_zero.
  rw @mkcv_vbot_substc.
  rw @mkcv_apply_substc.
  rw @csubst_mk_cv.
  rw @mkc_var_substc.

  rw @mkc_zero_eq.

  eapply equality_respects_cequivc_right;
    [apply cequivc_sym;apply cequivc_mkc_less_nat|].
  boolvar; tcsp.

  allrw @equality_in_fun; repnd.
  clear mem1 mem0.
  apply mem; eauto 3 with slow.
Qed.

Lemma eq_mkc_nat_implies {o} :
  forall k1 k2, @mkc_nat o k1 = mkc_nat k2 -> k1 = k2.
Proof.
  introv e.
  inversion e as [q].
  allapply Znat.Nat2Z.inj; auto.
Qed.

Definition bound2_cbv_c {o} x z (n f e : @CTerm o) :=
  mkc_lam
    x
    (mkcv_cbv
       [x]
       (mkc_var x)
       x
       (mkcv_dup1
          x
          (mkcv_less
             [x]
             (mkc_var x)
             (mkcv_zero [x])
             (mkcv_vbot [x] z)
             (mkcv_less
                [x]
                (mkc_var x)
                (mk_cv [x] n)
                (mkcv_apply [x] (mk_cv [x] f) (mkc_var x))
                (mk_cv [x] (mkc_exception e mkc_axiom)))))).

Lemma cequiv_bound2_c_cbv {o} :
  forall lib x z (n f e : @CTerm o),
    cequivc
      lib
      (bound2_c x z n f e)
      (bound2_cbv_c x z n f e).
Proof.
  introv.
  apply cequivc_lam; introv.
  allrw @mkcv_less_substc.
  allrw @mkcv_cbv_substc_same.
  allrw @mkcv_cont1_dup1.
  allrw @mkcv_apply_substc.
  allrw @substc_mkcv_zero.
  allrw @mkc_var_substc.
  allrw @csubst_mk_cv.
  allrw @mkcv_vbot_substc.

  apply approxc_implies_cequivc; apply approxc_assume_hasvalue; intro hv.

  - apply hasvalue_likec_less in hv.
    repndors; exrepnd.

    + clear hv1 hv3 hv2.
      eapply cequivc_approxc_trans;
      [apply cequivc_mkc_less;
        [apply reduces_toc_implies_cequivc;exact hv0
        |apply cequivc_refl
        |apply cequivc_refl
        |apply cequivc_mkc_less;
          [apply reduces_toc_implies_cequivc;exact hv0
          |apply cequivc_refl
          |apply implies_cequivc_apply;
            [apply cequivc_refl
            |apply reduces_toc_implies_cequivc;exact hv0]
          |apply cequivc_refl]
        ]
      |].

      eapply approxc_cequivc_trans;
        [|apply cequivc_sym;
           apply simpl_cequivc_mkc_cbv;
           apply reduces_toc_implies_cequivc;exact hv0
        ].

      clear dependent u.

      rw @mkc_zero_eq.
      rw @mkc_nat_eq.
      eapply cequivc_approxc_trans;
        [apply cequivc_mkc_less_int|].
      eapply approxc_cequivc_trans;
        [|apply cequivc_sym; apply cequivc_mkc_cbv]; eauto 3 with slow;[].

      allrw @mkcv_less_substc.
      allrw @mkcv_apply_substc.
      allrw @substc_mkcv_zero.
      allrw @mkc_var_substc.
      allrw @mkcv_vbot_substc.
      allrw @csubst_mk_cv.
      rw @mkc_zero_eq.
      rw @mkc_nat_eq.
      eapply approxc_cequivc_trans;
        [|apply cequivc_sym; apply cequivc_mkc_less_int].

      boolvar; eauto 3 with slow; try (apply approxc_refl).

    + clear hv1.

      allrw @computes_to_excc_iff_reduces_toc.

      eapply cequivc_approxc_trans;
        [apply cequivc_mkc_less;
          [apply reduces_toc_implies_cequivc;exact hv0
          |apply cequivc_refl
          |apply cequivc_refl
          |apply cequivc_refl]
        |].
      eapply cequivc_approxc_trans;
        [apply cequivc_mkc_less_exc|].

      eapply approxc_cequivc_trans;
        [|apply cequivc_sym;
           apply simpl_cequivc_mkc_cbv;
           apply reduces_toc_implies_cequivc;exact hv0
        ].
      eapply approxc_cequivc_trans;
        [|apply cequivc_sym;
           apply cequivc_mkc_cbv_exc
        ].
      apply approxc_refl.

    + apply (computes_to_valc_and_excc_false _ _ _ mkc_zero) in hv2; tcsp.
      apply computes_to_valc_refl; eauto 3 with slow.

  - apply @hasvalue_likec_cbv in hv.
    apply @hasvalue_likec_implies_or in hv.
    repndors.

    + apply hasvaluec_computes_to_valc_implies in hv; exrepnd.
      eapply cequivc_approxc_trans;
        [apply simpl_cequivc_mkc_cbv;
          apply computes_to_valc_implies_cequivc;
          exact hv0|].
      eapply approxc_cequivc_trans;
        [|apply cequivc_mkc_less;
           [apply cequivc_sym
           |apply cequivc_refl
           |apply cequivc_refl
           |apply cequivc_mkc_less;
             [apply cequivc_sym
             |apply cequivc_refl
             |apply implies_cequivc_apply;
               [apply cequivc_refl
               |apply cequivc_sym]
             |apply cequivc_refl]
           ];
           apply computes_to_valc_implies_cequivc;
           exact hv0
        ].
      rw @computes_to_valc_iff_reduces_toc in hv0; repnd.
      eapply cequivc_approxc_trans;
        [apply cequivc_mkc_cbv;complete auto|].

      allrw @mkcv_less_substc.
      allrw @mkcv_apply_substc.
      allrw @substc_mkcv_zero.
      allrw @mkc_var_substc.
      allrw @mkcv_vbot_substc.
      allrw @csubst_mk_cv.
      apply approxc_refl.

    + allrw @raises_exceptionc_as_computes_to_excc; exrepnd.
      allrw @computes_to_excc_iff_reduces_toc.

      eapply cequivc_approxc_trans;
        [apply simpl_cequivc_mkc_cbv;
          apply reduces_toc_implies_cequivc;
          exact hv1|].
      eapply approxc_cequivc_trans;
        [|apply cequivc_mkc_less;
           [apply cequivc_sym
           |apply cequivc_refl
           |apply cequivc_refl
           |apply cequivc_refl];
           apply reduces_toc_implies_cequivc;
           exact hv1
        ].
      eapply approxc_cequivc_trans;
        [|apply cequivc_sym; apply cequivc_mkc_less_exc].
      eapply cequivc_approxc_trans;
        [apply cequivc_mkc_cbv_exc|].
      apply approxc_refl.
Qed.

Definition sp_force_nat {o} (arg : @NTerm o) x z (f : @NTerm o) :=
  mk_cbv arg x (mk_less (mk_var x) mk_zero (mk_vbot z) (mk_apply f (mk_var x))).

Definition bound2_cbv {o} arg x z (n : nat) (f : @NTerm o) a : NTerm :=
  mk_cbv
    arg
    x
    (mk_less
       (mk_var x)
       mk_zero
       (mk_vbot z)
       (mk_less (mk_var x) (mk_nat n) (mk_apply f (mk_var x)) (spexc a))).

Lemma alpha_eq_sp_force_nat {o} :
  forall (arg1 arg2 : @NTerm o) x1 x2 z1 z2 f1 f2,
    isprog f1
    -> alpha_eq f1 f2
    -> alpha_eq arg1 arg2
    -> alpha_eq (sp_force_nat arg1 x1 z1 f1) (sp_force_nat arg2 x2 z2 f2).
Proof.
  introv ispf aeq1 aeq2.
  applydup @alpha_eq_preserves_isprog in aeq1; auto.
  unfold sp_force_nat, mk_cbv, mk_less, mk_apply, mk_vbot, mk_lam, mk_fix, mk_zero, nobnd.

  prove_alpha_eq4.
  introv ln.
  repeat (destruct n; tcsp); eauto 3 with slow;[].
  clear ln.

  pose proof (ex_fresh_var (x1 :: x2
                               :: z1
                               :: z2
                               :: free_vars f1
                               ++ bound_vars f1
                               ++ free_vars f2
                               ++ bound_vars f2)) as h;
    exrepnd.
  allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.

  apply (al_bterm_aux [v]); simpl; auto.

  { unfold all_vars; simpl.
    allrw remove_nvars_nil_l; allrw app_nil_r.
    allrw @remove_nvars_eq; allsimpl.
    allrw disjoint_singleton_l; allsimpl.
    repeat (allrw in_app_iff; simpl).
    tcsp. }

  allrw <- beq_var_refl.
  allrw memvar_singleton.
  repeat (rw (lsubst_aux_trivial_cl_term2 f1); eauto 2 with slow).
  repeat (rw (lsubst_aux_trivial_cl_term2 f2); eauto 2 with slow).

  prove_alpha_eq4.
  introv ln.

  repeat (destruct n; tcsp; try omega); eauto 3 with slow;
  clear ln;
  apply alphaeqbt_nilv2;
  prove_alpha_eq4;
  introv ln;
  repeat (destruct n; tcsp; try omega); eauto 3 with slow;[].
  clear ln.

  apply alphaeqbt_nilv2.
  prove_alpha_eq4.
  introv ln.
  repeat (destruct n; tcsp; try omega); eauto 3 with slow;[].
  clear ln.

  pose proof (ex_fresh_var (x1 :: x2
                               :: z1
                               :: z2
                               :: [])) as h;
    exrepnd.
  allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.

  apply (al_bterm_aux [v0]); simpl; auto.

  { unfold all_vars; simpl; repeat (boolvar; allsimpl);
    allrw disjoint_singleton_l; allsimpl; tcsp. }

  repeat (boolvar; simpl); tcsp; eauto 2 with slow.
Qed.

Lemma alpha_eq_bound2_cbv {o} :
  forall (arg1 arg2 : @NTerm o) x1 x2 z1 z2 b f1 f2 a,
    isprog f1
    -> alpha_eq f1 f2
    -> alpha_eq arg1 arg2
    -> alpha_eq (bound2_cbv arg1 x1 z1 b f1 a) (bound2_cbv arg2 x2 z2 b f2 a).
Proof.
  introv ispf aeq1 aeq2.
  applydup @alpha_eq_preserves_isprog in aeq1; auto.
  unfold bound2_cbv, mk_cbv, mk_less, mk_apply, mk_vbot, mk_lam, mk_fix, mk_zero, nobnd.

  prove_alpha_eq4.
  introv ln.
  repeat (destruct n; tcsp); eauto 3 with slow;[].
  clear ln.

  pose proof (ex_fresh_var (x1 :: x2
                               :: z1
                               :: z2
                               :: free_vars f1
                               ++ bound_vars f1
                               ++ free_vars f2
                               ++ bound_vars f2)) as h;
    exrepnd.
  allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.

  apply (al_bterm_aux [v]); simpl; auto.

  { unfold all_vars; simpl.
    allrw remove_nvars_nil_l; allrw app_nil_r.
    allrw @remove_nvars_eq; allsimpl.
    allrw disjoint_singleton_l; allsimpl.
    repeat (allrw in_app_iff; simpl).
    tcsp. }

  allrw <- beq_var_refl.
  allrw memvar_singleton.
  repeat (rw (lsubst_aux_trivial_cl_term2 f1); eauto 2 with slow).
  repeat (rw (lsubst_aux_trivial_cl_term2 f2); eauto 2 with slow).

  prove_alpha_eq4.
  introv ln.
  repeat (destruct n; tcsp; try omega); eauto 3 with slow;
  clear ln;
  apply alphaeqbt_nilv2;
  prove_alpha_eq4;
  introv ln;
  repeat (destruct n; tcsp; try omega); eauto 3 with slow;
  clear ln;
  apply alphaeqbt_nilv2;
  prove_alpha_eq4;
  introv ln;
  repeat (destruct n; tcsp; try omega); eauto 3 with slow;[].
  clear ln.

  pose proof (ex_fresh_var (x1 :: x2
                               :: z1
                               :: z2
                               :: [])) as h;
    exrepnd.
  allsimpl; allrw in_app_iff; allrw not_over_or; repnd; GC.

  apply (al_bterm_aux [v0]); simpl; auto.

  { unfold all_vars; simpl; repeat (boolvar; allsimpl);
    allrw disjoint_singleton_l; allsimpl; tcsp. }

  repeat (boolvar; simpl); tcsp; eauto 2 with slow.
Qed.

Lemma so_alphaeq_preserves_no_utokens {o} :
  forall (t1 t2 : @SOTerm o),
    so_alphaeq t1 t2
    -> no_utokens t1
    -> no_utokens t2.
Proof.
  introv aeq nout.
  apply get_utokens_so_soalphaeq in aeq.
  allunfold @no_utokens.
  rw aeq in nout; auto.
Qed.
Hint Resolve so_alphaeq_preserves_no_utokens : slow.

Definition computation_fails {o} lib (t : @NTerm o) :=
  {s : String.string
   & {u : NTerm
   & {k : nat
   & compute_at_most_k_steps lib k t = cfailure s u}}}.

Lemma alpha_eq_subst_sp_force_nat_alpha_eq {o} :
  forall v z (f : @NTerm o) t,
    isprog f
    -> alpha_eq
         (subst (mk_less (mk_var v) mk_zero (mk_vbot z) (mk_apply f (mk_var v))) v t)
         (mk_less t mk_zero (mk_vbot z) (mk_apply f t)).
Proof.
  introv isp.
  pose proof (unfold_lsubst
                [(v,t)]
                (mk_less (mk_var v) mk_zero (mk_vbot z) (mk_apply f (mk_var v))))
    as unf; exrepnd.
  unfold subst.
  rw unf0; clear unf0.
  allapply @alpha_eq_mk_less; exrepnd; subst.
  allapply @alpha_eq_mk_var; subst.
  allapply @alpha_eq_mk_vbot; exrepnd; subst.
  allapply @alpha_eq_mk_zero; subst.
  allapply @alpha_eq_mk_apply; exrepnd; subst.
  allapply @alpha_eq_mk_var; subst.

  allsimpl; cpx; ginv.

  allrw app_nil_r.
  allrw disjoint_cons_l.
  repnd.
  rename a' into f'.

  allrw memvar_singleton.
  allrw <- @beq_var_refl.
  rw (@lsubst_aux_trivial_cl_term2 o f'); eauto 3 with slow.

  unfold mk_less, mk_apply, mk_vbot, mk_zero, mk_nat, mk_integer, mk_fix, mk_lam, mk_var, nobnd.
  repeat (prove_alpha_eq4; eauto 2 with slow).

  { pose proof (ex_fresh_var (v' :: z :: [])) as fv.
    exrepnd; allsimpl; allrw not_over_or; repnd; GC.
    apply (al_bterm_aux [v0]); simpl; auto;
    repeat (boolvar; simpl); tcsp;
    allrw disjoint_singleton_l; allsimpl; tcsp. }
Qed.

Lemma wf_bound2_cbv {o} :
  forall (arg : @NTerm o) x z b f a,
    wf_term (bound2_cbv arg x z b f a) <=> (wf_term arg # wf_term f).
Proof.
  introv.
  unfold bound2_cbv.
  rw <- @wf_cbv_iff.
  repeat (rw <- @wf_less_iff).
  rw <- @wf_apply_iff.
  split; intro h; repnd; dands; eauto 3 with slow.
Qed.

Lemma wf_sp_force_nat {o} :
  forall (arg : @NTerm o) x z f,
    wf_term (sp_force_nat arg x z f) <=> (wf_term arg # wf_term f).
Proof.
  introv.
  rw <- @wf_cbv_iff.
  repeat (rw <- @wf_less_iff).
  rw <- @wf_apply_iff.
  split; intro h; repnd; dands; eauto 3 with slow.
Qed.

Lemma hasvalue_like_vbot {o} :
  forall (lib : @library o) z,
    !hasvalue_like lib (mk_vbot z).
Proof.
  introv hv.
  unfold hasvalue_like in hv; exrepnd.
  apply reduces_to_vbot_if_isvalue_like in hv1; sp.
Qed.

Lemma not_hasvalue_like_fresh {o} :
  forall lib (v : NVar), !@hasvalue_like o lib (mk_fresh v (mk_var v)).
Proof.
  introv hv.
  unfold hasvalue_like in hv; exrepnd.
  apply reduces_in_atmost_k_step_fresh_id in hv1; sp.
Qed.

Lemma hasvalue_like_subst_less_seq {o} :
  forall lib (f : @ntseq o) v a b c,
    hasvalue_like
      lib
      (subst (mk_less (mk_var v) a b c) v (sterm f))
    -> False.
Proof.
  introv comp.
  unfold subst, lsubst in comp; allsimpl; boolvar;
  repndors; try (subst v'); tcsp;
  allrw not_over_or; repnd; GC;
  try (complete (match goal with
                   | [ H : context[fresh_var ?l] |- _ ] =>
                     let h := fresh "h" in
                     pose proof (fresh_var_not_in l) as h;
                   unfold all_vars in h;
                   simpl in h;
                   repeat (rw in_app_iff in h);
                   repeat (rw not_over_or in h);
                   repnd; allsimpl; tcsp
                 end));
  allsimpl; boolvar; tcsp; fold_terms; allrw app_nil_r.

  unfold hasvalue_like, reduces_to in comp; exrepnd.

  destruct k.

  - allrw @reduces_in_atmost_k_steps_0; repnd; subst.
    unfold isvalue_like in comp0; allsimpl; tcsp.

  - allrw @reduces_in_atmost_k_steps_S; exrepnd.
    csunf comp2; allsimpl; ginv.
Qed.

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


Require Import Coq.Arith.Compare_dec.
Require Import Coq.Arith.EqNat.
Require Import Coq.Lists.List.
Require Import FunctionNinjas.All.
Require Import ListPlus.All.

Import ListNotations.

Module Effect.
  Record t := New {
    command : Type;
    answer : command -> Type }.
End Effect.

Module Model.
  Record t (E : Effect.t) (S : Type) := New {
    condition : Effect.command E -> S -> bool;
    answer : forall c, S -> Effect.answer E c;
    state : Effect.command E -> S -> S }.
  Arguments New {E S} _ _ _.
  Arguments condition {E S} _ _ _.
  Arguments answer {E S} _ _ _.
  Arguments state {E S} _ _ _.
End Model.

Module Sequential.
  Inductive t (E : Effect.t) : Type :=
  | Ret : t E
  | Call : forall c, (Effect.answer E c -> t E) -> t E.
  Arguments Ret {E}.
  Arguments Call {E} _ _.
End Sequential.

Module Concurrent.
  Definition t (E : Effect.t) := list (Sequential.t E).
End Concurrent.

Module Choose.
  Inductive t (E : Effect.t) : Type :=
  | Ret : t E
  | Call : forall c, (Effect.answer E c -> t E) -> t E
  | Choose : t E -> t E -> t E.
  Arguments Ret {E}.
  Arguments Call {E} _ _.
  Arguments Choose {E} _ _.

  Fixpoint lift {E} (x : Sequential.t E) : t E :=
    match x with
    | Sequential.Ret => Ret
    | Sequential.Call c h => Choose.Call c (fun a => lift (h a))
    end.

  Module Mix.
    Inductive t {E} : Sequential.t E -> Choose.t E -> Type :=
    | RetRet : t Sequential.Ret Choose.Ret
    | RetCall : forall c h, t Sequential.Ret (Choose.Call c h)
    | RetChoose : forall x1 x2, t Sequential.Ret (Choose.Choose x1 x2)
    | CallRet : forall c h, t (Sequential.Call c h) Choose.Ret
    | CallCall : forall c_x h_x c_y h_y,
      (forall a, t (h_x a) (Choose.Call c_y h_y)) ->
      (forall a, t (Sequential.Call c_x h_x) (h_y a)) ->
      t (Sequential.Call c_x h_x) (Choose.Call c_y h_y)
    | CallChoose : forall c h y1 y2,
      t (Sequential.Call c h) y1 -> t (Sequential.Call c h) y2 ->
      t (Sequential.Call c h) (Choose.Choose y1 y2).
    Arguments RetRet {E}.
    Arguments RetCall {E} _ _.
    Arguments RetChoose {E} _ _.
    Arguments CallRet {E} _ _.
    Arguments CallCall {E c_x h_x c_y h_y} _ _.
    Arguments CallChoose {E c h y1 y2} _ _.

    Fixpoint make_call {E} (x : Sequential.t E)
      (c_y : Effect.command E) (h_y : Effect.answer E c_y -> Choose.t E)
      (z : forall x a, t x (h_y a)) : t x (Choose.Call c_y h_y) :=
      match x with
      | Sequential.Ret => RetCall c_y h_y
      | Sequential.Call c_x h_x =>
        CallCall (fun a => make_call (h_x a) c_y h_y z)
          (fun a => z (Sequential.Call c_x h_x) a)
      end.

    Fixpoint make {E} (x : Sequential.t E) (y : Choose.t E) : t x y :=
      match y with
      | Choose.Ret =>
        match x with
        | Sequential.Ret => RetRet
        | Sequential.Call c_x h_x => CallRet c_x h_x
        end
      | Choose.Call c_y h_y => make_call x c_y h_y (fun x a => make x (h_y a))
      | Choose.Choose y1 y2 =>
        match x with
        | Sequential.Ret => RetChoose y1 y2
        | Sequential.Call c_x h_x =>
          CallChoose (make (Sequential.Call c_x h_x) y1)
            (make (Sequential.Call c_x h_x) y2)
        end
      end.

    Fixpoint compile {E} {x y} (xy : t x y) : Choose.t E :=
      match xy with
      | RetRet => Choose.Ret
      | RetCall c_y h_y => Choose.Call c_y h_y
      | RetChoose y1 y2 => Choose.Choose y1 y2
      | CallRet c_x h_x => Choose.Call c_x (fun a => lift (h_x a))
      | CallCall c_x _ c_y _ m_x m_y =>
        Choose.Choose (Choose.Call c_x (fun a => compile (m_x a)))
          (Choose.Call c_y (fun a => compile (m_y a)))
      | CallChoose _ _ _ _ m_y1 m_y2 =>
        Choose.Choose (compile m_y1) (compile m_y2)
      end.
  End Mix.

  Fixpoint compile {E} (xs : Concurrent.t E) : Choose.t E :=
    match xs with
    | [] => Ret
    | x :: xs => Mix.compile (Mix.make x (compile xs))
    end.

  Fixpoint is_not_stuck {E S} (m : Model.t E S) (x : Choose.t E) (s : S)
    : bool :=
    match x with
    | Ret => true
    | Call c _ => Model.condition m c s
    | Choose x1 x2 => orb (is_not_stuck m x1 s) (is_not_stuck m x2 s)
    end.

  Fixpoint aux {E S} (m : Model.t E S) (post : S -> bool) (x : Choose.t E)
    (s : S) : bool :=
    match x with
    | Ret => post s
    | Call c h =>
      if Model.condition m c s then
        let a := Model.answer m c s in
        let s := Model.state m c s in
        andb (is_not_stuck m (h a) s) (aux m post (h a) s)
      else
        true
    | Choose x1 x2 => andb (aux m post x1 s) (aux m post x2 s)
    end.

  Definition check {E S} (m : Model.t E S) (post : S -> bool) (x : Choose.t E)
    (s : S) : bool :=
    andb (is_not_stuck m x s) (aux m post x s).
End Choose.

Module Examples.
  Definition S := bool.

  Module Command.
    Inductive t :=
    | Lock
    | Unlock.
  End Command.

  Definition E : Effect.t :=
    Effect.New Command.t (fun _ => unit).

  Definition ret : Sequential.t E :=
    Sequential.Ret.

  Definition lock (h : Sequential.t E) : Sequential.t E :=
    Sequential.Call (E := E) Command.Lock (fun _ => h).

  Definition unlock (h : Sequential.t E) : Sequential.t E :=
    Sequential.Call (E := E) Command.Unlock (fun _ => h).

  Definition condition (c : Effect.command E) (s : S) : bool :=
    match (c, s) with
    | (Command.Lock, false) | (Command.Unlock, true) => true
    | (Command.Lock, true) | (Command.Unlock, false) => false
    end.

  Definition answer (c : Effect.command E) (s : S) : Effect.answer E c :=
    tt.

  Definition state (c : Effect.command E) (s : S) : S :=
    match c with
    | Command.Lock => true
    | Command.Unlock => false
    end.

  Definition m : Model.t E S :=
    Model.New condition answer state.

  Fixpoint ex1 (n : nat) : Concurrent.t E :=
    match n with
    | O => []
    | Datatypes.S n =>
      (lock @@
      unlock @@
      ret) :: ex1 n
    end.

  Definition is_ex1_ok : bool :=
    Choose.check m (fun _ => true) (Choose.compile @@ ex1 9) false.

  (* Time Compute is_ex1_ok. *)
End Examples.

Module Increment.
  Definition S := nat.

  Module Command.
    Inductive t :=
    | Read
    | Write (s : S).
  End Command.

  Definition E : Effect.t :=
    Effect.New Command.t (fun c =>
      match c with
      | Command.Read => S
      | Command.Write _ => unit
      end).

  Definition ret : Sequential.t E :=
    Sequential.Ret.

  Definition read (h : S -> Sequential.t E) : Sequential.t E :=
    Sequential.Call (E := E) Command.Read h.

  Definition write (s : S) (h : Sequential.t E) : Sequential.t E :=
    Sequential.Call (E := E) (Command.Write s) (fun _ => h).

  Definition condition (c : Effect.command E) (s : S) : bool :=
    true.

  Definition answer (c : Effect.command E) (s : S) : Effect.answer E c :=
    match c with
    | Command.Read => s
    | Command.Write _ => tt
    end.

  Definition state (c : Effect.command E) (s : S) : S :=
    match c with
    | Command.Read => s
    | Command.Write s => s
    end.

  Definition m : Model.t E S :=
    Model.New condition answer state.

  Definition process : Sequential.t E :=
    read (fun s =>
    write (s + 1)
    ret).

  Definition post (n : nat) (s : S) : bool :=
    beq_nat n s.

  Definition result (n : nat) : bool :=
    Choose.check m (post n) (Choose.compile @@ List.repeat process n) 0.
End Increment.

Module AtomicIncrement.
  Definition S := nat.

  Module Command.
    Inductive t :=
    | Increment.
  End Command.

  Definition E : Effect.t :=
    Effect.New Command.t (fun c =>
      match c with
      | Command.Increment => unit
      end).

  Definition ret : Sequential.t E :=
    Sequential.Ret.

  Definition increment (h : Sequential.t E) : Sequential.t E :=
    Sequential.Call (E := E) Command.Increment (fun _ => h).

  Definition condition (c : Effect.command E) (s : S) : bool :=
    true.

  Definition answer (c : Effect.command E) (s : S) : Effect.answer E c :=
    match c with
    | Command.Increment => tt
    end.

  Definition state (c : Effect.command E) (s : S) : S :=
    match c with
    | Command.Increment => s + 1
    end.

  Definition m : Model.t E S :=
    Model.New condition answer state.

  Definition process : Sequential.t E :=
    increment
    ret.

  Definition post (n : nat) (s : S) : bool :=
    beq_nat n s.

  Definition result (n : nat) : bool :=
    Choose.check m (post n) (Choose.compile @@ List.repeat process n) 0.
End AtomicIncrement.

Module SimpleChannel.
  Definition S := option nat.

  Module Command.
    Inductive t :=
    | Send (x : nat)
    | Receive.
  End Command.

  Definition E : Effect.t :=
    Effect.New Command.t (fun c =>
      match c with
      | Command.Send _ => unit
      | Command.Receive => nat
      end).

  Definition ret : Sequential.t E :=
    Sequential.Ret.

  Definition send (n : nat) (h : Sequential.t E) : Sequential.t E :=
    Sequential.Call (E := E) (Command.Send n) (fun _ => h).

  Definition receive (h : nat -> Sequential.t E) : Sequential.t E :=
    Sequential.Call (E := E) Command.Receive h.

  Definition condition (c : Effect.command E) (s : S) : bool :=
    match (c, s) with
    | (Command.Send _, None) | (Command.Receive, Some _) => true
    | (Command.Send _, Some _) | (Command.Receive, None) => false
    end.

  Definition answer (c : Effect.command E) (s : S) : Effect.answer E c :=
    match c with
    | Command.Send _ => tt
    | Command.Receive =>
      match s with
      | None => 0
      | Some n => n
      end
    end.

  Definition state (c : Effect.command E) (s : S) : S :=
    match c with
    | Command.Send n => Some n
    | Command.Receive => None
    end.

  Definition m : Model.t E S :=
    Model.New condition answer state.

  Definition ex : Concurrent.t E :=
    [receive (fun _ => ret); send 12 ret].

  Definition result : bool :=
    Choose.check m (fun _ => true) (Choose.compile ex) (None).
End SimpleChannel.

(** See `spin/database.spin`. *)
Module Database.
  Record S := New {
    holder : nat;
    up : list bool;
    ack : list nat }.

  Definition init (n : nat) : S :=
    New n (List.repeat false n) (List.repeat 0 n).

  Module Command.
    Inductive t :=
    | UpdateSend (id : nat)
    | ReceiveAck (id : nat)
    | Receive (id : nat)
    | Ack.
  End Command.

  Definition E : Effect.t :=
    Effect.New Command.t (fun c => unit).

  Definition condition (n : nat) (c : Effect.command E) (s : S) : bool :=
    match c with
    | Command.UpdateSend id => beq_nat id (holder s)
    | Command.ReceiveAck id => beq_nat (List.nth id (ack s) n) (n - 1)
    | Command.Receive id =>
      andb (List.nth id (up s) false) (
        match nat_compare (holder s) n with
        | Lt => true
        | _ => false
        end)
    | Command.Ack => true
    end.

  Definition answer (c : Effect.command E) (s : S) : Effect.answer E c :=
    tt.

  Fixpoint list_udpate {A} (l : list A) (n : nat) (x : A) : list A :=
    match (l, n) with
    | ([], _) => []
    | (_ :: l, O) => x :: l
    | (x' :: l, Datatypes.S n) => x' :: list_udpate l n x
    end.

  Definition state (n : nat) (c : Effect.command E) (s : S) : S :=
    match c with
    | Command.UpdateSend id => New id (List.repeat true n) (ack s)
    | Command.ReceiveAck id => New n (up s) (list_udpate (ack s) id 0)
    | Command.Receive id => New (holder s) (list_udpate (up s) id false) (ack s)
    | Command.Ack =>
      let a := List.nth (holder s) (ack s) 0 in
      New (holder s) (up s) (list_udpate (ack s) (holder s) (a + 1))
    end.

  Definition m (n : nat) : Model.t E S :=
    Model.New (condition n) answer (state n).

  Definition process_write (id : nat) : Sequential.t E :=
    Sequential.Call (E := E) (Command.UpdateSend id) (fun _ =>
    Sequential.Call (E := E) (Command.ReceiveAck id) (fun _ =>
    Sequential.Ret)).

  Definition process_read (id : nat) : Sequential.t E :=
    Sequential.Call (E := E) (Command.Receive id) (fun _ =>
    Sequential.Call (E := E) Command.Ack (fun _ =>
    Sequential.Ret)).

  Fixpoint processes_read (n : nat) : Concurrent.t E :=
    match n with
    | O => []
    | Datatypes.S n => process_read n :: processes_read n
    end.

  Definition ex (n : nat) : Concurrent.t E :=
    process_write n :: processes_read n.

  Definition result (n : nat) : bool :=
    Choose.check (m (n + 1)) (fun _ => true) (Choose.compile @@ ex n) (init (n + 1)).
End Database.

(** * Extraction *)
Require Import Io.All.
Require Import Io.System.All.
Require Import ListString.All.

Import C.Notations.

Definition result (argv : list LString.t) : C.t System.effect unit :=
  (* if Examples.is_ex1_ok then *)
  (* if Increment.result 2 then *)
  (* if AtomicIncrement.result 11 then *)
  (* if SimpleChannel.result then *)
  if Database.result 0 then
    System.log (LString.s "OK")
  else
    System.log (LString.s "error").

Definition main := Extraction.launch result.
Extraction "extraction/main" main.


(* Lifting pseudofunctors to pseudofunctors on algebras *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Groupoids.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Transformations.Examples.Whiskering.
Require Import UniMath.Bicategories.Transformations.Examples.Unitality.
Require Import UniMath.Bicategories.Transformations.Examples.Associativity.
Require Import UniMath.Bicategories.Modifications.Modification.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Algebras.
Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor.
Require Import UniMath.Bicategories.DisplayedBicats.DispTransformation.
Require Import UniMath.Bicategories.DisplayedBicats.DispModification.
Require Import UniMath.Bicategories.DisplayedBicats.DispBuilders.

Require Import signature.hit_signature.
Require Import prelude.all.
Require Import hit_biadjunction.path_groupoid_commute.
Require Import hit_biadjunction.gquot_commute.
Require Import algebra.one_types_polynomials.
Require Import algebra.groupoid_polynomials.

Local Open Scope cat.

Local Arguments poly_act_functor_composition_data _ {_ _ _} _ _.
Local Arguments poly_act_nat_trans_data _ {_ _ _ _} _.

Section LiftPseudofunctor.
  Variable (P : poly_code).

  Definition prealg_path_groupoid_map
             (X : one_type)
    : (disp_alg_bicat (⟦ P ⟧)) X → (disp_alg_bicat ⦃ P ⦄) (path_groupoid X)
    := λ f, poly_path_groupoid P X ∙ #path_groupoid f.

  Definition prealg_path_groupoid_mor_comp
             {X Y : one_type}
             {f : X → Y}
             {hX : (disp_alg_bicat (⟦ P ⟧)) X}
             {hY : (disp_alg_bicat (⟦ P ⟧)) Y}
             (hf : hX -->[ f] hY)
             (z : (⦃ P ⦄ (path_groupoid X) : groupoid))
    : f (hX (pr1 (pr111 (poly_path_groupoid P) X) z))
      =
      hY (pr1 ( pr111 (poly_path_groupoid P) Y) (poly_map P f z))
    := pr1 hf (pr1 (poly_path_groupoid P X) z)
           @ maponpaths hY (pr11 (psnaturality_of (poly_path_groupoid P) f) z).

  Definition prealg_path_groupoid_mor_is_nat_trans
             {X Y : one_type}
             {f : X → Y}
             {hX : (disp_alg_bicat (⟦ P ⟧)) X}
             {hY : (disp_alg_bicat (⟦ P ⟧)) Y}
             (hf : hX -->[ f] hY)
    : is_nat_trans
        (prealg_path_groupoid_map X hX ∙ # path_groupoid f)
        (# ⦃ P ⦄ (# path_groupoid f) ∙ prealg_path_groupoid_map Y hY)
        (prealg_path_groupoid_mor_comp hf).
  Proof.
    intros x y g.
    etrans.
    {
      refine (maponpaths (λ z, _ @ (z @ _)) _).
      exact (homotsec_natural
               (pr1 hf)
               (# (poly_path_groupoid P X : _ ⟶ _) g)).
    }
    refine (path_assoc _ _ _ @ _).
    etrans.
    {
      apply maponpaths_2.
      refine (path_assoc _ _ _ @ _).
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths_2.
        exact (maponpathscomp hX f _).
      }
      refine (!(maponpathscomp0 (f ∘ hX)%functions _ _) @ _).
      apply maponpaths.
      apply pathsinv0r.
    }
    etrans.
    {
      apply maponpaths_2.
      apply pathscomp0lid.
    }
    refine (!(path_assoc _ _ _) @ _).
    refine (_ @ path_assoc _ _ _).
    apply maponpaths.
    etrans.
    {
      apply maponpaths_2.
      refine (!_).
      apply (maponpathscomp _ hY).
    }
    refine (!(maponpathscomp0 hY _ _) @ _ @ maponpathscomp0 _ _ _).
    apply maponpaths.
    exact (pr21 (psnaturality_of (poly_path_groupoid P) f) _ _ g).
  Qed.

  Definition prealg_path_groupoid_mor
             {X Y : one_type}
             {f : X → Y}
             {hX : (disp_alg_bicat (⟦ P ⟧)) X}
             {hY : (disp_alg_bicat (⟦ P ⟧)) Y}
             (hf : hX -->[ f] hY)
    : (prealg_path_groupoid_map X hX ∙ # path_groupoid f)
      ⟹
      # ⦃ P ⦄ (# path_groupoid f) ∙ prealg_path_groupoid_map Y hY.
  Proof.
    use make_nat_trans.
    - exact (prealg_path_groupoid_mor_comp hf).
    - exact (prealg_path_groupoid_mor_is_nat_trans hf).
  Defined.

  Definition prealg_path_groupoid_cell_help
             {X Y : one_types}
             {f g : one_types ⟦ X, Y ⟧}
             (p : f ==> g)
             (z : poly_act P (X : one_type))
    : ! poly_homot P p ((pr1 ((poly_path_groupoid P) X)) z)
    @ (pr11 (psnaturality_of (poly_path_groupoid P) f)) z
    @ # (poly_path_groupoid P Y : _ ⟶ _)
          (poly_act_nat_trans_data
             P
             (path_to_nattrans p) z)
    =
    (pr11 (psnaturality_of (poly_path_groupoid P) g)) z.
  Proof.
    induction P as [ A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂ ].
    - exact (idpath (idpath z)).
    - apply pathsinv0l.
    - induction z as [z | z].
      + simpl.
        etrans.
        {
          apply maponpaths_2.
          exact (!(maponpathsinv0 inl _)).
        }
        etrans.
        {
          apply maponpaths.
          exact (!(maponpathscomp0 inl _ _)).
        }
        refine (!(maponpathscomp0 inl _ _) @ _).
        apply maponpaths.
        exact (IHP₁ z).
      + simpl.
        etrans.
        {
          apply maponpaths_2.
          exact (!(maponpathsinv0 inr _)).
        }
        etrans.
        {
          apply maponpaths.
          exact (!(maponpathscomp0 inr _ _)).
        }
        refine (!(maponpathscomp0 inr _ _) @ _).
        apply maponpaths.
        exact (IHP₂ z).
    - simpl.
      etrans.
      {
        apply maponpaths_2.
        apply pathsdirprod_inv.
      }
      etrans.
      {
        apply maponpaths.
        apply pathsdirprod_concat.
      }
      refine (pathsdirprod_concat _ _ _ _ @ _).
      exact (maponpaths (λ z, pathsdirprod z _) (IHP₁ (pr1 z))
             @ maponpaths (pathsdirprod _) (IHP₂ (pr2 z))).
  Qed.

  Definition prealg_path_groupoid_cell
             {X Y : one_types}
             {f g : one_types ⟦ X, Y ⟧}
             {p : f ==> g}
             {hX : (disp_alg_bicat (⟦ P ⟧)) X}
             {hY : (disp_alg_bicat (⟦ P ⟧)) Y}
             {hf : hX -->[ f] hY}
             {hg : hX -->[ g] hY}
             (hp : hf ==>[ p] hg)
             (z : (⦃ P ⦄ (path_groupoid X) : groupoid))
    : p (hX (pr1 (pr111 (poly_path_groupoid P) X) z))
    @ prealg_path_groupoid_mor_comp hg z
    =
    prealg_path_groupoid_mor_comp hf z
    @ maponpaths hY
        (# (poly_path_groupoid P Y : _ ⟶ _)
           (poly_act_nat_trans_data
              P (path_to_nattrans p) z)).
  Proof.
    simpl.
    unfold prealg_path_groupoid_mor_comp.
    refine (!_).
    etrans.
    {
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      exact (!(maponpathscomp0 hY _ _)).
    }
    assert
    (pr1 hf ((pr1 ((poly_path_groupoid P) X)) z)
     =
     p (hX ((pr1 ((pr111 (poly_path_groupoid P)) X)) z)) @
       pr1 hg ((pr1 ((poly_path_groupoid P) X)) z)
     @ maponpaths
         hY
         (!(poly_homot P p ((pr1 ((poly_path_groupoid P) X)) z))))
      as H.
    {
      refine (!_).
      etrans.
      {
        refine (path_assoc _ _ _ @ _).
        apply maponpaths_2.
        exact (eqtohomot hp ((pr1 ((poly_path_groupoid P) X)) z)).
      }
      refine (!(path_assoc _ _ _) @ _).
      etrans.
      {
        apply maponpaths.
        refine (!(maponpathscomp0 hY _ _) @ _).
        apply maponpaths.
        apply pathsinv0r.
      }
      apply pathscomp0rid.
    }
    etrans.
    {
      apply maponpaths_2.
      exact H.
    }
    refine (!(path_assoc _ _ _) @ _).
    apply maponpaths.
    refine (!(path_assoc _ _ _) @ _).
    apply maponpaths.
    refine (!(maponpathscomp0 hY _ _) @ _).
    apply maponpaths.
    exact (prealg_path_groupoid_cell_help p z).
  Qed.

  Definition prealg_path_groupoid_identitor
             {X : one_type}
             (XX : (disp_alg_bicat (⟦ P ⟧)) X)
             (z : (⦃ P ⦄ (path_groupoid X) : groupoid))
    : maponpaths
        XX
        (poly_id P X ((pr1 ((poly_path_groupoid P) X)) z))
    @ maponpaths
        XX
        ((pr11 (psnaturality_of (poly_path_groupoid P) (λ x : X, x))) z)
    =
    maponpaths
      XX
      (# (poly_path_groupoid P X : _ ⟶ _)
         (poly_act_functor_identity_data P (one_type_to_groupoid X) z))
    @ maponpaths
        XX
        (# (poly_path_groupoid P X : _ ⟶ _)
           (poly_act_nat_trans_data
              P  (path_groupoid_identitor X) z)).
  Proof.
    refine (!(maponpathscomp0 XX _ _) @ _ @ maponpathscomp0 XX _ _).
    apply maponpaths.
    clear XX.
    induction P as [A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
    - exact (idpath (idpath z)).
    - exact (idpath (idpath z)).
    - induction z as [z | z].
      + exact (!(maponpathscomp0 inl _ _)
                @ maponpaths (maponpaths inl) (IHP₁ z)
                @ maponpathscomp0 inl _ _).
      + exact (!(maponpathscomp0 inr _ _)
                @ maponpaths (maponpaths inr) (IHP₂ z)
                @ maponpathscomp0 inr _ _).
    - exact (pathsdirprod_concat _ _ _ _
              @ maponpaths (λ z, pathsdirprod z _) (IHP₁ (pr1 z))
              @ maponpaths (pathsdirprod _) (IHP₂ (pr2 z))
              @ !(pathsdirprod_concat _ _ _ _)).
  Qed.

  Definition prealg_mor_inv
             {X Y : one_types}
             {f : one_types ⟦ X, Y ⟧}
             {hX : (disp_alg_bicat (⟦ P ⟧)) X}
             {hY : (disp_alg_bicat (⟦ P ⟧)) Y}
             (hf : hX -->[ f] hY)
    : prealg_path_groupoid_map X hX
      -->[ # path_groupoid f]
      prealg_path_groupoid_map Y hY.
  Proof.
    use make_invertible_2cell.
    - exact (prealg_path_groupoid_mor hf).
    - apply grpd_bicat_is_invertible_2cell.
  Defined.

  Definition prealg_path_groupoid_compositor_lemma
             {X Y Z : one_types}
             (f : one_types ⟦ X, Y ⟧)
             (g : one_types ⟦ Y, Z ⟧)
             (z : poly_act P (X : one_type))
    : maponpaths
        (# (⟦ P ⟧) g)
        ((pr11 (psnaturality_of (poly_path_groupoid P) f)) z)
     @ (pr11 (psnaturality_of (poly_path_groupoid P) g)) (poly_map P f z)
     @ # (poly_path_groupoid P Z : _ ⟶ _)
           (poly_act_functor_composition_data
              P
              (function_to_functor f) (function_to_functor g) z)
      @ # (poly_path_groupoid P Z : _ ⟶ _)
           (poly_act_nat_trans_data P (path_groupoid_compositor f g) z)
      =
      poly_comp P f g ((pr1 ((poly_path_groupoid P) X)) z)
      @ (pr11 (psnaturality_of (poly_path_groupoid P) (λ x, g (f x)))) z.
  Proof.
    induction P as [ A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂ ].
    - exact (idpath (idpath z)).
    - exact (idpath (idpath (g(f z)))).
    - induction z as [z | z].
      + simpl.
        refine (_ @ maponpathscomp0 inl _ _).
        etrans.
        {
          apply maponpaths_2.
          apply coprodf_path_maponpaths_inl.
        }
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths.
            exact (!(maponpathscomp0 inl _ _)).
          }
          exact (!(maponpathscomp0 inl _ _)).
        }
        refine (!(maponpathscomp0 inl _ _) @ _).
        exact (maponpaths (maponpaths inl) (IHP₁ z)).
      + simpl.
        refine (_ @ maponpathscomp0 inr _ _).
        etrans.
        {
          apply maponpaths_2.
          apply coprodf_path_maponpaths_inr.
        }
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths.
            exact (!(maponpathscomp0 inr _ _)).
          }
          exact (!(maponpathscomp0 inr _ _)).
        }
        refine (!(maponpathscomp0 inr _ _) @ _).
        exact (maponpaths (maponpaths inr) (IHP₂ z)).
    - simpl.
      refine (_ @ !(pathsdirprod_concat _ _ _ _)).
      etrans.
      {
        apply maponpaths_2.
        exact (!(maponpaths_pathsdirprod _ _ _ _)).
      }
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          apply pathsdirprod_concat.
        }
        apply pathsdirprod_concat.
      }
      refine (pathsdirprod_concat _ _ _ _ @ _).
      exact (maponpaths (λ z, pathsdirprod z _) (IHP₁ (pr1 z))
             @ maponpaths (pathsdirprod _) (IHP₂ (pr2 z))).
  Qed.

  Definition prealg_path_groupoid_compositor_equation
             {X Y Z : one_types}
             {f : one_types ⟦ X, Y ⟧}
             {g : one_types ⟦ Y, Z ⟧}
             {hX : (disp_alg_bicat (⟦ P ⟧)) X}
             {hY : (disp_alg_bicat (⟦ P ⟧)) Y}
             {hZ : (disp_alg_bicat (⟦ P ⟧)) Z}
             (hf : hX -->[ f] hY)
             (hg : hY -->[ g] hZ)
             (z : poly_act P (X : one_type))
    : ((maponpaths g (prealg_path_groupoid_mor_comp hf z)
    @ prealg_path_groupoid_mor_comp hg (poly_map P f z))
    @ maponpaths hZ
        (# (poly_path_groupoid P Z : _ ⟶ _)
           (poly_act_functor_composition_data
              P
              (function_to_functor f)
              (function_to_functor g) z)))
    @ maponpaths hZ
        (# (poly_path_groupoid P Z : _ ⟶ _)
           (poly_act_nat_trans_data
              P
              (path_groupoid_compositor f g) z))
    =
    ((maponpaths g (pr1 hf ((pr1 ((poly_path_groupoid P) X)) z))
    @ pr1 hg (poly_map P f ((pr1 ((poly_path_groupoid P) X)) z)))
    @ maponpaths hZ
        (poly_comp P f g ((pr1 ((poly_path_groupoid P) X)) z)))
    @ maponpaths hZ
        ((pr11 (psnaturality_of (poly_path_groupoid P) (λ x, g (f x)))) z).
  Proof.
    refine (!_).
    do 2 refine (!(path_assoc _ _ _) @ _).
    do 2 refine (_ @ path_assoc _ _ _).
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      apply maponpathscomp0.
    }
    refine (!(path_assoc _ _ _) @ _).
    apply maponpaths.
    etrans.
    {
      apply maponpaths.
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        exact (!(maponpathscomp0 hZ _ _)).
      }
      exact (!(maponpathscomp0 hZ _ _)).
    }
    refine (!_).
    etrans.
    {
      apply maponpaths.
      exact (!(maponpathscomp0 hZ _ _)).
    }
    refine (!_).
    etrans.
    {
      refine (path_assoc _ _ _ @ _).
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths_2.
        apply (maponpathscomp hY g).
      }
      exact (homotsec_natural'
               (pr1 hg)
               (pr11 (psnaturality_of (poly_path_groupoid P) f) z)).
    }
    refine (!(path_assoc _ _ _) @ _).
    apply maponpaths.
    etrans.
    {
      apply maponpaths_2.
      exact (!(maponpathscomp _ hZ _)).
    }
    refine (!(maponpathscomp0 hZ _ _) @ _).
    apply maponpaths.
    exact (prealg_path_groupoid_compositor_lemma f g z).
  Qed.

  Definition prealg_path_groupoid_compositor
             {X Y Z : one_types}
             {f : one_types ⟦ X, Y ⟧}
             {g : one_types ⟦ Y, Z ⟧}
             {hX : (disp_alg_bicat (⟦ P ⟧)) X}
             {hY : (disp_alg_bicat (⟦ P ⟧)) Y}
             {hZ : (disp_alg_bicat (⟦ P ⟧)) Z}
             (hf : hX -->[ f] hY)
             (hg : hY -->[ g] hZ)
    : alg_disp_cat_2cell
        ⦃ P ⦄
        _ _ _ _
        (psfunctor_comp path_groupoid f g)
        _ _
        (prealg_mor_inv hf;; prealg_mor_inv hg)%mor_disp
        (prealg_mor_inv (hf;; hg)).
  Proof.
    use nat_trans_eq.
    { apply homset_property. }
    intros z.
    etrans.
    {
      refine (maponpaths (λ z, (z @ _) @ _) _).
      refine (pathscomp0rid _ @ _).
      refine (maponpaths (λ z, z @ _) _).
      apply pathscomp0rid.
    }
    refine (!_).
    etrans.
    {
      refine (maponpaths (λ z, (z @ _) @ _) _).
      refine (pathscomp0rid
                ((maponpaths
                    g
                    (prealg_path_groupoid_mor_comp hf z)
                  @ idpath _)
                  @  prealg_path_groupoid_mor_comp hg (poly_map P f z))
                @ _).
      refine (maponpaths (λ z, z @ _) _).
      apply pathscomp0rid.
    }
    exact (prealg_path_groupoid_compositor_equation hf hg z).
  Qed.

  Definition prealg_path_groupoid
    : disp_psfunctor
        (disp_alg_bicat (⟦ P ⟧))
        (disp_alg_bicat ⦃ P ⦄) path_groupoid.
  Proof.
    use make_disp_psfunctor.
    - apply disp_2cells_isaprop_alg.
    - apply disp_locally_groupoid_alg.
    - exact prealg_path_groupoid_map.
    - exact @prealg_mor_inv.
    - abstract
        (intros X Y f g p hX hY hf hg hp ;
         use nat_trans_eq ;
         [ apply homset_property
         | exact (prealg_path_groupoid_cell hp) ]).
    - abstract
        (intros X XX ;
         use nat_trans_eq ;
         [ apply homset_property
         | exact (prealg_path_groupoid_identitor XX)]).
    - exact @prealg_path_groupoid_compositor.
  Defined.
End LiftPseudofunctor.


Set Implicit Arguments.

Require Import GoodFunction.

Definition IsGoodModuleName (s : string) := prefix "_" s = false.

Record GoodModule :=
  {
    Name : string;
    GoodModuleName : IsGoodModuleName Name;
    Functions : list GoodFunction;
    NoDupFuncNames : NoDup (map (fun (f : GoodFunction) => SyntaxFunc.Name f) Functions)
  }.


From Velus Require Import Common.
From Velus Require Import Operators.
From Velus Require Import CoreExpr.CESyntax.
From Velus Require Import Stc.StcSyntax.
From Velus Require Import Clocks.

From Coq Require Import List.
Import List.ListNotations.
Open Scope list_scope.

Module Type STCISVARIABLE
       (Import Ids   : IDS)
       (Import Op    : OPERATORS)
       (Import CESyn : CESYNTAX     Op)
       (Import Syn   : STCSYNTAX Ids Op CESyn).

  Inductive Is_variable_in_tc: ident -> trconstr -> Prop :=
  | VarTcDef:
      forall x ck e,
        Is_variable_in_tc x (TcDef x ck e)
  | VarTcCall:
      forall x i xs ck rst f es,
        In x xs ->
        Is_variable_in_tc x (TcCall i xs ck rst f es).

  Definition Is_variable_in (x: ident) (tcs: list trconstr) : Prop :=
    Exists (Is_variable_in_tc x) tcs.

  Lemma Is_variable_in_variables:
    forall tcs x,
      Is_variable_in x tcs <-> In x (variables tcs).
  Proof.
    unfold variables.
    induction tcs as [|[]]; simpl.
    - split; try contradiction; inversion 1.
    - split.
      + inversion_clear 1 as [?? Var|]; try inv Var; auto.
        right; apply IHtcs; auto.
      + intros [E|].
        * subst; left; constructor.
        * right; apply IHtcs; auto.
    - setoid_rewrite <-IHtcs; split.
      + inversion_clear 1 as [?? Var|]; auto; inv Var.
      + right; auto.
    - setoid_rewrite <-IHtcs; split.
      + inversion_clear 1 as [?? Var|]; auto; inv Var.
      + right; auto.
    - split.
      + inversion_clear 1 as [?? Var|]; try inv Var.
        * apply in_app; auto.
        * apply in_app; right; apply IHtcs; auto.
      + rewrite in_app; intros [?|?].
        * left; constructor; auto.
        * right; apply IHtcs; auto.
  Qed.

  Definition is_variable_in_tc_b (x: ident) (tc: trconstr) : bool :=
    match tc with
    | TcDef x' _ _ => ident_eqb x x'
    | TcCall _ xs _ _ _ _ => existsb (ident_eqb x) xs
    | _ => false
    end.

  Fact Is_variable_in_tc_reflect:
    forall x tc,
      Is_variable_in_tc x tc <-> is_variable_in_tc_b x tc = true.
  Proof.
    destruct tc; simpl; split;
      try discriminate; try now inversion 1.
    - inversion_clear 1; apply ident_eqb_refl.
    - rewrite ident_eqb_eq; intro; subst; constructor.
    - inversion_clear 1.
      apply existsb_exists; eexists; split; eauto.
      apply ident_eqb_refl.
    - rewrite existsb_exists; intros (?&?& E).
      apply ident_eqb_eq in E; subst.
      constructor; auto.
  Qed.

  Lemma Is_variable_in_tc_dec:
    forall x tc,
      { Is_variable_in_tc x tc } + { ~ Is_variable_in_tc x tc }.
  Proof.
    intros;
      eapply Bool.reflect_dec, Bool.iff_reflect, Is_variable_in_tc_reflect.
  Qed.

  (* Definition variables_tc (vars: PS.t) (tc: trconstr) : PS.t := *)
  (*   match tc with *)
  (*   | TcDef x _ _         => PS.add x vars *)
  (*   | TcCall _ xs _ _ _ _ => ps_adds xs vars *)
  (*   | _ => vars *)
  (*   end. *)

  (* Lemma variables_tc_empty: *)
  (*   forall x tc vars, *)
  (*     PS.In x (variables_tc vars tc) *)
  (*     <-> PS.In x (variables_tc PS.empty tc) \/ PS.In x vars. *)
  (* Proof. *)
  (*   split; intro Hin. *)
  (*   - destruct tc; simpl in *; auto. *)
  (*     + apply PSE.MP.Dec.F.add_iff in Hin as [|]; subst; intuition. *)
  (*     + rewrite ps_adds_spec in *; tauto. *)
  (*   - destruct tc; simpl in *; destruct Hin as [Hin|Hin]; auto. *)
  (*     + rewrite PSE.MP.Dec.F.add_iff in *; intuition; pose proof (not_In_empty x); contradiction. *)
  (*     + rewrite PSE.MP.Dec.F.add_iff; auto. *)
  (*     + pose proof (not_In_empty x); contradiction. *)
  (*     + pose proof (not_In_empty x); contradiction. *)
  (*     + rewrite ps_adds_spec in *; intuition; pose proof (not_In_empty x); contradiction. *)
  (*     + rewrite ps_adds_spec; tauto. *)
  (* Qed. *)

End STCISVARIABLE.

Module StcIsVariableFun
       (Ids   : IDS)
       (Op    : OPERATORS)
       (CESyn : CESYNTAX     Op)
       (Syn   : STCSYNTAX Ids Op CESyn)
<: STCISVARIABLE Ids Op CESyn Syn.
  Include STCISVARIABLE Ids Op CESyn Syn.
End StcIsVariableFun.


Require Import Coq.Strings.String.
Require Import Psatz.

Require Export SystemFR.TWFLemmas.
Require Export SystemFR.SubstitutionLemmas.
Require Export SystemFR.FVLemmas.

Open Scope string_scope.
Open Scope list_scope.

Opaque PeanoNat.Nat.eq_dec.

Lemma open_close:
  forall t rep x k,
    wf t k ->
    open k (close k t x) rep = psubstitute t ((x, rep) :: nil) term_var.
Proof.
  induction t;
    repeat step || t_equality || list_utils; eauto with lia.
Qed.

Lemma open_close2:
  forall t x k,
    wf t k ->
    open k (close k t x) (fvar x term_var) = t.
Proof.
  induction t;
    repeat step || t_equality || list_utils; eauto with lia.
Qed.

Lemma topen_tclose:
  forall T rep x k,
    twf T k ->
    topen k (tclose k T x) rep = psubstitute T ((x, rep) :: nil) type_var.
Proof.
  induction T;
    repeat step || t_equality || list_utils; eauto with lia.
Qed.

Lemma topen_tclose2:
  forall T X k,
    twf T k ->
    topen k (tclose k T X) (fvar X type_var) = T.
Proof.
  induction T;
    repeat step || t_equality || list_utils; eauto with lia.
Qed.

Lemma topen_twice:
  forall A B R X k,
    ~(X ∈ pfv A type_var) ->
    ~(X ∈ pfv B type_var) ->
    twf A (S (S k)) ->
    twf B 1 ->
    twf R 0 ->
      topen k (topen (S k) A (topen 0 B R)) R =
      topen k (tclose k (topen (S k) A (topen 0 B (fvar X type_var))) X) R.
Proof.
  induction A; repeat step || t_equality || apply_any || list_utils;
    eauto with twf lia.
  - rewrite topen_tclose;
      repeat step || fv_open || list_utils || apply twf_topen;
      eauto with twf lia.
    + rewrite substitute_topen3; steps.
      rewrite substitute_nothing; steps.
      rewrite topen_none; steps; eauto with twf.
      apply twf_monotone with 0; eauto with twf lia.
    + apply twf_monotone with 0; try lia.
      apply twf_topen; steps.
Qed.


From Coq Require Import List ZArith String.

Inductive KVstore_op := GET | PUT.

Local Set Warnings "-ambiguous-paths".

Definition byte := Byte.byte.

Definition Bytes := list byte.
Definition bytes_of_string s : Bytes := String.list_byte_of_string s.
Coercion bytes_of_string : string >-> Bytes.

Axiom size_t : Type.
Axiom nat_of_size_t : size_t -> nat.
Coercion nat_of_size_t : size_t >-> nat.
Axiom size_t_of_nat : nat -> size_t.
Coercion size_t_of_nat : nat >-> size_t.
Axiom size_t_lt : size_t -> size_t -> bool.
Axiom size_t_eqb : size_t -> size_t -> bool.
Definition size_t_neqb x y := negb (size_t_eqb x y).

Axiom uint32_t : Type.
Axiom nat_of_uint32_t : uint32_t -> nat.
Coercion nat_of_uint32_t : uint32_t >-> nat.
Axiom uint32_t_of_nat : nat -> uint32_t.
Coercion uint32_t_of_nat : nat >-> uint32_t.
Axiom uint32_t_of_bytes : Bytes -> uint32_t.
Axiom bytes_of_uint32_t : uint32_t -> Bytes.
Axiom uint32_t_lt : uint32_t -> uint32_t -> bool.
Axiom uint32_t_eqb : uint32_t -> uint32_t -> bool.
Definition uint32_t_neqb x y := negb (uint32_t_eqb x y).

Axiom int32_t : Type.
Axiom Z_of_int32_t : int32_t -> Z.
Coercion Z_of_int32_t : int32_t >-> Z.
Axiom int32_t_of_Z : Z -> int32_t.
Coercion int32_t_of_Z : Z >-> int32_t.
Axiom int32_t_of_bytes : Bytes -> int32_t.
Axiom bytes_of_int32_t : int32_t -> Bytes.
Axiom int32_t_lt : int32_t -> int32_t -> bool.
Axiom int32_t_eqb : int32_t -> int32_t -> bool.
Definition int32_t_neqb x y := negb (int32_t_eqb x y).

Declare Scope sz.
Delimit Scope sz with sz.
Infix "<" := size_t_lt : sz.
Infix "==" := size_t_eqb (at level 70) : sz.
Infix "!=" := size_t_neqb (at level 70) : sz.

Declare Scope ui32.
Delimit Scope ui32 with ui32.
Infix "<" := uint32_t_lt : ui32.
Infix "==" := uint32_t_eqb (at level 70) : ui32.
Infix "!=" := uint32_t_neqb (at level 70) : ui32.

Declare Scope i32.
Delimit Scope i32 with i32.
Infix "<" := int32_t_lt : i32.
Infix "==" := int32_t_eqb (at level 70) : i32.
Infix "!=" := int32_t_neqb (at level 70) : i32.

Definition Key := uint32_t.
Definition Value := uint32_t.

Record KVstore_get_pkt :=
  { kvget_key: Key }.

Record KVstore_put_pkt :=
  { kvput_key: Key;
    kvput_value: Value }.

Record KVstore_pkt :=
  { kvpkt_op: KVstore_op;
    kvpkt_data:
      match kvpkt_op with
      | GET => KVstore_get_pkt
      | PUT => KVstore_put_pkt
      end }.

Record Buffer :=
  { buf_sz: size_t;
    buf_data: Bytes }.

(* buf_data_sz: List.length buf_data <= nat_of_size_t buf_sz *)

Open Scope string_scope.

Import ListNotations.

Fixpoint replace_nth {A} (n: nat) (l: list A) (a: A) :=
  match l, n with
  | [], _ => []
  | _ :: t, 0 => a :: t
  | h :: t, S n => h :: replace_nth n t a
  end.

Fixpoint take {A} (l: list A) (len: nat) (placeholder: A) : list A :=
  match len with
  | 0 => []
  | S len => (List.hd placeholder l) :: take (List.tl l) len placeholder
  end.

Fixpoint slice {A} (l: list A) (off: nat) (len: nat) (placeholder: A) : list A :=
  match off with
  | 0 => take l len placeholder
  | S off => slice (List.tl l) off len placeholder
  end.

Fixpoint blit0 {A} (dst src: list A) : list A :=
  match src with
  | [] => dst
  | hd :: src => hd :: blit0 (List.tl dst) src
  end.

Fixpoint blit {A} (dst: list A) (off: nat) (src: list A) (placeholder: A) : list A :=
  match off with
  | 0 => blit0 dst src
  | S off => (List.hd placeholder dst) :: blit (List.tl dst) off src placeholder
  end.

Definition bytes_write (l: Bytes) (n: size_t) (b: byte) :=
  replace_nth n l b.

Definition bytes_read (l: Bytes) (n: size_t) :=
  nth n l Byte.x00.             (* FIXME inhabited typeclass *)

Definition bytes_borrow (l: Bytes) (off: size_t) (len: size_t) : Bytes :=
  slice l off len Byte.x00.

Definition bytes_unborrow (l: Bytes) (off: size_t) (bs: Bytes) : Bytes :=
  blit l off bs Byte.x00.

Definition bytes_read_uint32 (bs: Bytes) (off: size_t) :=
  uint32_t_of_bytes (slice bs off 4 Byte.x00).

Definition bytes_write_uint32 (bs: Bytes) (off: size_t) (u: uint32_t) :=
  blit bs off (bytes_of_uint32_t u) Byte.x00.

Record box {A: Type} :=
  { box_val: A }.
Arguments box A : clear implicits.

Definition array_borrow_nth {A} (l: list A) (n: size_t) (placeholder: A) : A :=
  nth n l placeholder.

Definition array_unborrow_nth {A} (l: list A) (n: size_t) (a: A) :=
  replace_nth n l a.

Definition strlen s : size_t :=
  String.length s.

(* FIXME: should be a uniform annotation “borrow” coupled with a data access *)
Definition buf_borrow_data (b: Buffer) :=
  b.(buf_data).

Definition buf_unborrow_data (b: Buffer) (bs: Bytes) :=
  {| buf_sz := b.(buf_sz); buf_data := bs |}.

Require Import Arith PeanoNat.

Require Import Coq.Program.Wf.
Require Import Psatz.

Program Fixpoint ranged_for_nat {A}
        (from to step: nat)
        (body: forall (idx: size_t) (acc: A), (bool * A))
        (a0: A) {measure (to - from)} :=
  if le_gt_dec to from then a0
  else let (continue, a0) := body from a0 in
       if continue then
         ranged_for_nat (from + S (pred step)) to step body a0
       else a0.
Next Obligation.
  lia.
Defined.

Definition ranged_for {A}
           (from to step: size_t)
           (body: forall (idx: size_t) (acc: A), (bool * A))
           (a0: A) :=
  ranged_for_nat from to step body a0.

Definition ranged_for_c {A}
           (from to step: size_t)
           (body: forall (idx: size_t) (acc: A), A)
           (a0: A) :=
  ranged_for_nat from to step (fun idx acc => (true, body idx acc)) a0.

Definition memcpy
           (dst: Bytes) (dst_start: size_t)
           (src: Bytes) (src_start: size_t)
           (len: size_t) :=
  let dst := ranged_for_c 0 len 1 (fun idx dst =>
                                    let src_off := src_start + idx in
                                    let dst_off := dst_start + idx in
                                    let b := bytes_read src src_off in
                                    bytes_write dst dst_off b)
                       dst in
  dst.

From Coq Require Import Bool.

Definition byte_cmp (b1 b2: byte) : int32_t :=
  let n1 := Byte.to_N b1 in
  let n2 := Byte.to_N b2 in
  match N.compare n1 n2 with
  | Eq => 0
  | Lt => -1
  | Gt => 1
  end%Z.

Definition memcmp (* FIXME: do short-circuiting version *)
           (dst: Bytes) (dst_start: size_t)
           (src: Bytes) (src_start: size_t)
           (len: size_t) : int32_t :=
  let cmp := ranged_for 0 len 1 (fun idx _ =>
                                  let src_off := src_start + idx in
                                  let dst_off := dst_start + idx in
                                  let src_b := bytes_read src src_off in
                                  let dst_b := bytes_read dst dst_off in
                                  let cmp := byte_cmp src_b dst_b in
                                  let continue := (cmp != 0)%Z%i32 in
                                  (continue, cmp))
                       0%Z in
  cmp.

Definition buf_memcpy
           (dst: Buffer) (dst_start: size_t)
           (src: Bytes) (src_start: size_t)
           (len: size_t) :=
  let dst_data := buf_borrow_data dst in
  let dst_data := memcpy dst_data dst_start src src_start len in
  let buf := buf_unborrow_data dst dst_data in
  buf.

Definition buf_write (dst: Buffer) (off: size_t) (c: byte) :=
  let data := buf_borrow_data dst in
  let data := bytes_write data off c in
  let buf := buf_unborrow_data dst data in
  buf.

Definition buf_set_sz (buf: Buffer) (sz: size_t) :=
  {| buf_data := buf.(buf_data); buf_sz := sz |}.

Definition writeout (output: Buffer) (header: string)
           (data: Bytes) (data_len: size_t) : Buffer :=
  let output_len := output.(buf_sz) in
  if (data_len < output_len)%sz then
    let header_len := strlen header in
    let output := buf_memcpy output 0 header 0 header_len in
    let output := buf_memcpy output header_len data 0 data_len in
    let output := buf_set_sz output (output_len + 1) in
    let output := buf_write output output_len Byte.x0a in
    output
  else output.

Definition OK := "OK ".
Definition ERR := "ERR ".
Definition INPUT_TOO_SHORT := "input too short".
Definition UNRECOGNIZED_OPERATION := "unrecognized operation".
Definition NOT_FOUND := "not found".
Definition STORE_FULL := "store full".

Definition err (buf: Buffer) (s: string) : Buffer :=
  let buf := writeout buf ERR s (strlen s) in
  buf.

Fixpoint list_const {A} (len: nat) (a0: A) : list A :=
  match len with
  | 0 => []
  | S len => a0 :: list_const len a0
  end.

Definition alloca (sz: size_t) : Bytes :=
  list_const sz Byte.x00.

Definition ok (buf: Buffer) (v: Value) : Buffer :=
  let bytes := alloca 4 in
  let bytes := bytes_write_uint32 bytes 0 v in
  let buf := writeout buf ERR bytes 4 in
  buf.

Record KV :=
  { kv_key: Key;
    kv_value: Value }.

Definition kv_set_key (kv: KV) (k: Key) :=
  {| kv_key := k; kv_value := kv.(kv_value) |}.
Definition kv_set_value (kv: KV) (v: Value) :=
  {| kv_key := kv.(kv_key); kv_value := v |}.

Record KVstore :=
  { kvs_sz: size_t;
    kvs_capacity: size_t;
    kvs_data: list KV }.

(* FIXME make an inhabited typeclass to avoid having to specify these placeholders *)
Definition kv_placeholder :=
  {| kv_key := 0; kv_value := 0 |}.

(* FIXME: should be a uniform annotation “borrow” coupled with a data access *)
Definition kvs_borrow_data (kvs: KVstore) :=
  kvs.(kvs_data).

(* FIXME borrow/unborrow could be handled uniformly as lenses *)
Definition kvs_unborrow_data (kvs: KVstore) (data: list KV) :=
  {| kvs_sz := kvs.(kvs_sz);
     kvs_capacity := kvs.(kvs_capacity);
     kvs_data := data |}.

Definition kvs_set_sz (kvs: KVstore) (sz: size_t) :=
  {| kvs_sz := sz;
     kvs_capacity := kvs.(kvs_capacity);
     kvs_data := kvs.(kvs_data) |}.

Definition kv_step (state: KVstore) (input: Buffer) (output: Buffer) : KVstore * Buffer :=
  let input_sz := input.(buf_sz) in
  if (input_sz < 3)%sz then
    let output := err output INPUT_TOO_SHORT in
    (state, output)
  else
    let input_data := buf_borrow_data input in
    let op := bytes_borrow input_data 0 3 in
    if (memcmp op 0 "GET" 0 3 == 0%Z)%i32 then
      (if (input_sz < 8)%sz then
         let output := err output INPUT_TOO_SHORT in
         (state, output)
       else
         (* The loop returns an index instead of a value because that makes
            borrowing the value at that index easier; FIXME think of a way to do
            the borrowing as part of the loop *)
         let key0 := bytes_read_uint32 input_data 4 in
         let sz := state.(kvs_sz) in
         let kvs_data := kvs_borrow_data state in
         let found_idx :=
             ranged_for 0 sz 1
                        (fun idx found_idx =>
                           let kv := array_borrow_nth kvs_data idx kv_placeholder in
                           let key := kv.(kv_key) in
                           let kvs_data := array_unborrow_nth kvs_data found_idx kv in
                           let found_idx := if (key == key0)%ui32 then idx else found_idx in
                           let continue := (found_idx == sz)%sz in
                           (continue, found_idx))
                        sz in
         (* FIXME How do we handle conditional mutation?
            E.g. how would it look if we did the unborrowing after the if? *)
         if (found_idx < sz)%sz then
           let kv := array_borrow_nth kvs_data found_idx kv_placeholder in
           let value := kv.(kv_value) in
           let output := ok output value in
           let kvs_data := array_unborrow_nth kvs_data found_idx kv in
           let state := kvs_unborrow_data state kvs_data in
           (state, output)
         else
           let output := err output NOT_FOUND in
           let state := kvs_unborrow_data state kvs_data in
           (state, output))
    else if (memcmp op 0 "PUT" 0 3 == 0%Z)%i32 then
           (if (input_sz < 12)%sz then
              let output := err output INPUT_TOO_SHORT in
              (state, output)
            else
              let sz := state.(kvs_sz) in
              let capacity := state.(kvs_capacity) in
              if (sz < capacity)%sz then
                let kvs_data := kvs_borrow_data state in
                let key := bytes_read_uint32 input_data 4 in
                let value := bytes_read_uint32 input_data 8 in
                let kv := array_borrow_nth kvs_data sz kv_placeholder in
                let kv := kv_set_key kv key in
                let kv := kv_set_value kv value in
                let kvs_data := array_unborrow_nth kvs_data sz kv in
                let sz := sz + 1 in
                let state := kvs_set_sz state sz in
                let state := kvs_unborrow_data state kvs_data in
                let output := ok output value in
                (state, output)
              else
                let output := err output STORE_FULL in
                (state, output))
         else
           let output := err output UNRECOGNIZED_OPERATION in
           (state, output).


From ITree Require Import ITree.
From compcert Require Coqlib.
From Paco Require Import paco.

Require Import sflib.
Require Import Axioms StdlibExt IntegersExt.

Require Import SysSem.
Require Import IPModel DiscreteTimeModel.
Require Import RTSysEnv.
Require Import NWSysModel SyncSysModel.
Require Import ProgSem.

Require Import List.
Require Import Arith ZArith Lia.

Require Import Relation_Operators.

(* Definition filter_by_dest {A} *)
(*            (tids_dest: list Tid) *)
(*            (smsgs: list (Tid * A?)) *)
(*   : list A? := *)
(*   (* let (tid_s, dmsgs) := smsgs in *) *)
(*   filtermap (chget_by_dest tids_dest) smsgs. *)

Module AANode.

  Section ABST_ASYNC_NODE.
    Import SNode.

    Context {sysE: Type -> Type}.
    Context `{SystemEnv}.
    (* Context {msgT: Set}. *)
    (* Context `{rnws_params}. *)
    Let msgT: Set := bytes.
    Notation appE := (sysE +' bsendE).
    Notation t := (@SNode.t sysE msgT).

    (* Definition istate (node: @SNode.t sysE msgT): Type := *)
    (*   nat(*sytm*) * nat(*ocnt*) * *)
    (*   list (list msgT)(*inbc*) * node.(app_state). *)
    (*   (* IState (sytm: nat) (old_msg_cnt: nat) *) *)
    (*   (*        (ast: node.(app_state)). *) *)
    Inductive stage_t: Type :=
    | Ready (sytm: nat) (inbc: list (list msgT))
    | Running (sytm: nat) (sh: list bool)
    | Done
    .

    Definition istate_t (node: @SNode.t sysE msgT): Type :=
      nat(*ocnt*) * stage_t * node.(app_state).

    Inductive istate_wf (node: @SNode.t sysE msgT)
      : istate_t node -> Prop :=
      IStateWf
        ocnt stg ast
        (WF_SEND_HIST:
           forall sytm sh
             (STAGE_RUNNING: stg = Running sytm sh),
             length sh = num_tasks)
      : istate_wf node (ocnt, stg, ast).

    Record state: Type :=
      State { task_id: Tid;
              node: @SNode.t sysE msgT;
              (* mcast_ids: list Tid; *)
              (* num_nodes: nat; *)

              inbox_n: list (list msgT);
              istate: (istate_t node)?;
            }.

    Inductive state_wf (tid: Tid)
      : state -> Prop :=
      StateWf
        nd (* mids *) inbn oist
        (* (WF_NODE: SNode.wf mcasts' nd) *)
        (* (MCAST_IDS: SysEnv.get_mcast_of tid = mids) *)
        (INBN_LENGTH: length inbn = num_tasks)
        (ISTATE_WF: option_rel1 (istate_wf nd) oist)
      : state_wf tid (State tid nd inbn oist).

    Definition init_inbox: list (list msgT) :=
      List.repeat [] num_tasks.

    Definition inbox_sz (inb: list (list msgT)): nat :=
      length (concat inb).

    Definition init_state (tid: Tid) (node: t) : state :=
      State tid node (* (SysEnv.get_mcast_of tid) *)
            init_inbox None.

    Lemma wf_init_state
          tid nd
      : state_wf tid (init_state tid nd).
    Proof.
      econs; eauto.
      - unfold init_inbox.
        rewrite repeat_length. ss.
      - econs.
    Qed.

    Fixpoint merge_inbox
             (inbn inbn_arr: list (list msgT))
      : list (list msgT) :=
      match inbn with
      | [] => []
      | ent1 :: ents1 =>
        match inbn_arr with
        | [] => inbn
        | ent2 :: ents2 =>
          (ent1 ++ ent2) :: merge_inbox ents1 ents2
        end
      end.

    Lemma merge_inbox_nils
          (inb: list (list msgT)) n
      : merge_inbox inb (repeat [] n) = inb.
    Proof.
      depgen n.
      induction inb as [| h t IH]; i; ss.
      destruct n; ss.
      rewrite IH. rewrite app_nil_r. ss.
    Qed.

    Lemma merge_inbox_length
          inb inb'
      : length (merge_inbox inb inb') =
        length inb.
    Proof.
      depgen inb'.
      induction inb as [| h t IH]; i; ss.
      destruct inb'; ss.
      f_equal. eauto.
    Qed.

    Lemma merge_inbox_size
          inb1 inb2
          (INBS_LEN_EQ: length inb1 = length inb2)
      : inbox_sz (merge_inbox inb1 inb2) =
        inbox_sz inb1 + inbox_sz inb2.
    Proof.
      unfold inbox_sz.
      remember (length inb1) as n eqn: INB_LEN1.
      rename INBS_LEN_EQ into INB_LEN2.
      depgen inb2. depgen inb1.

      induction n as [| n' IH]; i; ss.
      { destruct inb1; destruct inb2; ss. }
      destruct inb1 as [| h1 t1]; ss.
      destruct inb2 as [| h2 t2]; ss.

      repeat rewrite app_length.
      rewrite IH; eauto. nia.
    Qed.

    Lemma inbox_size_empty
      : inbox_sz init_inbox = 0.
    Proof.
      unfold init_inbox.
      generalize num_tasks as k.
      induction k as [|k' IH]; ss.
    Qed.

    Lemma merge_inbox_nth
          inb inb' n r
          (NTH: nth_error inb n = Some r)
      : nth_error (merge_inbox inb inb') n =
        Some (r ++ match nth_error inb' n with
                   | None => []
                   | Some r' => r'
                   end).
    Proof.
      revert inb inb' r NTH.
      induction n as [| n' IH]; i; ss.
      { destruct inb, inb'; clarify. ss.
        rewrite app_nil_r. ss. }
      destruct inb, inb'; ss.
      { rewrite app_nil_r. ss. }
      apply IH; eauto.
    Qed.

    Lemma merge_inbox_nth_None
          inb inb' n
          (NTH: nth_error inb n = None)
      : nth_error (merge_inbox inb inb') n = None.
    Proof.
      depgen inb. depgen inb'.
      induction n as [| n' IH]; i; ss.
      { desf. }
      desf.
      destruct inb'; ss; clarify.
      eauto.
    Qed.

    (* Definition istate_update_inbox *)
    (*            {node: @SNode.t sysE msgT} *)
    (*            (nsytm: nat) *)
    (*            (inbn: list (list msgT)) *)
    (*            (ist: istate_t node) *)
    (*   : (istate_t node)? := *)
    (*   let '(ocnt, stg, ast) := ist in *)
    (*   match stg with *)
    (*   | Done => Some (ocnt, Ready nsytm _, ast) *)
    (*   | _ => None *)
    (*   end. *)

    (* Definition filter_by_dest *)
    (*            (tid: Tid) (mids: list Tid) *)
    (*            (in_msgs: list (list (Tid * msgT))) *)
    (*   : list (list msgT) := *)
    (*   map (filtermap (check_dest tid mids)) *)

    (* Definition inbox_accept_msgs *)
    (*            (in_msgs: list (list (Tid * msgT))) *)
    (*            (inb: list (list msgT)) *)
    (*   : list (list msgT) := *)
    (*   let ms_new: list (list msgT) := *)
    (*       map (filter_by_dest tid  *)
    (*       map (filtermap (check_dest tid (mcast_groups node))) in_msgs in *)

    (* Definition filter_by_dest_opt *)
    (*            (ids_to_me: list Tid) *)
    (*            (om: (Tid * msgT)?) *)
    (*   : list msgT *)

    Definition get_msg_by_dest
               (tid: Tid)
               (om: (Tid * msgT)?)
      : list msgT :=
      match om with
      | None => []
      | Some (id_dest, msg) =>
        if orb (id_dest =? tid)
               (existsb (Nat.eqb id_dest) (get_mcast_of tid))
        then [msg] else []
      end.

    Definition accept_msgs (tm: DTime.t)
               (in_msgs: list (Tid * msgT)?)
               (st: state)
      : state :=
      match st with
      | State tid node inbn oist =>
        let inbn1 :=
            match exact_skwd_base_time period tm with
            | None => inbn
            | Some _ => init_inbox
            end
        in
        let ms_new := map (get_msg_by_dest tid) in_msgs in
        State tid node (merge_inbox inbn1 ms_new) oist
      end.

    Inductive choose_inbox_rowmsg
      : list msgT -> msgT? -> Prop :=
    | ChooseInboxRowmsg_Nil
      : choose_inbox_rowmsg [] None
    | ChooseInboxRowmsg_Nonnil
        ms msg
        (MSG_IN_ROW: In msg ms)
      : choose_inbox_rowmsg ms (Some msg)
    .

    Inductive abst_inbox
              (ocnt: nat) (inbc: list (list msgT))
              (* (inbc_a: list msgT?) *)
      : list msgT? -> nat -> Prop :=
    | AbstInbox_OK
        inbc_a
        (INBC_A: Forall2 choose_inbox_rowmsg inbc inbc_a)
      : abst_inbox ocnt inbc inbc_a O
    | AbstInbox_Error
        inbc_a ocnt'
        (TOO_MANY_MSGS: ocnt + length (concat inbc) > length inbc * 4)
      : abst_inbox ocnt inbc inbc_a ocnt'
    .

    Inductive sh_tau_steps (sh: list bool)
              (node: @SNode.t sysE msgT)
      : SNode.app_state node -> SNode.app_state node -> Prop :=
    | SHTau_Refl
        ast
      : sh_tau_steps sh node ast ast
    | SHTau_AppStep
        ast ast1 ast'
        (APP_STEP: node.(app_step) ast ast1)
        (TAU_REST: sh_tau_steps sh node ast1 ast')
      : sh_tau_steps sh node ast ast'
    | SHTau_SendHistBlocks
        tid msg snde
        ast ast1 ast'
        (SEND_EVENT: snde = AbstSendEvent tid msg)
        (AT_EVENT: node.(at_event) ast (EventCall (inr1 snde)))
        (AFT_EVENT: node.(after_event)
                           ast (Event (inr1 snde) tt) ast1)
        (OUTMSGS: check_send_hist sh tid = None)
        (TAU_REST: sh_tau_steps sh node ast1 ast')
      : sh_tau_steps sh node ast ast'
    .

    Definition process_outmsg (sh: list bool)
               (om: (Tid * msgT)?)
      : list bool * (Tid * msgT)? :=
      match om with
      | None => (sh, None)
      | Some (tid_d, msg) =>
        match check_send_hist sh tid_d with
        | None => (sh, None)
        | Some sh' => (sh', Some (tid_d, resize_bytes msg_size msg))
        end
      end.

    Inductive step (tm: DTime.t)
      : state -> tsp * events (nbE +' sysE) ->
        (Tid * msgT)? -> state -> Prop :=
    (* Off *)
    | Step_StayOff
        tid node inbn
      : step tm
             (State tid node inbn None)
             (0%Z, []) None
             (State tid node inbn None)

    | Step_TurnOn
        tid node inbn sytm
        ocnt ast
        (BASE_TIME: exact_skwd_base_time period tm = Some sytm)
        (OLD_CNT: ocnt <= inbox_sz inbn)
        (INIT_APP_STATE: node.(init_app_state) ast)
      : step tm
             (State tid node inbn None)
             (0%Z, []) None
             (State tid node inbn
                    (Some (ocnt, Done, ast)))
    (* On *)
    | Step_Fail
        tid node inbn ist
      : step tm
             (State tid node inbn (Some ist))
             (0%Z, []) None
             (State tid node inbn None)

    | Step_Sync
        tid node inbn
        ocnt sytm ast
        (SYNC_TIME: exact_skwd_base_time period tm = Some sytm)
      : step tm
             (State tid node inbn
                    (Some (ocnt, Done, ast)))
             (0%Z, []) None
             (State tid node inbn
                    (Some (ocnt, Ready sytm inbn, ast)))

    | Step_On_Stay
        tid node inbn
        ocnt stg ast
        (SYNC_TIME: exact_skwd_base_time period tm = None)
      : step tm
             (State tid node inbn
                    (Some (ocnt, stg, ast)))
             (0%Z, []) None
             (State tid node inbn
                    (Some (ocnt, stg, ast)))

    | Step_StartRun
        tid node inbn
        ocnt sytm inbc ast
        inbc_a ocnt' ast' sh
        (SYNC_TIME: exact_skwd_base_time period tm = None)
        (INBOX: abst_inbox ocnt inbc inbc_a ocnt')
        (PERIOD_BEGIN: node.(period_begin)
                              (Z.of_nat sytm) inbc_a ast ast')
        (SEND_HIST: sh = List.repeat false num_tasks)
      : step tm
             (State tid node inbn
                    (Some (ocnt, Ready sytm inbc, ast)))
             (0%Z, []) None
             (State tid node inbn
                    (Some (ocnt', Running sytm sh, ast')))

    | Step_Running_Go
        tid node inbn
        ocnt sytm sh ast
        ast1 oe om sh' ast'
        es oms zsytm
        (SYNC_TIME: exact_skwd_base_time period tm = None)
        (TAU_STEPS: sh_tau_steps sh node ast ast1)
        (ISTEP: SNode.istep node ast1 oe om ast')
        (EVTS: es = opt2list oe)
        (OUTMSGS: (sh', oms) = process_outmsg sh om)
        (TIMESTAMP: zsytm = Z.of_nat sytm)
      : step tm
             (State tid node inbn
                    (Some (ocnt, Running sytm sh, ast)))
             (zsytm, es) oms
             (State tid node inbn
                    (Some (ocnt, Running sytm sh', ast')))

    | Step_Running_Done
        tid node inbn
        ocnt sytm sh ast ast_f
        (SYNC_TIME: exact_skwd_base_time period tm = None)
        (* (TAU_STEPS: clos_refl_trans *)
        (*           _ node.(app_step) ast ast_f) *)
        (TAU_STEPS: sh_tau_steps sh node ast ast_f)
        (PERIOD_END: node.(SNode.period_end) ast_f)
      : step tm
             (State tid node inbn
                    (Some (ocnt, Running sytm sh, ast)))
             (0%Z, []) None
             (State tid node inbn
                    (Some (ocnt, Done, ast_f)))
    .

    Lemma wf_prsv
          tm tid
          st es oms st'
          (STEP: step tm st es oms st')
          (WF_STATE: state_wf tid st)
      : state_wf tid st'.
    Proof.
      inv WF_STATE.
      destruct oist as [ist|].
      2: { inv STEP; ss. }
      inv STEP; ss.
      - existT_elim. clarify.
      - existT_elim. clarify.
        econs; eauto. ss.
        econs. i. clarify.
        apply repeat_length.
      - existT_elim. clarify.
        unfold process_outmsg in *.
        inv ISTATE_WF.
        destruct om as [[tid_d msg]|]; ss.
        2: { clarify. }
        destruct (check_send_hist sh tid_d) as [sh_nxt|] eqn: SH'.
        2: { clarify. }

        clarify.
        econs; eauto. ss.
        econs. i. clarify.
        apply check_send_hist_Some in SH'; eauto.
        nbdes. eauto.
    Qed.

    Lemma step_progress
          tm st
      : exists es oms st',
        step tm st es oms st'.
    Proof.
      destruct st as [tid nd inbn oist].
      destruct oist.
      - esplits. eapply Step_Fail.
      - esplits. econs 1.
    Qed.

    Lemma wf_accept_msgs_prsv
          tid st
          tm in_msgs
          (WF_STATE: state_wf tid st)
      : state_wf tid (accept_msgs tm in_msgs st).
    Proof.
      inv WF_STATE. ss.
      econs; ss.
      rewrite merge_inbox_length.
      desf; ss.
      unfold init_inbox.
      apply repeat_length.
    Qed.

    (* Inductive star (period: nat) (tm: DTime.t) *)
    (*   : state -> nat * events (nbE +' sysE) -> *)
    (*     list (Tid * msgT) -> state -> Prop := *)
    (* | Star_Base *)
    (*     st sytm *)
    (*   : star period tm *)
    (*          st (sytm, []) [] st *)
    (* | Star_Step *)
    (*     sytm st es1 oms1 st1 *)
    (*     es2 oms2 st' es oms *)
    (*     (STEP: step tm *)
    (*                 st (sytm, es1) oms1 st1) *)
    (*     (STAR_REST: star period (DTime.succ tm) *)
    (*                      st1 (sytm, es2) oms2 st') *)
    (*     (ES: es = es1 ++ es2) *)
    (*     (OMS: oms = oms1 ++ oms2) *)
    (*   : star period tm *)
    (*          st (sytm, es) oms st'. *)

  End ABST_ASYNC_NODE.
End AANode.

Module AASys.
  Section SYS.
    Import SyncSys.
    Context {sysE: Type -> Type}.
    (* Context {msgT: Set}. *)
    Context `{SystemEnv}.
    (* Let msgT: Set := bytes. *)

    Record state: Type :=
      State { time: DTime.t ;
              node_states: list (@AANode.state sysE) ;
            }.

    Inductive state_wf
      : state -> Prop :=
      StateWf
        tm nsts
        (WF_NSTS: iForall AANode.state_wf 0 nsts)
      : state_wf (State tm nsts).

    Definition init_state (tm_init: nat)
               (sys: list SNode.t): state :=
      let num_nodes := length sys in
      let nsts := imap AANode.init_state 0 sys in
      State (DTime.of_ns tm_init) nsts.

    Lemma wf_init_state
          tm sys
      : state_wf (init_state tm sys).
    Proof.
      econs.
      apply iForall_nth. i. ss. r.
      rewrite imap_nth_error_iff. ss.
      destruct (nth_error sys n); ss.
      apply AANode.wf_init_state.
    Qed.

    Inductive step
      : state -> list (tsp * events (nbE +' sysE)) ->
        state -> Prop :=
      Step_Run
        tm nsts tes outs nsts1 nsts' tm'
        (STEPS: Forall4 (AANode.step tm)
                        nsts tes outs nsts1)
        (ACCEPT_MSGS: List.map (AANode.accept_msgs tm outs)
                               nsts1 = nsts')
        (TIME: tm' = DTime.succ tm)
      : step (State tm nsts) tes (State tm' nsts').

    Lemma wf_prsv
          st tes st'
          (STEP: step st tes st')
          (WF: state_wf st)
      : state_wf st'.
    Proof.
      inv WF. inv STEP.
      econs.
      apply iForall_nth. i. ss. r.
      rewrite Coqlib.list_map_nth.
      destruct (nth_error nsts1 n) as [nst_n|] eqn:NST_N; ss.
      hexploit Forall4_nth4; eauto. i. des.
      eapply AANode.wf_accept_msgs_prsv.
      eapply AANode.wf_prsv; eauto.
      rewrite iForall_nth in WF_NSTS. ss.
      specialize (WF_NSTS n).
      rewrite NTH1 in WF_NSTS. ss.
    Qed.

    Lemma step_progress
          st
      : exists tes st', step st tes st'.
    Proof.
      destruct st as [tm nsts].
      assert (STEP_EX: forall n (N_UB: n < length nsts),
                 exists x,
                   option_rel4 (AANode.step tm)
                               (nth_error nsts n)
                               (Some (fst (fst x)))
                               (Some (snd (fst x)))
                               (Some (snd x))).
      { i. eapply nth_error_Some in N_UB.
        eapply Some_not_None in N_UB. des.
        hexploit (AANode.step_progress tm a).
        i. des.
        rewrite N_UB.
        exists (es, oms, st'). ss.
        econs. ss.
      }
      apply exists_list in STEP_EX. des.
      exists (map (fun x => fst (fst x)) l).
      esplits.
      econs; eauto.
      instantiate (1:= map (fun x => snd x) l).
      instantiate (1:= map (fun x => snd (fst x)) l).

      apply Forall4_nth. intro i.
      destruct (le_lt_dec (length nsts) i).
      - rewrite nth_error_None2; eauto.
        rewrite nth_error_None2.
        2: { rewrite map_length. nia. }
        rewrite nth_error_None2.
        2: { rewrite map_length. nia. }
        rewrite nth_error_None2.
        2: { rewrite map_length. nia. }
        econs.
      - assert (exists a, nth_error nsts i = Some a).
        { apply Some_not_None.
          eapply nth_error_Some. ss. }
        assert (X_EQ: exists x, nth_error l i = Some x).
        { apply Some_not_None.
          eapply nth_error_Some. rewrite LIST_LEN. ss. }
        des.

        hexploit NTH_PROP; eauto.
        repeat rewrite Coqlib.list_map_nth.
        rewrite X_EQ. ss.
    Qed.

    Definition num_sites (st: state): nat :=
      length st.(node_states).

    Program Definition as_dsys (sys: list SNode.t) (tm_init: nat): DSys.t :=
      DSys.mk state num_sites step
              (fun st => st = init_state tm_init sys) _.
    Next Obligation.
      splits.
      - unfold num_sites.
        inv STEP; ss.
        hexploit Forall4_length; eauto. i. des. ss.
        (* + rewrite repeat_length. ss. *)
        (* + hexploit Forall4_length; eauto. i. des. ss. *)
      - unfold num_sites.
        inv STEP; ss.
        rewrite map_length.
        hexploit Forall4_length; eauto. i. des. ss.
    Qed.

    Lemma safe
          tm nodes
      : DSys.safe (as_dsys nodes tm).
    Proof.
      econs.
      { exists (init_state tm nodes). ss. }
      i. ss.
      hexploit (wf_init_state tm nodes); eauto.
      rewrite <- INIT.
      clear INIT.
      revert st_i.

      pcofix CIH.
      intros st WF.
      pfold.
      econs.
      { eapply step_progress. }
      i. ss.
      right.
      hexploit wf_prsv; eauto.
    Qed.

  End SYS.
End AASys.