Require Import VST.floyd.proofauto.
Require Import VST.progs.load_demo.

#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Definition pair_pair_t := (Tstruct _pair_pair noattr).

Definition array_size := 100.

Definition get22_spec :=
 DECLARE _get22
  WITH pps: val, i: Z, x11: int, x12: int, x21: int, x22: int, sh : share
  PRE [ tptr pair_pair_t, tint ]
    PROP  (readable_share sh; 0 <= i < array_size)
    PARAMS (pps; Vint (Int.repr i))
    SEP   (field_at sh (tarray pair_pair_t array_size) [ArraySubsc i]
                    ((Vint x11, Vint x12), (Vint x21, Vint x22)) pps)
  POST [ tint ]
        PROP () RETURN (Vint x22)
    SEP   (field_at sh (tarray pair_pair_t array_size) [ArraySubsc i]
                    ((Vint x11, Vint x12), (Vint x21, Vint x22)) pps).

Definition uint_sum (contents : list Z) : int :=
  fold_right (fun el sum => Int.add sum (Int.repr el)) Int.zero contents.

Definition fiddle_spec :=
 DECLARE _fiddle
  WITH p: val, n: Z, tag: Z, contents: list Z
  PRE [ tptr tuint ]
          PROP  (Int.unsigned (Int.shru (Int.repr tag) (Int.repr 10)) = n)
          PARAMS (p)
          SEP (data_at Ews (tarray tuint (1+n))
                      (map Vint (map Int.repr (tag::contents)))
                      (offset_val (-sizeof tuint) p))
  POST [ tint ]
          PROP ( )
          RETURN (Vint (Int.add (Int.repr (Z.land tag 255)) (uint_sum contents)))
          SEP (data_at Ews (tarray tuint (1+n))
                      (map Vint (map Int.repr (tag::contents)))
                      (offset_val (-sizeof tuint) p)).

Definition get_uint32_le (arr: list Z) : int :=
 (Int.or (Int.or (Int.or
            (Int.repr (Znth 0 arr))
   (Int.shl (Int.repr (Znth 1 arr)) (Int.repr  8)))
   (Int.shl (Int.repr (Znth 2 arr)) (Int.repr 16)))
   (Int.shl (Int.repr (Znth 3 arr)) (Int.repr 24))).

Definition get_little_endian_spec :=
  DECLARE _get_little_endian
  WITH input : val, in_sh : share, arr : list Z
  PRE [ tptr tuchar ]
    PROP (Zlength arr = 4;
          readable_share in_sh;
          forall i, 0 <= i < 4 -> 0 <= Znth i arr <= Byte.max_unsigned)
    PARAMS (input)
    SEP (data_at in_sh (tarray tuchar 4) (map Vint (map Int.repr arr)) input)
  POST [ tuint ]
    PROP() RETURN (Vint (get_uint32_le arr))
    SEP (data_at in_sh (tarray tuchar 4) (map Vint (map Int.repr arr)) input).

Definition Gprog : funspecs := ltac:(with_library prog
  [get22_spec; fiddle_spec; get_little_endian_spec]).

Ltac solve_arr_range H :=
 match goal with |- context [Znth ?i _] =>
   specialize (H i); spec H; [ computable | ];
   rewrite Int.unsigned_repr; rep_lia
 end.

Lemma body_get_little_endian: semax_body Vprog Gprog f_get_little_endian get_little_endian_spec.
Proof.
start_function.
assert (BMU: Byte.max_unsigned=255) by reflexivity.
forward.
entailer!!. solve_arr_range H0.
forward.
forward.
entailer!!. solve_arr_range H0.
forward.
forward.
entailer!!. solve_arr_range H0.
forward.
entailer!. solve_arr_range H0.
forward.
Qed.

Lemma uint_sum_app: forall a b, uint_sum (a++b) = Int.add (uint_sum a) (uint_sum b).
Proof.
  intros. induction a; simpl.
  - symmetry. apply Int.add_zero_l.
  - rewrite IHa. rewrite !Int.add_assoc. f_equal. apply Int.add_commut.
Qed.

Lemma body_fiddle: semax_body Vprog Gprog f_fiddle fiddle_spec.
Proof.
start_function. simpl map.
rename H into Htag.
assert_PROP (Zlength contents = n) as LEN. {
  entailer!.
  forget (Int.unsigned (Int.shru (Int.repr tag) (Int.repr 10))) as n.
  clear - H0.
  rewrite Zlength_cons, !Zlength_map in H0.
  destruct (zlt n 0); [exfalso | ].
  rewrite Z.max_l in H0 by lia.
  pose proof (Zlength_nonneg contents).
  lia.
  rewrite Z.max_r in H0 by lia. lia.
}
assert (Zlength (tag :: contents) = 1 + n) as LEN1. {
  rewrite Zlength_cons. lia.
}
assert (N0: 0 <= n). {
  pose proof (Zlength_nonneg contents). lia.
}
assert_PROP (isptr p) as P by entailer!.

(* forward fails, but tells us to prove this: *)
assert_PROP (force_val (sem_add_ptr_int tuint Signed p (eval_unop Oneg tint (Vint (Int.repr 1))))
  = field_address (tarray tuint (1+n)) [ArraySubsc 0] (offset_val (-sizeof tuint) p)). {
  entailer!.
  destruct p; inversion P. simpl.
  rewrite field_compatible_field_address by auto with field_compatible.
  simpl.
  rewrite ptrofs_add_repr_0_r. reflexivity.
}
forward.
(* sum = tagword & 0xff; *)
forward.
(* size = tagword >> 10; *)
forward.
(* rewrite !Znth_0_cons. *)
forward_for_simple_bound (Int.unsigned (Int.shru (Int.repr tag) (Int.repr 10))) (EX i: Z,
  PROP ( )
  LOCAL (
    temp _size (Vint (Int.shru (Int.repr tag) (Int.repr 10)));
    temp _sum (Vint (Int.add (Int.and (Int.repr tag) (Int.repr 255))
                             (uint_sum (sublist 0 i contents))));
    temp _tagword (Vint (Int.repr tag));
    temp _p p
  )
  SEP (data_at Ews (tarray tuint (1 + n)) (map Vint (map Int.repr (tag :: contents)))
          (offset_val (- sizeof tuint) p))).
- (* precondition implies invariant: *)
  entailer!!.
- (* body preserves invariant: *)
  (* forward fails, but tells us to prove this: *)
  assert_PROP (force_val (sem_add_ptr_int tuint Unsigned p (Vint (Int.repr i)))
    = field_address (tarray tuint (1 + n)) [ArraySubsc (1 + i)] (offset_val (- sizeof tuint) p)). {
    entailer!.
    destruct p; inversion P. simpl.
    rewrite field_compatible_field_address by auto with field_compatible.
    simpl.
    rewrite Ptrofs.add_assoc, ptrofs_add_repr.
    f_equal. f_equal. f_equal. unfold sizeof; simpl. lia.
  }
  forward.
  forward.
  entailer!.
  rewrite Znth_pos_cons by lia.
  autorewrite with sublist. simpl.
  f_equal. rewrite Int.add_assoc. f_equal.
  rewrite (sublist_split 0 i (i+1)) by lia.
  rewrite sublist_len_1 by lia.
  replace (1 + i - 1) with i by lia.
  rewrite uint_sum_app. f_equal. simpl. apply Int.add_zero_l.
- (* return sum; *)
  forward. rewrite sublist_same by auto. entailer!!.
Qed.

Lemma body_get22_root_expr: semax_body Vprog Gprog f_get22 get22_spec.
 Proof.
 start_function.
 (* int_pair_t* p = &pps[i].right; *)
 forward.
 simpl (temp _p _).
 (* Assert_PROP what forward asks us for (only for the root expression "p"):  *)
 assert_PROP (offset_val 8 (force_val (sem_add_ptr_int (Tstruct _pair_pair noattr) Signed pps (Vint (Int.repr i))))
   = field_address (tarray pair_pair_t array_size) [StructField _right; ArraySubsc i] pps) as E. {
   entailer!. rewrite field_compatible_field_address by auto with field_compatible.
  simpl. normalize.
 }
 (* int res = p->snd; *)
 forward.
 (* return res; *)
 forward.
 Qed.

Lemma body_get22_full_expr: semax_body Vprog Gprog f_get22 get22_spec.
Proof.
start_function.
(* int_pair_t* p = &pps[i].right; *)
forward.
simpl (temp _p _).

(* Assert_PROP what forward asks us for (for the full expression "p->snd"): *)
assert_PROP (
  offset_val 4 (offset_val 8 (force_val
    (sem_add_ptr_int (Tstruct _pair_pair noattr) Signed pps (Vint (Int.repr i)))))
  = (field_address (tarray pair_pair_t array_size)
                   [StructField _snd; StructField _right; ArraySubsc i] pps)). {
  entailer!. rewrite field_compatible_field_address by auto with field_compatible.
  simpl. f_equal. unfold sizeof; simpl. lia.
}
(* int res = p->snd; *)
forward.
(* return res; *)
forward.
Qed.

Lemma body_get22_alt: semax_body Vprog Gprog f_get22 get22_spec.
Proof.
start_function.
(* int_pair_t* p = &pps[i].right; *)
forward.
simpl (temp _p _).

(* Alternative: Make p nice enough so that no hint is required: *)
assert_PROP (offset_val 8 (force_val (sem_add_ptr_int (Tstruct _pair_pair noattr) Signed pps (Vint (Int.repr i))))
  = field_address (tarray pair_pair_t array_size) [StructField _right; ArraySubsc i] pps) as E. {
  entailer!. rewrite field_compatible_field_address by auto with field_compatible.
  simpl.
  normalize.
}
rewrite E. clear E.
(* int res = p->snd; *)
forward.
(* return res; *)
forward.
Qed.


From iris.algebra Require Import numbers.
From iris.proofmode Require Import proofmode.
From lrust.typing Require Export type.
From lrust.typing Require Import type_context lft_contexts product own uniq_bor.
From lrust.typing Require Import shr_bor.
From iris.prelude Require Import options.

Section product_split.
  Context `{!typeGS Σ}.

  (** General splitting / merging for pointer types *)
  Fixpoint hasty_ptr_offsets (p : path) (ptr: type → type) tyl (off : nat) : tctx :=
    match tyl with
    | [] => []
    | ty :: tyl =>
      (p +ₗ #off ◁ ptr ty) :: hasty_ptr_offsets p ptr tyl (off + ty.(ty_size))
    end.

  Lemma hasty_ptr_offsets_offset (l : loc) p (off1 off2 : nat) ptr tyl tid :
    eval_path p = Some #l →
    tctx_interp tid $ hasty_ptr_offsets (p +ₗ #off1) ptr tyl off2 ≡
    tctx_interp tid $ hasty_ptr_offsets p ptr tyl (off1 + off2)%nat.
  Proof.
    intros Hp.
    revert off1 off2; induction tyl as [|ty tyl IH]; intros off1 off2; simpl; first done.
    rewrite !tctx_interp_cons. f_equiv; last first.
    { by rewrite IH assoc_L. }
    apply tctx_elt_interp_hasty_path. clear Hp. simpl.
    clear. destruct (eval_path p) as [v|]; last done. destruct v as [l|]; try done.
    destruct l; try done. rewrite shift_loc_assoc Nat2Z.inj_add //.
  Qed.

  Lemma tctx_split_ptr_prod E L ptr tyl :
    (∀ p ty1 ty2,
        tctx_incl E L [p ◁ ptr $ product2 ty1 ty2]
                      [p ◁ ptr ty1; p +ₗ #ty1.(ty_size) ◁ ptr ty2]) →
    (∀ tid ty vl, (ptr ty).(ty_own) tid vl -∗ ⌜∃ l : loc, vl = [(#l) : val]⌝) →
    ∀ p, tctx_incl E L [p ◁ ptr $ product tyl] (hasty_ptr_offsets p ptr tyl 0).
  Proof.
    iIntros (Hsplit Hloc p tid qmax qL) "#LFT #HE HL H".
    iInduction tyl as [|ty tyl IH] "IH" forall (p).
    { rewrite tctx_interp_nil. auto. }
    rewrite product_cons. iMod (Hsplit with "LFT HE HL H") as "(HL & H)".
    cbn -[tctx_elt_interp].
    iDestruct "H" as "[Hty Htyl]". iDestruct "Hty" as (v) "[Hp Hty]". iDestruct "Hp" as %Hp.
    iDestruct (Hloc with "Hty") as %[l [=->]].
    iAssert (tctx_elt_interp tid (p +ₗ #0 ◁ ptr ty)) with "[Hty]" as "$".
    { iExists #l. iSplit; last done. simpl; by rewrite Hp shift_loc_0. }
    iMod ("IH" with "HL [Htyl]") as "($ & Htyl)".
    { auto. }
    iClear "IH". rewrite (hasty_ptr_offsets_offset l) // -plus_n_O //.
  Qed.

  Lemma tctx_merge_ptr_prod E L ptr tyl :
    (Proper (eqtype E L ==> eqtype E L ) ptr) → tyl ≠ [] →
    (∀ p ty1 ty2,
        tctx_incl E L [p ◁ ptr ty1; p +ₗ #ty1.(ty_size) ◁ ptr ty2]
                      [p ◁ ptr $ product2 ty1 ty2]) →
    (∀ tid ty vl, (ptr ty).(ty_own) tid vl -∗ ⌜∃ l : loc, vl = [(#l) : val]⌝) →
    ∀ p, tctx_incl E L (hasty_ptr_offsets p ptr tyl 0) [p ◁ ptr $ product tyl].
  Proof.
    iIntros (Hptr Htyl Hmerge Hloc p tid qmax qL) "#LFT #HE HL H".
    iInduction tyl as [|ty tyl IH] "IH" forall (p Htyl); first done.
    rewrite product_cons. rewrite /= tctx_interp_singleton tctx_interp_cons.
    iDestruct "H" as "[Hty Htyl]". iDestruct "Hty" as (v) "[Hp Hty]".
    iDestruct "Hp" as %Hp. iDestruct (Hloc with "Hty") as %[l [=->]].
    assert (eval_path p = Some #l) as Hp'.
    { move:Hp. simpl. clear. destruct (eval_path p) as [v|]; last done.
      destruct v as [l'|]; try done. destruct l'; try done. rewrite shift_loc_0. done. }
    clear Hp. destruct tyl.
    { assert (eqtype E L (ptr ty) (ptr (product2 ty unit))) as [Hincl _].
      { rewrite right_id. done. }
      iDestruct (Hincl with "HL HE") as "#(_ & #Heq & _)".
      iFrame. iClear "IH Htyl". iExists #l. rewrite product_nil. iSplitR; first done.
      by iApply "Heq". }
    iMod ("IH" with "[] HL [Htyl]") as "(HL & Htyl)"; first done.
    { change (ty_size ty) with (0+ty_size ty)%nat at 1.
      rewrite plus_comm -hasty_ptr_offsets_offset //. }
    iClear "IH". iMod (Hmerge with "LFT HE HL [Hty Htyl]") as "($ & ?)";
                   last by rewrite tctx_interp_singleton.
    rewrite tctx_interp_singleton tctx_interp_cons tctx_interp_singleton. iFrame.
    iExists #l. iSplit; done.
  Qed.

  (** Owned pointers *)
  Lemma tctx_split_own_prod2 E L p n ty1 ty2 :
    tctx_incl E L [p ◁ own_ptr n $ product2 ty1 ty2]
                  [p ◁ own_ptr n ty1; p +ₗ #ty1.(ty_size) ◁ own_ptr n ty2].
  Proof.
    iIntros (tid qmax qL) "#LFT _ $ H".
    rewrite tctx_interp_singleton tctx_interp_cons tctx_interp_singleton.
    iDestruct "H" as ([[]|]) "[#Hp H]"; try done.
    iDestruct "H" as "[H >H†]". iDestruct "H" as (vl) "[>H↦ H]".
    iDestruct "H" as (vl1 vl2) "(>% & H1 & H2)". subst.
    rewrite heap_mapsto_vec_app -freeable_sz_split.
    iDestruct "H†" as "[H†1 H†2]". iDestruct "H↦" as "[H↦1 H↦2]".
    iDestruct (ty_size_eq with "H1") as "#>EQ".
    iDestruct "EQ" as %->. iSplitL "H↦1 H†1 H1".
    + iExists _. iFrame "#∗". iExists _. by iFrame.
    + iExists _. iSplitR; first (by simpl; iDestruct "Hp" as %->).
      iFrame. iExists _. by iFrame.
  Qed.

  Lemma tctx_merge_own_prod2 E L p n ty1 ty2 :
    tctx_incl E L [p ◁ own_ptr n ty1; p +ₗ #ty1.(ty_size) ◁ own_ptr n ty2]
                  [p ◁ own_ptr n $ product2 ty1 ty2].
  Proof.
    iIntros (tid qmax qL) "#LFT _ $ H".
    rewrite tctx_interp_singleton tctx_interp_cons tctx_interp_singleton.
    iDestruct "H" as "[H1 H2]". iDestruct "H1" as ([[|l|]|]) "(Hp1 & H1)"; try done.
    iDestruct "H1" as "(H↦1 & H†1)".
    iDestruct "H2" as (v2) "(Hp2 & H2)". simpl. iDestruct "Hp1" as %Hρ1.
    rewrite Hρ1. iDestruct "Hp2" as %[=<-]. iDestruct "H2" as "[H↦2 H†2]".
    iExists #l. iSplitR; first done. rewrite /= -freeable_sz_split. iFrame.
    iDestruct "H↦1" as (vl1) "[H↦1 H1]". iDestruct "H↦2" as (vl2) "[H↦2 H2]".
    iExists (vl1 ++ vl2). rewrite heap_mapsto_vec_app. iFrame.
    iDestruct (ty_size_eq with "H1") as "#>EQ". iDestruct "EQ" as %->.
    rewrite {3}/ty_own /=. auto 10 with iFrame.
  Qed.

  Lemma tctx_split_own_prod E L n tyl p :
    tctx_incl E L [p ◁ own_ptr n $ product tyl] (hasty_ptr_offsets p (own_ptr n) tyl 0).
  Proof.
    apply tctx_split_ptr_prod.
    - intros. apply tctx_split_own_prod2.
    - iIntros (??[|[[]|][]]) "?"; eauto.
  Qed.

  Lemma tctx_merge_own_prod E L n tyl :
    tyl ≠ [] →
    ∀ p, tctx_incl E L (hasty_ptr_offsets p (own_ptr n) tyl 0)
                   [p ◁ own_ptr n $ product tyl].
  Proof.
    intros. apply tctx_merge_ptr_prod; try done.
    - apply _.
    - intros. apply tctx_merge_own_prod2.
    - iIntros (??[|[[]|][]]) "?"; eauto.
  Qed.

  (** Unique borrows *)
  Lemma tctx_split_uniq_prod2 E L p κ ty1 ty2 :
    tctx_incl E L [p ◁ &uniq{κ}(product2 ty1 ty2)]
                  [p ◁ &uniq{κ} ty1; p +ₗ #ty1.(ty_size) ◁ &uniq{κ} ty2].
  Proof.
    iIntros (tid qmax qL) "#LFT _ $ H".
    rewrite tctx_interp_singleton tctx_interp_cons tctx_interp_singleton.
    iDestruct "H" as ([[]|]) "[Hp H]"; try done. iDestruct "Hp" as %Hp.
    rewrite /= split_prod_mt. iMod (bor_sep with "LFT H") as "[H1 H2]"; first solve_ndisj.
    rewrite /tctx_elt_interp /=.
    iSplitL "H1"; iExists _; (iSplitR; first by rewrite Hp); auto.
  Qed.

  Lemma tctx_merge_uniq_prod2 E L p κ ty1 ty2 :
    tctx_incl E L [p ◁ &uniq{κ} ty1; p +ₗ #ty1.(ty_size) ◁ &uniq{κ} ty2]
                  [p ◁ &uniq{κ}(product2 ty1 ty2)].
  Proof.
    iIntros (tid qmax qL) "#LFT _ $ H".
    rewrite tctx_interp_singleton tctx_interp_cons tctx_interp_singleton.
    iDestruct "H" as "[H1 H2]". iDestruct "H1" as ([[|l|]|]) "[Hp1 H1]"; try done.
    iDestruct "Hp1" as %Hp1. iDestruct "H2" as (v2) "(Hp2 & H2)". rewrite /= Hp1.
    iDestruct "Hp2" as %[=<-]. iExists #l. iFrame "%".
    iMod (bor_combine with "LFT H1 H2") as "H"; first solve_ndisj. by rewrite /= split_prod_mt.
  Qed.

  Lemma uniq_is_ptr κ ty tid (vl : list val) :
    ty_own (&uniq{κ}ty) tid vl -∗ ⌜∃ l : loc, vl = [(#l) : val]⌝.
  Proof. iIntros "H". destruct vl as [|[[]|][]]; eauto. Qed.

  Lemma tctx_split_uniq_prod E L κ tyl p :
    tctx_incl E L [p ◁ &uniq{κ}(product tyl)]
                  (hasty_ptr_offsets p (uniq_bor κ) tyl 0).
  Proof.
    apply tctx_split_ptr_prod.
    - intros. apply tctx_split_uniq_prod2.
    - intros. apply uniq_is_ptr.
  Qed.

  Lemma tctx_merge_uniq_prod E L κ tyl :
    tyl ≠ [] →
    ∀ p, tctx_incl E L (hasty_ptr_offsets p (uniq_bor κ) tyl 0)
                   [p ◁ &uniq{κ}(product tyl)].
  Proof.
    intros. apply tctx_merge_ptr_prod; try done.
    - apply _.
    - intros. apply tctx_merge_uniq_prod2.
    - intros. apply uniq_is_ptr.
  Qed.

  (** Shared borrows *)
  Lemma tctx_split_shr_prod2 E L p κ ty1 ty2 :
    tctx_incl E L [p ◁ &shr{κ}(product2 ty1 ty2)]
                  [p ◁ &shr{κ} ty1; p +ₗ #ty1.(ty_size) ◁ &shr{κ} ty2].
  Proof.
    iIntros (tid qmax qL) "#LFT _ $ H".
    rewrite tctx_interp_singleton tctx_interp_cons tctx_interp_singleton.
    iDestruct "H" as ([[]|]) "[Hp H]"; try iDestruct "H" as "[]".
    iDestruct "H" as "[H1 H2]". iDestruct "Hp" as %Hp.
    by iSplitL "H1"; iExists _; (iSplitR; first by rewrite /= Hp).
  Qed.

  Lemma tctx_merge_shr_prod2 E L p κ ty1 ty2 :
    tctx_incl E L [p ◁ &shr{κ} ty1; p +ₗ #ty1.(ty_size) ◁ &shr{κ} ty2]
                  [p ◁ &shr{κ}(product2 ty1 ty2)].
  Proof.
    iIntros (tid qmax qL) "#LFT _ $ H".
    rewrite tctx_interp_singleton tctx_interp_cons tctx_interp_singleton.
    iDestruct "H" as "[H1 H2]". iDestruct "H1" as ([[|l|]|]) "[Hp1 Hown1]"; try done.
    iDestruct "Hp1" as %Hp1. iDestruct "H2" as ([[]|]) "[Hp2 Hown2]"; try done.
    rewrite /= Hp1. iDestruct "Hp2" as %[=<-]. iExists #l. by iFrame.
  Qed.

  Lemma shr_is_ptr κ ty tid (vl : list val) :
    ty_own (&shr{κ} ty) tid vl -∗ ⌜∃ l : loc, vl = [(#l) : val]⌝.
  Proof. iIntros "H". destruct vl as [|[[]|][]]; eauto. Qed.

  Lemma tctx_split_shr_prod E L κ tyl p :
    tctx_incl E L [p ◁ &shr{κ}(product tyl)]
                  (hasty_ptr_offsets p (shr_bor κ) tyl 0).
  Proof.
    apply tctx_split_ptr_prod.
    - intros. apply tctx_split_shr_prod2.
    - intros. apply shr_is_ptr.
  Qed.

  Lemma tctx_merge_shr_prod E L κ tyl :
    tyl ≠ [] →
    ∀ p, tctx_incl E L (hasty_ptr_offsets p (shr_bor κ) tyl 0)
                   [p ◁ &shr{κ}(product tyl)].
  Proof.
    intros. apply tctx_merge_ptr_prod; try done.
    - apply _.
    - intros. apply tctx_merge_shr_prod2.
    - intros. apply shr_is_ptr.
  Qed.

  (* Splitting with [tctx_extract]. *)

  (* We do not state the extraction lemmas directly, because we want the
     automation system to be able to perform e.g., borrowing or splitting after
     splitting. *)
  Lemma tctx_extract_split_own_prod E L p p' n ty tyl T T' :
    tctx_extract_hasty E L p' ty (hasty_ptr_offsets p (own_ptr n) tyl 0) T' →
    tctx_extract_hasty E L p' ty ((p ◁ own_ptr n $ Π tyl) :: T) (T' ++ T).
  Proof.
    intros. apply (tctx_incl_frame_r T [_] (_::_)). by rewrite tctx_split_own_prod.
  Qed.

  Lemma tctx_extract_split_uniq_prod E L p p' κ ty tyl T T' :
    tctx_extract_hasty E L p' ty (hasty_ptr_offsets p (uniq_bor κ) tyl 0) T' →
    tctx_extract_hasty E L p' ty ((p ◁ &uniq{κ}(Π tyl)) :: T) (T' ++ T).
  Proof.
    intros. apply (tctx_incl_frame_r T [_] (_::_)). by rewrite tctx_split_uniq_prod.
  Qed.

  Lemma tctx_extract_split_shr_prod E L p p' κ ty tyl T T' :
    tctx_extract_hasty E L p' ty (hasty_ptr_offsets p (shr_bor κ) tyl 0) T' →
    tctx_extract_hasty E L p' ty ((p ◁ &shr{κ}(Π tyl)) :: T) ((p ◁ &shr{κ}(Π tyl)) :: T).
  Proof.
    intros. apply (tctx_incl_frame_r _ [_] [_;_]).
    rewrite {1}copy_tctx_incl. apply (tctx_incl_frame_r _ [_] [_]).
    rewrite tctx_split_shr_prod -(contains_tctx_incl _ _ [p' ◁ ty]) //.
    apply submseteq_skip, submseteq_nil_l.
  Qed.

  (* Merging with [tctx_extract]. *)

  Fixpoint extract_tyl E L p (ptr: type → type) tyl (off : nat) T T' : Prop :=
    match tyl with
    | [] => T = T'
    | ty :: tyl => ∃ T'',
        tctx_extract_hasty E L (p +ₗ #off) (ptr ty) T T'' ∧
        extract_tyl E L p ptr tyl (off + ty.(ty_size)) T'' T'
    end.

  Lemma tctx_extract_merge_ptr_prod E L p ptr tyl T T' :
    tctx_incl E L (hasty_ptr_offsets p ptr tyl 0) [p ◁ ptr $ product tyl] →
    extract_tyl E L p ptr tyl 0 T T' →
    tctx_extract_hasty E L p (ptr (Π tyl)) T T'.
  Proof.
    rewrite /extract_tyl /tctx_extract_hasty=>Hi Htyl.
    etrans; last by eapply (tctx_incl_frame_r T' _ [_]). revert T Htyl. clear.
    generalize 0%nat. induction tyl=>[T n /= -> //|T n /= [T'' [-> Htyl]]]. f_equiv. auto.
  Qed.

  Lemma tctx_extract_merge_own_prod E L p n tyl T T' :
    tyl ≠ [] →
    extract_tyl E L p (own_ptr n) tyl 0 T T' →
    tctx_extract_hasty E L p (own_ptr n (Π tyl)) T T'.
  Proof. auto using tctx_extract_merge_ptr_prod, tctx_merge_own_prod. Qed.

  Lemma tctx_extract_merge_uniq_prod E L p κ tyl T T' :
    tyl ≠ [] →
    extract_tyl E L p (uniq_bor κ) tyl 0 T T' →
    tctx_extract_hasty E L p (&uniq{κ}(Π tyl)) T T'.
  Proof. auto using tctx_extract_merge_ptr_prod, tctx_merge_uniq_prod. Qed.

  Lemma tctx_extract_merge_shr_prod E L p κ tyl T T' :
    tyl ≠ [] →
    extract_tyl E L p (shr_bor κ) tyl 0 T T' →
    tctx_extract_hasty E L p (&shr{κ}(Π tyl)) T T'.
  Proof. auto using tctx_extract_merge_ptr_prod, tctx_merge_shr_prod. Qed.
End product_split.

(* We do not want unification to try to unify the definition of these
   types with anything in order to try splitting or merging. *)
Global Hint Opaque own_ptr uniq_bor shr_bor tctx_extract_hasty : lrust_typing lrust_typing_merge.

(* We make sure that splitting is tried before borrowing, so that not
   the entire product is borrowed when only a part is needed. *)
Global Hint Resolve tctx_extract_split_own_prod tctx_extract_split_uniq_prod tctx_extract_split_shr_prod
    | 5 : lrust_typing.

(* Merging is also tried after everything, except
   [tctx_extract_hasty_further]. Moreover, it is placed in a
   difference hint db. The reason is that it can make the proof search
   diverge if the type is an evar.

   Unfortunately, priorities are not taken into account accross hint
   databases with [typeclasses eauto], so this is useless, and some
   solve_typing get slow because of that. See:
     https://coq.inria.fr/bugs/show_bug.cgi?id=5304
*)
Global Hint Resolve tctx_extract_merge_own_prod tctx_extract_merge_uniq_prod tctx_extract_merge_shr_prod
    | 40 : lrust_typing_merge.
Global Hint Unfold extract_tyl : lrust_typing.


(* ------------------------------------------------------- *)
(** #

#
        The double time redundancy (DTR) transformation
#
#
-  ctr block properties during odd(0) cycles

          Dmitry Burlyaev - Pascal Fradet - 2015
#
#                                           *)
(* ------------------------------------------------------- *)
(* Add LoadPath "..\..\Common\".
Require Import CirReflect .
Add LoadPath "..\..\TMRProof\".
Require Import tmrMainTh.
Add LoadPath "..\".
Require Import dtrTransform.
Add LoadPath "..\memoryBlocks".
*)

Add LoadPath "..\..\Common\".
Add LoadPath "..\..\TMRProof\".
Add LoadPath "..\Transf\".
Add LoadPath "..\memoryBlocks\".

Require Import dtrTransform controlFsmStep.

Set Implicit Arguments.

(* ########################################################## *)
(** Properties of DTR control block during the odd(0) cycles  *)
(* ########################################################## *)

(*Property: from the state '000' the control block goes to the states '001'*)
(*No glitches*)
(*by reflection*)
Lemma step0_tcbv_R : forall p t c, ((fun p => pure_bset p) p) ->
                            step ((fun p =>(ctrBlockTMR false false false)) p)
                                ((fun p =>
                                     let f3_I :=   (fstS(fstS p)) in
                                     let f2_I :=   (sndS(fstS p)) in
                                     let f1_I :=   (sndS p) in

                                     {f1_I, f2_I, f3_I} ) p) t c

                  -> (fun e => let p := fst(fst e) in
                               let t := snd(fst e) in
                               let c := snd e in

                     t={~0,~0,~0,~0,~0} /\ (c= (ctrBlockTMR false false true))) (p,t,c).
Proof. introv. Reflect_step_g. Qed.

(** The aforementioned property in a more useable form  *)
Lemma step0_tcbv : forall (f1 f2 f3:bool) f1_I f2_I f3_I t c ,
f1_I = bool2bset f1 -> f2_I= bool2bset f2 ->  f3_I= bool2bset f3
                    -> step (ctrBlockTMR false false false) {f1_I, f2_I, f3_I} t c
                    -> t={~0,~0,~0,~0,~0} /\ c = (ctrBlockTMR false false true).
Proof.
introv G1 G2 G3 H. set (p := {bool2bset f3, bool2bset f2,bool2bset f1}).
assert (X0: f1_I= (sndS p)) by
(replace p with {bool2bset f3, bool2bset f2,bool2bset f1}; destruct f1 ; easy).
assert (X1: f2_I= (sndS(fstS p))) by
(replace p with {bool2bset f3, bool2bset f2,bool2bset f1}; destruct f2 ; easy).
assert (X2: f3_I =   (fstS(fstS p))) by
(replace p with {bool2bset f3, bool2bset f2,bool2bset f1}; destruct f3 ; easy).
rewrite X0 in H. rewrite X1 in H. rewrite  X2 in H.
apply step0_tcbv_R with (t:=t) (c:=c) in H.
Simpl. CheckPure.
Qed.

(*Recovery from internal control block corruption during during the normal mode:
if one of three redundant parts of the control block is corrupted then
the error disappears the next clock cycle thanks to TMR*)
Lemma step0_tcbv_C: forall fI t ctrTMR c, pure_bset fI->
                     corrupt_1in3_cir (ctrBl_dtr false false false) ctrTMR
                     ->  step (ctrTMR -o- ctrVoting)  {fI,fI,fI}  t  c
                     -> t={~0,~0,~0,~0,~0} /\ c=(ctrBlockTMR false false true).
Proof.
introv H H0 H1. unfold ctrBlockTMR. split; Inverts H1.
 - apply tmr_corruptc  with (c':=(ctrBl_dtr false false true)) (s:=fI) (t:={~0,~0,~0,~0,~0}) in H0.
    + apply  det_step_res with (c1:=c1') (t1:=t0 )  in H0. Inverts H0.
      * assert (F:  fstep ctrVoting {~ 0, ~ 0, ~ 0, ~ 0, ~ 0,
                                    {~ 0, ~ 0, ~ 0, ~ 0, ~ 0},
                                    {~ 0, ~ 0, ~ 0, ~ 0, ~ 0}}  =
                    Some ({~0,~0,~0,~0,~0} ,  ctrVoting)) by
        (vm_compute; try easy). eapply fstep_imp_detstep in F; Simpl.
      * apply H6.
    + Checkpure.
    + assert ( exists t, exists c', step (ctrBl_dtr false false false) fI t c' ). apply step_all_ex.
      Simpl. assert (HA :=  H1). apply fact_stepCtrBl_12 in H1. destruct H1; Simpl.
 - apply tmr_corruptc  with (c':=(ctrBl_dtr false false true)) (s:=fI) (t:={~0,~0,~0,~0,~0}) in H0.
    + apply  det_step_cod with (c1:=c1') (t1:=t0 ) in H0. Inverts H0.
      * apply step_comb_cir in H11; Simpl. repeat constructor.
      * Checkpure.
      * apply H6.
    + Checkpure.
    + assert ( exists t, exists c', step (ctrBl_dtr false false false) fI t c' ). apply step_all_ex.
      Simpl. assert (HA :=  H1). apply fact_stepCtrBl_12 in H1. destruct H1; Simpl.
Qed.


(** This file was written by Colm Bhandal, PhD student, Foundations and Methods group,
School of Computer Science and Statistics, Trinity College, Dublin, Ireland.*)

(***************************** Standard Imports *****************************)

Require Import ComhCoq.Extras.LibTactics.

(***************************** Specialised Imports *****************************)

Require Import ComhCoq.GenTacs.
Require Import ComhCoq.StandardResults.
Require Import ComhCoq.ComhBasics.
Require Import ComhCoq.LanguageFoundations.
Require Import ComhCoq.SoftwareLanguage.
Require Import ComhCoq.InterfaceLanguage.
Require Import ComhCoq.ModeStateLanguage.

(***************Messages*********************)

(** A message is a vector of values augmented with coverage and location information.*)
Record Message : Type :=
mkMsg
{
  msgPayload :> list BaseType;
  msgPos : Position;
  msgCoverage : Distance
}.
Notation "[- v , l , r -]" := (mkMsg v l r) (at level 40).

(** Extract the delivery radius from a broadcast.*)
Definition rangeMsg (m : Message) : Distance :=
   match m with [-v, l, r-] => r end.

(** Return the first mode that occurs in v, or None if there is no such mode.*)
Fixpoint firstMode (v : list BaseType) : option Mode :=
  match v with
  | [] => None
  | b :: vs => match b with
    | baseMode m => Some m
    | _ => firstMode vs
    end
  end.

(** modeBc b will return the first mode m, if it exists,
within the list of base values in b.*)
Definition modeBc (m : Message) : option Mode :=
  match m with [-v, l, r-] => firstMode v end.

(** Extract the position information from a broadcast. Note that this is the position
of the sending entity at the time of sending rather than delivery. The entity may have
moved between sending and delivery.*)
Definition posBc (m : Message) : Position :=
  match m with [-v, l, r-] => l end.

(*************** Syntax (and some other stuff) *********************)

(** And entity is a quadruple of components: An interface term, a software term,
an MState term and a location.*)
Record Entity : Type := mkEntity
{
  procEnt :> ProcTerm;
  posEnt :> Position;
  interEnt :> Interface;
  mstEnt : ModeState
}.
Notation "[| p , l , i , k |]" := (mkEntity p l i k) (at level 30).

(** Equality on entities is decidable.*)
Lemma eqDecEnt : eqDec Entity. unfold eqDec.
  destruct x1, x2. addHyp (eqDecModeState mstEnt0 mstEnt1).
  addHyp (eqDecPosition posEnt0 posEnt1).
  addHyp (eqDecInterface interEnt0 interEnt1).
  addHyp (eqDecProcTerm procEnt0 procEnt1). invertClear H2.
  invertClear H. invertClear H0. invertClear H1. left.
  rewrite H2, H, H0, H3. reflexivity.
  right. unfold not. intro. apply H0. inversion H1. reflexivity.
  right. unfold not. intro. apply H. inversion H0. reflexivity.
  right. unfold not. intro. apply H2. inversion H. reflexivity.
  right. unfold not. intro. apply H3. inversion H2. reflexivity.
  Qed.

(** The current mode of an entity is the current mode of the mode state.*)
Coercion currModeEnt (e : Entity) : Mode :=
  match e with [|_, _, _, a|] => a end.

(** The next mode of an entity is the next mode of the mode state.*)
Definition nextModeEnt (e : Entity) : option Mode :=
  match e with [|_, _, _, a|] => nextModeMState a end.

Open Scope R_scope.

(** If the minimum distance of compatibiltiy of the respective modes
of the entities is less than or equal to the separation of the
entities in space, then they are compatible.*)
Definition compatible (e1 e2 : Entity) : Prop :=
  (minDistComp e1 e2) <= (dist2d e1 e2).
Notation "e1 ~~ e2" := (compatible e1 e2) (left associativity, at level 40).

(** Compatibility is a symmetric relation.*)
Lemma compatibleSymmetric : forall (e1 e2 : Entity), (e1 ~~ e2) <-> (e2 ~~ e1).
  unfold compatible. intros. split; intros; rewrite minDistCompSymmetric in H;
  rewrite distSymmetric in H; assumption. Qed.

(***************Semantics*********************)

(** A discrete action is either the input, output or ignorance of a message, or
it is the silent value tau.*)
Inductive ActDiscEnt : Type :=
  | aeTagOut : Message -> ActDiscEnt
  | aeTagIn : Message -> ActDiscEnt
  | aeTagIg : Message -> ActDiscEnt
  | aeTau : ActDiscEnt.
Notation "b #!" := (aeTagOut b) (at level 30).
Notation "b #?" := (aeTagIn b) (at level 30).
Notation "b #:" := (aeTagIg b) (at level 30).

Reserved Notation "e1 -EA- a ->> e2" (left associativity, at level 50).
Reserved Notation "e1 -ED- a ->> e2" (left associativity, at level 50).

(** The discrete action semantics for entities.*)
Inductive stepDiscEnt : Entity -> ActDiscEnt -> Entity -> Prop :=
  | stepDeProcTau : forall (p p' : ProcTerm) (l : Position) (i : Interface) (k : ModeState),
    p -PA- tauAct -PA> p' -> [| p , l , i , k |] -EA- aeTau ->> [| p' , l , i , k |]
  | stepDeIOProcInter : forall (p p' : ProcTerm) (l : Position)
    (i i' : Interface) (k : ModeState) (v : list BaseType),
    p -PA- chanOutProc ;! v -PA> p' -> i -i- chanOutProc {? v -i> i' ->
    [| p , l , i , k |] -EA- aeTau ->> [| p' , l , i' , k |]
  | stepDeIOInterProc : forall (p p' : ProcTerm) (l : Position)
    (i i' : Interface) (k : ModeState) (v : list BaseType),
    p -PA- chanInProc ;? v -PA> p' -> i -i- chanInProc {! v -i> i' ->
    [| p , l , i , k |] -EA- aeTau ->> [| p' , l , i' , k |]
  | stepDeNotif : forall (p p' : ProcTerm) (l : Position)
    (i i' : Interface) (k : ModeState) (v : list BaseType),
    p -PA- chanAN ;? v -PA> p' -> i -i- chanAN {! v -i> i' ->
    [| p , l , i , k |] -EA- aeTau ->> [| p' , l , i' , k |]
  | stepDeRdStbl : forall (p p' : ProcTerm) (l : Position)
    (i : Interface) (k k' : ModeState),
    p -PA- chanMStable *? -PA> p' -> k -ms- chanMStable @! -ms> k' ->
    [| p , l , i , k |] -EA- aeTau ->> [| p' , l , i , k' |]
  | stepDeCurrWrite : forall (p p' : ProcTerm) (l : Position)
    (i : Interface) (k k' : ModeState) (m : Mode),
    p -PA- chanMCurr *! -PA> p' -> k -ms- chanMCurr @? -ms> k' ->
    [| p , l , i , k |] -EA- aeTau ->> [| p' , l , i , k' |]
  | stepDeCurrRead : forall (p p' : ProcTerm) (l : Position)
    (i : Interface) (k k' : ModeState) (m : Mode),
    p -PA- chanMCurr ;? [baseMode m] -PA> p' -> k -ms- chanMCurr .! m -ms> k' ->
    [| p , l , i , k |] -EA- aeTau ->> [| p' , l , i , k' |]
  | stepDeNextWrite : forall (p p' : ProcTerm) (l : Position)
    (i : Interface) (k k' : ModeState) (m : Mode),
    p -PA- chanMNext ;! [baseMode m] -PA> p' -> k -ms- chanMNext .? m -ms> k' ->
    [| p , l , i , k |] -EA- aeTau ->> [| p' , l , i , k' |]
  | stepDeNextRead : forall (p p' : ProcTerm) (l : Position)
    (i : Interface) (k k' : ModeState) (m : Mode),
    p -PA- chanMNext ;? [baseMode m] -PA> p' -> k -ms- chanMNext .! m -ms> k' ->
    [| p , l , i , k |] -EA- aeTau ->> [| p' , l , i , k' |]
  | stepDePosRead : forall (p p' : ProcTerm) (l : Position)
    (i : Interface) (k : ModeState),
    p -PA- chanPos ;? [basePosition l] -PA> p' ->
    [| p , l , i , k |] -EA- aeTau ->> [| p' , l , i , k |]
  (** If the message sent was too far away, it gets ignored.*)
  | stepDeIgnore : forall (p : ProcTerm) (l l' : Position)
    (i : Interface) (k : ModeState) (v : list BaseType) (r : Distance),
     r < dist2d l l' ->
    [| p , l , i , k |] -EA- [-v, l', r-]#: ->> [| p , l , i , k |]
  (** If the message sent was within range, then it gets input. This can be proven not
  to block by analysing the behaviour of interface components. Therefore, a message
  should always be accepted.*)
  | stepDeIn : forall (p : ProcTerm) (l l' : Position)
    (i i' : Interface) (k : ModeState) (v : list BaseType) (r : Distance),
    dist2d l l' <= r -> i -i- chanIOEnv {? v -i> i' ->
    [| p , l , i , k |] -EA- [-v, l', r-]#? ->> [| p , l , i' , k |]
  | stepDeOut : forall (p : ProcTerm) (l : Position)
    (i i' : Interface) (k : ModeState) (v : list BaseType) (r : Distance),
    i -i- chanIOEnv _! v !_ r -i> i' ->
    [| p , l , i , k |] -EA- [-v, l, r-]#! ->> [| p , l , i' , k |]
  | stepDeTest : forall (p : ProcTerm) (l : Position)
    (i : Interface) (k k' : ModeState) (m : Mode),
    k -ms- chanMNext .? m -ms> k' ->
    [| p , l , i , k |] -EA- aeTau ->> [| p , l , i , k' |]
  where "e1 -EA- a ->> e2" := (stepDiscEnt e1 a e2).

(**An entity e is discrete action enabled for the discrete action a iff
there is some entity e' such that e transitions to e' via a.*)
Definition discActEnabledEnt (e : Entity) (a : ActDiscEnt) :=
  exists e', e -EA- a ->> e'.

(** This predicate says that it is impossible for p to synchronise with either i
or k via the discrete action a i.e. if p can do a, then neither i nor k can do its
complement.*)
Definition noSyncNow (a : DiscAct) (p : ProcTerm)
  (i : Interface) (k : ModeState) : Prop :=
  discActEnabled p a ->
  (~discActEnabledInter (a^) i /\ ~discActEnabledMState (a^) k).

(** This predicate says that p i and k cannot synchronise now, nor can they
synchronise after each has respectively performed a delay of d' that is less
than d.*)
Definition noSync (p : ProcTerm) (i : Interface)
  (k : ModeState) (d : Delay) : Prop :=
  forall a : DiscAct, noSyncNow a p i k /\
  (forall (p' : ProcTerm) (i' : Interface) (k' : ModeState) (d' : Delay),
  d' < d -> p -PD- d' -PD> p' -> i -i- d' -i> i' -> k -ms- d' -ms> k' ->
  noSyncNow a p' i' k').

(** The timed action semantics for entities. There is only one delay law. The software,
mode state and interface components all must delay by the same amount d for the entire
entity to delay by this amount. After this, there are two interesting premises to the law.
The first deals with a displacement vector delta, saying that its absolute value must be
at most the delay multiplied by the maximum speed. In other words, movement is bounded.
The other premise that is of interest says that the components of the entity must not
be capable of synchronisation at any point during the delay.*)
Inductive stepTimedEnt : Entity -> Delay -> Entity -> Prop :=
  | stepTeDel : forall (d : Delay) (p p' : ProcTerm) (l delta : Position)
    (i i' : Interface) (k k' : ModeState),
    p -PD- d -PD> p' -> i -i- d -i> i' -> k -ms- d -ms> k' ->
    displacement delta <= speedMax * d -> noSync p i k d ->
    [| p , l , i , k |] -ED- d ->> [| p' , addPos l delta, i' , k' |]
  where "e1 -ED- d ->> e2" := (stepTimedEnt e1 d e2).

(*************** Results & Tactics *********************)

(*Destruct an entity and then its interface component*)
Ltac destr_ent_inter e p l k li lo ln := let h := fresh in destruct e as [p l h k];
  destruct h as [li lo ln].

(**If the current mode has changed across a tau transition, then the software process
output on mCurr, and the mode state input on the same channel.*)
Theorem curr_switch_proc (p p' : ProcTerm) (l l' : Position) (h h' : Interface) (k k' : ModeState) :
  [|p, l, h, k|] -EA- aeTau ->> [|p', l', h', k'|] -> currModeMState k <> currModeMState k' ->
  p -PA- chanMCurr *! -PA> p' /\ k -ms- chanMCurr @? -ms> k'.
  intros H H0.
  (*By inversion on the discrete entity transition*)
  (*We first eliminate the cases where the mode state is the preserved.*)
  invertClear H; try (false; apply H0; assumption);
  (*We can then eliminate all cases where the the action is not tau,
  and simultaneously match our goal.*)
  try (lets K : curr_switch_mState H10 H0; inversion K).
  (*Now we have this case which follows from assumptions.*)
  split;assumption.
  (*Finally we deal with a stray case that wasn't caught in our earlier elimination.*)
  lets K : curr_switch_mState H2 H0. inversion K. Qed.

(** The derivative of an ignore transition is the same as the source.*)
Theorem ignoreEqEnt : forall (e e' : Entity) (m : Message),
  e -EA- m#: ->> e' -> e = e'. intros. invertClear H. reflexivity. Qed.

(** An entity can always either input or ignore a message.*)
Theorem inOrIgEnt : forall (e : Entity) (m : Message),
  discActEnabledEnt e (m#?) \/ discActEnabledEnt e (m#:). intros.
  destruct m as [v l' r]. destruct e as [p l i k].
  addHyp (Rlt_or_le r (dist2d l l')). invertClear H. right.
  exists ([|p, l, i, k|]). apply stepDeIgnore. assumption.
  left. addHyp (interfaceInEnabled i v). invertClear H.
  rename x into i'. exists ([|p, l, i', k|]).
  apply stepDeIn; assumption. Qed.

Conjecture dec_compatible : forall (e1 e2 : Entity),
  e1 ~~ e2 \/ ~(e1 ~~e2).
(**Proof: Obvious*)

Conjecture currMode_ent_mState : forall (p : ProcTerm) (l : Position) (h : Interface)
  (k : ModeState) (m : Mode), currModeEnt ([|p, l, h, k|]) = m -> currModeMState k = m.
(**Proof: Obvious from definitions*)

Lemma link_ent_inter_disc p p' l l' h h' k k' a :
  [|p, l, h, k|] -EA- a ->> [|p', l', h', k'|] ->
  h = h' \/
  (k = k' /\
  ((exists v, (h -i- chanOutProc {? v -i> h' /\ p -PA- chanOutProc;! v -PA> p')) \/
  (exists v, (h -i- chanInProc {! v -i> h' /\ p -PA- chanInProc;? v -PA> p')) \/
  (exists v, (h -i- chanAN {! v -i> h' /\ p -PA- chanAN;? v -PA> p')) \/
  (exists v, h -i- chanIOEnv {? v -i> h') \/
  (exists v r, h -i- chanIOEnv _! v !_ r -i> h'))).
  (*Inversion on entity transition and try LHS*)
  introz U. inversion U; subst; try (left; reflexivity); right;
  (split; [ reflexivity | ]).
  (*Now we do the other cases.*)
  left. exists v. split; assumption.
  right. left. exists v. split; assumption.
  right. right. left. exists v. split; assumption.
  do 3 right. left. exists v. assumption.
  do 4 right. exists v r. assumption. Qed.

(*Adds the result stepDisc_ent_inter to the hypotheses and splits it up and tidies it.*)
Ltac link_entinterdisc_tac v r U :=
  match goal with
  | [ H : [|?p, ?l, ?h, ?k|] -EA- ?a ->> [|?p', ?l', ?h', ?k'|] |- _] =>
    let H1 := fresh in lets H1 : link_ent_inter_disc H;
    let U1 := fresh U in let H0 := fresh in
    (*Break off first disjunct as U1, leave H0 as chunk*)
    elim_intro H1 U1 H0;[ |
    let H7 := fresh in let H8 := fresh in
    (*Break conjunction H0 into H7 and H8*)
    decompAnd2 H0 H7 H8; let V := fresh v in
    (*Break H8 up into 5 disjuncts*)
    elimOr5 H8 U;
    [(let H2 := fresh in destruct U1 as [V H2];
    andflat U).. | let H2 := fresh in destruct U1 as [V H2]; rename H2 into U1 |
    let R := fresh r in let H3 := fresh in
    decompEx2 U1 V R H3;rename H3 into U1 ]
    ]
  end.

Lemma link_ent_inter_del p p' l l' h h' k k' d :
  [|p, l, h, k|] -ED- d ->> [|p', l', h', k'|] ->
  h -i- d -i> h'. intros. inversion H. assumption. Qed.

Ltac link_entinterdel_tac U :=
  match goal with
  | [ H : [|?p, ?l, ?h, ?k|] -ED- ?d ->> [|?p', ?l', ?h', ?k'|] |- _] =>
  let U1 := fresh U in lets U1 : link_ent_inter_del H
  end.

Lemma link_ent_soft_del p p' l l' h h' k k' d :
  [|p, l, h, k|] -ED- d ->> [|p', l', h', k'|] ->
  p -PD- d -PD> p'. intros. inversion H. assumption. Qed.

Ltac link_entsoftdel_tac U :=
  match goal with
  | [ H : [|?p, ?l, ?h, ?k|] -ED- ?d ->> [|?p', ?l', ?h', ?k'|] |- _] =>
  let U1 := fresh U in lets U1 : link_ent_soft_del H
  end.

Lemma link_ent_mState_del p p' l l' h h' k k' d :
  [|p, l, h, k|] -ED- d ->> [|p', l', h', k'|] ->
  k -ms- d -ms> k'. intros. inversion H. assumption. Qed.

Ltac link_entmstatedel_tac U :=
  match goal with
  | [ H : [|?p, ?l, ?h, ?k|] -ED- ?d ->> [|?p', ?l', ?h', ?k'|] |- _] =>
  let U1 := fresh U in lets U1 : link_ent_mState_del H
  end.

Lemma timeSplit_ent e e'' d d' d'' :
  e -ED- d'' ->> e'' -> d'' = d +d+ d' ->
  exists e', e -ED- d ->> e' /\ e' -ED- d' ->> e''. Admitted. (*6*)
(**Proof: This should follow from time split properties of the underlying components. Also, it would have to be shown that the noSynch predicate would still hold for the intermediate entity component e', with the time parameter changed.*)

(*LOCAL TIDY*)

(** Destructs the next entity it encounters naming its sub-components as fresh instances
of p, l, h, k.*)
Ltac destrEnt p l h k :=
  match goal with
  [ e : Entity |- _ ] =>
  let vp := fresh p in let vl := fresh l in
  let vh := fresh h in let vk := fresh k in
  destruct e as [vp vl vh vk]
  end.

(** Repeatedly destructs all entities according to the names given.*)
Ltac destrEnts p l h k := repeat destrEnt p l h k.

(**Destructs any entities it finds. May have also be searched for as destr_ents.*)
Ltac destrEnts_norm := let p := fresh "p" in let l := fresh "l" in
  let h := fresh "h" in let k := fresh "k" in destrEnts p l h k.

(** From a delay on an entity creates the hypothesis NS (a parameter) that no synchronisation
is possible between any of the components of the entity.*)
Ltac del_noSync_tac NS :=
  match goal with [a : DiscAct, U : [|?p0, _, ?h0, ?k0|] -ED- ?d ->> _ |- _] =>
  assert (noSync p0 h0 k0 d) as NS; [inversion U; assumption | ]
  end.

(** From a hypothesis X of noSynch between various components, creates a weakened version of X
saying that noSyncNow is possible between those components and calls it NS.*)
Ltac noSync_noSyncNow_tac NS :=
  match goal with
  [ a : DiscAct, X : noSync ?p0 ?h0 ?k0 _ |- _] =>
  assert (noSyncNow a p0 h0 k0) as NS; [unfold noSync in X; apply X
  | ] end.

(** From an entity delay creates the hypothesis NS saying that noSyncNow is possible between
the components of the entity, via the first action a matched in the hypotheses.*)
Ltac del_noSyncNow_tac NS :=
  let X := fresh in del_noSync_tac X; noSync_noSyncNow_tac NS;
  clear X.

(**Takes a delay hypothesis and inverts to give that noSyncNow holds for
the components of the entity in question.*)
Ltac noSyncNow_tac := match goal with
  [A : [|?p, _, ?h, ?k|] -ED- ?d ->> _ |- _] =>
  let NS := fresh "NS" in
  assert (forall a, noSyncNow a p h k) as NS;
  [inversion A; match goal with [B : noSync p h k d |- _] =>
  apply B end| ] end.

(*Inverts an entity delay to a process delay*)
  Ltac invertDel_ent_proc := match goal with
  [U1 : [|?p0, _, _, _|] -ED- ?d ->> [|?p, _, _, _|] |- _ ]
  => assert (p0 -PD- d -PD> p) as PD; [inversion U1; assumption | ] end.

(** Creates a hypothesis PD saying that some process delays to another process,
then rewrites TR, an equality identifying the process with a triple of processes,
then creates three hypotheses saying that the sort relations of the three processes
are distinct, called SORT1_2, SORT1_3 and SORT2_3.*)
Ltac del_triple_sort_tac :=
  (try invertDel_ent_proc); match goal with
  [TR : ?p = ?p1 $||$ ?p2 $||$ ?p3, PD : ?p -PD- ?d -PD> ?p' |- _] =>
  rewrite TR in PD; let U := fresh in let x := fresh "SORT1_2" in
  let y := fresh "SORT1_3" in let z := fresh "SORT2_3" in
  (lets U : del_triple_sort PD; decompAnd3 U x y z) end.

(*-LOCAL TIDY*)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* A directed graph -Digraph- is a type dependant of a set of           *)
(* vertices and a set of arcs. An inhabitant of such a type is a        *)
(* construction, inductively defined, of this graph. Some Digraphs      *)
(* are not inhabited.                                                   *)

(* The following notions are defined :                                  *)
(*      - (Digraph v a) : set of directed graph with vertices in v      *)
(*                              and arcs in a,                          *)
(*              constructors : D_empty, D_vertex, D_arc, D_eq;          *)
(*      - DV_list : list of vertices of a Digraph;                      *)
(*      - DA_list : list of arcs of a Digraph;                          *)
(*      - D_oreder : number of vertices;                                *)
(*      - D_size : number of arcs.                                      *)

Require Export Arcs.

Section DIGRAPH.

Variable A:Type.
Variable eq_a_dec: forall x y : A, {x = y} + {x <> y}.

Inductive Digraph : @V_set A -> @A_set A -> Type :=
  | D_empty : Digraph (@V_empty A) (@A_empty A)
  | D_vertex :
      forall (v : V_set) (a : A_set) (d : Digraph v a) (x : Vertex),
      ~ v x -> Digraph (V_union (V_single x) v) a
  | D_arc :
      forall (v : V_set) (a : A_set) (d : Digraph v a) (x y : Vertex),
      v x ->
      v y ->
      ~ a (A_ends x y) -> Digraph v (A_union (A_single (A_ends x y)) a)
  | D_eq :
      forall (v v' : V_set) (a a' : A_set),
      v = v' -> a = a' -> Digraph v a -> Digraph v' a'.

Fixpoint DV_list (v : V_set) (a : A_set) (d : Digraph v a) {struct d} :
 V_list :=
  match d with
  | D_empty => V_nil
  | D_vertex v' a' d' x _ => x :: DV_list v' a' d'
  | D_arc v' a' d' x y _ _ _ => DV_list v' a' d'
  | D_eq v v' a a' _ _ d => DV_list v a d
  end.

Fixpoint DA_list (v : V_set) (a : A_set) (d : Digraph v a) {struct d} :
 A_list :=
  match d with
  | D_empty => A_nil
  | D_vertex v' a' d' x _ => DA_list v' a' d'
  | D_arc v' a' d' x y _ _ _ => A_ends x y :: DA_list v' a' d'
  | D_eq v v' a a' _ _ d => DA_list v a d
  end.

Definition D_order (v : V_set) (a : A_set) (d : Digraph v a) :=
  length (DV_list v a d).

Definition D_size (v : V_set) (a : A_set) (d : Digraph v a) :=
  length (DA_list v a d).

Lemma D_v_dec :
 forall (v : V_set) (a : A_set) (d : Digraph v a) (x : Vertex),
 {v x} + {~ v x}.
Proof.
        intros v a d; elim d; intros.
        right; apply V_empty_nothing.

        case (X x0); intros.
        left; apply V_in_right; trivial.

        case (V_eq_dec eq_a_dec x x0); intros.
        left; apply V_in_left; rewrite e; apply V_in_single.

        right; red in |- *; intros; inversion H.
        elim n1; inversion H0; trivial.

        elim n0; trivial.

        auto.

        case (X x); intros.
        left; elim e; trivial.

        right; elim e; trivial.
Qed.

Lemma D_a_dec :
 forall (v : V_set) (a : A_set) (d : Digraph v a) (x : Arc), {a x} + {~ a x}.
Proof.
        intros v a d; elim d; intros.
        right; apply A_empty_nothing.

        auto.

        case (X x0); intros.
        left; apply A_in_right; trivial.

        case (A_eq_dec eq_a_dec (A_ends x y) x0); intros.
        left; apply A_in_left; rewrite e; apply A_in_single.

        right; red in |- *; intros; inversion H.
        elim n1; inversion H0; trivial.

        elim n0; trivial.

        case (X x); intros.
        left; elim e0; trivial.

        right; elim e0; trivial.
Qed.

End DIGRAPH.

Implicit Arguments Digraph [A].
Implicit Arguments D_v_dec [A].
Implicit Arguments D_a_dec [A].

Section UNION_DIGRAPHS.

Variable A:Type.
Variable eq_a_dec: forall x y : A, {x = y} + {x <> y}.

Lemma D_union :
 forall (v1 v2 : V_set) (a1 a2 : @A_set A),
 Digraph v1 a1 -> Digraph v2 a2 -> Digraph (V_union v1 v2) (A_union a1 a2).
Proof.
        intros; elim X; intros.
        apply D_eq with (v := v2) (a := a2).
        symmetry  in |- *; apply V_union_neutral.

        symmetry  in |- *; apply A_union_neutral.

        trivial.

        case (D_v_dec eq_a_dec v2 a2 X0 x); intros.
        apply D_eq with (v := V_union v v2) (a := A_union a a2).
        autounfold.
        rewrite V_union_assoc; rewrite (V_union_absorb (V_single x)); trivial.
        apply V_included_single; apply V_in_right; trivial.

        trivial.

        trivial.

        apply
         D_eq
          with (v := V_union (V_single x) (V_union v v2)) (a := A_union a a2).
        symmetry  in |- *; apply V_union_assoc.

        trivial.

        apply D_vertex.
        trivial.

        apply V_not_union; trivial.

        case (D_a_dec eq_a_dec v2 a2 X0 (A_ends x y)); intros.
        apply D_eq with (v := V_union v v2) (a := A_union a a2).
        trivial.

        repeat autounfold.
        rewrite A_union_assoc;
         rewrite (A_union_absorb (A_single (A_ends x y)));
         trivial.
        apply A_included_single; apply A_in_right; trivial.

        trivial.

        apply
         D_eq
          with
            (v := V_union v v2)
            (a := A_union (A_single (A_ends x y)) (A_union a a2)).
        trivial.

        symmetry  in |- *; apply A_union_assoc.

        apply D_arc.
        trivial.

        apply V_in_left; trivial.

        apply V_in_left; trivial.

        apply A_not_union; trivial.

        apply D_eq with (v := V_union v v2) (a := A_union a a2).
        elim e; trivial.

        elim e0; trivial.

        trivial.
Qed.

End UNION_DIGRAPHS.

Implicit Arguments D_empty [A].
Implicit Arguments D_vertex [A].
Implicit Arguments D_eq [A].
Implicit Arguments D_arc [A].


(* begin hide *)
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Coq.Numbers.Natural.Peano.NPeano.
(* end hide *)
(** Many languages provide mechanisms for formatted output, with C's
[printf] undoubtedly being the most influential one. Some of these
functions allow a format to be specified using a concise and intuitive
syntax, which is probably part of the reason for them being so
popular. For [printf], for instance, a format is described using just
a plain string.

Unfortunately, this convenience often comes with a price. In C, a
mismatch between the output format and the other arguments results in
incorrect behavior. This non-trivial dependency can't be expressed in
the language's type system and requires additional compiler checks to
be enforced. Other languages suffer from similar problems. Haskell's
standard [printf] also causes a run-time error when a format mismatch
occurs. OCaml is able to enforce that format and arguments are
compatible at compile-time, but at the cost of extending the language
with an _ad-hoc_ [format] type that is also represented as
strings. Other approaches solve the problem by adopting different
representations for the output format, which can make it slightly less
convenient to specify. In #Functional
Unparsing#, Olivier Danvy showed how to implement an analogue of
[printf] using formatting combinators. More recently, Oleg Kiselyov
used delimited control operators to implement his own type-safe
version of [printf] in #Haskell#,
an idea that has also been ported to #Coq#
by Matthieu Sozeau.

It would be a shame if we had to extend our language in an _ad-hoc_
manner just to get safe and convenient formatting. We will see how we
can use Coq's expressive type system to describe the dependency
between a format string and the arguments it requires, and implement a
version of [sprintf] that doesn't suffer from the aforementioned
issues.

Let's begin by defining some useful notations for lists and
strings. *)

Notation "[ ]" := nil : list_scope.
Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..) : list_scope.
Notation "x ::: y" := (String x y)
                        (at level 60, right associativity) : string_scope.

Open Scope list_scope.
Open Scope char_scope.

(** ** Directives and format

Before working directly with strings, we will define a new data type
to describe an output format, and then use it to implement a
preliminary version of [sprintf]. As we shall see, this will help us
express the not-so-trivial type of [sprintf] and simplify our
implementation. Later, we will write a separate function to convert
[string]s to this new type, and combine both programs to obtain our
final result.

Our [format] type is inspired by [printf] formats in C, which can be
seen as a sequence of _directives_. Each directive can be either a
literal character, to be printed verbatim, or a _control sequence_,
which instructs the function to print one of its arguments in a
certain format. Thus, we begin by defining a [directive] type, loosely
based upon what is available in C: *)

Inductive directive : Type :=
| DLit : ascii -> directive
| DNum : option nat -> directive
| DBool : directive
| DString : directive
| DChar : directive.

(** Directive [DLit c] outputs the literal character [c], while [DNum
s], [DBool], [DString], and [DChar] take an argument of the
corresponding type and print it. The [s] field of [DNum s] controls
how its argument should be printed. If [s = Some n], then we output
exactly the [n] least-significant digits of the number, padding it
with zeros if necessary. Otherwise, if [s = None], we just print the
whole number. Thus, the number [4] should be printed as [4] using the
[DNum None], but as [04] using [DNum (Some 2)].

With the [directive] type in hand, defining [format] is
straightforward: *)

Definition format := list directive.

(** ** Relating format and arguments

As noted above, [sprintf f] should be a function that returns a
[string] and takes one argument for each directive in [f] that
requires one. For instance, [sprintf [DBool, DString]] should have
type [bool -> string -> string], whereas [sprintf [DLit "a", DLit "b",
DNum None]] should have type [nat -> string].

This relation is easy to express in Coq using dependent types. Since
types can be the result of computations, it is possible to write a
[formatType] function that takes a [format] [f] and returns the type
of [sprintf f]. Let's begin by defining a function that maps each
directive to the corresponding argument type. Notice that its result
type must be an [option], since [DLit] doesn't need arguments. *)

Definition directiveType (dir : directive) :=
  match dir with
    | DLit _ => None
    | DNum _ => Some nat
    | DBool => Some bool
    | DString => Some string
    | DChar => Some ascii
  end.

(** Now, [formatType] itself is just a direct translation of what we
stated above. *)

Fixpoint formatType (f : format) : Type :=
  match f with
    | [] => string
    | dir :: dirs =>
      match directiveType dir with
        | Some T => T -> formatType dirs
        | None => formatType dirs
      end
  end.

(** We can check if this definition makes sense on simple examples. *)

Example formatTypeTest1 : formatType [DBool, DString] =
                          (bool -> string -> string).
Proof. reflexivity. Qed.

Example formatTypeTest2 : formatType [DLit "a", DLit "b", DNum None] =
                          (nat -> string).
Proof. reflexivity. Qed.

(** ** The implementation

Now that we can express the type of [sprintf], we can try to implement
it. We might be tempted to try something like this:

[[
Fixpoint sprintf (f : format) : formatType f :=
  match f with
    | [] => ""
    | dir :: dirs =>
      match dir with
        | DLit c => c ::: sprintf dirs
        (* ... *)
      end
  end.
]]

Alas, this approach doesn't work. The problem here is that our
recursive call to [sprintf] returns a [formatType dirs] instead of
a [string], which means that we are unable to add character [c] in
front of it.

Instead of building the string directly on the body of the match, we
will add an auxiliary parameter [k] to [sprintf]. [k] will be a
_continuation_ of type [string -> string] that builds the final output
using the result of the recursive calls. The implementation uses some
auxiliary functions, such as [writeNat], that have been omitted in the
interest of space. Their definitions can be found in the original [.v]
file. *)

(* begin hide *)
Definition digitToNat (c : ascii) : option nat :=
  match c with
    | "0" => Some 0
    | "1" => Some 1
    | "2" => Some 2
    | "3" => Some 3
    | "4" => Some 4
    | "5" => Some 5
    | "6" => Some 6
    | "7" => Some 7
    | "8" => Some 8
    | "9" => Some 9
    | _   => None
  end.

Definition natToDigit (n : nat) : ascii :=
  match n with
    | 0 => "0"
    | 1 => "1"
    | 2 => "2"
    | 3 => "3"
    | 4 => "4"
    | 5 => "5"
    | 6 => "6"
    | 7 => "7"
    | 8 => "8"
    | _ => "9"
  end%char.

Open Scope string_scope.

Fixpoint writeNatAux (time n : nat) (crop : bool) (acc : string) : string :=
  match time with
    | 0 => acc
    | S time' =>
      let acc' := natToDigit (n mod 10) ::: acc in
      match n / 10 with
        | 0 => if crop then acc'
               else writeNatAux time' 0 crop acc'
        | n' => writeNatAux time' n' crop acc'
      end
  end.

Definition writeNat (n : nat) (acc : string) : string :=
  writeNatAux (S n) n true acc.

Definition writeNatSize (size : nat) (n : nat) (acc : string) : string :=
  writeNatAux size n false acc.

Definition writeBool (b : bool) : string :=
  if b then "true" else "false".
(* end hide *)

Module Internal.

Fixpoint sprintf (f : format) (k : string -> string) : formatType f :=
  match f with
    | [] => k ""
    | dir :: dirs =>
      match dir return formatType (dir :: dirs) with
        | DLit c => sprintf dirs (fun res => k (c ::: res))
        | DNum o =>
          fun n =>
            let k' := match o with
                        | Some size => fun res => k (writeNatSize size n res)
                        | None => fun res => k (writeNat n res)
                      end in
            sprintf dirs k'
        | DBool =>
          fun b =>
            sprintf dirs (fun res => k (writeBool b ++ res))
        | DString =>
          fun s =>
            sprintf dirs (fun res => k (s ++ res))
        | DChar =>
          fun c =>
            sprintf dirs (fun res => k (c ::: res))
      end
  end.

(** Most directives generate an additional argument to [sprintf] by
wrapping the recursive call with an anonymous function. Also, notice
the type annotation on the inner [match]: [return formatType (dir ::
dirs)]. As one could hope, this mysterious expression is telling Coq
which type is being returned on each branch of the [match]. Dependent
types require more sophisticated type inference, and in some cases it
is necessary to provide these annotations explicitly.

To use [sprintf], we just have to pass it the identity continuation
[fun res => res], which will receive the value built by [sprintf] and
return it as-is. *)

Example sprintfTest1 :
  sprintf [DNum None, DString] (fun res => res)
          42 "This is a string" = "42This is a string".
Proof. reflexivity. Qed.

Example sprintfTest2 :
  sprintf [DNum (Some 2), DLit "/", DNum (Some 2)] (fun res => res)
          2 4 = "02/04".
Proof. reflexivity. Qed.

End Internal.

(** ** Strings as format

Now that we have our first implementation, we will write the code
needed to parse the format from a [string]. Our format syntax is
inspired by C's own syntax. All characters are interpreted literally,
except for [%], which signals the beginning of a control sequence. As
in C, we can write [%<n>d], where [<n>] is a number, to specify how
many digits we want when printing a [nat].

The [parseFormat] function below tries to read a [format], returning
[Some f] if the [string] argument represents [f], and [None] if there
was a parse error. [parseFormatSize] is used to read the [%<n>d]
directives. The auxiliary function [addDir] adds a directive to an
[option format] when possible, returning [None] otherwise. *)

Definition addDir (o : option format) (dir : directive) : option format :=
  match o with
    | Some f => Some (dir :: f)
    | None => None
  end.

Fixpoint parseFormat (s : string) : option format :=
  match s with
    | "" => Some []
    | "%" ::: s' =>
      match s' with
        | "%" ::: s'' => addDir (parseFormat s'') (DLit "%")
        | "b" ::: s'' => addDir (parseFormat s'') DBool
        | "s" ::: s'' => addDir (parseFormat s'') DString
        | "c" ::: s'' => addDir (parseFormat s'') DChar
        | "d" ::: s'' => addDir (parseFormat s'') (DNum None)
        | _ => parseFormatSize s' 0
      end
    | c ::: s' =>
      addDir (parseFormat s') (DLit c)
  end

with parseFormatSize (s : string) (acc : nat) : option format :=
       match s with
         | "" => None
         | "d" ::: s' => addDir (parseFormat s') (DNum (Some acc))
         | c ::: s' =>
           match digitToNat c with
             | Some n => parseFormatSize s' (10 * acc + n)
             | None => None
           end
       end.

(** We can test our function in some simple cases. *)

Example parseFormatTest1 :
  parseFormat "%d%4da" = Some [DNum None, DNum (Some 4), DLit "a"].
Proof. reflexivity. Qed.

Example parseFormatTest2 :
  parseFormat "%ca%s%" = None.
Proof. reflexivity. Qed.

Example parseFormatTest3 :
  parseFormat "%s%b" = Some [DString, DBool].
Proof. reflexivity. Qed.

(** ** Putting the pieces together

Using [parseFormat], we can now write a convenient wrapper for our
first [sprintf]. Just as we did in the #previous
post#, we ensure that invalid format strings are detected right
away by producing a value of a different type when we hit a parse
error. *)

Inductive printfError := InvalidFormat.

Definition sprintfOpt (o : option format) : match o with
                                              | Some f => formatType f
                                              | None => printfError
                                            end :=
  match o with
    | Some f => Internal.sprintf f (fun res => res)
    | None => InvalidFormat
  end.

Definition sprintf (s : string) := sprintfOpt (parseFormat s).

(** Despite its intricate type, using our function is simple, as the
examples below show. *)

Definition greet name y m d : string :=
  sprintf "Hello %s, today is %d/%2d/%2d" name y m d.

Example greetTest1 : greet "readers" 2013 4 19 =
                     "Hello readers, today is 2013/04/19".
Proof. reflexivity. Qed.

Definition tableRow name value : string :=
  sprintf "
%s	%b
" name value.

Example tableRowTest1 : tableRow "x1" true =
                        "
x1	true
".
Proof. reflexivity. Qed.

(** Trying to pass the wrong number of arguments to [sprintf], or
giving it arguments of the wrong type, will result in a type error. *)

(* Example greetTest2 : string := greet 2013 4 19 "readers". *)

(* Error: The term "2013" has type "nat" while it is expected to have type
  "string". *)

(* Example tableRowTest2 : string := tableRow "x1". *)

(* Error: The term "tableRow "x1"" has type "bool -> string"
   while it is expected to have type "string". *)

(** ** Summary

We've seen how to implement a type-safe version of [sprintf] in
Coq. Unlike other approaches to the problem, our solution did not
require abandoning strings for specifying formats, nor relies on any
special extensions to the language. Type computation and dependent
types, the key ingredients in our implementation, are powerful
general-purpose features that lie at the heart of Coq. *)


Definition Berry (x y z : bool) :=
  match x, y, z with
  | true, false, _ => 0
  | false, _, true => 1
  | _, true, false => 2
  end.


(*
Copyright © 2020 Vincent Semeria

Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
*)

(** Consequence of the Markov principle on constructive reals. *)

Require Import Coq.QArith.QArith_base.
Require Import Coq.Reals.Abstract.ConstructiveReals.
Require Import Coq.Reals.Abstract.ConstructiveAbs.

Local Open Scope ConstructiveReals.

(* This axiom has computational content :
   run the unbounded search Pdec 0, Pdec 1, ...
   and the last hypothesis is a proof of termination. *)
Definition Markov : Prop
  := forall (P : nat -> Prop),
    (forall n:nat, {P n} + {~P n})
    -> (~~exists n:nat, P n)
    -> exists n:nat, P n.

Lemma Markov_notnot_lt_0 : forall {R : ConstructiveReals} (x : CRcarrier R),
    Markov -> (~~CRltProp R 0 x) -> CRltProp R 0 x.
Proof.
  intro R.
  assert (forall (x : CRcarrier R) (n:nat),
             x - CR_of_Q R (1#Pos.of_nat n) < x) as bumpDown.
  { intros x n.
    apply (CRlt_le_trans _ (x-0)).
    apply CRplus_lt_compat_l.
    apply CRopp_gt_lt_contravar, CR_of_Q_lt.
    reflexivity.
    unfold CRminus. rewrite CRopp_0, CRplus_0_r.
    apply CRle_refl. }
  intros x markov xpos.
  assert (exists n:nat, Qlt 0 (let (q,_) := CR_Q_dense R _ _ (bumpDown x n) in q)).
  { apply markov.
    - intro n.
      destruct (CR_Q_dense R _ _ (bumpDown x n)) as [q H].
      destruct (Qlt_le_dec 0 q).
      left. exact q0. right. apply (Qle_not_lt _ _ q0).
    - intro abs. contradict xpos; intro xpos.
      apply CRltEpsilon in xpos.
      contradict abs.
      destruct (CR_archimedean R (CRinv R x (inr xpos))) as [n H].
      exists (Pos.to_nat n).
      destruct ( CR_Q_dense R (x - CR_of_Q R (1 # Pos.of_nat (Pos.to_nat n)))%ConstructiveReals
        x (bumpDown x (Pos.to_nat n))) as [q H0].
      apply (lt_CR_of_Q R).
      refine (CRle_lt_trans _ _ _ _ (fst H0)).
      clear H0 q.
      rewrite Pos2Nat.id.
      apply (CRplus_le_reg_r (CR_of_Q R (1#n))).
      unfold CRminus.
      rewrite CRplus_0_l.
      rewrite CRplus_assoc.
      rewrite CRplus_opp_l, CRplus_0_r.
      apply CRlt_asym in H.
      apply (CRmult_le_compat_l x) in H.
      rewrite CRinv_r in H.
      apply (CRmult_le_compat_r (CR_of_Q R (1#n))) in H.
      rewrite CRmult_1_l, CRmult_assoc, <- CR_of_Q_mult in H.
      setoid_replace ((Z.pos n # 1) * (1 # n))%Q with 1%Q in H.
      rewrite CRmult_1_r in H. exact H.
      unfold Qeq; simpl.
      rewrite Pos.mul_1_r, Pos.mul_1_r. reflexivity.
      apply CR_of_Q_le; discriminate.
      apply CRlt_asym, xpos. }
  clear xpos.
  destruct H as [n H].
  destruct (CR_Q_dense R _ _ (bumpDown x n)) as [q H0].
  apply CRltForget.
  apply (CRlt_trans _ (CR_of_Q R q)).
  apply CR_of_Q_lt, H.
  apply H0.
Qed.

Lemma Markov_notnot_lt : forall {R : ConstructiveReals} (x y : CRcarrier R),
    Markov -> (~~CRltProp R x y) -> CRltProp R x y.
Proof.
  intros. apply CRltForget.
  apply (CRplus_lt_reg_r (-x)).
  apply (CRle_lt_trans _ 0).
  rewrite CRplus_opp_r. apply CRle_refl.
  apply CRltEpsilon.
  apply (Markov_notnot_lt_0 (y-x) H).
  intro abs. contradict H0; intro H0.
  contradict abs.
  apply CRltForget.
  apply (CRplus_lt_reg_r x).
  apply (CRle_lt_trans _ x).
  rewrite CRplus_0_l. apply CRle_refl.
  apply (CRlt_le_trans _ y).
  apply CRltEpsilon, H0.
  unfold CRminus.
  rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r.
  apply CRle_refl.
Qed.

Lemma Markov_notnot_apart_0 : forall {R : ConstructiveReals} (x : CRcarrier R),
    Markov -> (~(x == 0)) -> (x ≶ 0).
Proof.
  intros.
  apply CRabs_appart_0.
  apply CRltEpsilon, (Markov_notnot_lt_0 _ H).
  intro abs. contradict H0.
  assert (CRabs R x <= 0) as H0.
  { intro H0. contradict abs.
    apply CRltForget, H0. }
  pose proof (CRabs_def2 x 0 H0) as [H1 H2].
  rewrite CRopp_0 in H2.
  split; assumption.
Qed.

Lemma Markov_notnot_apart : forall {R : ConstructiveReals} (x y : CRcarrier R),
    Markov -> (~(x == y)) -> (x ≶ y).
Proof.
  intros.
  apply (CRplus_appart_reg_r (-y)).
  rewrite CRplus_opp_r.
  apply (Markov_notnot_apart_0 _ H).
  intro abs. contradict H0.
  apply (CRplus_eq_reg_r (-y)).
  rewrite CRplus_opp_r. exact abs.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj14synthconj5 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv0 lv1)).
Admitted.
QuickChick conj14synthconj5.


(* -*- mode: coq; mode: visual-line -*-  *)

From HoTT Require Import Basics.
From WildCat Require Import Basics.
From WildCat Require Export Cat1 Laxity.

Generalizable Variables m n p A B C.

(** * Inserters and natural transformations *)

(** ** Dependent inserters *)

Definition GenDInserter (ls : Stream Laxity) `{IsGlob m A} `{HasEquivs n B}
           (F G : A -> B) `{!IsFunctor0 F, !IsFunctor0 G}
           (a : A)
  := lHom (head ls) (F a) (G a).

CoFixpoint isdglob_gendinserter (ls : Stream Laxity)
           `{IsGlob m A} `{HasEquivs n B}
           (F G : A -> B) `{!IsFunctor0 F, !IsFunctor0 G}
  : IsDGlob n (GenDInserter ls F G).
Proof.
  unshelve econstructor.
  - intros a b f ta tb; revert f.
    unfold GenDInserter in ta, tb.
    destruct (head ls).
    + exact (GenDInserter (tail ls) (cat_postcomp (F a) tb o fmap F)
                          (cat_precomp (G b) ta o fmap G)).
    + exact (GenDInserter (tail ls) (cat_postcomp (F a) tb o fmap F)
                          (cat_precomp (G b) ta o fmap G)).
    + exact (GenDInserter (tail ls) (cat_postcomp (G a) tb o fmap G)
                          (cat_precomp (F b) ta o fmap F)).
  - intros a b ta tb; cbn.
    unfold GenDInserter in ta, tb.
    set (l := head ls) in *.
    destruct l;
    apply isdglob_gendinserter.
Defined.
Global Existing Instance isdglob_gendinserter.

(** We can forget the invertibility of an iso-inserter. *)
Definition colax_pseudo_inserter
           (ls : Stream Laxity) `{IsGlob m A} `{HasEquivs n B}
           (F G : A -> B) `{!IsFunctor0 F, !IsFunctor0 G} (a : A)
  : (GenDInserter (scons pseudo ls) F G a) -> (GenDInserter (scons colax ls) F G a)
  := fun f => cate_fun f.

Global Instance isdfunctor0_colax_pseudo_inserter
       (ls : Stream Laxity) `{IsGlob m A} `{HasEquivs n B}
       (F G : A -> B) `{!IsFunctor0 F, !IsFunctor0 G}
  : IsDFunctor0 idmap (colax_pseudo_inserter ls F G).
Proof.
  unshelve econstructor.
  - cbn; intros a b u v f g.
    exact g.
  - cbn; intros a b u v.
    apply isdfunctor0_idmap.
Defined.

(** And we can turn around a lax inserter into a colax one. *)
Definition colax_lax_inserter
           (ls : Stream Laxity) `{IsGlob m A} `{HasEquivs n B}
           (F G : A -> B) `{!IsFunctor0 F, !IsFunctor0 G} (a : A)
  : (GenDInserter (scons lax ls) G F a) -> (GenDInserter (scons colax ls) F G a)
  := fun f => f.

Global Instance isdfunctor0_colax_lax_inserter
       (ls : Stream Laxity) `{IsGlob m A} `{HasEquivs n B}
       (F G : A -> B) `{!IsFunctor0 F, !IsFunctor0 G}
  : IsDFunctor0 idmap (colax_lax_inserter ls F G).
Proof.
  unshelve econstructor.
  - cbn; intros a b u v f g.
    exact g.
  - cbn; intros a b u v.
    apply isdfunctor0_idmap.
Defined.

(*
CoFixpoint iscat0_gendinserter (ls : Stream Laxity)
           `{IsCat0 m A} `{IsCat1 n B} (F G : A -> B)
           `{!IsFunctor0 F, !IsFunctor1 F, !IsFunctor0 G, !IsFunctor1 G}
  : IsDCat0 n (GenDInserter ls F G).
Proof.
  unshelve econstructor.
  - intros a b c ta tb tc g f.
    unfold GenDInserter in ta, tb, tc.
    cbn; destruct (head ls); cbn; intros p q.
    all: unfold GenDInserter in p, q.
    all: unfold GenDInserter.
    all: destruct (head (tail ls)); cbn in *.
    all: unfold cat_precomp, cat_postcomp in *.
    (** Should really be using a library for squares. *)
    1,4,7:refine (_ $o (_ $<o fmap_comp _ _ _)).
    1-3:refine (_ $o (cat_assoc _ _ _)^-1$).
    1-3:refine (((fmap_comp _ _ _)^-1$ $o> _) $o _).
    1-3:refine ((cat_assoc _ _ _)^-1$ $o _).
    1-3:refine (_ $o (p $o> _)).
    1-3:refine ((_ $<o q) $o _).
    1-3:by apply cat_assoc.
    1,3,5:refine (_ $oE (_ $<oE fmap_comp _ _ _)).
    1-3:refine (_ $oE (cat_assoc _ _ _)^-1$).
    1-3:refine (((fmap_comp _ _ _)^-1$ $o>E _) $oE _).
    1-3:refine ((cat_assoc _ _ _)^-1$ $oE _).
    1-3:refine (_ $oE (p $o>E _)).
    1-3:refine ((_ $<oE q) $oE _).
    1-3:by apply cat_assoc.
    all:refine (_ $o (fmap_comp _ _ _ $o> _)).
    all:refine (_ $o (cat_assoc _ _ _)).
    all:refine ((_ $<o (fmap_comp _ _ _)^-1$) $o _).
    all:refine ((cat_assoc _ _ _) $o _).
    all:refine (_ $o (_ $<o q)).
    all:refine ((p $o> _) $o _).
    all:exact (cat_assoc _ _ _)^-1$.
  - unfold GenDInserter; cbn; intros a ta.
    destruct (head ls); cbn.
    all: unfold GenDInserter.
    all: destruct (head (tail ls)); cbn in *.
    all: unfold cat_precomp, cat_postcomp in *.
    1,4,7:refine (_ $o (_ $<o fmap_id _ _)).
    1-3:refine (((fmap_id _ _)^-1$ $o> _) $o _).
    1-3:exact ((cat_idl _)^-1$ $o (cat_idr _)).
    1,3,5:refine (_ $oE (_ $<oE fmap_id _ _)).
    1-3:refine (((fmap_id _ _)^-1$ $o>E _) $oE _).
    1-3:exact ((cat_idl _)^-1$ $oE (cat_idr _)).
    all:refine (_ $o (fmap_id _ _ $o> _)).
    all:refine ((_ $<o (fmap_id _ _)^-1$) $o _).
    all:exact ((cat_idr _)^-1$ $o (cat_idl _)).
Abort.
*)

Notation DIsoInserter := (GenDInserter all_pseudo).
Notation DInserter := (GenDInserter one_colax).

Definition GenInserter (l : Stream Laxity)
           `{IsGlob m A} `{HasEquivs n B}
           (F G : A -> B) `{!IsFunctor0 F, !IsFunctor0 G}
  := sig (GenDInserter l F G).

Notation IsoInserter := (GenInserter all_pseudo).
Notation Inserter := (GenInserter one_colax).

(** For instance, the category of prespectra (resp. spectra) should be the inserter (resp. isoinserter) of the identity functor of (nat -> pType) over a functor [shift o loops]. *)

(** ** Natural transformations *)

(** A natural transformation [F $=> G] is a section of their displayed inserter.  The freedom to choose laxities at all dimensions carries over, although we insist that a transformation always goes from [F] to [G] so that the inserter is colax at the bottom level. *)

Definition Transformation {A} `{IsGlob n B} (F G : A -> B)
  := forall a, F a $-> G a.
Notation "F $=> G" := (Transformation F G).

Notation IsGenNatural1 l F G :=
  (@IsCatSect0 _ _ _ (GenDInserter (scons colax l) F G) _ _).

Definition isgennat (ls : Stream Laxity) `{IsGlob m A} `{HasEquivs n B}
      {F : A -> B} `{!IsFunctor0 F} {G : A -> B} `{!IsFunctor0 G}
      (alpha : F $=> G) {alnat : IsGenNatural1 ls F G alpha}
      {x y : A} (f : x $-> y)
  : lHom (head ls) (alpha y $o fmap F f) (fmap G f $o alpha x)
  := fmapD (B := GenDInserter (scons colax ls) F G) alpha f.

Notation IsNatural1 F G := (IsGenNatural1 all_pseudo F G).

Definition isnat `{IsGlob m A} `{HasEquivs n B}
      {F : A -> B} `{!IsFunctor0 F} {G : A -> B} `{!IsFunctor0 G}
      (alpha : F $=> G) {alnat : IsNatural1 F G alpha}
      {x y : A} (f : x $-> y)
  : (alpha y $o fmap F f) $<~> (fmap G f $o alpha x)
  := isgennat all_pseudo alpha f.

Global Instance isgennat_iscolaxnat (ls : Stream Laxity) `{IsGlob m A} `{HasEquivs n B}
      {F : A -> B} `{!IsFunctor0 F} {G : A -> B} `{!IsFunctor0 G}
      (alpha : F $=> G)
      {alnat : IsGenNatural1 (scons colax ls) F G alpha}
      (x y : A)
  : IsGenNatural1 ls ((cat_postcomp (F x) (alpha y)) o (fmap' F x y))
                  ((cat_precomp (G y) (alpha x)) o (fmap' G x y))
                  (isgennat (scons colax ls) alpha)
  := iscatsect0_fmapD alpha alnat x y.

Global Instance isgennat_ispseudonat (ls : Stream Laxity) `{IsGlob m A} `{HasEquivs n B}
      {F : A -> B} `{!IsFunctor0 F} {G : A -> B} `{!IsFunctor0 G}
      (alpha : F $=> G)
      {alnat : IsGenNatural1 (scons pseudo ls) F G alpha}
      (x y : A)
  : IsGenNatural1 ls ((cat_postcomp (F x) (alpha y)) o (fmap' F x y))
                  ((cat_precomp (G y) (alpha x)) o (fmap' G x y))
                  (fun f => cate_fun (isgennat (scons pseudo ls) alpha f)).
Proof.
  (** We have to nudge this from a section of the iso-inserter to a section of the inserter. *)
  pose (iscatsect0_fmapD alpha alnat x y).
  exact (iscatsect0_isdfunctor0_compose
           (colax_pseudo_inserter ls ((cat_postcomp (F x) (alpha y)) o (fmap' F x y))
                              ((cat_precomp (G y) (alpha x)) o (fmap' G x y)))
           (@fmapD _ _ _ _ _ _ alpha alnat x y)).
Defined.

Global Instance isgennat_islaxnat (ls : Stream Laxity) `{IsGlob m A} `{HasEquivs n B}
      {F : A -> B} `{!IsFunctor0 F} {G : A -> B} `{!IsFunctor0 G}
      (alpha : F $=> G)
      {alnat : IsGenNatural1 (scons lax ls) F G alpha}
      (x y : A)
  : IsGenNatural1 ls ((cat_precomp (G y) (alpha x)) o (fmap' G x y))
                  ((cat_postcomp (F x) (alpha y)) o (fmap' F x y))
                  (isgennat (scons lax ls) alpha).
Proof.
  (** Similarly here, we have to nudge from a section of the lax inserter in one direction to a section of the colax inserter in the other direction. *)
  pose (iscatsect0_fmapD alpha alnat x y).
  exact (iscatsect0_isdfunctor0_compose
           (colax_lax_inserter ls ((cat_precomp (G y) (alpha x)) o (fmap' G x y))
                                ((cat_postcomp (F x) (alpha y)) o (fmap' F x y)))
           (@fmapD _ _ _ _ _ _ alpha alnat x y)).
Defined.

(** If we generalized comma categories (and hence inserters) to act on category-sections rather than just functors, we could in principle iterate this approach to define modifications and higher transfors, analogously to how we iterate [isglob_forall] to define all the higher structure of [Type] and similarly for [pType].  Such a generalization seems to require either that the displayed category is an isofibration, or that we define a more general notion of inserter over a given natural transformation, and either one seems to require 2-coherent categories.  In fact, since the level of coherence seems to go down by one each time we apply a comma construction, we probably wouldn't be able to use this to define a whole oo-category of oo-categories at any fixed coherence level.  *)


Require Import Coq.Lists.List Coq.Setoids.Setoid Coq.Classes.Morphisms.
Require Import Coq.omega.Omega.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.Refinement.BinOpBrackets.ParenBalanced.
Require Import Fiat.Parsers.Reachable.ParenBalanced.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Common.Equality.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.
Require Import Fiat.Common.Enumerable.
Require Import Fiat.Common.FixedPoints.

Local Open Scope bool_scope.
Local Open Scope string_like_scope.

Set Implicit Arguments.

Local Notation eta x := (fst x, snd x) (only parsing).
Local Notation eta2 x := (fst x, (fst (snd x), snd (snd x))) (only parsing).

Local Opaque rdp_list_predata.

Section specific.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}
          {CharE : Enumerable Char}.
  Context {pdata : paren_balanced_hiding_dataT Char}.
  Context (G : pregrammar' Char).
  Let predata := (@rdp_list_predata _ G).
  Local Existing Instance predata.

  Section assume_lists.
    Context (pb_nts pbh_nts : nonterminals_listT).

    Definition paren_balanced''_production_step
               (hiding : bool)
      := fun (it : item Char) (rest_balanced : nat -> bool) level
         => let predata := @rdp_list_predata _ G in
            match it with
              | Terminal P
                => ((pb_check_level_fun hiding P level)
                      && match pb_new_level_fun P level with
                           | new_level::nil => rest_balanced new_level
                           | _ => false
                         end)%bool
              | NonTerminal nt
                => (*(is_valid_nonterminal initial_nonterminals_data nt)
                   &&*)
                (if (hiding && Compare_dec.zerop level)
                 then is_valid_nonterminal pbh_nts (of_nonterminal nt)
                 else is_valid_nonterminal pb_nts (of_nonterminal nt))
                  && rest_balanced level
            end.

    Definition paren_balanced''_production
               (hiding : bool)
               (level : nat)
               (pat : production Char)
    : bool
      := fold_right
           (paren_balanced''_production_step hiding)
           Compare_dec.zerop
           pat
           level.

    Definition paren_balanced''_productions
               (hiding : bool)
               (level : nat)
               (pats : productions Char)
    : bool
      := fold_right
           andb
           true
           (map (paren_balanced''_production hiding level) pats).

    Definition paren_balanced''_nt
               (hiding : bool)
               (nt : nonterminal_carrierT)
    : bool
      := let predata := @rdp_list_predata _ G in
         (paren_balanced''_productions
            hiding
            0
            (Lookup_idx G nt)).

    Section correct.
      Context (H_pb : forall nt, is_valid_nonterminal pb_nts nt
                                 -> paren_balanced''_nt false nt)
              (H_pbh : forall nt, is_valid_nonterminal pbh_nts nt
                                  -> paren_balanced''_nt true nt).

      Fixpoint paren_balanced_productions_correct
               (hiding : bool)
               (level : nat)
               (pats : productions Char)
               (H_p : paren_balanced''_productions hiding level pats)
               (str : String)
               (p : parse_of G str pats)
      : if hiding
        then paren_balanced_hiding' str level
        else paren_balanced' str level
      with paren_balanced_production_correct
             (hiding : bool)
             (level : nat)
             (pat : production Char)
             (H_p : paren_balanced''_production hiding level pat)
             (str : String)
             (p : parse_of_production G str pat)
           : if hiding
             then paren_balanced_hiding' str level
             else paren_balanced' str level.
      Proof.
        { destruct p as [?? p | ?? p ];
          [ apply (fun hiding level H_p => paren_balanced_production_correct hiding level _ H_p _ p)
          | apply (fun hiding level H_p => paren_balanced_productions_correct hiding level _ H_p _ p) ];
          clear paren_balanced_production_correct paren_balanced_productions_correct;
          unfold paren_balanced''_productions in *;
          simpl in *;
          apply Bool.andb_true_iff in H_p;
          destruct H_p as [H_p0 H_p1];
          assumption. }
        { destruct p as [| ??? p0 p1 ].
          { clear paren_balanced_productions_correct paren_balanced_production_correct.
            unfold paren_balanced''_production in *.
            simpl in *.
            edestruct Compare_dec.zerop; subst; simpl in *; try congruence; [].
            destruct hiding.
            { rewrite paren_balanced_hiding'_nil by assumption; reflexivity. }
            { rewrite paren_balanced'_nil by assumption; reflexivity. } }
          { specialize (fun hiding level H_p => paren_balanced_production_correct hiding level _ H_p _ p1); clear p1.
            unfold paren_balanced''_production in *.
            simpl in *.
            destruct p0 as [| ? ? p0 ].
            { clear paren_balanced_productions_correct.
              unfold paren_balanced''_production_step at 1 in H_p.
              destruct (pb_new_level_fun P level) as [|? [|]] eqn:Heq;
                simpl in *;
                try rewrite Bool.andb_false_r in *; try congruence;
                [].
              apply Bool.andb_true_iff in H_p;
                destruct H_p as [H_p0 H_p1].
              specialize (paren_balanced_production_correct _ _ H_p1).
              clear H_p1.
              rewrite paren_balanced_hiding'_recr.
              rewrite paren_balanced'_recr.
              repeat match goal with
                       | [ H : is_true (_ ~= [ _ ]) |- _ ]
                         => pose proof (length_singleton _ _ H);
                           progress apply take_n_1_singleton in H
                       | [ H : context[length (StringLike.take _ _)] |- _ ]
                         => rewrite take_length in H
                     end.
              erewrite !(proj1 (get_0 _ _)) by eassumption.
              assert (H' : StringLike.drop n str =s StringLike.drop 1 str).
              { destruct n as [|[|n]]; simpl in *; try congruence; try reflexivity.
                destruct (length str) as [|[|]] eqn:?; try congruence.
                apply bool_eq_empty; rewrite ?drop_length; omega. }
              rewrite !H' in paren_balanced_production_correct; clear H'.
              repeat match goal with
                       | [ H : _ |- _ ] => setoid_rewrite pb_check_level_fun_correct in H
                       | [ H : _ |- _ ] => setoid_rewrite pb_new_level_fun_correct in H
                     end.
              unfold paren_balanced_hiding'_step, paren_balanced'_step, pb_check_level_fun, pb_new_level_fun, pb_check_level, pb_new_level in *.
              repeat match goal with
                       | _ => assumption
                       | _ => progress subst
                       | [ H : filter _ _ = _::nil |- _ ] => eapply filter_enumerate in H
                       | _ => progress split_iff
                       | _ => specialize_by eassumption; progress subst
                       | [ H : context[fold_right andb true (map _ _)] |- _ ]
                         => rewrite fold_right_andb_map_in_iff in H
                       | [ H : context[In _ (filter _ _)] |- _ ]
                         => setoid_rewrite filter_In in H
                       | [ H : forall x, _ /\ _ -> _ |- _ ] => specialize (fun x A B => H x (conj A B))
                       | [ H : forall x, In _ (enumerate _) -> _ |- _ ]
                           => specialize (fun x => H x (enumerate_correct _))
                       | [ H : ?x = true, H' : context[?x] |- _ ] => rewrite H in H'
                       | [ H : ?x = false, H' : context[?x] |- _ ] => rewrite H in H'
                       | [ H : ?x = ?y::nil |- _ ]
                         => assert (forall n, In n x <-> n = y)
                           by (intro; rewrite H; simpl; intuition);
                           clear H
                       | [ H : forall x, _ = x -> _ |- _ ] => specialize (H _ eq_refl)
                       | [ H : forall x, x = _ -> _ |- _ ] => specialize (H _ eq_refl)
                       | [ H : context[In _ (uniquize _ _)] |- _ ]
                         => setoid_rewrite <- (ListFacts.uniquize_In_refl_iff _ EqNat.beq_nat _ (lb eq_refl) bl) in H
                       | [ H : context[In _ (map _ _)] |- _ ]
                         => setoid_rewrite in_map_iff in H
                       | _ => progress destruct_head ex
                       | _ => progress destruct_head and
                       | [ H : forall x, ex _ -> _ |- _ ]
                         => specialize (fun x a b => H x (ex_intro _ a b))
                       | _ => progress cbv beta in *
                       | _ => progress split_and
                       | [ |- context[bool_of_sumbool ?e] ] => destruct e; simpl
                       | [ |- context[if ?e then _ else _] ]
                         => destruct e eqn:?
                       | [ H : forall ch, is_true (?P ch) -> _ |- _ ]
                         => repeat match goal with
                                     | [ H' : is_true (P ?ch') |- _ ]
                                       => unique pose proof (H _ H')
                                     | [ H' : P ?ch' = true |- _ ]
                                       => unique pose proof (H _ H')
                                   end;
                           clear H
                     end. }
            { specialize (fun hiding level H_p => paren_balanced_productions_correct hiding level _ H_p _ p0); clear p0.
              unfold paren_balanced''_production_step at 1 in H_p.
              apply Bool.andb_true_iff in H_p;
                destruct H_p as [H_p0 H_p1].
              specialize (paren_balanced_production_correct _ _ H_p1); clear H_p1.
              destruct hiding.
              { simpl in *.
                rewrite paren_balanced_hiding'_split_0; [ reflexivity | | eassumption ].
                destruct level as [|level]; simpl in *.
                { specialize (H_pbh _ H_p0); clear H_p0.
                  unfold paren_balanced''_nt in *.
                  (*apply Bool.andb_true_iff in H_pbh;
                  destruct H_pbh as [H_pbh0 H_pbh1]; clear H_pbh.*)
                  rewrite <- Carriers.list_to_productions_to_nonterminal in H_pbh.
                  change Carriers.default_to_nonterminal with to_nonterminal in H_pbh.
                  rewrite to_of_nonterminal in H_pbh by assumption.
                  specialize (paren_balanced_productions_correct _ _ H_pbh).
                  simpl in *.
                  assumption. }
                { specialize (H_pb _ H_p0); clear H_p0.
                  unfold paren_balanced''_nt in *.
                  (*apply Bool.andb_true_iff in H_pb;
                  destruct H_pb as [H_pb0 H_pb1]; clear H_pb.*)
                  rewrite <- Carriers.list_to_productions_to_nonterminal in H_pb.
                  change Carriers.default_to_nonterminal with to_nonterminal in H_pb.
                  rewrite to_of_nonterminal in H_pb by assumption.
                  specialize (paren_balanced_productions_correct _ _ H_pb).
                  simpl in *.
                  assumption. } }
              { simpl in *.
                rewrite paren_balanced'_split_0; [ reflexivity | | eassumption ].
                specialize (H_pb _ H_p0); clear H_p0.
                unfold paren_balanced''_nt in *.
                (*apply Bool.andb_true_iff in H_pb;
                destruct H_pb as [H_pb0 H_pb1]; clear H_pb.*)
                rewrite <- Carriers.list_to_productions_to_nonterminal in H_pb.
                change Carriers.default_to_nonterminal with to_nonterminal in H_pb.
                rewrite to_of_nonterminal in H_pb by assumption.
                specialize (paren_balanced_productions_correct _ _ H_pb).
                simpl in *.
                assumption. } } } }
      Defined.

      Lemma paren_balanced_nt''_correct
            (hiding : bool)
            nt
            (H_p : paren_balanced''_nt hiding (of_nonterminal nt))
            (str : String)
            (p : parse_of_item G str (NonTerminal nt))
      : if hiding
        then paren_balanced_hiding str
        else paren_balanced str.
      Proof.
        dependent destruction p.
        eapply paren_balanced_productions_correct;
          try eassumption; instantiate;
            rewrite <- Carriers.list_to_productions_to_nonterminal;
            change Carriers.default_to_nonterminal with to_nonterminal;
            rewrite ?to_of_nonterminal; eassumption.
      Qed.
    End correct.

    Section correct_reflective.
      Local Transparent rdp_list_predata.

      Context (H_pb : fold_right andb true (map (paren_balanced''_nt false) pb_nts))
              (H_pbh : fold_right andb true (map (paren_balanced''_nt true) pbh_nts)).

      Local Ltac t :=
        repeat match goal with
                 | _ => progress simpl in *
                 | _ => progress specialize_by assumption
                 | _ => progress intros
                 | _ => progress unfold rdp_list_is_valid_nonterminal in *
                 | _ => progress subst
                 | _ => congruence
                 | [ H : string_beq _ _ = true |- _ ] => apply string_bl in H
                 | [ H : EqNat.beq_nat _ _ = true |- _ ] => apply EqNat.beq_nat_true in H
                 | [ H : is_true (_ || _) |- _ ] => apply Bool.orb_true_iff in H
                 | [ H : is_true (_ && _) |- _ ] => apply Bool.andb_true_iff in H
                 | [ H : _ /\ _ |- _ ] => let H1 := fresh in
                                          let H2 := fresh in
                                          destruct H as [H1 H2]; try clear H
                 | [ H : _ \/ _ |- _ ] => destruct H
                 | _ => solve [ eauto with nocore ]
               end.

      Lemma paren_balanced_nt'_correct
            (hiding : bool)
            nt
            (H_p : paren_balanced''_nt hiding (of_nonterminal nt))
            (str : String)
            (p : parse_of_item G str (NonTerminal nt))
      : if hiding
        then paren_balanced_hiding str
        else paren_balanced str.
      Proof.
        eapply paren_balanced_nt''_correct; try eassumption.
        { clear -H_pb.
          induction pb_nts; t. }
        { clear -H_pbh.
          induction pbh_nts; t. }
      Qed.
    End correct_reflective.
  End assume_lists.
End specific.

Section paren_balanced_nonterminals.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char}.
  Context {HEC : Enumerable Char}.
  Context {pdata : paren_balanced_hiding_dataT Char}
          (G : pregrammar' Char)
          (hiding : bool).
  Let predata := (@rdp_list_predata _ G).
  Local Existing Instance predata.

  Definition paren_balanced_nonterminals (nt : String.string) : list nonterminal_carrierT * list nonterminal_carrierT
    := greatest_fixpoint_of_lists
         (fun pb_nts pbh_nts => paren_balanced''_nt (G := G) pb_nts pbh_nts false)
         (fun pb_nts pbh_nts => paren_balanced''_nt (G := G) pb_nts pbh_nts true)
         initial_nonterminals_data
         initial_nonterminals_data.
End paren_balanced_nonterminals.

Local Transparent rdp_list_predata.

Section with_lists.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}.
  Context {HEC : Enumerable Char}.
  Context {pdata : paren_balanced_hiding_dataT Char}.
  Context (G : pregrammar' Char).
  Let predata := (@rdp_list_predata _ G).
  Local Existing Instance predata.

  Section pre.
    Context (hiding : bool)
            (nt : String.string).

    Let pb_nts : nonterminals_listT
      := fst (paren_balanced_nonterminals G nt).
    Let pbh_nts : nonterminals_listT
      := snd (paren_balanced_nonterminals G nt).

    Let H_pb : fold_right andb true (map (paren_balanced''_nt pb_nts pbh_nts false) pb_nts).
    Proof.
      rapply @greatest_fixpoint_of_lists_correct_1.
    Qed.
    Let H_pbh : fold_right andb true (map (paren_balanced''_nt pb_nts pbh_nts true) pbh_nts).
    Proof.
      rapply @greatest_fixpoint_of_lists_correct_2.
    Qed.

    Lemma paren_balanced_nt_correct
          (H_p : paren_balanced''_nt pb_nts pbh_nts hiding (of_nonterminal nt))
          (str : String)
          (p : parse_of_item G str (NonTerminal nt))
    : if hiding
      then paren_balanced_hiding str
      else paren_balanced str.
    Proof.
      eapply paren_balanced_nt'_correct; eassumption.
    Qed.
  End pre.

  Section rule.
    Context (nt : String.string).

    Let pb_nts : nonterminals_listT
      := fst (paren_balanced_nonterminals G nt).
    Let pbh_nts : nonterminals_listT
      := snd (paren_balanced_nonterminals G nt).

    Definition paren_balanced_hiding_correctness_type
      := (*(fold_right andb true (map (paren_balanced''_nt pb_nts pbh_nts false) pb_nts))
           && (fold_right andb true (map (paren_balanced''_nt pb_nts pbh_nts true) pbh_nts))
           && *)(paren_balanced''_nt pb_nts pbh_nts true (of_nonterminal nt)).

    Global Arguments paren_balanced_hiding_correctness_type / .

    (** Just check for paren-balanced-ness, not for that it hides the binary operation. *)
    Definition paren_balanced_correctness_type
      := (*(fold_right andb true (map (paren_balanced''_nt pb_nts pbh_nts false) pb_nts))
           && (fold_right andb true (map (paren_balanced''_nt pb_nts pbh_nts false) pbh_nts))
           &&*) (paren_balanced''_nt pb_nts pbh_nts false (of_nonterminal nt)).

    Global Arguments paren_balanced_hiding_correctness_type / .

    Lemma paren_balanced_hiding_nt_correct
          (Hvalid : paren_balanced_hiding_correctness_type)
    : forall str', parse_of_item G str' (NonTerminal nt)
                   -> paren_balanced_hiding str'.
    Proof.
      simpl in Hvalid.
      apply (paren_balanced_nt_correct true);
      assumption.
    Qed.
  End rule.
End with_lists.