(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University

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

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

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

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

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

  Authors: Vincent Rahli

 *)

Require Export proof1.

(*
Lemma cequiv_open_unfold_lib {o} :
  forall lib,
    no_undefined_abs_in_lib lib
    -> forall (t : @NTerm o),
      wf_term t
      -> cequiv_open lib t (unfold_lib lib t).
Proof.
  nterm_ind1s t as [v|f ind|op bs ind] Case; introv isp; allsimpl.

  - Case "vterm".
    rewrite unfold_lib_vterm; eauto 3 with slow.

  - Case "sterm".
    rewrite unfold_lib_sterm.
    apply implies_cequiv_open_sterm; eauto 3 with slow.
    rewrite <- unfold_lib_sterm.
    eauto 3 with slow.

  - Case "oterm".

Lemma unfold_library_oterm_comp {o} :
  forall lib op (bs : list (@BTerm o)),
    reduces_to_al
      lib
      (oterm op (unfold_library_bterms lib bs))
      (unfold_library lib (oterm op bs)).
Proof.
  induction lib; introv; simpl; autorewrite with slow; eauto 3 with slow.
  rewrite unfold_entry_op_eq.
  destruct (dec_op_abs op) as [d|d]; exrepnd; subst; allsimpl.

  - unfold unfold_abs_entry.
    destruct a; allsimpl.
    boolvar.

    + assert (found_entry
                (lib_abs opabs vars rhs correct :: lib)
                abs
                (map (unfold_entry_bterm (lib_abs opabs vars rhs correct)) bs)
                opabs vars rhs correct) as fe.
      {
        unfold found_entry; simpl.
        boolvar; tcsp.
        apply not_matching_entry_iff in n; tcsp.
      }

      pose proof (compute_step_lib_success_change_bs
                    (lib_abs opabs vars rhs correct :: lib)
                    abs opabs
                    (map (unfold_entry_bterm (lib_abs opabs vars rhs correct)) bs)
                    (unfold_library_bterms
                       lib
                       (map (unfold_entry_bterm (lib_abs opabs vars rhs correct)) bs))
                    vars rhs correct) as h.
      repeat (autodimp h hyp).
      {
        unfold unfold_library_bterms.
        allrw map_map.
        unfold compose, num_bvars; apply eq_maps; introv i.
        destruct x as [l t]; simpl; auto.
      }

      eapply reduces_to_al_if_split2;[exact h|].
      clear h.

      remember (map (unfold_entry_bterm (lib_abs opabs vars rhs correct)) bs) as bs'.

      unfold mk_instance.
      destruct rhs as [v ts|f|op bs1].

      *

Lemma sosub_sovar_alpha_eq {o} :
  forall var (ts : list (@SOTerm o)) sub,
    alpha_eq
      (sosub sub (sovar var ts))
      (match sosub_find sub (var, length ts) with
       | Some (sosk vs u) => lsubst u (combine vs (map (sosub sub) ts))
       | None => apply_list (mk_var var) (map (sosub sub) ts)
       end).
Proof.
  introv.
  pose proof (unfold_sosub sub (sovar var ts)) as h; exrepnd.
  inversion h2 as [? ? ? len imp| |]; subst; clear h2.
  rewrite h1; simpl.
  allsimpl.
  remember (sosub_find sub' (var, length ts2)) as sf; symmetry in Heqsf; destruct sf.

  - destruct s.
    pose proof (sosub_find_some_if_alphaeq_sosub
                  sub' sub (var, length ts2) (sosk l n)) as q.
    repeat (autodimp q hyp); eauto 3 with slow.
    exrepnd.
    rewrite <- len in q0.
    rewrite q0.
    destruct sk'.

    applydup @sosub_find_some in Heqsf; repnd.
    applydup @sosub_find_some in q0; repnd.

    apply alphaeq_sk_iff_alphaeq_bterm2 in q1; simpl in q1.
    allrw disjoint_cons_l; repnd.

    assert (disjoint (sub_free_vars (combine l (map (sosub_aux sub') ts2)))
                     (bound_vars n)) as disj.
    {
      rewrite sub_free_vars_combine; autorewrite with slow; auto.
      rewrite flat_map_map; unfold compose.
      apply disjoint_sym.
      eapply disjoint_bound_vars_prop4; try (exact Heqsf1); eauto 2 with slow.
    }
    rewrite sub_free_vars_combine in disj; autorewrite with slow; auto.
    rewrite flat_map_map in disj; unfold compose in disj.

    rewrite <- lsubst_lsubst_aux;
      [|rewrite range_combine;autorewrite with slow;auto;
        rewrite flat_map_map;unfold compose;eauto 3 with slow
      ].

    eapply lsubst_alpha_congr4; try (exact q1);
    try (rewrite dom_sub_combine);autorewrite with slow; auto.

    apply implies_alphaeq_sub_range_combine; autorewrite with slow; auto; try omega.
    introv i.
    rewrite <- map_combine in i.
    apply in_map_iff in i; exrepnd; ginv.

    SearchAbout (alphaeq (sosub _ _) (sosub _ _)).

Qed.

      * admit.

      * admit.

      (* by cases on rhs? *)

      (*
      apply reduces_to_if_step.
      csunf; simpl.
      rewrite h; auto.
       *)

    + pose proof (IHlib
                    (Abs abs)
                    (map (unfold_entry_bterm (lib_abs opabs vars rhs correct)) bs))
        as q; clear IHlib.

      admit.

      (* Prove something like reduces_to_preserves_agreeing_libraries but
         assuming that the abstractions are not in the extension to the library.
         This is going to be useful in all 3 cases.
       *)

  - pose proof (IHlib op (map (unfold_entry_bterm a) bs)) as q; clear IHlib.

    admit.
Qed.

    pose proof (unfold_library_oterm_comp lib op bs) as h.

    eapply cequiv_open_trans;
      [|apply reduces_to_al_implies_cequiv_open;
         [|
          |]
      ].

    Focus 4.

    Check unfold_library_oterm_comp.
    SearchAbout cequiv_open reduces_to.

Lemma unfold_library_oterm {o} :
  forall lib,
    no_undefined_abs_in_lib lib
    ->
    forall op (bs : list (@BTerm o)),
      unfold_library lib (oterm op bs)
      = match dec_op_abs op with
        | inl (existT abs _) =>
          match unfold_abs lib abs bs with
          | Some t => unfold_library lib t
          | None => oterm op (unfold_library_bterms lib bs)
          end
        | _ => oterm op (unfold_library_bterms lib bs)
        end.
Proof.
  induction lib; introv noundef; introv; simpl; auto;
  autorewrite with slow; auto;
  destruct (dec_op_abs op) as [d|d]; exrepnd; subst; allsimpl; auto; repnd;
  autodimp IHlib hyp.

  - destruct a; allsimpl.
    boolvar.

    +

    + apply not_matching_entry_iff in n; destruct n.
      eapply matching_entry_change_bs;try (exact m).
      unfold unfold_library_bterms.
      allrw map_map; unfold compose.
      apply eq_maps; introv i.
      destruct x as [l t]; unfold num_bvars; simpl; auto.

    + apply not_matching_entry_iff in n; destruct n.
      eapply matching_entry_change_bs;try (exact m).
      unfold unfold_library_bterms.
      allrw map_map; unfold compose.
      apply eq_maps; introv i.
      destruct x as [l t]; unfold num_bvars; simpl; auto.

    + rewrite IHlib; simpl.
      destruct (dec_op_abs (Abs abs)) as [e|e]; exrepnd; ginv; auto.
      destruct e; eexists; eauto.

  - rewrite unfold_entry_op_eq.
    destruct (dec_op_abs op) as [e|e]; try (complete (destruct d; auto)); GC.
    rewrite IHlib.
    destruct (dec_op_abs op) as [e|e]; try (complete (destruct d; auto)); GC.
    auto.
Qed.

Qed.
*)

(* THIS IS WHERE I'M AT *)

(*
Lemma exists_all_defined {o} :
  forall lib,
    no_undefined_abs_in_lib lib
    -> forall (t : @NTerm o),
      isprog t
      -> cequiv lib t (unfold_lib lib t).
Proof.
  induction lib; intro nodef; simpl.

  - introv isp; dands.

    unfold unfold_lib; simpl.
    apply cequiv_nil_abs2bot; auto.

  - introv isp.
    unfold unfold_lib; allsimpl; repnd.
    autodimp IHlib hyp.
    pose proof (IHlib (unfold_entry a t)) as h; clear IHlib.
    autodimp h hyp; eauto 3 with slow; repnd.

    unfold unfold_lib in h.

    assert (cequiv
              (a :: lib)
              (unfold_entry a t)
              (abs2bot (unfold_library lib (unfold_entry a t)))) as ceq;
      [|eapply cequiv_trans;[|exact ceq];apply cequiv_unfold_entry;auto].

    (* we prove that using add_entry_to_cequiv (see below) *)

Fixpoint all_abstractions_not_defined {o} lib (t : @NTerm o) : obool :=
  match t with
  | vterm _ => otrue
  | sterm f => obseq (fun n => all_abstractions_not_defined lib (f n))
  | oterm op bs =>
    oband
      (bool2obool (negb (found_opid_in_library_sign lib op)))
      (oball (map (all_abstractions_not_defined_b lib) bs))
  end
with all_abstractions_not_defined_b {o} lib (b : @BTerm o) : obool :=
       match b with
       | bterm vs t => all_abstractions_not_defined lib t
       end.

Lemma add_entry_to_approx {o} :
  forall entry lib (t1 t2 : @NTerm o),
    wf_term t1
    -> wf_term t2
    -> isotrue (all_abstractions_not_defined [entry] t1)
    -> isotrue (all_abstractions_not_defined [entry] t2)
    -> approx lib t1 t2
    -> approx (entry :: lib) t1 t2.
Proof.
  nterm_ind t1 as [v|f ind|op bs ind] Case;
  introv wf1 wf2 iso1 iso2 apr; allsimpl; GC.

  Focus 2.

  - Case "vterm".
    inversion apr; subst.
    constructor.

Lemma approx_open_vterm_implies {o} :
  forall lib v (t : @NTerm o),
    approx_open lib (vterm v) t -> t = vterm v.
Proof.
  introv ceq.
  apply olift_cequiv_approx in ceq; repnd.
  clear ceq0.

  SearchAbout approx_open vterm.
Qed.

Qed.

Focus 2.

XXXXXXXXXXX

Qed.
 *)

Lemma free_vars_unfold_library {o} :
  forall lib (t : @NTerm o),
    subset (free_vars (unfold_library lib t)) (free_vars t).
Proof.
  induction lib; simpl; introv; auto.
  eapply subset_trans;[apply IHlib|].
  apply free_vars_unfold_entry.
Qed.

Lemma isprog_unfold_library {o} :
  forall lib (t : @NTerm o),
    isprog t
    -> isprog (unfold_library lib t).
Proof.
  introv isp; allrw @isprog_eq.
  inversion isp as [cl wf].
  constructor; allrw @nt_wf_eq; eauto 3 with slow.
  pose proof (free_vars_unfold_library lib t) as h.
  rewrite cl in h.
  apply subset_nil_implies_nil; auto.
Qed.

Lemma isprog_unfold_lib {o} :
  forall lib (t : @NTerm o),
    isprog t
    -> isprog (unfold_lib lib t).
Proof.
  introv isp.
  apply implies_isprog_abs2bot.
  apply isprog_unfold_library; auto.
Qed.

Definition unfold_libc {o} lib (t : @CTerm o) :=
  match t with
  | exist _ a p => mk_ct (unfold_lib lib a) (isprog_unfold_lib lib a p)
  end.

Lemma isotrue_all_abs_are_defined_unfold_lib {o} :
  forall lib1 lib2 (t : @NTerm o),
    isotrue (all_abstractions_are_defined lib1 (unfold_lib lib2 t)).
Proof.
  introv.
  apply isotrue_all_abs_are_defined_abs2bot.
Qed.

Lemma isotrue_all_abs_are_defined_cterm_unfold_libc {o} :
  forall lib1 lib2 (t : @CTerm o),
    isotrue (all_abstractions_are_defined_cterm lib1 (unfold_libc lib2 t)).
Proof.
  introv.
  destruct_cterms.
  unfold all_abstractions_are_defined_cterm; simpl.
  apply isotrue_all_abs_are_defined_unfold_lib.
Qed.
Hint Resolve isotrue_all_abs_are_defined_cterm_unfold_libc : slow.

Lemma isotrue_all_abs_are_defined_cterm_approx {o} :
  forall lib (a b : @CTerm o),
    isotrue (all_abstractions_are_defined_cterm lib a)
    -> isotrue (all_abstractions_are_defined_cterm lib b)
    -> isotrue (all_abstractions_are_defined_cterm lib (mkc_approx a b)).
Proof.
  introv h1 h2.
  destruct_cterms.
  allunfold @all_abstractions_are_defined_cterm; allsimpl.
  autorewrite with slow.
  apply isotrue_oband; auto.
Qed.

Lemma isotrue_all_abs_are_defined_cterm_cequiv {o} :
  forall lib (a b : @CTerm o),
    isotrue (all_abstractions_are_defined_cterm lib a)
    -> isotrue (all_abstractions_are_defined_cterm lib b)
    -> isotrue (all_abstractions_are_defined_cterm lib (mkc_cequiv a b)).
Proof.
  introv h1 h2.
  destruct_cterms.
  allunfold @all_abstractions_are_defined_cterm; allsimpl.
  autorewrite with slow.
  apply isotrue_oband; auto.
Qed.

Lemma approx_decomp_cequiv {p} :
  forall lib a b c d,
    approx lib (mk_cequiv a b) (@mk_cequiv p c d)
    <=> approx lib a c # approx lib b d.
Proof.
  split; unfold mk_cequiv; introv Hyp.
  - applydup @approx_relates_only_progs in Hyp. repnd.
    apply  approx_canonical_form2 in Hyp.
    unfold lblift in Hyp. repnd. allsimpl.
    alpharelbtd. GC.
    eapply blift_approx_open_nobnd in Hyp1bt; eauto 3 with slow.
    eapply blift_approx_open_nobnd in Hyp0bt; eauto 3 with slow.
  - repnd. applydup @approx_relates_only_progs in Hyp. repnd.
    applydup @approx_relates_only_progs in Hyp0. repnd.
    apply approx_canonical_form3.
    + apply isprogram_ot_iff. allsimpl. dands; auto. introv Hin.
      dorn Hin;[| dorn Hin]; sp;[|];
      subst; apply implies_isprogram_bt0; eauto with slow.
    + apply isprogram_ot_iff. allsimpl. dands; auto. introv Hin.
      dorn Hin;[| dorn Hin]; sp;[|];
      subst; apply implies_isprogram_bt0; eauto with slow.
    + unfold lblift. allsimpl. split; auto.
      introv Hin. unfold selectbt.
      repeat(destruct n; try (omega;fail); allsimpl);
      apply blift_approx_open_nobnd2; sp.
Qed.

Lemma cequiv_decomp_cequiv {p} :
  forall lib a b c d,
    cequiv lib (mk_cequiv a b) (@mk_cequiv p c d)
    <=> cequiv lib a c # cequiv lib b d.
Proof.
  intros.
  unfold cequiv.
  generalize (approx_decomp_cequiv lib a b c d); intro.
  trewrite X; clear X.
  generalize (approx_decomp_cequiv lib c d a b); intro.
  trewrite X; clear X.
  split; sp.
Qed.

Lemma cequivc_decomp_cequiv {p} :
  forall lib a b c d,
    cequivc lib (mkc_cequiv a b) (@mkc_cequiv p c d)
    <=> cequivc lib a c # cequivc lib b d.
Proof.
  destruct a, b, c, d.
  unfold cequivc, mkc_cequiv; simpl.
  apply cequiv_decomp_cequiv.
Qed.

Lemma cequivc_unfold_lib {o} :
  forall lib,
    no_undefined_abs_in_lib lib
    -> forall (t : @CTerm o),
      cequivc lib t (unfold_libc lib t).
Proof.
  (* see above *)
Admitted.

Definition ex_all_defined {o} lib (t : @CTerm o) :=
  {u : CTerm
   , ccequivc lib t u
   /\ isotrue (all_abstractions_are_defined_cterm lib u) }.

Lemma restrict_to_lib_eq_in_nuprl {o} :
  forall lib (T T' : @CTerm o) eq,
    no_undefined_abs_in_lib lib
    -> nuprl lib T T' eq
    ->
    (
      ex_all_defined lib T
      /\ forall t t', eq t t' -> ex_all_defined lib t
    ).
Proof.
  introv noundef n.
  dands.
  - pose proof (cequivc_unfold_lib lib noundef T) as h.
    exists (unfold_libc lib T); dands; spcast; eauto 3 with slow.
  - introv e.
    pose proof (cequivc_unfold_lib lib noundef t) as h.
    exists (unfold_libc lib t); dands; spcast; eauto 3 with slow.

    (*
  unfold nuprl in n.
  remember (univ lib) as ts.
  close_cases (induction n using @close_ind') Case; subst; introv.

  - Case "CL_init".
    duniv i h.

    revert dependent eq.
    revert dependent T.
    revert dependent T'.
    induction i; introv u; allsimpl; tcsp.
    repndors; exrepnd; spcast; try (complete (apply IHi in u; tcsp)).

    dands.

    + exists (@mkc_uni o i); dands; simpl; auto.
      spcast; eauto 3 with slow.

    + introv e.
      apply u in e; exrepnd.

      remember (univi lib i) as ts.
      close_cases (induction e0 using @close_ind') SCase; subst; introv.

      * SCase "CL_init".
        match goal with
        | [ H : univi _ _ _ _ _ |- _ ] => apply IHi in H; sp
        end.

      * SCase "CL_int".
        allunfold @per_int; repnd; spcast.
        exists (@mkc_int o); simpl; dands; spcast; eauto 3 with slow.

      * SCase "CL_atom".
        allunfold @per_atom; repnd; spcast.
        exists (@mkc_atom o); simpl; dands; spcast; eauto 3 with slow.

      * SCase "CL_uatom".
        allunfold @per_uatom; repnd; spcast.
        exists (@mkc_uatom o); simpl; dands; spcast; eauto 3 with slow.

      * SCase "CL_base".
        allunfold @per_base; repnd; spcast.
        exists (@mkc_base o); simpl; dands; spcast; eauto 3 with slow.

      * SCase "CL_approx".
        allunfold @per_approx; exrepnd; spcast.

        pose proof (cequivc_unfold_lib lib noundef a) as ha.
        pose proof (cequivc_unfold_lib lib noundef b) as hb.

        exists (mkc_approx (unfold_libc lib a) (unfold_libc lib b)); simpl; dands; spcast; eauto 3 with slow.

        {
          eapply cequivc_trans;[apply computes_to_valc_implies_cequivc; eauto|].
          apply cequivc_decomp_approx; auto.
        }

        {
          apply isotrue_all_abs_are_defined_cterm_approx; eauto 3 with slow.
        }

      * SCase "CL_cequiv".
        allunfold @per_cequiv; exrepnd; spcast.

        pose proof (cequivc_unfold_lib lib noundef a) as ha.
        pose proof (cequivc_unfold_lib lib noundef b) as hb.

        exists (mkc_cequiv (unfold_libc lib a) (unfold_libc lib b)); simpl; dands; spcast; eauto 3 with slow.

        {
          eapply cequivc_trans;[apply computes_to_valc_implies_cequivc; eauto|].
          apply cequivc_decomp_cequiv; auto.
        }

        {
          apply isotrue_all_abs_are_defined_cterm_cequiv; eauto 3 with slow.
        }

      *
*)
Qed.

Lemma tequality_cons_library_entry {o} :
  forall lib1 lib2 (t1 t2 : @CTerm o) eq,
    assert (wf_library lib1)
    -> assert (wf_library lib2)
    -> libraries_agree_on_intersection lib1 lib2
    -> no_repeats_lib lib2
    -> simple_no_undefined_abs_in_lib lib1
    -> simple_no_undefined_abs_in_lib lib2
    -> isotrue (all_abstractions_are_defined_cterm lib1 t1)
    -> isotrue (all_abstractions_are_defined_cterm lib1 t2)
    -> isotrue (all_abstractions_are_defined_cterm lib2 t1)
    -> isotrue (all_abstractions_are_defined_cterm lib2 t2)
    -> nuprl lib1 t1 t2 eq
    -> nuprl lib2 t1 t2 eq.
Proof.
  introv wflib1 wflib2 agree norep undef1 undef2;
  introv iso11 iso12 iso21 iso22 n.
  allunfold @nuprl.

  remember (univ lib1) as ts.
  close_cases (induction n using @close_ind') Case; subst.

  (*
  - Case "CL_init".
    duniv i h.

    induction i; allsimpl; tcsp.
    repndors; exrepnd; spcast;
    try (complete (autodimp IHi hyp)).

    apply CL_init.
    exists (S i); simpl.
    left; dands; auto; spcast;
    try (complete (apply computes_to_valc_consistent_with_new_definition; auto)).
*)

(*
Focus 6.
  - Case "CL_approx".
    unfold per_approx in per; exrepnd; spcast.
    eexists.
    apply CL_approx.
    unfold per_approx.
    eexists; eexists; eexists; eexists; dands; spcast;
    try (complete (apply computes_to_valc_consistent_with_new_definition; eauto));
    try (complete (introv; apply t_iff_refl)).
    allrw @approx_stable_iff; auto.
*)

  Focus 11.

  - Case "CL_func".
    clear per; spcast.
    apply CL_func.
    unfold per_func.
    exists eqa eqb; dands; auto.
    unfold type_family.
    exists A A' v v' B B'; dands; spcast; auto.

    { apply (computes_to_value_preserves_agreeing_libraries lib1 lib2); eauto 2 with slow. }

    { apply (computes_to_value_preserves_agreeing_libraries lib1 lib2); eauto 2 with slow. }

    { apply IHn; auto.
      admit.
      admit.
      admit.
      admit.

    }

    {
      introv.

      apply recb; auto.
    }

XXXXXXXXXXXXXXXXXXX

    rename eq0 into eqa0.

    assert (forall a a' : CTerm,
               eqa a a' ->
               exists eq0,
                 close (e :: lib)
                       (univ (e :: lib))
                       (B) [[v \\ a]]
                       (B') [[v' \\ a']]
                       eq0) as recbb.
    { introv h; apply recb; auto. }
    clear recb.

    apply choice_teq0 in recbb; exrepnd.
    rename f into eqb0.

    exists (fun t t' =>
              forall a a' (e : eqa0 a a'),
                (eqb0 a a' e) (mkc_apply t a) (mkc_apply t' a')).

  - Case "CL_init".
    duniv i h.

    induction i; allsimpl; tcsp.
    repndors; exrepnd; spcast.

    + exists (fun A A' => exists eqa, close (e :: lib) (univi (e :: lib) i) A A' eqa).
      apply CL_init.
      exists (S i); simpl.
      left; dands; auto; spcast;
      try (complete (apply computes_to_valc_consistent_with_new_definition; auto)).

    + autodimp IHi hyp.

  - Case "CL_int".
    exists (equality_of_int (e :: lib)).
    apply CL_int.
    allunfold @per_int; repnd; dands; auto; spcast;
    try (complete (apply computes_to_valc_consistent_with_new_definition; auto)).

  - Case "CL_atom".
    unfold per_atom in per; repnd; spcast.
    eexists.
    apply CL_atom.
    unfold per_atom; repnd; dands; auto; spcast;
    try (complete (apply computes_to_valc_consistent_with_new_definition; auto)).

  - Case "CL_uatom".
    unfold per_uatom in per; repnd; spcast.
    eexists.
    apply CL_uatom.
    unfold per_uatom; repnd; dands; auto; spcast;
    try (complete (apply computes_to_valc_consistent_with_new_definition; auto)).

  - Case "CL_base".
    unfold per_base in per; repnd; spcast.
    eexists.
    apply CL_base.
    unfold per_base; repnd; dands; auto; spcast;
    try (complete (apply computes_to_valc_consistent_with_new_definition; auto)).

  - Case "CL_approx".
    unfold per_approx in per; exrepnd; spcast.
    eexists.
    apply CL_approx.
    unfold per_approx.
    eexists; eexists; eexists; eexists; dands; spcast;
    try (complete (apply computes_to_valc_consistent_with_new_definition; eauto));
    try (complete (introv; apply t_iff_refl)).
    allrw @approx_stable_iff; auto.

  - Case "CL_cequiv".
    unfold per_cequiv in per; exrepnd; spcast.
    eexists.
    apply CL_cequiv.
    unfold per_cequiv.
    eexists; eexists; eexists; eexists; dands; spcast;
    try (complete (apply computes_to_valc_consistent_with_new_definition; eauto));
    try (complete (introv; apply t_iff_refl)).
    allrw @cequiv_stable_iff; auto.

  - Case "CL_eq".
    clear per.
    autodimp IHteq0 hyp; exrepnd.
    eexists.
    apply CL_eq.
    unfold per_eq.
    eexists; eexists; eexists; eexists; eexists; eexists; eexists; dands; spcast;
    try (complete (apply computes_to_valc_consistent_with_new_definition; eauto));
    try (complete (introv; apply t_iff_refl)); eauto.
    allrw @cequiv_stable_iff; auto.
Qed.

Lemma tequality_cons_library_entry {o} :
  forall lib e (t1 t2 : @CTerm o),
    !in_lib (opabs_of_lib_entry e) lib
    -> tequality lib t1 t2
    -> tequality (e :: lib) t1 t2.
Proof.
  introv p teq.
  allunfold @tequality; exrepnd.
  allunfold @nuprl.

  remember (univ lib) as ts.
  close_cases (induction teq0 using @close_ind') Case; subst.

  Focus 11.

  - Case "CL_func".
    clear per; spcast.
    autodimp IHteq0 hyp; exrepnd.
    rename eq0 into eqa0.

    assert (forall a a' : CTerm,
               eqa a a' ->
               exists eq0,
                 close (e :: lib)
                       (univ (e :: lib))
                       (B) [[v \\ a]]
                       (B') [[v' \\ a']]
                       eq0) as recbb.
    { introv h; apply recb; auto. }
    clear recb.

    apply choice_teq0 in recbb; exrepnd.
    rename f into eqb0.

    exists (fun t t' =>
              forall a a' (e : eqa0 a a'),
                (eqb0 a a' e) (mkc_apply t a) (mkc_apply t' a')).

  - Case "CL_init".
    duniv i h.

    induction i; allsimpl; tcsp.
    repndors; exrepnd; spcast.

    + exists (fun A A' => exists eqa, close (e :: lib) (univi (e :: lib) i) A A' eqa).
      apply CL_init.
      exists (S i); simpl.
      left; dands; auto; spcast;
      try (complete (apply computes_to_valc_consistent_with_new_definition; auto)).

    + autodimp IHi hyp.

  - Case "CL_int".
    exists (equality_of_int (e :: lib)).
    apply CL_int.
    allunfold @per_int; repnd; dands; auto; spcast;
    try (complete (apply computes_to_valc_consistent_with_new_definition; auto)).

  - Case "CL_atom".
    unfold per_atom in per; repnd; spcast.
    eexists.
    apply CL_atom.
    unfold per_atom; repnd; dands; auto; spcast;
    try (complete (apply computes_to_valc_consistent_with_new_definition; auto)).

  - Case "CL_uatom".
    unfold per_uatom in per; repnd; spcast.
    eexists.
    apply CL_uatom.
    unfold per_uatom; repnd; dands; auto; spcast;
    try (complete (apply computes_to_valc_consistent_with_new_definition; auto)).

  - Case "CL_base".
    unfold per_base in per; repnd; spcast.
    eexists.
    apply CL_base.
    unfold per_base; repnd; dands; auto; spcast;
    try (complete (apply computes_to_valc_consistent_with_new_definition; auto)).

  - Case "CL_approx".
    unfold per_approx in per; exrepnd; spcast.
    eexists.
    apply CL_approx.
    unfold per_approx.
    eexists; eexists; eexists; eexists; dands; spcast;
    try (complete (apply computes_to_valc_consistent_with_new_definition; eauto));
    try (complete (introv; apply t_iff_refl)).
    allrw @approx_stable_iff; auto.

  - Case "CL_cequiv".
    unfold per_cequiv in per; exrepnd; spcast.
    eexists.
    apply CL_cequiv.
    unfold per_cequiv.
    eexists; eexists; eexists; eexists; dands; spcast;
    try (complete (apply computes_to_valc_consistent_with_new_definition; eauto));
    try (complete (introv; apply t_iff_refl)).
    allrw @cequiv_stable_iff; auto.

  - Case "CL_eq".
    clear per.
    autodimp IHteq0 hyp; exrepnd.
    eexists.
    apply CL_eq.
    unfold per_eq.
    eexists; eexists; eexists; eexists; eexists; eexists; eexists; dands; spcast;
    try (complete (apply computes_to_valc_consistent_with_new_definition; eauto));
    try (complete (introv; apply t_iff_refl)); eauto.
    allrw @cequiv_stable_iff; auto.
Qed.

Lemma cover_vars_nil_iff_closed {o} :
  forall (t : @NTerm o), cover_vars t [] <=> closed t.
Proof.
  introv.
  rw @cover_vars_eq; simpl.
  unfold closed.
  rw subvars_eq; split; intro h; try (rewrite h); auto.
  remember (free_vars t) as l; clear Heql; destruct l; auto.
  apply subset_cons_nil in h; tcsp.
Qed.

Lemma cover_vars_nil2closed {o} :
  forall {t : @NTerm o}, cover_vars t [] -> closed t.
Proof.
  introv cov.
  apply cover_vars_nil_iff_closed; auto.
Qed.

Lemma wfClosed2isprogram {o} :
  forall {t : @NTerm o},
    wf_term t
    -> closed t
    -> isprogram t.
Proof.
  introv w c.
  constructor; eauto 3 with slow.
Qed.

Definition mk_cterm_wc {o}
           (t : @NTerm o)
           (w : wf_term t)
           (c : cover_vars t []) : CTerm :=
  mk_cterm t (wfClosed2isprogram w (cover_vars_nil2closed c)).

Lemma lsubstc_sub_nil {o} :
  forall (t : @NTerm o) w c,
    lsubstc t w [] c = mk_cterm_wc t w c.
Proof.
  introv.
  apply cterm_eq; simpl.
  apply csubst_nil.
Qed.

Lemma sequent_true2_cons_library_entry {o} :
  forall lib e (c : @conclusion o),
    sequent_true2 lib (mk_baresequent [] c)
    -> sequent_true2 (e :: lib) (mk_baresequent [] c).
Proof.
  introv h.
  allunfold @sequent_true2; exrepnd.
  exists c0.
  allrw @sequent_true_eq_VR.
  allunfold @VR_sequent_true; introv.
  pose proof (h0 s1 s2) as q; clear h0; simpl in *.
  intros sim hf.
  dup sim as sim'.
  apply similarity_nil_implies in sim'; repnd; subst; allsimpl.
  pose proof (q (sim_nil lib) (hyps_functionality_nil lib)) as h; clear q; repnd.

  dands.

  - clear h.

    match goal with [ |- tequality _ (lsubstc _ _ _ ?c) _ ] => let c := fresh "c" in remember c; clear_eq1 c end.
    match goal with [ |- tequality _ _ (lsubstc _ _ _ ?c) ] => let c := fresh "c" in remember c; clear_eq1 c end.
    match goal with [ H : tequality _ (lsubstc _ _ _ ?c) _ |- _ ] => let c := fresh "c" in remember c; clear_eq1 c end.
    match goal with [ H : tequality _ _ (lsubstc _ _ _ ?c) |- _ ] => let c := fresh "c" in remember c; clear_eq1 c end.
    proof_irr.
    allrw @lsubstc_sub_nil.

Qed.

(* By assuming [wf_bseq seq], when we start with a sequent with no hypotheses,
   it means that we have to prove that the conclusion is well-formed and closed.
 *)
Lemma valid_proof {o} :
  forall ctxt (seq : @baresequent o) (wf : wf_bseq seq),
    Library ctxt
    -> proof ctxt seq
    -> sequent_true2 ctxt seq.
Proof.
  introv wf Lib p.
  induction p
    as [ (* proved sequent       *) seq p
       | (* isect_eq             *) a1 a2 b1 b2 e1 e2 x1 x2 y i hs niy p1 ih1 p2 ih2
       | (* approx_refl          *) a hs
       | (* cequiv_approx        *) a b e1 e2 hs p1 ih1 p2 ih2
       | (* approx_eq            *) a1 a2 b1 b2 e1 e2 i hs p1 ih1 p2 ih2
       | (* cequiv_eq            *) a1 a2 b1 b2 e1 e2 i hs p1 ih1 p2 ih2
       | (* bottom_diverges      *) x hs js
       | (* cut                  *) B C t u x hs wB covB nixH p1 ih1 p2 ih2
       | (* equal_in_base        *) a b e F H p1 ih1 ps ihs
       | (* hypothesis           *) x A G J
       | (* cequiv_subst_concl   *) C x a b t e H wfa wfb cova covb p1 ih1 p2 ih2
       | (* approx_member_eq     *) a b e H p ih
       | (* cequiv_computation   *) a b H p ih
       | (* function elimination *) A B C a e ea f x z H J wa cova nizH nizJ dzf p1 ih1 p2 ih2
       ];
    allsimpl;
    allrw NVin_iff.

  -

Lemma seq_in_library_is_true {o} :
  forall (ctxt : @ProofContext o) c,
    Library ctxt
    -> LIn c (PC_conclusions ctxt)
    -> sequent_true2 ctxt (mk_baresequent [] c).
Proof.
  introv Lib.
  induction Lib; simpl; introv i; tcsp.
  - autodimp IHLib hyp.

Qed.

  - apply (rule_isect_equality2_true3 lib a1 a2 b1 b2 e1 e2 x1 x2 y i hs); simpl; tcsp.

    + unfold args_constraints; simpl; introv h; repndors; subst; tcsp.

    + introv e; repndors; subst; tcsp.

      * apply ih1; auto.
        apply (rule_isect_equality2_wf2 y i a1 a2 b1 b2 e1 e2 x1 x2 hs); simpl; tcsp.

      * apply ih2; auto.
        apply (rule_isect_equality2_wf2 y i a1 a2 b1 b2 e1 e2 x1 x2 hs); simpl; tcsp.

  - apply (rule_approx_refl_true3 lib hs a); simpl; tcsp.

  - apply (rule_cequiv_approx2_true3 lib hs a b e1 e2); simpl; tcsp.
    introv xx; repndors; subst; tcsp.

    apply ih2; auto.
    apply (rule_cequiv_approx2_wf2 a b e1 e2 hs); simpl; tcsp.

  - apply (rule_approx_eq2_true3 lib a1 a2 b1 b2 e1 e2 i hs); simpl; tcsp.
    introv xx; repndors; subst; tcsp.

    + apply ih1; auto.
      apply (rule_approx_eq2_wf2 a1 a2 b1 b2 e1 e2 i hs); simpl; tcsp.

    + apply ih2; auto.
      apply (rule_approx_eq2_wf2 a1 a2 b1 b2 e1 e2 i hs); simpl; tcsp.

  - apply (rule_cequiv_eq2_true3 lib a1 a2 b1 b2 e1 e2 i hs); simpl; tcsp.
    introv xx; repndors; subst; tcsp.

    + apply ih1; auto.
      apply (rule_cequiv_eq2_wf2 a1 a2 b1 b2 e1 e2 i hs); simpl; tcsp.

    + apply ih2; auto.
      apply (rule_cequiv_eq2_wf2 a1 a2 b1 b2 e1 e2 i hs); simpl; tcsp.

  - apply (rule_bottom_diverges_true3 lib x hs js); simpl; tcsp.

  - apply (rule_cut_true3 lib hs B C t u x); simpl; tcsp.

    + unfold args_constraints; simpl; introv xx; repndors; subst; tcsp.

    + introv xx; repndors; subst; tcsp.

      * apply ih1.
        apply (rule_cut_wf2 hs B C t u x); simpl; tcsp.

      * apply ih2.
        apply (rule_cut_wf2 hs B C t u x); simpl; tcsp.

  - apply (rule_equal_in_base2_true3 lib H a b e F); simpl; tcsp.

    introv xx; repndors; subst; tcsp.
    unfold rule_equal_in_base2_rest in xx; apply in_mapin in xx; exrepnd; subst.
    pose proof (ihs a0 i) as hh; clear ihs.
    repeat (autodimp hh hyp).
    pose proof (rule_equal_in_base2_wf2 H a b e F) as w.
    apply w; simpl; tcsp.
    right.
    apply in_mapin; eauto.

  - apply (rule_hypothesis_true3 lib); simpl; tcsp.

  - apply (rule_cequiv_subst_concl2_true3 lib H x C a b t e); allsimpl; tcsp.

    introv i; repndors; subst; allsimpl; tcsp.

    + apply ih1.
      apply (rule_cequiv_subst_concl2_wf2 H x C a b t e); simpl; tcsp.

    + apply ih2.
      apply (rule_cequiv_subst_concl2_wf2 H x C a b t e); simpl; tcsp.

  - apply (rule_approx_member_eq2_true3 lib a b e); simpl; tcsp.
    introv xx; repndors; subst; tcsp.
    apply ih.
    apply (rule_approx_member_eq2_wf2 a b e H); simpl; tcsp.

  - apply (rule_cequiv_computation_true3 lib); simpl; tcsp.

  - apply (rule_function_elimination_true3 lib A B C a e ea f x z); simpl; tcsp.

    introv ih; repndors; subst; tcsp.

    + apply ih1.
      pose proof (rule_function_elimination_wf2 A B C a e ea f x z H J) as h.
      unfold wf_rule2, wf_subgoals2 in h; simpl in h.
      repeat (autodimp h hyp).

    + apply ih2.
      pose proof (rule_function_elimination_wf2 A B C a e ea f x z H J) as h.
      unfold wf_rule2, wf_subgoals2 in h; simpl in h.
      repeat (autodimp h hyp).
Qed.

Fixpoint map_option
         {T U : Type}
         (f : T -> option U)
         (l : list T) : option (list U) :=
  match l with
  | [] => Some []
  | t :: ts =>
    match f t, map_option f ts with
    | Some u, Some us => Some (u :: us)
    | _, _ => None
    end
  end.

Fixpoint map_option_in
         {T U : Type}
         (l : list T)
  : forall (f : forall (t : T) (i : LIn t l), option U), option (list U) :=
  match l with
  | [] => fun f => Some []
  | t :: ts =>
    fun f =>
      match f t (@inl (t = t) (LIn t ts) eq_refl), map_option_in ts (fun x i => f x (inr i)) with
      | Some u, Some us => Some (u :: us)
      | _, _ => None
      end
  end.

Fixpoint map_option_in_fun
         {T U}
         (l : list T)
  : (forall t, LIn t l -> option (U t)) -> option (forall t, LIn t l -> U t) :=
  match l with
  | [] => fun f => Some (fun t (i : LIn t []) => match i with end)
  | t :: ts =>
    fun (f : forall x, LIn x (t :: ts) -> option (U x)) =>
      match f t (@inl (t = t) (LIn t ts) eq_refl),
            map_option_in_fun ts (fun x i => f x (inr i)) with
      | Some u, Some g => Some (fun x (i : LIn x (t :: ts)) =>
                                   match i with
                                   | inl e => transport e u
                                   | inr j => g x j
                                   end)
      | _, _ => None
      end
  end.

Lemma map_option_in_fun2_lem :
  forall {T : Type }
         (l : list T)
         (U : forall (t : T) (i : LIn t l), Type)
         (f : forall (t : T) (i : LIn t l), option (U t i)),
    option (forall t (i : LIn t l), U t i).
Proof.
  induction l; introv f; simpl in *.
  - left; introv; destruct i.
  - pose proof (f a (inl eq_refl)) as opt1.
    destruct opt1 as [u|];[|right].
    pose proof (IHl (fun x i => U x (inr i)) (fun x i => f x (inr i))) as opt2.
    destruct opt2 as [g|];[|right].
    left.
    introv.
    destruct i as [i|i].
    + rewrite <- i.
      exact u.
    + apply g.
Defined.

Fixpoint map_option_in_fun2
         {T : Type }
         (l : list T)
  : forall (U : forall (t : T) (i : LIn t l), Type),
    (forall (t : T) (i : LIn t l), option (U t i))
    -> option (forall t (i : LIn t l), U t i) :=
  match l with
  | [] => fun U f => Some (fun t (i : LIn t []) => match i with end)
  | t :: ts =>
    fun (U : forall (x : T) (i : LIn x (t :: ts)), Type)
        (f : forall x (i : LIn x (t :: ts)), option (U x i)) =>
      match f t (@inl (t = t) (LIn t ts) eq_refl),
            @map_option_in_fun2 T ts (fun x i => U x (inr i)) (fun x i => f x (inr i))
            return option (forall x (i : LIn x (t :: ts)), U x i)
      with
      | Some u, Some g => Some (fun x (i : LIn x (t :: ts)) =>
                                  match i as s return U x s with
                                  | inl e =>
                                    internal_eq_rew_dep
                                      T t
                                      (fun (x : T) (i : t = x) => U x injL(i))
                                      u x e
                                  | inr j => g x j
                                  end)
      | _, _ => None
      end
  end.

Fixpoint finish_pre_proof
         {o} {seq : @pre_baresequent o} {h : bool} {lib}
         (prf: pre_proof h lib seq) : option (pre_proof false lib seq) :=
  match prf with
  | pre_proof_hole s e => None
  | pre_proof_isect_eq a1 a2 b1 b2 x1 x2 y i H niyH pa pb =>
    match finish_pre_proof pa, finish_pre_proof pb with
    | Some p1, Some p2 => Some (pre_proof_isect_eq _ _ a1 a2 b1 b2 x1 x2 y i H niyH p1 p2)
    | _, _ => None
    end
  | pre_proof_approx_refl a H => Some (pre_proof_approx_refl _ _ a H)
  | pre_proof_cequiv_approx a b H p1 p2 =>
    match finish_pre_proof p1, finish_pre_proof p2 with
    | Some p1, Some p2 => Some (pre_proof_cequiv_approx _ _ a b H p1 p2)
    | _, _ => None
    end
  | pre_proof_approx_eq a1 a2 b1 b2 i H p1 p2 =>
    match finish_pre_proof p1, finish_pre_proof p2 with
    | Some p1, Some p2 => Some (pre_proof_approx_eq _ _ a1 a2 b1 b2 i H p1 p2)
    | _, _ => None
    end
  | pre_proof_cequiv_eq a1 a2 b1 b2 i H p1 p2 =>
    match finish_pre_proof p1, finish_pre_proof p2 with
    | Some p1, Some p2 => Some (pre_proof_cequiv_eq _ _ a1 a2 b1 b2 i H p1 p2)
    | _, _ => None
    end
  | pre_proof_bottom_diverges x H J => Some (pre_proof_bottom_diverges _ _ x H J)
  | pre_proof_cut B C x H wB cBH nixH pu pt =>
    match finish_pre_proof pu, finish_pre_proof pt with
    | Some p1, Some p2 => Some (pre_proof_cut _ _ B C x H wB cBH nixH p1 p2)
    | _, _ => None
    end
  | pre_proof_equal_in_base a b H p1 pl =>
    let op := map_option_in_fun (free_vars a) (fun v i => finish_pre_proof (pl v i)) in
    match finish_pre_proof p1, op with
    | Some p1, Some g => Some (pre_proof_equal_in_base _ _ a b H p1 g)
    | _, _ => None
    end
  | pre_proof_hypothesis x A G J => Some (pre_proof_hypothesis _ _ x A G J)
  | pre_proof_cequiv_subst_concl C x a b H wa wb ca cb p1 p2 =>
    match finish_pre_proof p1, finish_pre_proof p2 with
    | Some p1, Some p2 => Some (pre_proof_cequiv_subst_concl _ _ C x a b H wa wb ca cb p1 p2)
    | _, _ => None
    end
  | pre_proof_approx_member_eq a b H p1 =>
    match finish_pre_proof p1 with
    | Some p1 => Some (pre_proof_approx_member_eq _ _ a b H p1)
    | _ => None
    end
  | pre_proof_cequiv_computation a b H r => Some (pre_proof_cequiv_computation _ _ a b H r)
  | pre_proof_function_elimination A B C a f x z H J wa cova nizH nizJ dzf p1 p2 =>
    match finish_pre_proof p1, finish_pre_proof p2 with
    | Some p1, Some p2 => Some (pre_proof_function_elimination _ _ A B C a f x z H J wa cova nizH nizJ dzf p1 p2)
    | _, _ => None
    end
  end.

Definition pre2conclusion {o} (c : @pre_conclusion o) (e : @NTerm o) :=
  match c with
  | pre_concl_ext T => concl_ext T e
  | pre_concl_typ T => concl_typ T
  end.

Definition pre2baresequent {o} (s : @pre_baresequent o) (e : @NTerm o) :=
  mk_baresequent
    (pre_hyps s)
    (pre2conclusion (pre_concl s) e).

Definition ExtractProof {o} (seq : @pre_baresequent o) lib :=
  {e : NTerm & proof lib (pre2baresequent seq e)}.

Definition mkExtractProof {o} {lib}
           (seq : @pre_baresequent o)
           (e : @NTerm o)
           (p : proof lib (pre2baresequent seq e))
  : ExtractProof seq lib :=
  existT _ e p.

(* converts a pre-proof without holes to a proof without holes by
 * generating the extract
 *)
Fixpoint pre_proof2iproof
         {o} {seq : @pre_baresequent o} {lib}
         (prf : pre_proof false lib seq)
  : ExtractProof seq lib  :=
  match prf with
  | pre_proof_hole s e => match e with end
  | pre_proof_isect_eq a1 a2 b1 b2 x1 x2 y i H niyH pa pb =>
    match pre_proof2iproof pa, pre_proof2iproof pb with
    | existT e1 p1, existT e2 p2 =>
      mkExtractProof
        (pre_rule_isect_equality_concl a1 a2 x1 x2 b1 b2 i H)
        mk_axiom
        (proof_isect_eq _ a1 a2 b1 b2 e1 e2 x1 x2 y i H niyH p1 p2)
 (* I need to generalize the rule a bit to allow any extract in subgoals *)
    end
  | pre_proof_approx_refl a H =>
    mkExtractProof
      (pre_rule_approx_refl_concl a H)
      mk_axiom
      (proof_approx_refl _ a H)
  | pre_proof_cequiv_approx a b H p1 p2 =>
    match pre_proof2iproof p1, pre_proof2iproof p2 with
    | existT e1 p1, existT e2 p2 =>
      mkExtractProof
        (pre_rule_cequiv_approx_concl a b H)
        mk_axiom
        (proof_cequiv_approx _ a b e1 e2 H p1 p2)
    end
  | pre_proof_approx_eq a1 a2 b1 b2 i H p1 p2 =>
    match pre_proof2iproof p1, pre_proof2iproof p2 with
    | existT e1 p1, existT e2 p2 =>
      mkExtractProof
        (pre_rule_approx_eq_concl a1 a2 b1 b2 i H)
        mk_axiom
        (proof_approx_eq _ a1 a2 b1 b2 e1 e2 i H p1 p2)
    end
  | pre_proof_cequiv_eq a1 a2 b1 b2 i H p1 p2 =>
    match pre_proof2iproof p1, pre_proof2iproof p2 with
    | existT e1 p1, existT e2 p2 =>
      mkExtractProof
        (pre_rule_cequiv_eq_concl a1 a2 b1 b2 i H)
        mk_axiom
        (proof_cequiv_eq _ a1 a2 b1 b2 e1 e2 i H p1 p2)
    end
  | pre_proof_bottom_diverges x H J =>
    mkExtractProof
      (pre_rule_bottom_diverges_concl x H J)
      mk_bottom
      (proof_bottom_diverges _ x H J)
  | pre_proof_cut B C x H wB cBH nixH pu pt =>
    match pre_proof2iproof pu, pre_proof2iproof pt with
    | existT u p1, existT t p2 =>
      mkExtractProof
        (pre_rule_cut_concl H C)
        (subst t x u)
        (proof_cut _ B C t u x H wB cBH nixH p1 p2)
    end
  | pre_proof_equal_in_base a b H p1 pl =>
    let F := fun v (i : LIn v (free_vars a)) => pre_proof2iproof (pl v i) in
    let E := fun v i => projT1 (F v i) in
    let P := fun v i => projT2 (F v i) in
    match pre_proof2iproof p1 with
    | existT e p1 =>
      mkExtractProof
        (pre_rule_equal_in_base_concl a b H)
        mk_axiom
        (proof_equal_in_base _ a b e E H p1 P)
    end
  | pre_proof_hypothesis x A G J =>
    mkExtractProof
      (pre_rule_hypothesis_concl G J A x)
      (mk_var x)
      (proof_hypothesis _ x A G J)
  | pre_proof_cequiv_subst_concl C x a b H wa wb ca cb p1 p2 =>
    match pre_proof2iproof p1, pre_proof2iproof p2 with
    | existT t p1, existT e p2 =>
      mkExtractProof
        (pre_rule_cequiv_subst_hyp1 H x C a)
        t
        (proof_cequiv_subst_concl _ C x a b t e H wa wb ca cb p1 p2)
    end
  | pre_proof_approx_member_eq a b H p1 =>
    match pre_proof2iproof p1 with
    | existT e1 p1 =>
      mkExtractProof
        (pre_rule_approx_member_eq_concl a b H)
        mk_axiom
        (proof_approx_member_eq _ a b e1 H p1)
    end
  | pre_proof_cequiv_computation a b H r =>
    mkExtractProof
      (pre_rule_cequiv_concl a b H)
      mk_axiom
      (proof_cequiv_computation _ a b H r)
  | pre_proof_function_elimination A B C a f x z H J wa cova nizH nizJ dzf p1 p2 =>
    match pre_proof2iproof p1, pre_proof2iproof p2 with
    | existT ea p1, existT e p2 =>
      mkExtractProof
        (pre_rule_function_elimination_concl A B C f x H J)
        (subst e z mk_axiom)
        (proof_function_elimination _ A B C a e ea f x z H J wa cova nizH nizJ dzf p1 p2)
    end
  end.

Lemma test {o} :
  @sequent_true2 o emlib (mk_baresequent [] (mk_conclax ((mk_member mk_axiom mk_unit)))).
Proof.
  apply valid_proof;
  [ exact (eq_refl, (eq_refl, eq_refl))
  | exact (proof_approx_member_eq emlib (mk_axiom) (mk_axiom) (mk_axiom) (nil) (proof_approx_refl emlib (mk_axiom) (nil)))
          (* This last bit was generated by JonPRL; I've got to generate the whole thing now *)
  ].
Qed.

(*
Inductive test : nat -> Type :=
| Foo : test 1
| Bar : test 0.

(* works *)
Definition xxx {n : nat} (t : test n) : test n :=
  match t with
  | Foo => Foo
  | Bar => Bar
  end.

(* works *)
Definition yyy {n : nat} (t : test n) : test n :=
  match t with
  | Foo => Foo
  | x => x
  end.

(* works *)
Definition www {n : nat} (t : test n) : option (test n) :=
  match t with
  | Foo => Some Foo
  | Bar => None
  end.

(* doesn't work *)
Definition zzz {n : nat} (t : test n) : test n :=
  match t with
  | Foo => Foo
  | Bar => t
  end.
*)

Definition proof_update_fun {o} lib (s seq : @baresequent o) :=
  proof lib s -> proof lib seq.

Definition proof_update {o} lib (seq : @baresequent o) :=
  {s : @baresequent o & proof_update_fun lib s seq}.

Definition ProofUpdate {o} lib (seq : @baresequent o) :=
  option (proof_update lib seq).

Definition retProofUpd
           {o} {lib} {seq : @baresequent o}
           (s : @baresequent o)
           (f : proof lib s -> proof lib seq)
  : ProofUpdate lib seq :=
  Some (existT _ s f).

Definition idProofUpd
           {o} {lib}
           (seq : @baresequent o)
  : ProofUpdate lib seq :=
  retProofUpd seq (fun p => p).

Definition noProofUpd {o} {lib} {seq : @baresequent o}
  : ProofUpdate lib seq :=
  None.

Definition bindProofUpd
           {o} {lib} {seq1 seq2 : @baresequent o}
           (pu  : ProofUpdate lib seq1)
           (puf : proof lib seq1 -> proof lib seq2)
  : ProofUpdate lib seq2 :=
  match pu with
  | Some (existT s f) => retProofUpd s (fun p => puf (f p))
  | None => None
  end.

Definition address := list nat.

Fixpoint get_sequent_fun_at_address {o}
         {lib}
         {seq  : @baresequent o}
         (prf  : proof lib seq)
         (addr : address) : ProofUpdate lib seq :=
  match prf with
  | proof_isect_eq a1 a2 b1 b2 e1 e2 x1 x2 y i H niyH pa pb =>
    match addr with
    | [] => idProofUpd (rule_isect_equality_concl a1 a2 x1 x2 b1 b2 i H)
    | 1 :: addr =>
      bindProofUpd
        (get_sequent_fun_at_address pa addr)
        (fun x => proof_isect_eq _ a1 a2 b1 b2 e1 e2 x1 x2 y i H niyH x pb)
    | 2 :: addr =>
      bindProofUpd
        (get_sequent_fun_at_address pb addr)
        (fun x => proof_isect_eq _ a1 a2 b1 b2 e1 e2 x1 x2 y i H niyH pa x)
    | _ => noProofUpd
    end
  | proof_approx_refl a H =>
    match addr with
    | [] => idProofUpd (rule_approx_refl_concl a H)
    | _ => noProofUpd
    end
  | proof_cequiv_approx a b e1 e2 H p1 p2 =>
    match addr with
    | [] => idProofUpd (rule_cequiv_approx_concl a b H)
    | 1 :: addr =>
      bindProofUpd
        (get_sequent_fun_at_address p1 addr)
        (fun x => proof_cequiv_approx _ a b e1 e2 H x p2)
    | 2 :: addr =>
      bindProofUpd
        (get_sequent_fun_at_address p2 addr)
        (fun x => proof_cequiv_approx _ a b e1 e2 H p1 x)
    | _ => noProofUpd
    end
  | proof_approx_eq a1 a2 b1 b2 e1 e2 i H p1 p2 =>
    match addr with
    | [] => idProofUpd (rule_approx_eq_concl a1 a2 b1 b2 i H)
    | 1 :: addr =>
      bindProofUpd
        (get_sequent_fun_at_address p1 addr)
        (fun x => proof_approx_eq _ a1 a2 b1 b2 e1 e2 i H x p2)
    | 2 :: addr =>
      bindProofUpd
        (get_sequent_fun_at_address p2 addr)
        (fun x => proof_approx_eq _ a1 a2 b1 b2 e1 e2 i H p1 x)
    | _ => noProofUpd
    end
  | proof_cequiv_eq a1 a2 b1 b2 e1 e2 i H p1 p2 =>
    match addr with
    | [] => idProofUpd (rule_cequiv_eq_concl a1 a2 b1 b2 i H)
    | 1 :: addr =>
      bindProofUpd
        (get_sequent_fun_at_address p1 addr)
        (fun x => proof_cequiv_eq _ a1 a2 b1 b2 e1 e2 i H x p2)
    | 2 :: addr =>
      bindProofUpd
        (get_sequent_fun_at_address p2 addr)
        (fun x => proof_cequiv_eq _ a1 a2 b1 b2 e1 e2 i H p1 x)
    | _ => noProofUpd
    end
  | proof_bottom_diverges x H J =>
    match addr with
    | [] => idProofUpd (rule_bottom_diverges_concl x H J)
    | _ => noProofUpd
    end
  | proof_cut B C t u x H wB cBH nixH pu pt =>
    match addr with
    | [] => idProofUpd (rule_cut_concl H C t x u)
    | 1 :: addr =>
      bindProofUpd
        (get_sequent_fun_at_address pu addr)
        (fun z => proof_cut _ B C t u x H wB cBH nixH z pt)
    | 2 :: addr =>
      bindProofUpd
        (get_sequent_fun_at_address pt addr)
        (fun z => proof_cut _ B C t u x H wB cBH nixH pu z)
    | _ => noProofUpd
    end
  | proof_equal_in_base a b e F H p1 pl =>
    match addr with
    | [] => idProofUpd (rule_equal_in_base_concl a b H)
    | 1 :: addr =>
      bindProofUpd
        (get_sequent_fun_at_address p1 addr)
        (fun z => proof_equal_in_base _ a b e F H z pl)
    | _ => noProofUpd (* TODO *)
    end
  | proof_hypothesis x A G J =>
    match addr with
    | [] => idProofUpd (rule_hypothesis_concl G J A x)
    | _ => noProofUpd
    end
  | proof_cequiv_subst_concl C x a b t e H wa wb ca cb p1 p2 =>
    match addr with
    | [] => idProofUpd (rule_cequiv_subst_hyp1 H x C a t)
    | 1 :: addr =>
      bindProofUpd
        (get_sequent_fun_at_address p1 addr)
        (fun z => proof_cequiv_subst_concl _ C x a b t e H wa wb ca cb z p2)
    | 2 :: addr =>
      bindProofUpd
        (get_sequent_fun_at_address p2 addr)
        (fun z => proof_cequiv_subst_concl _ C x a b t e H wa wb ca cb p1 z)
    | _ => noProofUpd
    end
  | proof_approx_member_eq a b e H p1 =>
    match addr with
    | [] => idProofUpd (rule_approx_member_eq_concl a b H)
    | 1 :: addr =>
      bindProofUpd
        (get_sequent_fun_at_address p1 addr)
        (fun z => proof_approx_member_eq _ a b e H z)
    | _ => noProofUpd
    end
  | proof_cequiv_computation a b H r =>
    match addr with
    | [] => idProofUpd (rule_cequiv_concl a b H)
    | _ => noProofUpd
    end
  | proof_function_elimination A B C a e ea f x z H J wa cova nizH nizJ dzf p1 p2 =>
    match addr with
    | [] => idProofUpd (rule_function_elimination_concl A B C e f x z H J)
    | 1 :: addr =>
      bindProofUpd
        (get_sequent_fun_at_address p1 addr)
        (fun p => proof_function_elimination _ A B C a e ea f x z H J wa cova nizH nizJ dzf p p2)
    | 2 :: addr =>
      bindProofUpd
        (get_sequent_fun_at_address p2 addr)
        (fun p => proof_function_elimination _ A B C a e ea f x z H J wa cova nizH nizJ dzf p1 p)
    | _ => noProofUpd
    end
  end.

Fixpoint get_sequent_at_address {o}
           {seq  : @baresequent o}
           {lib}
           (prf  : proof lib seq)
           (addr : address) : option baresequent :=
  match get_sequent_fun_at_address prf addr with
  | Some (existT s _) => Some s
  | _ => None
  end.

Definition list1 {T} : forall a : T, LIn a [a].
Proof.
  tcsp.
Qed.

(* Looking at how we can define a Nuprl process *)

Inductive command {o} :=
(* add a definition at the head *)
| COM_add_def :
    forall (opabs   : opabs)
           (vars    : list sovar_sig)
           (rhs     : @SOTerm o)
           (correct : correct_abs opabs vars rhs),
      command
(* tries to complete a proof if it has no holes *)
| COM_finish_proof :
    ProofName -> command
(* focuses to a node in a proof *)
| COM_focus_proof :
    ProofName -> address -> command.

Definition proof_library {o} lib := list (@proof_library_entry o lib).

Record proof_update_seq {o} lib :=
  MkProofUpdateSeq
    {
      PUS_name  : ProofName;
      PUS_seq   : @baresequent o;
      PUS_focus : baresequent;
      PUS_upd   : proof_update_fun lib PUS_focus PUS_seq
    }.

Definition ProofUpdateSeq {o} lib :=
  option (@proof_update_seq o lib).

Record NuprlState {o} :=
  MkNuprlState
    {
      NuprlState_def_library   : @library o;
      NuprlState_proof_library : @proof_library o NuprlState_def_library;
      NuprlState_focus         : @ProofUpdateSeq o NuprlState_def_library
    }.

Fixpoint proof_consistent_with_new_definition
         {o} {seq : @baresequent o} {lib}
         (prf : proof lib seq)
         (e   : library_entry)
         (p   : !in_lib (opabs_of_lib_entry e) lib)
  : proof (e :: lib) seq :=
  match prf with
  | proof_isect_eq a1 a2 b1 b2 e1 e2 x1 x2 y i H niyH pa pb =>
    let p1 := proof_consistent_with_new_definition pa e p in
    let p2 := proof_consistent_with_new_definition pb e p in
    proof_isect_eq _ a1 a2 b1 b2 e1 e2 x1 x2 y i H niyH p1 p2
  | proof_approx_refl a H => proof_approx_refl _ a H
  | proof_cequiv_approx a b e1 e2 H p1 p2 =>
    let p1 := proof_consistent_with_new_definition p1 e p in
    let p2 := proof_consistent_with_new_definition p2 e p in
    proof_cequiv_approx _ a b e1 e2 H p1 p2
  | proof_approx_eq a1 a2 b1 b2 e1 e2 i H p1 p2 =>
    let p1 := proof_consistent_with_new_definition p1 e p in
    let p2 := proof_consistent_with_new_definition p2 e p in
    proof_approx_eq _ a1 a2 b1 b2 e1 e2 i H p1 p2
  | proof_cequiv_eq a1 a2 b1 b2 e1 e2 i H p1 p2 =>
    let p1 := proof_consistent_with_new_definition p1 e p in
    let p2 := proof_consistent_with_new_definition p2 e p in
    proof_cequiv_eq _ a1 a2 b1 b2 e1 e2 i H p1 p2
  | proof_bottom_diverges x H J => proof_bottom_diverges _ x H J
  | proof_cut B C t u x H wB cBH nixH pu pt =>
    let p1 := proof_consistent_with_new_definition pu e p in
    let p2 := proof_consistent_with_new_definition pt e p in
    proof_cut _ B C t u x H wB cBH nixH p1 p2
  | proof_equal_in_base a b ee F H p1 pl =>
    let p1 := proof_consistent_with_new_definition p1 e p in
    let g := fun v (i : LIn v (free_vars a)) => proof_consistent_with_new_definition (pl v i) e p in
    proof_equal_in_base _ a b ee F H p1 g
  | proof_hypothesis x A G J => proof_hypothesis _ x A G J
  | proof_cequiv_subst_concl C x a b t ee H wa wb ca cb p1 p2 =>
    let p1 := proof_consistent_with_new_definition p1 e p in
    let p2 := proof_consistent_with_new_definition p2 e p in
    proof_cequiv_subst_concl _ C x a b t ee H wa wb ca cb p1 p2
  | proof_approx_member_eq a b ee H p1 =>
    let p1 := proof_consistent_with_new_definition p1 e p in
    proof_approx_member_eq _ a b ee H p1
  | proof_cequiv_computation a b H r =>
    proof_cequiv_computation
      _ a b H
      (reduces_to_consistent_with_new_definition a b r e p)
  | proof_function_elimination A B C a ee ea f x z H J wa cova nizH nizJ dzf p1 p2 =>
    let p1 := proof_consistent_with_new_definition p1 e p in
    let p2 := proof_consistent_with_new_definition p2 e p in
    proof_function_elimination _ A B C a ee ea f x z H J wa cova nizH nizJ dzf p1 p2
  end.

Definition NuprlState_add_def_lib {o}
           (state   : @NuprlState o)
           (opabs   : opabs)
           (vars    : list sovar_sig)
           (rhs     : SOTerm)
           (correct : correct_abs opabs vars rhs) : NuprlState :=
  let lib := NuprlState_def_library state in
  match in_lib_dec opabs lib with
  | inl _ => state
  | inr p =>
    @MkNuprlState
      o
      (lib_abs opabs vars rhs correct :: lib)
      (NuprlState_proof_library state)
      (NuprlState_focus state)
  end.

Definition NuprlState_upd_proof_lib {o}
           (state : @NuprlState o)
           (lib   : @proof_library o) : NuprlState :=
  @MkNuprlState
    o
    (NuprlState_def_library state)
    lib
    (NuprlState_focus state).

Definition NuprlState_upd_focus {o}
           (state : @NuprlState o)
           (upd   : @ProofUpdateSeq o) : NuprlState :=
  @MkNuprlState
    o
    (NuprlState_def_library state)
    (NuprlState_proof_library state)
    upd.

Definition proof_library_entry_upd_proof {o} {lib}
           (e : @proof_library_entry o lib)
           (p : proof lib (proof_library_entry_seq lib e))
  : proof_library_entry lib :=
  MkProofLibEntry
    _
    _
    (proof_library_entry_name _ e)
    (proof_library_entry_seq _ e)
    h
    p.

Fixpoint finish_proof_in_library {o}
           (lib : @proof_library o)
           (name : ProofName) : proof_library :=
  match lib with
  | [] => []
  | p :: ps =>
    if String.string_dec (proof_library_entry_name p) name
    then if proof_library_entry_hole p (* no need to finish the proof if it is already finished *)
         then let p' := option_with_default
                          (option_map (fun p' => proof_library_entry_upd_proof p p')
                                      (finish_proof (proof_library_entry_proof p)))
                          p
              in p' :: ps
         else p :: ps
    else p :: finish_proof_in_library ps name
  end.

Fixpoint focus_proof_in_library {o}
           (lib : @proof_library o)
           (name : ProofName)
           (addr : address) : ProofUpdateSeq :=
  match lib with
  | [] => None
  | p :: ps =>
    if String.string_dec (proof_library_entry_name p) name
    then match get_sequent_fun_at_address (proof_library_entry_proof p) addr with
         | Some (existT s f) =>
           Some (MkProofUpdateSeq
                   o
                   name
                   (proof_library_entry_hole p)
                   (proof_library_entry_seq p)
                   s
                   f)
         | None => None
         end
    else focus_proof_in_library ps name addr
  end.

Definition update {o}
           (state : @NuprlState o)
           (com   : command) : NuprlState :=
  match com with
  | COM_add_def opabs vars rhs correct =>
    NuprlState_add_def_lib state opabs vars rhs correct
  | COM_finish_proof name =>
    let lib := NuprlState_proof_library state in
    NuprlState_upd_proof_lib state (finish_proof_in_library lib name)
  | COM_focus_proof name addr =>
    let lib := NuprlState_proof_library state in
    NuprlState_upd_focus state (focus_proof_in_library lib name addr)
  end.

CoInductive Loop {o} : Type :=
| proc : (@command o -> Loop) -> Loop.

CoFixpoint loop {o} (state : @NuprlState o) : Loop :=
  proc (fun c => loop (update state c)).


From mathcomp.ssreflect Require Import all_ssreflect seq.
From mathcomp Require Import finmap.

From Paco Require Import paco paco1 paco2.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import MPST.Common.
Require Import MPST.Local.
Require Import MPST.Session.

Require Import MPST.Projection.IProject.

Fixpoint merge (A : eqType) (oL : A) (K : seq A) :=
  match K with
  | [::] => Some oL
  | h::t => if h == oL then merge oL t
            else None
  end.

Notation merge_all := (merge_all (@merge _)).

Fixpoint partial_proj (l : l_ty) (r : role) : option s_ty :=
  match l with
  | l_end => Some (s_end)
  | l_var v => Some (s_var v)
  | l_rec L =>
    match partial_proj L r with
    | Some s => Some (if s_binds 0 s then s_end else s_rec s)
    | _ => None
    end
    | l_msg a p Ks =>
      match (fix prj_all Ks r :=
               match Ks with
               | [::] => Some [::]
               | K::Ks =>
                 match partial_proj K.2.2 r, prj_all Ks r with
                 | Some s, Some Ks => Some ((K.1, (K.2.1, s)) :: Ks)
                 | _, _ => None
                 end
               end
            ) Ks r with
      | Some Ks => if p == r then Some (s_msg a Ks)
                   else merge_all [seq K.2.2 | K <- Ks]
      | None => None
      end
  end.

Fixpoint pprj_all (Ks : seq (lbl * (mty * l_ty))) (r : role)
  : option (seq (lbl * (mty * s_ty))) :=
  match Ks with
  | [::] => Some [::]
  | K::Ks => match partial_proj K.2.2 r, pprj_all Ks r with
             | Some s, Some Ks => Some ((K.1, (K.2.1, s)) :: Ks)
             | _, _ => None
             end
  end.

Lemma partialproj_all a p Ks r
  : partial_proj (l_msg a p Ks) r =
    match pprj_all Ks r with
    | Some Ks' => if p == r then Some (s_msg a Ks')
                  else merge_all [seq K.2.2 | K <- Ks']
    | None => None
    end.
Proof. by []. Qed.

Lemma merge_some (A : eqType)
      (K : lbl * (mty * A))
      (Ks : seq (lbl * (mty * A))) L
  : merge K.2.2 [seq K0.2.2 | K0 <- Ks] == Some L -> K.2.2 = L.
Proof. by elim: Ks=>[/eqP-[]//|K' Ks Ih/=]; case:ifP. Qed.

Notation lmerge_all := (IProject.merge_all simple_merge).

Lemma lmerge_some (K : lbl * (mty * l_ty)) (Ks : seq (lbl * (mty * l_ty))) L
  : simple_merge K.2.2 [seq K0.2.2 | K0 <- Ks] == Some L -> K.2.2 = L.
Proof. by elim: Ks=>[/eqP-[]//|K' Ks Ih/=]; case:ifP. Qed.

Lemma merge_pprj L' Ks L p S
  : simple_merge L' [seq K.2.2 | K <- Ks] == Some L ->
    partial_proj L p == Some S ->
    exists Ks', pprj_all Ks p = Some Ks' /\
                merge S [seq K.2.2 | K <- Ks'] = Some S.
Proof.
  elim: Ks=>[_|K' Ks Ih]/=; first (by exists [::]; split); move: Ih.
  case: ifP=>///eqP<- Ih M_L'; move: (lmerge_some M_L')=>-> /eqP-L_S.
  rewrite L_S; move: L_S=>/eqP-L_S; move: (Ih M_L' L_S) => [Ks' [Ksp M_S]].
  by exists ((K'.1, (K'.2.1, S)):: Ks'); rewrite Ksp /= eq_refl M_S.
Qed.

Lemma mergeall_pprj Ks L p S
  : lmerge_all [seq K.2.2 | K <- Ks] == Some L ->
    partial_proj L p == Some S ->
    exists Ks', pprj_all Ks p = Some Ks' /\
                merge_all [seq K.2.2 | K <- Ks'] = Some S.
Proof.
  case: Ks=>[//|K Ks]/=; move=> H; move: (lmerge_some H)=>KL.
  move: KL H=>-> H /eqP-L_S; rewrite L_S; move: L_S=>/eqP-L_S.
  move: (merge_pprj H L_S)=>[Ks' [Ksp M_S]].
  by exists ((K.1, (K.2.1, S)) :: Ks'); rewrite Ksp/= M_S.
Qed.

Lemma fun_mergeall (A B : eqType) (f : A -> B) (Ks : seq (lbl * (mty * A))) X
  : injective f ->
    merge_all [seq f x.2.2 | x <- Ks] == Some (f X) ->
    merge_all [seq x.2.2 | x <- Ks] == Some X.
Proof.
  case: Ks=>[//|K Ks/=] I; elim: Ks=>[|K' Ks]//=.
  - by move=>/eqP-[/I->].
  - by move=> Ih; case: ifP=>///eqP-[/I->]; rewrite eq_refl=>/Ih.
Qed.

Lemma mergeall_fun (A B : eqType) (f : A -> B) (Ks : seq (lbl * (mty * A))) X:
  merge_all [seq x.2.2 | x <- Ks] == Some X
  -> merge_all [seq f x.2.2 | x <- Ks] == Some (f X).
Proof.
  case: Ks=>[//|K Ks/=]; elim: Ks=>[|K' Ks]//=.
  - by move=>/eqP-[->].
  - by move=> Ih; case: ifP=>///eqP-[->]; rewrite eq_refl=>/Ih.
Qed.

Lemma pprjall_merge p Ks KsL L :
  pprj_all Ks p == Some KsL ->
  merge_all [seq K0.2.2 | K0 <- KsL] == Some L ->
  forall K, member K Ks -> partial_proj K.2.2 p == Some L.
Proof.
  case: KsL=>//= Kl KsL; case: Ks=>//= Kg Ks.
  case Kg_p: partial_proj => [Lp | //]; case Ks_p: pprj_all => [Ksp | //]/=.
  move=> Eq; move: Eq Ks_p => /eqP-[<-->] /eqP-Prj Mrg {Kl Ksp}.
  move:Mrg (merge_some Mrg)=>/=Mrg Eq; move: Eq Mrg Kg_p=>->Mrg /eqP-Kg_p.
  move=> K [<-//|]; move: Prj Mrg K {Lp Kg_p Kg}.
  elim: Ks KsL=>//= Kg Ks Ih KsL.
  case Kg_p: partial_proj => [Lp | //]; case Ks_p: pprj_all => [Ksp | //]/=.
  move=> Eq; move: Eq Ih Ks_p Kg_p=>/eqP-[<-]//= Ih /eqP-Prj.
  case: ifP=>[/eqP-> {Lp}|//] /eqP-Kg_p Mrg K [<-//|].
  by move: Prj=>/Ih/(_ Mrg K).
Qed.

Lemma pprjall_some p Ks Ks' :
  pprj_all Ks p == Some Ks' ->
  forall K,
    member K Ks ->
    exists L, member (K.1, (K.2.1, L)) Ks' /\ partial_proj K.2.2 p = Some L.
Proof.
  elim: Ks=>//= Kl Ks Ih in Ks' *.
  case Kl_p: partial_proj=>[s|//].
  case Ks_p: pprj_all=>[Ks0|//]; move: Ks_p=>/eqP/Ih-{Ih} Ih.
  move=>/eqP-[<-] K [E|/Ih-{Ih}[s' [M Kp]]]{Ks'}.
  - by move: E Kl_p=>-> {Kl}; exists s; split=>//; left.
  - by exists s'; split=>//; right.
Qed.


(** * Valid port map relations. *)

(** Defines the relations that check the validity of port maps
    encountered in the component instantiation statements that are
    part of the description of an H-VHDL design's behavior.  *)

Require Import common.CoqLib.
Require Import common.GlobalTypes.
Require Import common.NatMap.

Require Import hvhdl.Environment.
Require Import hvhdl.SemanticalDomains.
Require Import hvhdl.AbstractSyntax.
Require Import hvhdl.ExpressionEvaluation.
Require Import hvhdl.StaticExpressions.
Require Import hvhdl.HVhdlTypes.

Open Scope N_scope.

(** ** Valid check for input port maps *)

(** Defines the relation that lists the connection of ports in a given
    input port map, i.e a port map where all formal parts of the
    associations corresponds to input port identifiers.

    - [Δ] represents the embedding design in its elaborated version;
      remember that a port map appears in a design instantiation
      statement that is part of the behavior description for a
      embedding design.

    - [Δ__c] is the design instance in its elaborated version.

    - [sst] is the signal store of the default design state being
      constructed by the elaboration phase.

    - [formals] lists the port identifiers that appears in the formal
      part of a port map.

      If a couple [(id, None)] appears in [formals], then [id] appears
      as a formal part of the port map.

      If a couple [(id, Some v)] appears in [formals], then [id(v)]
      appears as formal part of the port map.  *)

Inductive ListIPM (Δ Δ__c : ElDesign) (sst : IdMap value) (formals : list (ident * option N)) :
  list ipassoc -> list (ident * option N) -> Prop :=

(** An empty list of port associations does not change the [formals] list. *)
| ListIPMNil : ListIPM Δ Δ__c sst formals [] formals

(** Lists an non-empty list of port associations. *)
| ListIPMCons :
    forall ipa lofipas formals' formals'',
      EIPAssoc Δ Δ__c sst formals ipa formals' ->
      ListIPM Δ Δ__c sst formals' lofipas formals'' ->
      ListIPM Δ Δ__c sst formals (ipa :: lofipas) formals''

(** Defines the relation that checks the validity of a single input
    port map association. *)

with EIPAssoc (Δ Δ__c : ElDesign) (sst : IdMap value) (formals : list (ident * option N)) :
  ipassoc -> list (ident * option N) -> Prop :=

(** Checks an association with a simple port identifier (no index). *)
| EIPAssocSimple :
    forall id e v t,

      (* Premises *)
      VExpr Δ sst EmptyLEnv false e v ->
      IsOfType v t ->

      (* Side conditions *)
      (~exists optn, List.In (id, optn) formals) ->  (* (id, optn) ∉ formals *)
      MapsTo id (Input t) Δ__c -> (* [id ∈ Ins(Δ__c) and Δ__c(id) = t] *)

      (* Conclusion *)
      EIPAssoc Δ Δ__c sst formals (ipa_ (n_id id) e) (formals ++ [(id, None)])

(** Checks an association with a partial port identifier (with index). *)
| EIPAssocPartial :
    forall id ei e v i t l u,

      (* Premises *)
      IGStaticExpr Δ ei ->
      VExpr Δ sst EmptyLEnv false e v ->
      VExpr Δ sst EmptyLEnv false ei (Vnat i) ->
      IsOfType v t ->
      IsOfType (Vnat i) (Tnat l u) ->

      (* Side conditions *)
      ~List.In (id, None) formals -> (* (id, None) ∉ formals *)
      ~List.In (id, Some i) formals -> (* (id, Some i) ∉ formals *)
      MapsTo id (Input (Tarray t l u)) Δ__c ->  (* [id ∈ Ins(Δ__c) and Δ__c(id) = array(t,l,u)] *)

      (* Conclusion *)
      EIPAssoc Δ Δ__c sst formals (ipa_ (n_xid id ei) e) (formals ++ [(id, Some i)]).

#[export] Hint Constructors ListIPM : hvhdl.
#[export] Hint Constructors EIPAssoc : hvhdl.

(** Defines the predicate that checks the [formals] list (built by the
    [ListIPM] relation) against the component environment [Δ__c].

    For all input port identifier declared in the elaborated design
    [Δ__c], the identifier must appear as a left part of a couple in the
    [formals] list. If the input port identifier is of the array type,
    then all its subelements must appear as a left part of a couple in
    the [formals] list. *)

Definition CheckFormals (Δ__c : ElDesign) (formals : list (ident * option N)) : Prop :=
  forall (id : ident) (t : type),
    MapsTo id (Input t) Δ__c ->
    match t with
    | Tbool | Tnat _ _ => List.In (id, None) formals
    | Tarray t' l u => List.In (id, None) formals \/ forall i, l <= i <= u -> List.In (id, Some i) formals
    end.

(** Defines the predicate stating that an input port map is valid. *)

Inductive ValidIPM (Δ Δ__c : ElDesign) (sst : IdMap value) (i : inputmap) : Prop :=
| ValidIPM_ (formals : list (ident * option N)) :
  ListIPM Δ Δ__c sst [] i formals ->
  CheckFormals Δ__c formals ->
  ValidIPM Δ Δ__c sst i.

(** ** Validity check for output port maps. *)

(** Defines the relation that lists and checks the port identifiers
    present in an output port map. *)

Inductive ListOPM (Δ Δ__c : ElDesign) (formals : list (ident * option N)) :
  list opassoc -> list (ident * option N) -> Prop :=

(** An empty list of port associations does not change the [formals]
    list. *)
| ListOPMNil : ListOPM Δ Δ__c formals [] formals

(** Lists an non-empty list of port associations. *)
| ListOPMCons :
    forall opa lofopas formals' formals'',
      EOPAssoc Δ Δ__c formals opa formals' ->
      ListOPM Δ Δ__c formals' lofopas formals'' ->
      ListOPM Δ Δ__c formals (opa :: lofopas) formals''

(** Defines the relation that checks the validity of an output port
    map association.  *)

with EOPAssoc (Δ Δ__c : ElDesign) (formals : list (ident * option N)) :
  opassoc -> list (ident * option N) -> Prop :=

(** Checks an output port map association of the form [idf ⇒ ida],
    where [ida] refers to a declared signal or an output port
    identifier of the embedding elaborated design.  *)
| EOPAssocSimpleToSimple :
    forall idf ida t,

      (* Side conditions *)
      (forall optv, ~List.In (idf, optv) formals) ->

      (* idf and ida have the same type. *)
      MapsTo idf (Output t) Δ__c -> (* [idf ∈ Outs(Δ__c)] *)
      (* [ida ∈ Sigs(Δ) ∪ Outs(Δ)] *)
      MapsTo ida (Internal t) Δ \/ MapsTo ida (Output t) Δ ->

      (* Conclusion *)
      EOPAssoc Δ Δ__c formals (opa_simpl idf (Some (n_id ida))) (formals ++ [(idf, None)])

(** Checks an output port map association of the form [idf ⇒ ida(ei)],
    where the actual part refers to a composite declared signal or
    output port identifier .  *)

| EOPAssocSimpleToPartial :
    forall idf ida ei i t l u,

      (* Premises *)
      IGStaticExpr Δ ei ->
      VExpr Δ EmptySStore EmptyLEnv false ei (Vnat i) ->
      IsOfType (Vnat i) (Tnat l u) ->

      (* Side conditions *)
      (forall optv, ~List.In (idf, optv) formals) ->

      (* idf and ida(ei) have the same type. *)
      MapsTo idf (Output t) Δ__c ->
      MapsTo ida (Internal (Tarray t l u)) Δ \/ MapsTo ida (Output (Tarray t l u)) Δ ->

      (* Conclusion *)
      EOPAssoc Δ Δ__c formals (opa_simpl idf (Some (n_xid ida ei))) (formals ++ [(idf, None)])

(** Checks an output port map association of the form [idf ⇒ open]. *)
| EOPAssocSimpleToOpen :
    forall idf t,

      (* Side conditions *)
      (forall optv, ~List.In (idf, optv) formals) ->
      MapsTo idf (Output t) Δ__c ->

      (* Conclusion *)
      EOPAssoc Δ Δ__c formals (opa_simpl idf None) (formals ++ [(idf,None)])

(** Checks an output port map association of the form [idf(ei) ⇒ ida],
    where [ida] refers to a declared signal or an output port
    identifier. *)
| EOPAssocPartialToSimple :
    forall idf ei ida i t l u,

      (* Premises *)
      IGStaticExpr Δ ei ->
      VExpr Δ EmptySStore EmptyLEnv false ei (Vnat i) ->
      IsOfType (Vnat i) (Tnat l u) ->

      (* Side conditions *)
      ~List.In (idf, None) formals ->
      ~List.In (idf, Some i) formals ->
      MapsTo idf (Output (Tarray t l u)) Δ__c ->
      MapsTo ida (Internal t) Δ \/ MapsTo ida (Output t) Δ ->

      (* Conclusion *)
      EOPAssoc Δ Δ__c formals (opa_idx idf ei ($ida)) (formals ++ [(idf, Some i)])

(** Checks an output port map association of the form [idf(ei) =>
    ida(ei')], where [ida] refers to a declared signal or an output
    port identifier. *)

| EOPAssocPartialToPartial :
    forall idf ei ida ei' i i' t l u l' u',

      (* Premises *)
      IGStaticExpr Δ ei ->
      IGStaticExpr Δ ei' ->
      VExpr Δ EmptySStore EmptyLEnv false ei (Vnat i) ->
      VExpr Δ EmptySStore EmptyLEnv false ei' (Vnat i') ->
      IsOfType (Vnat i) (Tnat l u) ->
      IsOfType (Vnat i') (Tnat l' u') ->

      (* Side conditions *)
      ~List.In (idf, None) formals ->
      ~List.In (idf, Some i) formals ->
      MapsTo idf (Output (Tarray t l u)) Δ__c ->
      MapsTo ida (Internal (Tarray t l' u')) Δ \/ MapsTo ida (Output (Tarray t l' u')) Δ ->

      (* Conclusion *)
      EOPAssoc Δ Δ__c formals (opa_idx idf ei (ida$[[ei']])) (formals ++ [(idf, Some i)]).

#[export] Hint Constructors ListOPM : hvhdl.
#[export] Hint Constructors EOPAssoc : hvhdl.

(** Defines the relation that checks the validity of an output port
    map. *)

Inductive ValidOPM (Δ Δ__c : ElDesign) (o : list opassoc) : Prop :=
| ValidOPM_ (formals : list (ident * option N)) :
  ListOPM Δ Δ__c [] o formals ->
  ValidOPM Δ Δ__c o.


Require Import Term_Defs Term Eqb_Evidence.

Require Import StructTactics.

Require Import PeanoNat Coq.Program.Tactics.

(*
Inductive EvSubT: Evidence -> Evidence -> Prop :=
| evsub_refl_t : forall e : Evidence, EvSubT e e
| uuSubT: forall e e' i tid l tpl,
    EvSubT e e' ->
    EvSubT e (uu i l tpl tid e')
| ggSubT: forall e e' p,
    EvSubT e e' ->
    EvSubT e (gg p e')
| nnSubT: forall e e' i,
    EvSubT e e' ->
    EvSubT e (nn i e').
*)

Inductive req_evidence: AnnoTerm -> Plc -> Plc -> Evidence -> Evidence -> Prop :=
| is_req_evidence: forall annt t pp p q i e e',
    events annt pp e (req i p q t e') ->
    req_evidence annt pp q e e'.

Fixpoint check_req (t:AnnoTerm) (pp:Plc) (q:Plc) (e:Evidence) (e':Evidence): bool :=
  match t with
  | aatt r rp t' => (eqb_evidence e e' && (Nat.eqb q rp)) || (check_req t' rp q e e')
  | alseq r t1 t2 => (check_req t1 pp q e e') || (check_req t2 pp q (aeval t1 pp e) e')
  | abseq r s t1 t2 =>
    (check_req t1 pp q (splitEv_T_l s e) e') || (check_req t2 pp q (splitEv_T_r s e) e')
  | abpar r s t1 t2 =>
    (check_req t1 pp q (splitEv_T_l s e) e') || (check_req t2 pp q (splitEv_T_r s e) e')
  | _ => false
  end.

Lemma req_implies_check: forall t pp q e e',
    req_evidence t pp q e e' -> check_req t pp q e e' = true.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros.
  -
    destruct a.
    +
      cbn.
      inversion H.
      solve_by_inversion.
    +
      cbn.
      inversion H.
      solve_by_inversion.
    +
      cbn.
      inversion H.
      solve_by_inversion.
    +
      cbn.
      inversion H.
      solve_by_inversion.
  -

    invc H.
    invc H0; subst; cbn.
    +
      rewrite Bool.orb_true_iff.
      left.
      rewrite Bool.andb_true_iff.
      split.
      ++
        rewrite eqb_eq_evidence.
        tauto.
      ++
        apply Nat.eqb_refl.
    +
      rewrite Bool.orb_true_iff.
      right.
      eapply IHt.
      econstructor.
      eassumption.
  -
    cbn.
    invc H.
    invc H0.
    +
      rewrite Bool.orb_true_iff.
      left.
      eapply IHt1.
      econstructor.
      eassumption.
    +
      rewrite Bool.orb_true_iff.
      right.
      eapply IHt2.
      econstructor.
      eassumption.
  -
    cbn.
    invc H.
    invc H0.
    +
      rewrite Bool.orb_true_iff.
      left.
      eapply IHt1.
      econstructor.
      eassumption.
    +
      rewrite Bool.orb_true_iff.
      right.
      eapply IHt2.
      econstructor.
      eassumption.
  -
    cbn.
    invc H.
    invc H0.
    +
      rewrite Bool.orb_true_iff.
      left.
      eapply IHt1.
      econstructor.
      eassumption.
    +
      rewrite Bool.orb_true_iff.
      right.
      eapply IHt2.
      econstructor.
      eassumption.
Defined.

Lemma check_implies_req: forall t pp q e e',
    check_req t pp q e e' = true -> req_evidence t pp q e e'.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros.
  -
    destruct a;
      cbn; try solve_by_inversion.
  -
    cbn in *.
      rewrite Bool.orb_true_iff in H.
      destruct H.
      +
        rewrite Bool.andb_true_iff in H.
        destruct_conjs.
        econstructor.
        rewrite eqb_eq_evidence in *.

        apply EqNat.beq_nat_true in H0.
        subst.
        eauto.
      +

        assert (req_evidence t n q e e') by eauto.
        invc H0.
        econstructor.
        econstructor.
        eassumption.
  -
    cbn in *.
    rewrite Bool.orb_true_iff in H.
    destruct_conjs.
    destruct H.
    +
      assert (req_evidence t1 pp q e e') by eauto.
      invc H0.
      econstructor.
      apply evtslseql.
      eassumption.
    +
      assert (req_evidence t2 pp q (aeval t1 pp e) e') by eauto.
      invc H0.
      econstructor.
      apply evtslseqr.
      eassumption.
  -
    cbn in *.
    rewrite Bool.orb_true_iff in H.
    destruct_conjs.
    destruct H.
    +
      assert (req_evidence t1 pp q (splitEv_T_l s e) e') by eauto.
      invc H0.
      econstructor.
      apply evtsbseql.
      eassumption.
    +
      assert (req_evidence t2 pp q (splitEv_T_r s e) e') by eauto.
      invc H0.
      econstructor.
      apply evtsbseqr.
      eassumption.
  -
    cbn in *.
    rewrite Bool.orb_true_iff in H.
    destruct_conjs.
    destruct H.
    +
      assert (req_evidence t1 pp q (splitEv_T_l s e) e') by eauto.
      invc H0.
      econstructor.
      apply evtsbparl.
      eassumption.
    +
      assert (req_evidence t2 pp q (splitEv_T_r s e) e') by eauto.
      invc H0.
      econstructor.
      apply evtsbparr.
      eassumption.
Defined.

(*

(* priv_pol p e --> allow place p to receive evidence with shape e *)
Definition priv_pol := Plc -> Evidence -> Prop.

Check priv_pol.

Definition satisfies_policy (t:AnnoTerm) (pp:Plc) (ee:Evidence)
           (q:Plc) (es:Evidence) (pol:priv_pol) :=
  req_evidence t pp ee q es -> (pol q es).

Definition test_term: Term := att 1 (asp CPY).
Definition test_term_anno := annotated test_term.
Compute test_term_anno.

Definition test_init_evidence := uu 1 [] 42 442 mt.
Definition test_init_evidence2 := uu 2 [] 42 442 mt.

Definition test_pol (p:Plc) (e:Evidence) :=
  match (p,e) with
  | (1, (uu 1 [] 42 442 mt)) => False
  | _ => True
  end.

Example test_term_satisfies_test_pol: forall pp ee q,
    satisfies_policy test_term_anno pp ee q mt test_pol.
Proof.
  intros.
  cbn.
  unfold test_init_evidence.
  unfold satisfies_policy.
  intros.
  unfold test_pol.
  cbv.
  intros.
  invc H.
  inv H1.
  auto.
  invc H1.
  auto.
  solve_by_inversion.
Qed.
*)


Require Export paconotation pacotac pacodef pacotacuser.
Set Implicit Arguments.

(** ** Predicates of Arity 9
*)

(** 1 Mutual Coinduction *)

Section Arg9_1.

Definition monotone9 T0 T1 T2 T3 T4 T5 T6 T7 T8 (gf: rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8) :=
  forall x0 x1 x2 x3 x4 x5 x6 x7 x8 r r' (IN: gf r x0 x1 x2 x3 x4 x5 x6 x7 x8) (LE: r <9= r'), gf r' x0 x1 x2 x3 x4 x5 x6 x7 x8.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable T5 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3), Type.
Variable T6 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4), Type.
Variable T7 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5), Type.
Variable T8 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6), Type.
Variable gf : rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8.
Implicit Arguments gf [].

Theorem paco9_acc: forall
  l r (OBG: forall rr (INC: r <9= rr) (CIH: l <_paco_9= rr), l <_paco_9= paco9 gf rr),
  l <9= paco9 gf r.
Proof.
  intros; assert (SIM: paco9 gf (r \9/ l) x0 x1 x2 x3 x4 x5 x6 x7 x8) by eauto.
  clear PR; repeat (try left; do 10 paco_revert; paco_cofix_auto).
Qed.

Theorem paco9_mon: monotone9 (paco9 gf).
Proof. paco_cofix_auto; repeat (left; do 10 paco_revert; paco_cofix_auto). Qed.

Theorem paco9_mult_strong: forall r,
  paco9 gf (paco9 gf r \9/ r) <9= paco9 gf r.
Proof. paco_cofix_auto; repeat (left; do 10 paco_revert; paco_cofix_auto). Qed.

Corollary paco9_mult: forall r,
  paco9 gf (paco9 gf r) <9= paco9 gf r.
Proof. intros; eapply paco9_mult_strong, paco9_mon; eauto. Qed.

Theorem paco9_fold: forall r,
  gf (paco9 gf r \9/ r) <9= paco9 gf r.
Proof. intros; econstructor; [ |eauto]; eauto. Qed.

Theorem paco9_unfold: forall (MON: monotone9 gf) r,
  paco9 gf r <9= gf (paco9 gf r \9/ r).
Proof. unfold monotone9; intros; destruct PR; eauto. Qed.

End Arg9_1.

Hint Unfold monotone9.
Hint Resolve paco9_fold.

Implicit Arguments paco9_acc            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_mon            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_mult_strong    [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_mult           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_fold           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_unfold         [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].

Instance paco9_inst  T0 T1 T2 T3 T4 T5 T6 T7 T8 (gf : rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8->_) r x0 x1 x2 x3 x4 x5 x6 x7 x8 : paco_class (paco9 gf r x0 x1 x2 x3 x4 x5 x6 x7 x8) :=
{ pacoacc    := paco9_acc gf;
  pacomult   := paco9_mult gf;
  pacofold   := paco9_fold gf;
  pacounfold := paco9_unfold gf }.

(** 2 Mutual Coinduction *)

Section Arg9_2.

Definition monotone9_2 T0 T1 T2 T3 T4 T5 T6 T7 T8 (gf: rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8) :=
  forall x0 x1 x2 x3 x4 x5 x6 x7 x8 r_0 r_1 r'_0 r'_1 (IN: gf r_0 r_1 x0 x1 x2 x3 x4 x5 x6 x7 x8) (LE_0: r_0 <9= r'_0)(LE_1: r_1 <9= r'_1), gf r'_0 r'_1 x0 x1 x2 x3 x4 x5 x6 x7 x8.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable T5 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3), Type.
Variable T6 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4), Type.
Variable T7 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5), Type.
Variable T8 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6), Type.
Variable gf_0 gf_1 : rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8.
Implicit Arguments gf_0 [].
Implicit Arguments gf_1 [].

Theorem paco9_2_0_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_0 <9= rr) (CIH: l <_paco_9= rr), l <_paco_9= paco9_2_0 gf_0 gf_1 rr r_1),
  l <9= paco9_2_0 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco9_2_0 gf_0 gf_1 (r_0 \9/ l) r_1 x0 x1 x2 x3 x4 x5 x6 x7 x8) by eauto.
  clear PR; repeat (try left; do 10 paco_revert; paco_cofix_auto).
Qed.

Theorem paco9_2_1_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_1 <9= rr) (CIH: l <_paco_9= rr), l <_paco_9= paco9_2_1 gf_0 gf_1 r_0 rr),
  l <9= paco9_2_1 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco9_2_1 gf_0 gf_1 r_0 (r_1 \9/ l) x0 x1 x2 x3 x4 x5 x6 x7 x8) by eauto.
  clear PR; repeat (try left; do 10 paco_revert; paco_cofix_auto).
Qed.

Theorem paco9_2_0_mon: monotone9_2 (paco9_2_0 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 10 paco_revert; paco_cofix_auto). Qed.

Theorem paco9_2_1_mon: monotone9_2 (paco9_2_1 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 10 paco_revert; paco_cofix_auto). Qed.

Theorem paco9_2_0_mult_strong: forall r_0 r_1,
  paco9_2_0 gf_0 gf_1 (paco9_2_0 gf_0 gf_1 r_0 r_1 \9/ r_0) (paco9_2_1 gf_0 gf_1 r_0 r_1 \9/ r_1) <9= paco9_2_0 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 10 paco_revert; paco_cofix_auto). Qed.

Theorem paco9_2_1_mult_strong: forall r_0 r_1,
  paco9_2_1 gf_0 gf_1 (paco9_2_0 gf_0 gf_1 r_0 r_1 \9/ r_0) (paco9_2_1 gf_0 gf_1 r_0 r_1 \9/ r_1) <9= paco9_2_1 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 10 paco_revert; paco_cofix_auto). Qed.

Corollary paco9_2_0_mult: forall r_0 r_1,
  paco9_2_0 gf_0 gf_1 (paco9_2_0 gf_0 gf_1 r_0 r_1) (paco9_2_1 gf_0 gf_1 r_0 r_1) <9= paco9_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco9_2_0_mult_strong, paco9_2_0_mon; eauto. Qed.

Corollary paco9_2_1_mult: forall r_0 r_1,
  paco9_2_1 gf_0 gf_1 (paco9_2_0 gf_0 gf_1 r_0 r_1) (paco9_2_1 gf_0 gf_1 r_0 r_1) <9= paco9_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco9_2_1_mult_strong, paco9_2_1_mon; eauto. Qed.

Theorem paco9_2_0_fold: forall r_0 r_1,
  gf_0 (paco9_2_0 gf_0 gf_1 r_0 r_1 \9/ r_0) (paco9_2_1 gf_0 gf_1 r_0 r_1 \9/ r_1) <9= paco9_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco9_2_1_fold: forall r_0 r_1,
  gf_1 (paco9_2_0 gf_0 gf_1 r_0 r_1 \9/ r_0) (paco9_2_1 gf_0 gf_1 r_0 r_1 \9/ r_1) <9= paco9_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco9_2_0_unfold: forall (MON: monotone9_2 gf_0) (MON: monotone9_2 gf_1) r_0 r_1,
  paco9_2_0 gf_0 gf_1 r_0 r_1 <9= gf_0 (paco9_2_0 gf_0 gf_1 r_0 r_1 \9/ r_0) (paco9_2_1 gf_0 gf_1 r_0 r_1 \9/ r_1).
Proof. unfold monotone9_2; intros; destruct PR; eauto. Qed.

Theorem paco9_2_1_unfold: forall (MON: monotone9_2 gf_0) (MON: monotone9_2 gf_1) r_0 r_1,
  paco9_2_1 gf_0 gf_1 r_0 r_1 <9= gf_1 (paco9_2_0 gf_0 gf_1 r_0 r_1 \9/ r_0) (paco9_2_1 gf_0 gf_1 r_0 r_1 \9/ r_1).
Proof. unfold monotone9_2; intros; destruct PR; eauto. Qed.

End Arg9_2.

Hint Unfold monotone9_2.
Hint Resolve paco9_2_0_fold.
Hint Resolve paco9_2_1_fold.

Implicit Arguments paco9_2_0_acc            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_2_1_acc            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_2_0_mon            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_2_1_mon            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_2_0_mult_strong    [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_2_1_mult_strong    [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_2_0_mult           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_2_1_mult           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_2_0_fold           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_2_1_fold           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_2_0_unfold         [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_2_1_unfold         [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].

Instance paco9_2_0_inst  T0 T1 T2 T3 T4 T5 T6 T7 T8 (gf_0 gf_1 : rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8->_) r_0 r_1 x0 x1 x2 x3 x4 x5 x6 x7 x8 : paco_class (paco9_2_0 gf_0 gf_1 r_0 r_1 x0 x1 x2 x3 x4 x5 x6 x7 x8) :=
{ pacoacc    := paco9_2_0_acc gf_0 gf_1;
  pacomult   := paco9_2_0_mult gf_0 gf_1;
  pacofold   := paco9_2_0_fold gf_0 gf_1;
  pacounfold := paco9_2_0_unfold gf_0 gf_1 }.

Instance paco9_2_1_inst  T0 T1 T2 T3 T4 T5 T6 T7 T8 (gf_0 gf_1 : rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8->_) r_0 r_1 x0 x1 x2 x3 x4 x5 x6 x7 x8 : paco_class (paco9_2_1 gf_0 gf_1 r_0 r_1 x0 x1 x2 x3 x4 x5 x6 x7 x8) :=
{ pacoacc    := paco9_2_1_acc gf_0 gf_1;
  pacomult   := paco9_2_1_mult gf_0 gf_1;
  pacofold   := paco9_2_1_fold gf_0 gf_1;
  pacounfold := paco9_2_1_unfold gf_0 gf_1 }.

(** 3 Mutual Coinduction *)

Section Arg9_3.

Definition monotone9_3 T0 T1 T2 T3 T4 T5 T6 T7 T8 (gf: rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8) :=
  forall x0 x1 x2 x3 x4 x5 x6 x7 x8 r_0 r_1 r_2 r'_0 r'_1 r'_2 (IN: gf r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6 x7 x8) (LE_0: r_0 <9= r'_0)(LE_1: r_1 <9= r'_1)(LE_2: r_2 <9= r'_2), gf r'_0 r'_1 r'_2 x0 x1 x2 x3 x4 x5 x6 x7 x8.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable T5 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3), Type.
Variable T6 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4), Type.
Variable T7 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5), Type.
Variable T8 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6), Type.
Variable gf_0 gf_1 gf_2 : rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8 -> rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8.
Implicit Arguments gf_0 [].
Implicit Arguments gf_1 [].
Implicit Arguments gf_2 [].

Theorem paco9_3_0_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_0 <9= rr) (CIH: l <_paco_9= rr), l <_paco_9= paco9_3_0 gf_0 gf_1 gf_2 rr r_1 r_2),
  l <9= paco9_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco9_3_0 gf_0 gf_1 gf_2 (r_0 \9/ l) r_1 r_2 x0 x1 x2 x3 x4 x5 x6 x7 x8) by eauto.
  clear PR; repeat (try left; do 10 paco_revert; paco_cofix_auto).
Qed.

Theorem paco9_3_1_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_1 <9= rr) (CIH: l <_paco_9= rr), l <_paco_9= paco9_3_1 gf_0 gf_1 gf_2 r_0 rr r_2),
  l <9= paco9_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco9_3_1 gf_0 gf_1 gf_2 r_0 (r_1 \9/ l) r_2 x0 x1 x2 x3 x4 x5 x6 x7 x8) by eauto.
  clear PR; repeat (try left; do 10 paco_revert; paco_cofix_auto).
Qed.

Theorem paco9_3_2_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_2 <9= rr) (CIH: l <_paco_9= rr), l <_paco_9= paco9_3_2 gf_0 gf_1 gf_2 r_0 r_1 rr),
  l <9= paco9_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco9_3_2 gf_0 gf_1 gf_2 r_0 r_1 (r_2 \9/ l) x0 x1 x2 x3 x4 x5 x6 x7 x8) by eauto.
  clear PR; repeat (try left; do 10 paco_revert; paco_cofix_auto).
Qed.

Theorem paco9_3_0_mon: monotone9_3 (paco9_3_0 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 10 paco_revert; paco_cofix_auto). Qed.

Theorem paco9_3_1_mon: monotone9_3 (paco9_3_1 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 10 paco_revert; paco_cofix_auto). Qed.

Theorem paco9_3_2_mon: monotone9_3 (paco9_3_2 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 10 paco_revert; paco_cofix_auto). Qed.

Theorem paco9_3_0_mult_strong: forall r_0 r_1 r_2,
  paco9_3_0 gf_0 gf_1 gf_2 (paco9_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_0) (paco9_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_1) (paco9_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_2) <9= paco9_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 10 paco_revert; paco_cofix_auto). Qed.

Theorem paco9_3_1_mult_strong: forall r_0 r_1 r_2,
  paco9_3_1 gf_0 gf_1 gf_2 (paco9_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_0) (paco9_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_1) (paco9_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_2) <9= paco9_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 10 paco_revert; paco_cofix_auto). Qed.

Theorem paco9_3_2_mult_strong: forall r_0 r_1 r_2,
  paco9_3_2 gf_0 gf_1 gf_2 (paco9_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_0) (paco9_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_1) (paco9_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_2) <9= paco9_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 10 paco_revert; paco_cofix_auto). Qed.

Corollary paco9_3_0_mult: forall r_0 r_1 r_2,
  paco9_3_0 gf_0 gf_1 gf_2 (paco9_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco9_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco9_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <9= paco9_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco9_3_0_mult_strong, paco9_3_0_mon; eauto. Qed.

Corollary paco9_3_1_mult: forall r_0 r_1 r_2,
  paco9_3_1 gf_0 gf_1 gf_2 (paco9_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco9_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco9_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <9= paco9_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco9_3_1_mult_strong, paco9_3_1_mon; eauto. Qed.

Corollary paco9_3_2_mult: forall r_0 r_1 r_2,
  paco9_3_2 gf_0 gf_1 gf_2 (paco9_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco9_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco9_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <9= paco9_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco9_3_2_mult_strong, paco9_3_2_mon; eauto. Qed.

Theorem paco9_3_0_fold: forall r_0 r_1 r_2,
  gf_0 (paco9_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_0) (paco9_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_1) (paco9_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_2) <9= paco9_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco9_3_1_fold: forall r_0 r_1 r_2,
  gf_1 (paco9_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_0) (paco9_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_1) (paco9_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_2) <9= paco9_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco9_3_2_fold: forall r_0 r_1 r_2,
  gf_2 (paco9_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_0) (paco9_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_1) (paco9_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_2) <9= paco9_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco9_3_0_unfold: forall (MON: monotone9_3 gf_0) (MON: monotone9_3 gf_1) (MON: monotone9_3 gf_2) r_0 r_1 r_2,
  paco9_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 <9= gf_0 (paco9_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_0) (paco9_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_1) (paco9_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_2).
Proof. unfold monotone9_3; intros; destruct PR; eauto. Qed.

Theorem paco9_3_1_unfold: forall (MON: monotone9_3 gf_0) (MON: monotone9_3 gf_1) (MON: monotone9_3 gf_2) r_0 r_1 r_2,
  paco9_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 <9= gf_1 (paco9_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_0) (paco9_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_1) (paco9_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_2).
Proof. unfold monotone9_3; intros; destruct PR; eauto. Qed.

Theorem paco9_3_2_unfold: forall (MON: monotone9_3 gf_0) (MON: monotone9_3 gf_1) (MON: monotone9_3 gf_2) r_0 r_1 r_2,
  paco9_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 <9= gf_2 (paco9_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_0) (paco9_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_1) (paco9_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \9/ r_2).
Proof. unfold monotone9_3; intros; destruct PR; eauto. Qed.

End Arg9_3.

Hint Unfold monotone9_3.
Hint Resolve paco9_3_0_fold.
Hint Resolve paco9_3_1_fold.
Hint Resolve paco9_3_2_fold.

Implicit Arguments paco9_3_0_acc            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_3_1_acc            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_3_2_acc            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_3_0_mon            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_3_1_mon            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_3_2_mon            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_3_0_mult_strong    [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_3_1_mult_strong    [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_3_2_mult_strong    [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_3_0_mult           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_3_1_mult           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_3_2_mult           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_3_0_fold           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_3_1_fold           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_3_2_fold           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_3_0_unfold         [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_3_1_unfold         [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].
Implicit Arguments paco9_3_2_unfold         [ T0 T1 T2 T3 T4 T5 T6 T7 T8 ].

Instance paco9_3_0_inst  T0 T1 T2 T3 T4 T5 T6 T7 T8 (gf_0 gf_1 gf_2 : rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8->_) r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6 x7 x8 : paco_class (paco9_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6 x7 x8) :=
{ pacoacc    := paco9_3_0_acc gf_0 gf_1 gf_2;
  pacomult   := paco9_3_0_mult gf_0 gf_1 gf_2;
  pacofold   := paco9_3_0_fold gf_0 gf_1 gf_2;
  pacounfold := paco9_3_0_unfold gf_0 gf_1 gf_2 }.

Instance paco9_3_1_inst  T0 T1 T2 T3 T4 T5 T6 T7 T8 (gf_0 gf_1 gf_2 : rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8->_) r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6 x7 x8 : paco_class (paco9_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6 x7 x8) :=
{ pacoacc    := paco9_3_1_acc gf_0 gf_1 gf_2;
  pacomult   := paco9_3_1_mult gf_0 gf_1 gf_2;
  pacofold   := paco9_3_1_fold gf_0 gf_1 gf_2;
  pacounfold := paco9_3_1_unfold gf_0 gf_1 gf_2 }.

Instance paco9_3_2_inst  T0 T1 T2 T3 T4 T5 T6 T7 T8 (gf_0 gf_1 gf_2 : rel9 T0 T1 T2 T3 T4 T5 T6 T7 T8->_) r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6 x7 x8 : paco_class (paco9_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6 x7 x8) :=
{ pacoacc    := paco9_3_2_acc gf_0 gf_1 gf_2;
  pacomult   := paco9_3_2_mult gf_0 gf_1 gf_2;
  pacofold   := paco9_3_2_fold gf_0 gf_1 gf_2;
  pacounfold := paco9_3_2_unfold gf_0 gf_1 gf_2 }.


Require Import Ynot.
Require Import List Ascii.

Set Implicit Arguments.

Open Local Scope stsepi_scope.
Open Local Scope hprop_scope.

(* Mimic open types *)
Axiom axiom_Action : Set.
Definition Action := axiom_Action.
Definition Action_model := unit.

Definition Trace := list Action.
Definition TraceModel := list Action_model.

Axiom axiom_traced : Trace -> hprop.
Definition traced := axiom_traced.
Definition traced_model (t: TraceModel) := [True].

Definition forever : forall (I : Trace -> hprop)
  (B : forall t', STsep (t' ~~ traced t' * I t')
        (fun t'':[Trace] => t' ~~ t'' ~~ traced (t'' ++ t') * I (t'' ++ t')))
  (t' : [Trace]),
  STsep (t' ~~ traced t' * I t')
        (fun _:Empty_set => t' ~~ Exists t'' :@ Trace, traced (t'' ++ t') * I (t'' ++ t') * [False]).
  refine (fun I B t' =>
    Fix (fun t => t ~~ traced t * I t)
        (fun t (_:Empty_set) => t ~~ Exists t'' :@ Trace, traced (t'' ++ t) * I (t'' ++ t) * [False])
        (fun self t =>
          tr' <- B t;
          {{self (inhabit_unpack' t (fun t => inhabit_unpack tr' (fun tr' => tr' ++ t))) }}
        ) t');
  sep fail auto.
Qed.

Definition foreverInv : forall (CTX : Type) (ctx : CTX) (I : CTX -> Trace -> hprop)
  (B : forall ctx t',
         STsep (t' ~~ traced t' * I ctx t')
               (fun ctx':CTX * [Trace] => t' ~~ t'' :~~ snd ctx' in traced (t'' ++ t') * I (fst ctx') (t'' ++ t')))
  (t' : [Trace]),
  STsep (t' ~~ traced t' * I ctx t')
        (fun _:Empty_set => t' ~~ Exists t'' :@ Trace, Exists ctx' :@ CTX, traced (t'' ++ t') * I ctx' (t'' ++ t') * [False]).
  intros. refine (
    Fix2 (fun ctx t => t ~~ traced t * I ctx t)
         (fun ctx t (_:Empty_set) => t ~~ Exists t'' :@ Trace, Exists ctx' :@ CTX, traced (t'' ++ t) * I ctx' (t'' ++ t) * [False])
         (fun self ctx t =>
           ctx' <- B ctx t;
           {{self (fst ctx') (inhabit_unpack' t (fun t => inhabit_unpack (snd ctx') (fun tr' => tr' ++ t))) }}
         ) ctx t').
    solve [ sep fail auto ].
    solve [ sep fail auto ].
    sep fail auto. inhabiter. rewrite H in H1. simpl in H1. sep fail auto.
    solve [ sep fail auto ].
Qed.

(***********************************************)

(* A type of invariant preserving computations
   that make progress.  We repeat this forever
   to get a server. *)

Definition server_t (I: Trace -> Prop) (pf_startable: I nil) := forall (tr: [Trace]),
 STsep                (tr ~~ traced       tr  * [I       tr])
(fun r:[Trace] => r ~~ tr ~~ traced (r ++ tr) * [I (r ++ tr)] * [r <> nil]).

Require Export RSep.