Require Import Coq.Strings.String.
Require Import BinNat.
Require Import BinInt.
Require Import Poulet4.P4light.Syntax.Typed.
Require Import Poulet4.P4light.Syntax.Syntax.
Require Import Poulet4.P4light.Syntax.Value.
Require Import Poulet4.P4light.Semantics.Semantics.
Require Import Poulet4.P4light.Architecture.Tofino.
Require Import Poulet4.P4light.Syntax.P4Notations.
Require Import Poulet4.Utils.P4Arith.
Require Import ProD3.core.Core.
Require Import Hammer.Plugin.Hammer.
Open Scope string_scope.
Open Scope list_scope.
Open Scope Z_scope.

Section TofinoSpec.

Context {tags_t: Type} {tags_t_inhabitant : Inhabitant tags_t}.
Notation Val := (@ValueBase bool).
Notation Sval := (@ValueBase (option bool)).
(* Notation ValSet := (@ValueSet tags_t). *)
Notation ValSetT := (@ValSetT tags_t).
Notation Lval := ValueLvalue.

Notation ident := (String.string).
Notation path := (list ident).
Notation P4Int := (P4Int.t tags_t).
Notation P4String := (P4String.t tags_t).
Notation Expression := (@Expression tags_t).
Notation table_entry_valset := (@table_entry_valset tags_t Expression).

Instance target : @Target tags_t Expression := Tofino.

Variable ge : genv.
Variable am_ge : genv.

Lemma hoare_extern_match_list_intro : forall keys_match_kinds entryvs,
  hoare_extern_match_list keys_match_kinds entryvs (extern_matches keys_match_kinds entryvs).
Proof.
  intros. unfold hoare_extern_match_list.
  simpl. unfold extern_match.
  remember (extern_matches keys_match_kinds entryvs) as cases.
  clear Heqcases.
  induction cases.
  - auto.
  - destruct a.
    destruct b; auto.
Qed.

Fixpoint assert_int_nondet (sv : Sval) : option (N * option Z * list (option bool)) :=
  match sv with
  | ValBaseBit sbits =>
      match lift_option sbits with
      | Some bits =>
          Some (map_snd Some (BitArith.from_lbool bits), sbits)
      | None =>
          Some (Z.to_N (Zlength sbits), None, sbits)
      end
  | ValBaseInt sbits =>
      match lift_option sbits with
      | Some bits =>
          Some (map_snd Some (BitArith.from_lbool bits), sbits)
      | None =>
          Some (Z.to_N (Zlength sbits), None, sbits)
      end
  | ValBaseSenumField _ val => assert_int_nondet val
  | _ => None
  end.

Definition values_match_singleton_nondet (key: Sval) (val: Val): option bool :=
  match eval_sval_to_val key with
  | Some v =>
      Some (values_match_singleton v val)
  | None => None
  end.

(* Fixpoint vmm_help (bits0 bits1 bits2: list bool): bool :=
  match bits2, bits1, bits0 with
  | [], [], [] => true
  | false::tl2, _::tl1, _::tl0 => vmm_help tl0 tl1 tl2
  | true::tl2, hd1::tl1, hd0::tl0 =>
      if (Bool.eqb hd0 hd1)
      then (vmm_help tl0 tl1 tl2)
      else false
  (* should never hit *)
  | _, _, _ => dummy_bool
  end.

Definition values_match_mask (key: Val) (val mask: Val): bool :=
  match assert_int key, assert_int val, assert_int mask with
  | Some (w0, _, bits0), Some (w1, _, bits1), Some (w2, _, bits2) =>
    if negb ((w0 =? w1)%N && (w1 =? w2)%N) then dummy_bool
    else vmm_help bits0 bits1 bits2
  | _, _, _ => dummy_bool
  end.

Fixpoint vmm_help_z (v : Z) (bits1 bits2: list bool) :=
  match bits2, bits1 with
  | [], [] => true
  | false::tl2, _::tl1 => vmm_help_z (v / 2) tl1 tl2
  | true::tl2, hd1::tl1 =>
      if Bool.eqb (Z.odd v) hd1
      then (vmm_help_z (v / 2) tl1 tl2)
      else false
  | _, _ => dummy_bool
  end.

(* Fixpoint vmm_help_z' (v : Z) (bits1 bits2: list bool) :=
  match bits2, bits1 with
  | [], [] => true
  | false::tl2, _::tl1 => vmm_help_z' (v / 2) tl1 tl2
  | true::tl2, hd1::tl1 =>
      andb (Bool.eqb (Z.odd v) hd1) (vmm_help_z' (v / 2) tl1 tl2)
  | _, _ => Tofino.dummy_bool
  end. *)

Definition lpm_nbits_to_mask (w1 w2 : N) : list bool :=
(Zrepeat false (Z.of_N (w1 - w2))) ++ (Zrepeat true (Z.of_N w2)).

Definition values_match_lpm (key: Val) (val: Val) (lpm_num_bits: N): bool :=
  match assert_int key, assert_int val with
  | Some (w0, _, bits0), Some (w1, _, bits1) =>
    if negb ((w0 =? w1)%N && (lpm_num_bits <=? w1)%N) then dummy_bool
    else let bits2 := lpm_nbits_to_mask w1 lpm_num_bits in
     vmm_help bits0 bits1 bits2
  | _, _ => dummy_bool
  end. *)

Definition values_match_range_nondet (key: Sval) (lo hi: Val): option bool :=
  match assert_int_nondet key, assert_int lo, assert_int hi with
  | Some (w0, Some z0, _), Some (w1, z1, _), Some (w2, z2, _) =>
      if negb ((w0 =? w1)%N && (w1 =? w2)%N) then Some dummy_bool
      else Some ((z1 <=? z0) && (z0 <=? z2))
  | _, _, _ => None
  end.

Definition values_match_set_nondet (keys : list Sval) (valset : ValSetT) : option bool :=
  let values_match_set'' (key_valset: Sval * ValSetT) :=
    let (key, valset) := key_valset in
    match valset with
    | VSTSingleton v => values_match_singleton_nondet key v
    | VSTUniversal => Some true
    | VSTMask v1 v2 => None (* values_match_mask key v1 v2 *)
    | VSTRange lo hi => values_match_range_nondet key lo hi
    | VSTLpm w2 v1 => None (* values_match_lpm key v1 w2 *)
    | _ => Some dummy_bool
    end in
  let values_match_set' (keys: list Sval) (valset: ValSetT) :=
    match valset with
    | VSTProd l =>
        if negb (Nat.eqb (List.length l) (List.length keys)) then Some dummy_bool
        else option_map fold_andb (lift_option (List.map values_match_set'' (List.combine keys l)))
    | _ => values_match_set'' (List.hd ValBaseNull keys, valset)
    end in
  match valset with
  | VSTValueSet _ _ sets =>
      option_map fold_orb (lift_option (List.map (values_match_set' keys) sets))
  | _ => values_match_set' keys valset
  end.

Definition extern_matches_nondet (key: list (Sval * ident)) (entries: list table_entry_valset)
    : list (option bool * action_ref) :=
  let ks := List.map fst key in
  let mks := List.map snd key in
  match check_lpm_count mks with
  | None => []
  | Some lpm_idx =>
    let entries' := List.map (fun p => (valset_to_valsett (fst p), snd p)) entries in
    let entries'' :=
      if (Nat.ltb lpm_idx (List.length mks))
      then sort_lpm entries' lpm_idx
      else entries' in
    List.map (fun s => (values_match_set_nondet ks (fst s), snd s)) entries''
  end.

Lemma hoare_extern_match_list_nondet_intro : forall keys match_kinds entryvs,
  hoare_extern_match_list_nondet keys match_kinds entryvs
      (extern_matches_nondet (combine keys match_kinds) entryvs).
Proof.
  (* intros. induction entryvs.
  - red; intros.
    unfold extern_matches_nondet.
    simpl.
  unfold hoare_extern_match_list_nondet.
    simpl.
  unfold hoare_extern_match_list_nondet; intros.

  simpl. unfold extern_match.
  inductionn
  remember (extern_matches keys_match_kinds c) as cases.
  clear Heqcases.
  induction cases.
  - auto.
  - destruct a.
    destruct b; auto. *)
(* Qed. *)
Admitted.

Open Scope func_spec.

(* This is the general form of RegisterAction's apply method's spec that we support.
  We expecct this is general enough for all practical application. We don't support
  other kind of apply methods. *)
(* I don't define f as (Val -> Val) because this function should be partial. *)
Definition RegisterAction_apply_spec {A} (p : path) (repr : A -> Val) (f : A -> A) (retv : A -> Sval) : func_spec :=
  WITH,
    PATH p
    MOD None []
    WITH (old_value : A),
      PRE
        (ARG [eval_val_to_sval (repr old_value)]
        (MEM []
        (EXT [])))
      POST
        (ARG_RET [eval_val_to_sval (repr (f old_value));
                  retv old_value]
           ValBaseNull
        (MEM []
        (EXT []))).

Definition RegisterAction_apply_spec' {A} (p : path) (valid : A -> Prop) (repr : A -> Val) (f : A -> A) (retv : A -> Sval) : func_spec :=
  WITH,
    PATH p
    MOD None []
    WITH (old_value : A) (H_old_value : valid old_value),
      PRE
        (ARG [eval_val_to_sval (repr old_value)]
        (MEM []
        (EXT [])))
      POST
        (ARG_RET [eval_val_to_sval (repr (f old_value));
                  retv old_value]
           ValBaseNull
        (MEM []
        (EXT []))).

(* Remove the content type constaint of register, right? *)

Definition RegisterAction_execute_spec : func_spec :=
  WITH A p (* path *) index_w typ s (* size *) r (* reg *)
      (H_r : PathMap.get p (ge_ext ge) = Some (Tofino.EnvRegAction r))
      (H_ws : PathMap.get r (ge_ext ge) = Some (Tofino.EnvRegister (index_w, typ, s)))
      (H_s : 0 <= s <= Z.pow 2 (Z.of_N index_w))
      apply_fd repr apply_f apply_retv
      (H_apply_fd : PathMap.get (p ++ ["apply"]) (ge_ext ge) =
          Some (Tofino.EnvAbsMet (exec_abstract_method am_ge p apply_fd)))
      (H_apply_body : func_sound am_ge apply_fd nil
          (RegisterAction_apply_spec (A := A) p repr apply_f apply_retv)),
    PATH p
    MOD None [r]
    WITH (c : list Val) (i : Z)
      (H_c : Zlength c = s)
      (H_i : 0 <= i < s)
      old_v
      (H_old_v : Znth i c = repr old_v),
      PRE
        (ARG [P4Bit index_w i]
        (MEM []
        (EXT [ExtPred.singleton r (Tofino.ObjRegister c)])))
      POST
        (ARG_RET [] (apply_retv old_v)
        (MEM []
        (EXT [ExtPred.singleton r
            (Tofino.ObjRegister (upd_Znth i c (repr (apply_f old_v))))]))).

Definition RegisterAction_execute_spec' : func_spec :=
  WITH A p (* path *) index_w typ s (* size *) r (* reg *)
      (H_r : PathMap.get p (ge_ext ge) = Some (Tofino.EnvRegAction r))
      (H_ws : PathMap.get r (ge_ext ge) = Some (Tofino.EnvRegister (index_w, typ, s)))
      (H_s : 0 <= s <= Z.pow 2 (Z.of_N index_w))
      apply_fd apply_valid repr apply_f apply_retv
      (H_apply_fd : PathMap.get (p ++ ["apply"]) (ge_ext ge) =
          Some (Tofino.EnvAbsMet (exec_abstract_method am_ge p apply_fd)))
      (H_apply_body : func_sound am_ge apply_fd nil
          (RegisterAction_apply_spec' (A := A) p apply_valid repr apply_f apply_retv)),
    PATH p
    MOD None [r]
    WITH (c : list Val) (i : Z)
      (H_c : Zlength c = s)
      (H_i : 0 <= i < s)
      old_v
      (H_old_v : Znth i c = repr old_v)
      (H_valid : apply_valid old_v),
      PRE
        (ARG [P4Bit index_w i]
        (MEM []
        (EXT [ExtPred.singleton r (Tofino.ObjRegister c)])))
      POST
        (ARG_RET [] (apply_retv old_v)
        (MEM []
        (EXT [ExtPred.singleton r
            (Tofino.ObjRegister (upd_Znth i c (repr (apply_f old_v))))]))).

Definition execute_fundef : (@fundef tags_t) := FExternal "RegisterAction" "execute".

Lemma to_lbool_lbool_to_val' : forall bs w,
  w = Z.to_N (Zlength bs) ->
  P4Arith.to_lbool w
      (P4Arith.BitArith.lbool_to_val bs 1 0)
  = bs.
Proof.
  intros; subst.
  apply to_lbool_lbool_to_val.
Qed.

Lemma RegisterAction_execute_body' :
  func_sound ge execute_fundef nil RegisterAction_execute_spec'.
Proof.
  intros_fs_bind.
  split.
  2 : {
    unfold func_modifies. intros.
    inv H.
    inv H5. inv H.
    eapply eq_trans in H0; only 2 : (symmetry; apply H_r).
    symmetry in H0; inv H0.
    eapply eq_trans in H3; only 2 : (symmetry; apply H_ws).
    symmetry in H3; inv H3.
    eapply eq_trans in H1; only 2 : (symmetry; apply H_apply_fd).
    symmetry in H1; inv H1.
    destruct (-1 <? index) eqn:?.
    2 : {
      simpl in H8. destruct H8; subst.
      apply modifies_refl.
    }
    destruct (index <? s) eqn:?.
    2 : {
      simpl in H8. destruct H8; subst.
      apply modifies_refl.
    }
    simpl in H8. destruct H8; subst.
    eapply modifies_trans.
    { eapply modifies_incl.
      { assert (modifies None [] (m, es) (m, s')). {
          inv H7.
          eapply (proj2 H_apply_body) in H1.
          solve_modifies.
        }
        eassumption.
      }
      all : solve_modifies.
    }
    eapply modifies_set_ext with (st := (m, s')).
    simpl.
    replace (in_scope r r) with true. 2 : {
      clear; induction r.
      - auto.
      - simpl. rewrite eqb_refl; auto.
    }
    auto.
  }
  intros_fsh_bind.
  unfold fundef_satisfies_hoare.
  unfold hoare_func; intros.
  inv H0. inv H6.
  inv H0.
  eapply eq_trans in H1; only 2 : (symmetry; apply H_r).
  symmetry in H1; inv H1.
  eapply eq_trans in H4; only 2 : (symmetry; apply H_ws).
  symmetry in H4; inv H4.
  eapply eq_trans in H2; only 2 : (symmetry; apply H_apply_fd).
  symmetry in H2; inv H2.
  destruct H as [? []].
  destruct H1 as [? _].
  simpl in H1.
  rewrite H5 in H1. inv H1.
  assert (index = i). {
    clear -H_i H_s H H3 H6.
    unfold arg_denote, arg_satisfies in H.
    inv H. inv H5.
    inv H3. clear H7.
    assert (ValBaseBit indexb = (ValBaseBit (P4Arith.to_lbool index_w i))). {
      eapply exec_val_eq.
      eapply exec_val_sym with eq.
      { clear; auto. }
      assert (val_to_sval
          (ValBaseBit (P4Arith.to_lbool index_w i))
          (eval_val_to_sval (ValBaseBit (P4Arith.to_lbool index_w i)))). {
        eapply exec_val_sym with strict_read_ndetbit.
        2 : eapply sval_to_val_eval_val_to_sval.
        { clear; sauto. }
        { clear; sauto. }
      }
      eapply exec_val_trans with (f := read_detbit);
        [ | eapply exec_val_trans; [ | eassumption | eassumption] | eassumption ].
      { unfold rel_trans; clear; sauto. }
      { unfold rel_trans; clear; sauto. }
    }
    inv H.
    rewrite P4Arith.bit_from_to_bool in H6.
    inv H6.
    apply Z.mod_small.
    unfold P4Arith.BitArith.upper_bound.
    lia.
  }
  clear H H3 H6.
  subst.
  destruct (-1 <? i) eqn:Heqb; only 2 : lia. clear Heqb.
  destruct (i <? Zlength c) eqn:Heqb; only 2 : lia. clear Heqb.
  simpl in H7. destruct H9. subst.
  clear H0.
  assert (content' = c). {
    clear -H_apply_body H H5 H8.
    inv H8.
    apply (H_apply_body) in H1.
    destruct H1.
    assert (PathMap.get r s' = PathMap.get r es). {
      symmetry.
      apply H3.
      auto.
    }
    rewrite H4 in H.
    change (@extern_object tags_t Expression (@extern_sem tags_t Expression target))
      with (@Tofino.object tags_t Expression) in H.
    congruence.
  }
  clear H H5.
  subst.
  rewrite H_old_v in H8.
  assert (new_value = repr (apply_f old_v)
      /\ sval_to_val read_ndetbit (apply_retv old_v) retv). {
    clear -H_apply_body H_valid H8.
    inv H8.
    eapply (proj1 H_apply_body old_v) in H0.
    2 : { auto. }
    2 : {
      split.
      2 : { split; constructor. }
      inv H. inv H6.
      apply val_to_sval_iff in H4.
      subst.
      constructor; only 2 : constructor.
      apply sval_refine_refl.
    }
    clear H.
    destruct H0.
    inv H. inv H6. inv H7.
    inv H1. inv H8. inv H9.
    eapply sval_refine_sval_to_val_n_trans in H6. 2 : eapply H4. clear H4.
    eapply sval_refine_sval_to_val_n_trans in H5. 2 : eapply H3. clear H3.
    split.
    { eapply sval_to_val_n_eval_val_to_sval_eq; eauto. }
    { auto. }
  }
  clear H8.
  destruct H; subst.
  split.
  { inv H12. constructor. }
  clear H12.
  split.
  { unfold ret_denote, ret_satisfies.
    intros.
    eapply exec_val_trans; only 2, 3 : eassumption.
    clear; red; sauto.
  }
  split.
  { constructor. }
  { constructor.
    2 : constructor.
    simpl.
    rewrite PathMap.get_set_same.
    auto.
  }
Qed.

Lemma RegisterAction_execute_body :
  func_sound ge execute_fundef nil RegisterAction_execute_spec.
Proof.
  intros_fs_bind.
  assert (H_apply_body' : func_sound am_ge apply_fd []
      (RegisterAction_apply_spec' p (fun _ => True) repr apply_f apply_retv)). {
    refine_function H_apply_body.
    entailer.
    entailer.
  }
  split.
  2 : {
    unshelve eapply (proj2 (RegisterAction_execute_body' _ _ _ _ _ _ _ _ _ _ (fun _ => True) _ _ _ _ _));
      eauto.
  }
  intros_fsh_bind.
  eapply hoare_func_post.
  { eapply hoare_func_pre.
    2 : {
      unshelve eapply (proj1 (RegisterAction_execute_body' _ _ _ _ s _ _ _ _ _ (fun _ => True) _ _ _ _ _));
        eauto.
    }
    entailer.
  }
  entailer.
Qed.

Definition extend_hash_output_Z (hash_w : N) (output : list bool) : Z :=
  let output_w := N.of_nat (List.length output) in
  let num_copies := N.div hash_w output_w in
  let num_remainder := Z.of_N (N.modulo hash_w output_w) in
  let lsbs := repeat_concat_list (N.to_nat num_copies) output in
  let msbs := sublist (Z.of_N output_w - num_remainder) (Z.of_N output_w) output in
  BitArith.lbool_to_val (app msbs lsbs) 1 0.

Definition dummy_Z : Z.
Proof. exact 0. Qed.

Definition hash_Z (hash_w : N) (poly : CRC_polynomial) (v : Val) : Z :=
  match convert_to_bits v with
  | Some input =>
      extend_hash_output_Z hash_w (Hash.compute_crc (N.to_nat (CRCP_width poly)) (lbool_to_N (CRCP_coeff poly))
          (lbool_to_N (CRCP_init poly)) (lbool_to_N (CRCP_xor poly))
          (CRCP_reversed poly) (CRCP_reversed poly) input)
  | None =>
      dummy_Z
  end.

Definition Hash_get_fundef : (@fundef tags_t) := FExternal "Hash" "get".

Definition Hash_get_spec : func_spec :=
  WITH p (* path *) hash_w poly
      (H_p : PathMap.get p (ge_ext ge) = Some (EnvHash (hash_w, poly)))
      (H_width : (CRCP_width poly > 0)%N),
    PATH p
    MOD None []
    WITH (v : Val),
      PRE
        (ARG [eval_val_to_sval v]
        (MEM []
        (EXT [])))
      POST
        (ARG_RET [] (P4Bit hash_w (hash_Z hash_w poly v))
        (MEM []
        (EXT []))).

Lemma Zlength_repeat_concat_list : forall {A} num (l : list A),
  Zlength (repeat_concat_list num l) = Z.of_nat num * Zlength l.
Proof.
  intros. unfold repeat_concat_list.
  assert (forall l',
    Zlength
      ((fix repeat_concat_list' (num0 : nat) (l0 res : list A) {struct num0} : list A :=
          match num0 with
          | 0%nat => res
          | S num' => repeat_concat_list' num' l0 (l0 ++ res)
          end) num l l') = Z.of_nat num * Zlength l + Zlength l'). {
    induction num; intros.
    - list_solve.
    - rewrite IHnum.
      list_solve.
  }
  specialize (H []).
  list_solve.
Qed.

Lemma Hash_get_body targs :
  func_sound ge Hash_get_fundef targs Hash_get_spec.
Proof.
  intros_fs_bind.
  split.
  2 : {
    red. intros.
    inv H.
    inv H5. inv H.
    apply modifies_refl.
  }
  intros_fsh_bind.
  hnf; intros.
  inv H0. inv H6.
  inv H0.
  eapply eq_trans in H1; only 2 : (symmetry; apply H_p).
  symmetry in H1; inv H1.
  unfold hash_Z.
  destruct H as [? []].
  hnf in H. inv H. inv H8.
  inv H3. clear H9.
  assert (sval_to_val read_ndetbit (eval_val_to_sval v) v0). {
    eapply exec_val_trans. 2, 3 : eassumption.
    red; clear; sauto lq: on.
  }
  clear H7. rename H into H7.
  apply sval_to_val_eval_val_to_sval_iff in H7. 2 : {
    clear; sauto lq: on.
  }
  subst.
  rewrite H2. clear H2.
  split.
  { inv H12. constructor. }
  split.
  { apply eval_val_to_sval_ret_denote.
    unfold extend_hash_output_Z.
    unfold P4Bit.
    unfold to_loptbool.
    rewrite to_lbool_lbool_to_val'. 2 : {
      clear -H_width.
      assert (Datatypes.length
                 (Hash.compute_crc (N.to_nat (CRCP_width poly)) (lbool_to_N (CRCP_coeff poly))
                    (lbool_to_N (CRCP_init poly)) (lbool_to_N (CRCP_xor poly))
                    (CRCP_reversed poly) (CRCP_reversed poly) input) = N.to_nat (CRCP_width poly)). {
        apply Hash.length_compute_crc.
      }
      revert H.
      generalize (Hash.compute_crc (N.to_nat (CRCP_width poly)) (lbool_to_N (CRCP_coeff poly))
                    (lbool_to_N (CRCP_init poly)) (lbool_to_N (CRCP_xor poly))
                    (CRCP_reversed poly) (CRCP_reversed poly) input).
      intros.
      replace (N.of_nat (Datatypes.length b)) with (Z.to_N (Zlength b)). 2 : {
        rewrite Zlength_correct. lia.
      }
      assert (Zlength b > 0). {
        rewrite Zlength_correct. lia.
      }
      clear -H0.
      assert (0 <= Z.of_N (hash_w mod Z.to_N (Zlength b)) < (Zlength b)). {
        assert (0 <= hash_w mod Z.to_N (Zlength b) < Z.to_N (Zlength b))%N. {
          apply N.mod_bound_pos; lia.
        }
        lia.
      }
      list_simplify.
      rewrite Zlength_repeat_concat_list.
      replace (Z.of_N (Z.to_N (Zlength b))) with (Zlength b) by list_solve.
      replace (Z.of_nat (N.to_nat (hash_w / Z.to_N (Zlength b))) * Zlength b) with
        (Z.of_N (hash_w / Z.to_N (Zlength b) * Z.to_N (Zlength b))) by lia.
      pose proof (N.div_mod hash_w (Z.to_N (Zlength b))).
      lia.
    }
    reflexivity.
  }
  repeat constructor.
Qed.

(* Lemmas for table matching simplifcation. *)

Lemma reduce_match_range: forall w x lo hi x' lo' hi' xb lob hib,
  Tofino.assert_int x = Some (w, x', xb) ->
  Tofino.assert_int lo = Some (w, lo', lob) ->
  Tofino.assert_int hi = Some (w, hi', hib) ->
  Tofino.values_match_range x lo hi = (lo' <=? x') && (x' <=? hi').
Proof.
  intros.
  unfold Tofino.values_match_range.
  rewrite H, H0, H1. rewrite N.eqb_refl. simpl.
  reflexivity.
Qed.

Lemma reduce_match_singleton: forall w x y x' y' xb yb,
  val_sim x y ->
  Tofino.assert_int x = Some (w, x', xb) ->
  Tofino.assert_int y = Some (w, y', yb) ->
  Tofino.values_match_singleton x y = (x' =? y').
Proof.
  intros. revert y H H1.
  induction x;
  induction y; intros;
  simpl in H0; simpl in H1; unfold val_sim in H; try discriminate; try inv H.
  { unfold Tofino.values_match_singleton, Ops.eval_binary_op_eq.
    remember (P4Arith.BitArith.from_lbool value0) as n0_name. inv H1.
    remember (P4Arith.BitArith.from_lbool value) as n_name. inv H0.
    rewrite N.eqb_refl. trivial. }
  { unfold Tofino.values_match_singleton, Ops.eval_binary_op_eq.
    remember (P4Arith.IntArith.from_lbool value0) as z0_name. inv H1.
    remember (P4Arith.IntArith.from_lbool value) as z_name. inv H0.
    rewrite N.eqb_refl. trivial. }
  unfold Tofino.values_match_singleton in IHx |- *. simpl in IHx |- *. rewrite String.eqb_refl.
  eapply IHx; assumption.
Qed.

Lemma assert_int_len : forall x w x' xb,
  Tofino.assert_int x = Some (w, x', xb) -> Z.to_N (Zlength xb) = w.
Proof.
  induction x; intros; simpl in H; try discriminate.
  - unfold P4Arith.BitArith.from_lbool in H; inv H; trivial.
  - unfold P4Arith.IntArith.from_lbool in H; inv H; trivial.
  - eapply IHx; eauto.
Qed.

(* This lemma is unused. *)
Lemma to_lbool''_to_lbool : forall (width : N) (value : Z),
  rev (to_lbool'' (N.to_nat width) value) = P4Arith.to_lbool width value.
Proof.
  intros.
  apply to_lbool''_to_lbool'.
Qed.

(* This lemma is unused. *)
Lemma bit_to_from_bool : forall bl,
  P4Arith.to_lbool (fst (P4Arith.BitArith.from_lbool bl)) (snd (P4Arith.BitArith.from_lbool bl)) = bl.
Proof.
  intros.
  rewrite <- to_lbool''_to_lbool.
  unfold BitArith.from_lbool, BitArith.lbool_to_val. simpl.
  rewrite <- Zlength_rev. rewrite <- (rev_involutive bl) at 3. f_equal.
  generalize (rev bl). clear bl. intro bl.
  induction bl; auto.
  simpl.
  replace (N.to_nat (Z.to_N (Zlength (a :: bl)))) with (S (N.to_nat (Z.to_N (Zlength bl)))) by list_solve.
  simpl to_lbool''.
  destruct a; rewrite P4Arith.BitArith.le_lbool_to_val_1_0.
  - f_equal.
    { replace (P4Arith.BitArith.le_lbool_to_val bl 1 0 * 2 + 1) with
        (1 + 2 * P4Arith.BitArith.le_lbool_to_val bl 1 0) by lia.
      rewrite Z.odd_add_mul_2; auto.
    }
    rewrite Z.div_add_l by lia.
    replace (1 / 2) with 0 by auto.
    rewrite Z.add_0_r.
    apply IHbl.
  - f_equal.
    { replace (P4Arith.BitArith.le_lbool_to_val bl 1 0 * 2 + 0) with
        (0 + 2 * P4Arith.BitArith.le_lbool_to_val bl 1 0) by lia.
      rewrite Z.odd_add_mul_2; auto.
    }
    rewrite Z.div_add_l by lia.
    replace (0 / 2) with 0 by auto.
    rewrite Z.add_0_r.
    apply IHbl.
Qed.

(* This lemma is unused. *)
Lemma int_to_from_bool : forall bl,
  P4Arith.to_lbool (fst (P4Arith.IntArith.from_lbool bl)) (snd (P4Arith.IntArith.from_lbool bl)) = bl.
Proof.
  intros.
  rewrite <- to_lbool''_to_lbool.
  unfold IntArith.from_lbool, IntArith.lbool_to_val. simpl.
  rewrite <- Zlength_rev. rewrite <- (rev_involutive bl) at 3. f_equal.
  generalize (rev bl). clear bl. intro bl.
  induction bl; auto.
  simpl.
  replace (N.to_nat (Z.to_N (Zlength (a :: bl)))) with (S (N.to_nat (Z.to_N (Zlength bl)))) by list_solve.
  simpl to_lbool''.
  destruct a; rewrite P4Arith.IntArith.le_lbool_to_val_1_0.
  - f_equal.
    { destruct bl as [ | b bl']; auto.
      set (bl := b :: bl') in *.
      replace (P4Arith.IntArith.le_lbool_to_val bl 1 0 * 2 + 1) with
        (1 + 2 * P4Arith.IntArith.le_lbool_to_val bl 1 0) by lia.
      rewrite Z.odd_add_mul_2; auto.
    }
    destruct bl as [ | b bl']; auto.
    set (bl := b :: bl') in *.
    rewrite Z.div_add_l by lia.
    replace (1 / 2) with 0 by auto.
    rewrite Z.add_0_r.
    apply IHbl.
  - f_equal.
    { destruct bl as [ | b bl']; auto.
      set (bl := b :: bl') in *.
      replace (P4Arith.IntArith.le_lbool_to_val bl 1 0 * 2 + 0) with
        (0 + 2 * P4Arith.IntArith.le_lbool_to_val bl 1 0) by lia.
      rewrite Z.odd_add_mul_2; auto.
    }
    destruct bl as [ | b bl']; auto.
    set (bl := b :: bl') in *.
    rewrite Z.div_add_l by lia.
    replace (0 / 2) with 0 by auto.
    rewrite Z.add_0_r.
    apply IHbl.
Qed.

(* This lemma is unused. *)
Lemma assert_int_conv : forall w x x' xb,
  Tofino.assert_int x = Some (w, x', xb) ->
  P4Arith.to_lbool w x' = xb.
Proof.
  induction x; intros; simpl in H; try discriminate; inv H.
  - apply bit_to_from_bool.
  - apply int_to_from_bool.
  - auto.
Qed.

Lemma reduce_match_mask: forall w x v m x' v' m' xb vb mb,
  Tofino.assert_int x = Some (w, x', xb) ->
  Tofino.assert_int v = Some (w, v', vb) ->
  Tofino.assert_int m = Some (w, m', mb) ->
  Tofino.values_match_mask x v m = Tofino.vmm_help xb vb mb.
Proof.
  intros.
  unfold Tofino.values_match_mask; rewrite H, H0, H1; rewrite N.eqb_refl; simpl.
  auto.
Qed.

End TofinoSpec.

#[export] Hint Extern 5 (func_modifies _ _ _ _ _) =>
  (refine (proj2 (Hash_get_body _ _ _ _ _ _ _)); try exact (@nil _); compute; reflexivity) : func_specs.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(* begin hide *)

Require Export CoRN.ftc.COrdLemmas.
Require Export CoRN.ftc.Partitions.

Section Separating__Separated.

Variables a b : IR.
Hypothesis Hab : a[<=]b.
Let I := compact a b Hab.

Variable F : PartIR.
Hypothesis contF : Continuous_I Hab F.
Hypothesis incF : included (Compact Hab) (Dom F).

Hypothesis Hab' : a[<]b.
Variables m n : nat.
Variable P : Partition Hab n.
Variable R : Partition Hab m.

Hypothesis HP : _Separated P.
Hypothesis HR : _Separated R.

Lemma RS_pos_n : 0 < n.
Proof.
 apply partition_less_imp_gt_zero with a b Hab; assumption.
Qed.

Lemma RS_pos_m : 0 < m.
Proof.
 apply partition_less_imp_gt_zero with a b Hab; assumption.
Qed.

Variable alpha : IR.
Hypothesis Halpha : [0][<]alpha.

Let e := alpha [/]TwoNZ[/] _[//]max_one_ap_zero (b[-]a).

Lemma RS_He : [0][<]e.
Proof.
 unfold e in |- *; apply div_resp_pos.
  apply pos_max_one.
 apply pos_div_two; assumption.
Qed.

Let contF' := contin_prop _ _ _ _ contF.

Let d : IR.
Proof.
 elim (contF' e RS_He).
 intros; apply x.
Defined.

Lemma RS_Hd : [0][<]d.
Proof.
 unfold d in |- *; elim (contF' e RS_He); auto.
Qed.

Lemma RS_Hd' :
  forall x y : IR,
  I x ->
  I y -> forall Hx Hy, AbsIR (x[-]y)[<=]d -> AbsIR (F x Hx[-]F y Hy)[<=]e.
Proof.
 unfold d in |- *; elim (contF' e RS_He); auto.
Qed.

Variable csi : IR.
Hypothesis Hcsi : [0][<]csi.

Let M := Norm_Funct contF.

Let deltaP := AntiMesh P.
Let deltaR := AntiMesh R.
Let delta :=
  Min (Min deltaP deltaR)
    (Min (alpha [/]TwoNZ[/] _[//]max_one_ap_zero (nring n[*]M)) (Min csi d)).

Lemma RS_delta_deltaP : delta[<=]deltaP.
Proof.
 unfold delta in |- *; eapply leEq_transitive.
  apply Min_leEq_lft.
 apply Min_leEq_lft.
Qed.

Lemma RS_delta_deltaR : delta[<=]deltaR.
Proof.
 unfold delta in |- *; eapply leEq_transitive.
  apply Min_leEq_lft.
 apply Min_leEq_rht.
Qed.

Lemma RS_delta_csi : delta[<=]csi.
Proof.
 unfold delta in |- *; eapply leEq_transitive.
  apply Min_leEq_rht.
 eapply leEq_transitive.
  apply Min_leEq_rht.
 apply Min_leEq_lft.
Qed.

Lemma RS_delta_d : delta[<=]d.
Proof.
 unfold delta in |- *; eapply leEq_transitive.
  apply Min_leEq_rht.
 eapply leEq_transitive; apply Min_leEq_rht.
Qed.

Lemma RS_delta_pos : [0][<]delta.
Proof.
 unfold delta in |- *; apply less_Min; apply less_Min.
    unfold deltaP in |- *; apply pos_AntiMesh; [ apply RS_pos_n | assumption ].
   unfold deltaR in |- *; apply pos_AntiMesh; [ apply RS_pos_m | assumption ].
  apply div_resp_pos.
   apply pos_max_one.
  apply pos_div_two; assumption.
 apply less_Min.
  assumption.
 apply RS_Hd.
Qed.

Section Defining_ai'.

Variable i : nat.
Hypothesis Hi : i <= n.

Lemma separation_conseq :
  forall (j : nat) (Hj : j <= m),
  AbsIR (P i Hi[-]R j Hj)[<]delta [/]TwoNZ ->
  forall j' : nat,
  j <> j' -> forall Hj' : j' <= m, delta [/]TwoNZ[<]AbsIR (P i Hi[-]R j' Hj').
Proof.
 intros j Hj H; intros.
 elim (Cnat_total_order _ _ H0); clear H0; intro H0.
  elim (le_lt_dec j' m); intro.
   cut (S j <= m); [ intro | clear H; apply le_trans with j'; auto ].
   eapply less_wdr.
    2: apply AbsIR_minus.
   cut (R (S j) H1[<=]R j' Hj'); intros.
    eapply less_wdr.
     2: apply eq_symmetric_unfolded; apply AbsIR_eq_x.
     rstepr (R _ Hj'[-]R _ H1[+](R _ H1[-]R _ Hj)[+](R _ Hj[-]P i Hi)).
     rstepl ([0][+]delta[+][--](delta [/]TwoNZ)).
     apply plus_resp_leEq_less.
      apply plus_resp_leEq_both.
       apply shift_leEq_minus; astepl (R _ H1).
       assumption.
      apply leEq_transitive with deltaR.
       apply RS_delta_deltaR.
      unfold deltaR in |- *; apply AntiMesh_lemma.
     rstepl ([--](delta [/]TwoNZ)).
     rstepr ([--](P i Hi[-]R j Hj)).
     apply inv_resp_less.
     eapply leEq_less_trans.
      apply leEq_AbsIR.
     assumption.
    apply shift_leEq_minus; astepl (P i Hi).
    eapply leEq_transitive.
     2: apply H2.
    apply less_leEq; apply less_transitive_unfolded with (R j Hj[+]delta [/]TwoNZ).
     apply shift_less_plus'.
     eapply leEq_less_trans; [ apply leEq_AbsIR | apply H ].
    apply shift_plus_less'.
    apply less_leEq_trans with delta.
     apply pos_div_two'; exact RS_delta_pos.
    apply leEq_transitive with deltaR.
     apply RS_delta_deltaR.
    unfold deltaR in |- *; apply AntiMesh_lemma.
   apply local_mon_imp_mon'_le with (f := fun (i : nat) (Hi : i <= m) => R i Hi).
     intros; apply HR.
    red in |- *; intros; apply prf1; auto.
   assumption.
  exfalso; apply (le_not_lt j' m); auto.
 elim (le_lt_dec j 0); intro.
  exfalso; apply lt_n_O with j'; red in |- *; apply le_trans with j; auto.
 generalize Hj H H0; clear H0 H Hj.
 set (jj := pred j) in *.
 cut (j = S jj); [ intro | unfold jj in |- *; apply S_pred with 0; auto ].
 rewrite H; intros.
 cut (jj <= m); [ intro | auto with arith ].
 cut (R j' Hj'[<=]R jj H2); intros.
  eapply less_wdr.
   2: apply eq_symmetric_unfolded; apply AbsIR_eq_x.
   rstepr (P i Hi[-]R _ Hj[+](R _ Hj[-]R jj H2)[+](R jj H2[-]R j' Hj')).
   rstepl ([--](delta [/]TwoNZ)[+]delta[+][0]).
   apply plus_resp_less_leEq.
    apply plus_resp_less_leEq.
     eapply less_wdr.
      2: apply cg_inv_inv.
     apply inv_resp_less; eapply leEq_less_trans.
      2: apply H0.
     apply inv_leEq_AbsIR.
    eapply leEq_transitive.
     apply RS_delta_deltaR.
    unfold deltaR in |- *; apply AntiMesh_lemma.
   apply shift_leEq_minus; eapply leEq_wdl.
    apply H3.
   algebra.
  apply shift_leEq_minus; astepl (R j' Hj').
  eapply leEq_transitive.
   apply H3.
  apply less_leEq; apply less_transitive_unfolded with (R _ Hj[-]delta [/]TwoNZ).
   apply shift_less_minus; apply shift_plus_less'.
   apply less_leEq_trans with delta.
    apply pos_div_two'; exact RS_delta_pos.
   eapply leEq_transitive.
    apply RS_delta_deltaR.
   unfold deltaR in |- *; apply AntiMesh_lemma.
  apply shift_minus_less; apply shift_less_plus'.
  eapply leEq_less_trans.
   2: apply H0.
  eapply leEq_wdr.
   2: apply AbsIR_minus.
  apply leEq_AbsIR.
 apply local_mon_imp_mon'_le with (f := fun (i : nat) (Hi : i <= m) => R i Hi).
   intros; apply HR.
  red in |- *; intros; apply prf1; auto.
 auto with arith.
Qed.

Let pred1 (j : nat) (Hj : j <= m) :=
  forall Hi' : i <= n, AbsIR (P i Hi'[-]R j Hj)[<]delta [/]TwoNZ.
Let pred2 (j : nat) (Hj : j <= m) :=
  forall Hi' : i <= n, delta [/]FourNZ[<]AbsIR (P i Hi'[-]R j Hj).

Lemma sep__sep_aux_lemma :
 {j : nat | {Hj : j <= m | pred1 j Hj}}
 or (forall (j : nat) (Hj : j <= m), pred2 j Hj).
Proof.
 apply finite_or_elim.
   red in |- *; unfold pred1 in |- *; do 3 intro.
   rewrite H; intros H0 H' H1 Hi'.
   eapply less_wdl.
    apply H1 with (Hi' := Hi').
   apply AbsIR_wd; apply cg_minus_wd; apply prf1; auto.
  red in |- *; unfold pred2 in |- *; intros. rename X into H1.
  eapply less_wdr.
   apply H1 with (Hi' := Hi').
  apply AbsIR_wd; apply cg_minus_wd; apply prf1; auto.
 intros j Hj.
 cut (pred2 j Hj or pred1 j Hj).
  intro H; inversion_clear H; [ right | left ]; assumption.
 unfold pred1, pred2 in |- *.
 cut (forall Hi' : i <= n, delta [/]FourNZ[<]AbsIR (P i Hi'[-]R j Hj)
   or AbsIR (P i Hi'[-]R j Hj)[<]delta [/]TwoNZ). intro H.
  elim (le_lt_dec i n); intro.
   elim (H a0); intro.
    left; intro.
    eapply less_wdr.
     apply a1.
    apply AbsIR_wd; apply cg_minus_wd; apply prf1; auto.
   right; intro.
   eapply less_wdl.
    apply b0.
   apply AbsIR_wd; apply cg_minus_wd; apply prf1; auto.
  left; intro.
  exfalso; apply le_not_lt with i n; auto.
 intros.
 apply less_cotransitive_unfolded.
 rstepl ((delta [/]TwoNZ) [/]TwoNZ).
 apply pos_div_two'; apply pos_div_two; apply RS_delta_pos.
Qed.

Hypothesis Hi0 : 0 < i.
Hypothesis Hin : i < n.

Definition sep__sep_fun_i : IR.
Proof.
 elim sep__sep_aux_lemma; intros.
  2: apply (P i Hi).
 apply (P i Hi[+]delta [/]TwoNZ).
Defined.

Lemma sep__sep_leEq : forall Hi' : i <= n, P i Hi'[<=]sep__sep_fun_i.
Proof.
 unfold sep__sep_fun_i in |- *.
 elim sep__sep_aux_lemma; intros; simpl in |- *.
  2: apply eq_imp_leEq; apply prf1; auto.
 apply leEq_wdl with (P i Hi).
  2: apply prf1; auto.
 apply shift_leEq_plus'; astepl ZeroR.
 astepr (delta [/]TwoNZ).
 apply less_leEq; apply pos_div_two; exact RS_delta_pos.
Qed.

Lemma sep__sep_less : forall Hi' : S i <= n, sep__sep_fun_i[<]P (S i) Hi'.
Proof.
 unfold sep__sep_fun_i in |- *.
 elim sep__sep_aux_lemma; intros; simpl in |- *.
  2: apply HP.
 apply shift_plus_less'.
 apply less_leEq_trans with delta.
  astepl (delta [/]TwoNZ).
  apply pos_div_two'; exact RS_delta_pos.
 apply leEq_transitive with deltaP.
  apply RS_delta_deltaP.
 unfold deltaP in |- *; apply AntiMesh_lemma.
Qed.

Lemma sep__sep_ap : forall (j : nat) (Hj : j <= m), sep__sep_fun_i[#]R j Hj.
Proof.
 intros.
 unfold sep__sep_fun_i in |- *; elim sep__sep_aux_lemma; intro; simpl in |- *.
  2: apply zero_minus_apart; apply AbsIR_cancel_ap_zero; apply Greater_imp_ap.
  elim a0; intros j' H.
  elim H; clear a0 H; intros Hj' H.
  unfold pred1 in H.
  rstepr (P i Hi[+](R j Hj[-]P i Hi)).
  apply op_lft_resp_ap.
  apply un_op_strext_unfolded with AbsIR.
  apply ap_wdl_unfolded with (delta [/]TwoNZ).
   2: apply eq_symmetric_unfolded; apply AbsIR_eq_x.
   2: apply less_leEq; apply pos_div_two; exact RS_delta_pos.
  eapply ap_wdr_unfolded.
   2: apply AbsIR_minus.
  elim (le_lt_dec j j'); intro.
   elim (le_lt_eq_dec _ _ a0); clear a0; intro.
    apply less_imp_ap; apply separation_conseq with j' Hj'.
     apply H.
    intro; rewrite H0 in a0; apply (lt_irrefl _ a0).
   apply Greater_imp_ap.
   eapply less_wdl.
    apply H with (Hi' := Hi).
   apply AbsIR_wd.
   apply cg_minus_wd.
    algebra.
   apply prf1; auto.
  apply less_imp_ap; apply separation_conseq with j' Hj'.
   apply H.
  intro; rewrite H0 in b0; apply (lt_irrefl _ b0).
 unfold pred2 in b0.
 eapply less_transitive_unfolded.
  2: apply b0.
 apply pos_div_four; exact RS_delta_pos.
Qed.

End Defining_ai'.

Definition sep__sep_fun : forall i : nat, i <= n -> IR.
Proof.
 intros.
 elim (le_lt_dec i 0); intro.
  apply a.
 elim (le_lt_eq_dec _ _ H); intro.
  apply (sep__sep_fun_i i H).
 apply b.
Defined.

Lemma sep__sep_fun_i_delta :
 forall (i : nat) (Hi Hi' : i <= n) (Hi0 : i < n),
 AbsIR (sep__sep_fun_i i Hi[-]P i Hi')[<=]delta [/]TwoNZ.
Proof.
 intros.
 unfold sep__sep_fun_i in |- *.
 elim (sep__sep_aux_lemma i); intro; simpl in |- *.
  apply eq_imp_leEq.
  eapply eq_transitive_unfolded.
   2: apply AbsIR_eq_x.
   apply AbsIR_wd.
   rstepr (P i Hi'[+]delta [/]TwoNZ[-]P i Hi').
   apply cg_minus_wd.
    apply bin_op_wd_unfolded.
     apply prf1; auto.
    algebra.
   algebra.
  astepr (delta [/]TwoNZ); apply less_leEq; apply pos_div_two; exact RS_delta_pos.
 apply leEq_wdl with ZeroR.
  astepr (delta [/]TwoNZ); apply less_leEq; apply pos_div_two; exact RS_delta_pos.
 eapply eq_transitive_unfolded.
  apply eq_symmetric_unfolded; apply AbsIRz_isz.
 apply AbsIR_wd.
 astepl (P i Hi[-]P i Hi).
 apply cg_minus_wd; apply prf1; auto.
Qed.

Lemma sep__sep_fun_delta :
 forall (i : nat) (Hi Hi' : i <= n),
 AbsIR (sep__sep_fun i Hi[-]P i Hi')[<=]delta [/]TwoNZ.
Proof.
 intros.
 unfold sep__sep_fun in |- *.
 elim (le_lt_dec i 0); intro; simpl in |- *.
  cut (i = 0); [ intro | auto with arith ].
  generalize Hi'; rewrite H; intros.
  apply leEq_wdl with ZeroR.
   astepr (delta [/]TwoNZ); apply less_leEq; apply pos_div_two; exact RS_delta_pos.
  eapply eq_transitive_unfolded.
   apply eq_symmetric_unfolded; apply AbsIRz_isz.
  apply AbsIR_wd.
  astepl (a[-]a).
  apply cg_minus_wd; [ algebra | apply eq_symmetric_unfolded; apply start ].
 elim (le_lt_eq_dec _ _ Hi); intro; simpl in |- *.
  apply sep__sep_fun_i_delta; assumption.
 generalize Hi'; rewrite b1; intros.
 apply leEq_wdl with ZeroR.
  astepr (delta [/]TwoNZ); apply less_leEq; apply pos_div_two; exact RS_delta_pos.
 eapply eq_transitive_unfolded.
  apply eq_symmetric_unfolded; apply AbsIRz_isz.
 apply AbsIR_wd.
 astepl (b[-]b).
 apply cg_minus_wd; [ algebra | apply eq_symmetric_unfolded; apply finish ].
Qed.

Lemma sep__sep_mon_i :
 forall (i : nat) (Hi : i <= n) (Hi' : S i <= n) (Hi0 : i < n),
 sep__sep_fun_i i Hi[<]sep__sep_fun_i (S i) Hi'.
Proof.
 intros.
 apply less_leEq_trans with (P (S i) Hi0).
  apply sep__sep_less.
 apply sep__sep_leEq.
Qed.

Lemma sep__sep_mon :
 forall (i : nat) (Hi : i <= n) (Hi' : S i <= n),
 sep__sep_fun i Hi[<]sep__sep_fun (S i) Hi'.
Proof.
 intros.
 unfold sep__sep_fun in |- *.
 elim (le_lt_dec (S i) 0); intro; simpl in |- *.
  exfalso; apply (le_Sn_O _ a0).
 elim (le_lt_dec i 0); intro; simpl in |- *.
  elim (le_lt_eq_dec _ _ Hi'); intro; simpl in |- *.
   apply less_leEq_trans with (P (S i) Hi').
    apply leEq_less_trans with (P i Hi).
     elim (Partition_in_compact _ _ _ _ P i Hi); intros; auto.
    apply HP.
   apply sep__sep_leEq.
  assumption.
 elim (le_lt_eq_dec _ _ Hi); intro; simpl in |- *.
  elim (le_lt_eq_dec _ _ Hi'); intro; simpl in |- *.
   apply sep__sep_mon_i; assumption.
  eapply less_wdr.
   2: apply finish with (p := P) (H := le_n n).
  eapply less_wdr.
   apply sep__sep_less with (Hi' := Hi').
  generalize Hi'; rewrite b2.
  intro; apply prf1; auto.
 exfalso; rewrite b2 in Hi'; apply (le_Sn_n _ Hi').
Qed.

Lemma sep__sep_fun_i_wd :
 forall i j : nat,
 i = j ->
 forall (Hi : i <= n) (Hj : j <= n),
 sep__sep_fun_i i Hi[=]sep__sep_fun_i j Hj.
Proof.
 do 3 intro.
 rewrite <- H.
 intros.
 unfold sep__sep_fun_i in |- *.
 elim (sep__sep_aux_lemma i); intros; simpl in |- *.
  apply bin_op_wd_unfolded; [ apply prf1; auto | algebra ].
 apply prf1; auto.
Qed.

Lemma sep__sep_fun_wd :
 forall i j : nat,
 i = j ->
 forall (Hi : i <= n) (Hj : j <= n), sep__sep_fun i Hi[=]sep__sep_fun j Hj.
Proof.
 intros.
 unfold sep__sep_fun in |- *.
 elim (le_lt_dec i 0); elim (le_lt_dec j 0); intros; simpl in |- *.
    algebra.
   exfalso; apply (lt_irrefl 0); apply lt_le_trans with j; auto; rewrite <- H; auto.
  exfalso; apply (lt_irrefl 0); apply lt_le_trans with j; auto; rewrite <- H; auto.
 elim (le_lt_eq_dec _ _ Hi); elim (le_lt_eq_dec _ _ Hj); intros; simpl in |- *.
    apply sep__sep_fun_i_wd; auto.
   exfalso; rewrite H in a0; rewrite b2 in a0; apply (lt_irrefl _ a0).
  exfalso; rewrite <- H in a0; rewrite b2 in a0; apply (lt_irrefl _ a0).
 algebra.
Qed.

Definition sep__sep_part : Partition Hab n.
Proof.
 apply Build_Partition with sep__sep_fun.
    exact sep__sep_fun_wd.
   intros; apply less_leEq; apply sep__sep_mon.
  intros; unfold sep__sep_fun in |- *.
  elim (le_lt_dec 0 0); intro; simpl in |- *.
   algebra.
  exfalso; inversion b0.
 intros; unfold sep__sep_fun in |- *.
 elim (le_lt_dec n 0); intro; simpl in |- *.
  apply partition_length_zero with Hab.
  cut (n = 0); [ intro | auto with arith ].
  rewrite <- H0; apply P.
 elim (le_lt_eq_dec _ _ H); intro; simpl in |- *.
  exfalso; apply (lt_irrefl _ a0).
 algebra.
Defined.

Lemma sep__sep_lemma : Separated sep__sep_part R.
Proof.
 repeat split; unfold _Separated in |- *; intros.
   apply sep__sep_mon.
  apply HR.
 unfold sep__sep_part in |- *; simpl in |- *.
 unfold sep__sep_fun in |- *; simpl in |- *.
 elim (le_lt_dec i 0); intro; simpl in |- *.
  exfalso; apply lt_irrefl with 0; apply lt_le_trans with i; auto.
 elim (le_lt_eq_dec _ _ Hi); intro; simpl in |- *.
  apply sep__sep_ap.
 exfalso; rewrite b1 in H1; apply (lt_irrefl _ H1).
Qed.

Variable g : forall i : nat, i < n -> IR.
Hypothesis gP : Points_in_Partition P g.

Definition sep__sep_points (i : nat) (Hi : i < n) : IR.
Proof.
 intros.
 apply (Max (sep__sep_fun_i i (lt_le_weak _ _ Hi)) (g i Hi)).
Defined.

Lemma sep__sep_points_lemma :
 Points_in_Partition sep__sep_part sep__sep_points.
Proof.
 red in |- *; intros.
 split.
  unfold sep__sep_part in |- *; simpl in |- *.
  unfold sep__sep_fun, sep__sep_points in |- *.
  elim (le_lt_dec i 0); intro; simpl in |- *.
   apply leEq_transitive with (g i Hi).
    elim (Pts_part_lemma _ _ _ _ _ _ gP i Hi); intros; assumption.
   apply rht_leEq_Max.
  elim (le_lt_eq_dec _ _ (lt_le_weak _ _ Hi)); intro; simpl in |- *.
   eapply leEq_wdl.
    apply lft_leEq_Max.
   apply sep__sep_fun_i_wd; auto.
  exfalso; rewrite b1 in Hi; apply (lt_irrefl _ Hi).
 unfold sep__sep_part in |- *; simpl in |- *.
 unfold sep__sep_fun, sep__sep_points in |- *.
 elim (le_lt_dec (S i) 0); intro; simpl in |- *.
  exfalso; inversion a0.
 elim (le_lt_eq_dec _ _ Hi); intro; simpl in |- *.
  apply Max_leEq.
   apply less_leEq; apply sep__sep_mon_i; assumption.
  apply leEq_transitive with (P (S i) Hi).
   elim (gP i Hi); intros; auto.
  apply sep__sep_leEq.
 apply Max_leEq.
  unfold sep__sep_fun_i in |- *.
  elim (sep__sep_aux_lemma i); intro; simpl in |- *.
   apply leEq_transitive with (P (S i) Hi).
    apply shift_plus_leEq'.
    apply leEq_transitive with delta.
     astepl (delta [/]TwoNZ); apply less_leEq; apply pos_div_two'; exact RS_delta_pos.
    apply leEq_transitive with deltaP.
     apply RS_delta_deltaP.
    unfold deltaP in |- *; apply AntiMesh_lemma.
   elim (Partition_in_compact _ _ _ _ P (S i) Hi); intros; assumption.
  elim (Partition_in_compact _ _ _ _ P i (lt_le_weak _ _ Hi)); intros; assumption.
 elim (Pts_part_lemma _ _ _ _ _ _ gP i Hi); intros; assumption.
Qed.

Lemma sep__sep_aux :
  forall (i : nat) (H : i < n) Hg Hs,
  AbsIR (F (g i H) Hg[-]F (sep__sep_points i H) Hs)[<=]e.
Proof.
 intros.
 apply RS_Hd'.
   unfold I in |- *; apply Pts_part_lemma with n P; assumption.
  unfold I in |- *; apply Pts_part_lemma with n sep__sep_part; apply sep__sep_points_lemma.
 unfold sep__sep_points in |- *; simpl in |- *.
 eapply leEq_wdl.
  2: apply AbsIR_minus.
 eapply leEq_wdl.
  2: apply eq_symmetric_unfolded; apply AbsIR_eq_x.
  apply shift_minus_leEq; apply Max_leEq.
   unfold sep__sep_fun_i in |- *.
   elim sep__sep_aux_lemma; intro; simpl in |- *.
    apply leEq_transitive with (P i (lt_le_weak _ _ H)[+]delta).
     apply plus_resp_leEq_lft.
     apply less_leEq; astepl (delta [/]TwoNZ); apply pos_div_two'; exact RS_delta_pos.
    eapply leEq_wdr.
     2: apply cag_commutes_unfolded.
    apply plus_resp_leEq_both.
     elim (gP i H); intros; assumption.
    apply RS_delta_d.
   astepl ([0][+]P i (lt_le_weak _ _ H)).
   apply plus_resp_leEq_both.
    apply less_leEq; exact RS_Hd.
   elim (gP i H); intros; auto.
  apply shift_leEq_plus; astepl ZeroR; apply less_leEq; exact RS_Hd.
 apply shift_leEq_minus.
 eapply leEq_wdl.
  apply rht_leEq_Max.
 algebra.
Qed.

Notation just1 := (incF _ (Pts_part_lemma _ _ _ _ _ _ gP _ _)).
Notation just2 :=
  (incF _ (Pts_part_lemma _ _ _ _ _ _ sep__sep_points_lemma _ _)).

Lemma sep__sep_Sum :
 AbsIR (Partition_Sum gP incF[-]Partition_Sum sep__sep_points_lemma incF)[<=]
 alpha.
Proof.
 unfold Partition_Sum in |- *; simpl in |- *.
 rstepr (alpha [/]TwoNZ[+]alpha [/]TwoNZ).
 apply leEq_transitive with (e[*](b[-]a)[+]nring n[*]M[*]delta).
  apply leEq_wdr with (e[*] Sumx (fun (i : nat) (Hi : i < n) => P _ Hi[-]P _ (lt_le_weak _ _ Hi))[+]
    Sumx (fun (i : nat) (Hi : i < n) => M[*]delta)).
   apply leEq_transitive with (Sumx (fun (i : nat) (Hi : i < n) =>
     AbsIR (F (g i Hi) just1[-]F (sep__sep_points i Hi) just2)[*] (P _ Hi[-]P _ (lt_le_weak _ _ Hi)))[+]
       Sumx (fun (i : nat) (Hi : i < n) => AbsIR (F (sep__sep_points i Hi) just2)[*]
         (AbsIR (sep__sep_fun _ Hi[-]P _ Hi)[+]
           AbsIR (P _ (lt_le_weak _ _ Hi)[-]sep__sep_fun _ (lt_le_weak _ _ Hi))))).
    apply leEq_transitive with (AbsIR (Sumx (fun (i : nat) (Hi : i < n) =>
      F (g i Hi) just1[*](P _ Hi[-]P _ (lt_le_weak _ _ Hi))[-] F (sep__sep_points i Hi) just2[*]
        (P _ Hi[-]P _ (lt_le_weak _ _ Hi))))[+] AbsIR (Sumx (fun (i : nat) (Hi : i < n) =>
          F (sep__sep_points i Hi) just2[*] (sep__sep_fun _ Hi[-]P _ Hi[+]
            (P _ (lt_le_weak _ _ Hi)[-]sep__sep_fun _ (lt_le_weak _ _ Hi)))))).
     eapply leEq_wdl.
      apply triangle_IR_minus.
     apply eq_symmetric_unfolded.
     apply AbsIR_wd.
     eapply eq_transitive_unfolded.
      apply Sumx_minus_Sumx.
     eapply eq_transitive_unfolded.
      2: apply eq_symmetric_unfolded; apply Sumx_minus_Sumx.
     apply Sumx_wd; intros.
     astepl (F (g i H) just1[*](P _ H[-]P _ (lt_le_weak _ _ H))[-] F (sep__sep_points i H) just2[*]
       (sep__sep_fun _ H[-]sep__sep_fun _ (lt_le_weak _ _ H))).
     rational.
    apply plus_resp_leEq_both.
     eapply leEq_wdr.
      apply triangle_SumxIR.
     apply Sumx_wd; intros.
     apply eq_transitive_unfolded with (AbsIR (F (g i H) just1[-]F (sep__sep_points i H) just2)[*]
       AbsIR (P _ H[-]P _ (lt_le_weak _ _ H))).
      eapply eq_transitive_unfolded.
       2: apply AbsIR_resp_mult.
      apply AbsIR_wd; algebra.
     apply mult_wdr.
     apply AbsIR_eq_x.
     apply shift_leEq_minus; astepl (P i (lt_le_weak _ _ H)); apply prf2.
    eapply leEq_transitive.
     apply triangle_SumxIR.
    apply Sumx_resp_leEq; intros.
    eapply leEq_wdl.
     2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult.
    apply mult_resp_leEq_lft.
     apply triangle_IR.
    apply AbsIR_nonneg.
   apply plus_resp_leEq_both.
    eapply leEq_wdr.
     2: apply Sumx_comm_scal'.
    apply Sumx_resp_leEq; intros.
    apply mult_resp_leEq_rht.
     apply sep__sep_aux.
    apply shift_leEq_minus; astepl (P i (lt_le_weak _ _ H)); apply prf2.
   apply Sumx_resp_leEq; intros.
   apply mult_resp_leEq_both.
      apply AbsIR_nonneg.
     astepl (ZeroR[+][0]); apply plus_resp_leEq_both; apply AbsIR_nonneg.
    unfold I, M in |- *; apply norm_bnd_AbsIR.
    apply Pts_part_lemma with n sep__sep_part; apply sep__sep_points_lemma.
   rstepr (delta [/]TwoNZ[+]delta [/]TwoNZ).
   apply plus_resp_leEq_both.
    apply sep__sep_fun_delta.
   eapply leEq_wdl.
    2: apply AbsIR_minus.
   apply sep__sep_fun_delta.
  apply bin_op_wd_unfolded.
   apply mult_wdr.
   eapply eq_transitive_unfolded.
    apply Mengolli_Sum with (f := fun (i : nat) (Hi : i <= n) => P i Hi).
     red in |- *; intros; apply prf1; auto.
    intros; algebra.
   apply cg_minus_wd.
    apply finish.
   apply start.
  astepr (nring n[*](M[*]delta)); apply sumx_const.
 apply plus_resp_leEq_both.
  unfold e in |- *.
  apply leEq_wdl with (alpha [/]TwoNZ[*](b[-]a[/] _[//]max_one_ap_zero (b[-]a))).
   rstepr (alpha [/]TwoNZ[*][1]).
   apply mult_resp_leEq_lft.
    apply shift_div_leEq.
     apply pos_max_one.
    astepr (Max (b[-]a) [1]); apply lft_leEq_Max.
   apply less_leEq; apply pos_div_two; assumption.
  simpl in |- *; rational.
 apply leEq_transitive with (Max (nring n[*]M) [1][*]delta).
  apply mult_resp_leEq_rht.
   apply lft_leEq_Max.
  apply less_leEq; apply RS_delta_pos.
 apply shift_mult_leEq' with (max_one_ap_zero (nring n[*]M)).
  apply pos_max_one.
 unfold delta in |- *.
 eapply leEq_transitive.
  apply Min_leEq_rht.
 apply Min_leEq_lft.
Qed.

Lemma sep__sep_Mesh : Mesh sep__sep_part[<=]Mesh P[+]csi.
Proof.
 unfold Mesh in |- *.
 apply maxlist_leEq.
  apply length_Part_Mesh_List.
  exact RS_pos_n.
 intros x H.
 elim (Part_Mesh_List_lemma _ _ _ _ _ _ H); intros i Hi.
 elim Hi; clear Hi; intros Hi Hi'.
 elim Hi'; clear Hi'; intros Hi' Hx.
 eapply leEq_wdl.
  2: apply eq_symmetric_unfolded; apply Hx.
 unfold sep__sep_part in |- *; simpl in |- *.
 unfold sep__sep_fun in |- *; simpl in |- *.
 elim (le_lt_dec (S i) 0); intro; simpl in |- *.
  exfalso; inversion a0.
 elim (le_lt_eq_dec _ _ Hi'); intro; simpl in |- *.
  elim (le_lt_dec i 0); intro; simpl in |- *.
   cut (i = 0); [ intro | auto with arith ].
   unfold sep__sep_fun_i in |- *; simpl in |- *.
   elim (sep__sep_aux_lemma (S i)); intro; simpl in |- *.
    generalize Hi'; rewrite H0; clear Hx Hi'; intro.
    apply leEq_wdl with (P 1 Hi'[+]delta [/]TwoNZ[-]P 0 (le_O_n _)).
     rstepl (P 1 Hi'[-]P 0 (le_O_n _)[+]delta [/]TwoNZ).
     apply plus_resp_leEq_both.
      fold (Mesh P) in |- *; apply Mesh_lemma.
     apply leEq_transitive with delta.
      apply less_leEq; apply pos_div_two'; exact RS_delta_pos.
     apply RS_delta_csi.
    apply cg_minus_wd; [ algebra | apply start ].
   generalize Hi'; rewrite H0; clear Hx Hi'; intro.
   apply leEq_wdl with (P 1 Hi'[-]P 0 (le_O_n _)).
    fold (Mesh P) in |- *; apply leEq_transitive with (Mesh P[+][0]).
     astepr (Mesh P); apply Mesh_lemma.
    apply plus_resp_leEq_lft.
    apply less_leEq; assumption.
   apply cg_minus_wd; [ algebra | apply start ].
  elim (le_lt_eq_dec _ _ Hi); intro; simpl in |- *.
   unfold sep__sep_fun_i in |- *.
   elim (sep__sep_aux_lemma (S i)); elim (sep__sep_aux_lemma i); intros; simpl in |- *.
      rstepl (P (S i) Hi'[-]P i Hi).
      fold (Mesh P) in |- *; apply leEq_transitive with (Mesh P[+][0]).
       astepr (Mesh P); apply Mesh_lemma.
      apply plus_resp_leEq_lft.
      apply less_leEq; assumption.
     rstepl (P _ Hi'[-]P _ Hi[+]delta [/]TwoNZ).
     apply plus_resp_leEq_both.
      fold (Mesh P) in |- *; apply Mesh_lemma.
     apply leEq_transitive with delta.
      apply less_leEq; apply pos_div_two'; exact RS_delta_pos.
     apply RS_delta_csi.
    rstepl (P _ Hi'[-]P _ Hi[-]delta [/]TwoNZ).
    unfold cg_minus at 1 in |- *; apply plus_resp_leEq_both.
     fold (Mesh P) in |- *; apply Mesh_lemma.
    apply leEq_transitive with ZeroR.
     astepr ([--]ZeroR); apply inv_resp_leEq.
     apply less_leEq; apply pos_div_two; exact RS_delta_pos.
    apply leEq_transitive with delta.
     apply less_leEq; exact RS_delta_pos.
    apply RS_delta_csi.
   fold (Mesh P) in |- *; apply leEq_transitive with (Mesh P[+][0]).
    astepr (Mesh P); apply Mesh_lemma.
   apply plus_resp_leEq_lft.
   apply less_leEq; assumption.
  exfalso; rewrite b2 in a0; apply lt_irrefl with (S n);
    apply lt_trans with (S n); auto with arith.
 elim (le_lt_dec i 0); intro; simpl in |- *.
  cut (i = 0); [ intro | auto with arith ].
  rewrite H0 in b1.
  clear Hx; rewrite H0 in Hi'.
  apply leEq_wdl with (P 1 Hi'[-]P 0 (le_O_n n)).
   fold (Mesh P) in |- *; apply leEq_transitive with (Mesh P[+][0]).
    astepr (Mesh P); apply Mesh_lemma.
   apply plus_resp_leEq_lft.
   apply less_leEq; assumption.
  apply cg_minus_wd.
   generalize Hi'; rewrite b1; intro; apply finish.
  apply start.
 elim (le_lt_eq_dec _ _ Hi); intro; simpl in |- *.
  unfold sep__sep_fun_i in |- *.
  elim (sep__sep_aux_lemma i); intro; simpl in |- *.
   apply leEq_wdl with (P (S i) Hi'[-](P i Hi[+]delta [/]TwoNZ)).
    rstepl (P (S i) Hi'[-]P i Hi[-]delta [/]TwoNZ).
    unfold cg_minus at 1 in |- *; apply plus_resp_leEq_both.
     fold (Mesh P) in |- *; apply Mesh_lemma.
    apply leEq_transitive with ZeroR.
     astepr ([--]ZeroR); apply inv_resp_leEq.
     apply less_leEq; apply pos_div_two; exact RS_delta_pos.
    apply leEq_transitive with delta.
     apply less_leEq; exact RS_delta_pos.
    apply RS_delta_csi.
   apply cg_minus_wd.
    generalize Hi'; rewrite b1; intro; apply finish.
   algebra.
  apply leEq_wdl with (P (S i) Hi'[-]P i Hi).
   fold (Mesh P) in |- *; apply leEq_transitive with (Mesh P[+][0]).
    astepr (Mesh P); apply Mesh_lemma.
   apply plus_resp_leEq_lft.
   apply less_leEq; assumption.
  apply cg_minus_wd.
   generalize Hi'; rewrite b1; intro; apply finish.
  algebra.
 exfalso; rewrite b3 in b1; apply n_Sn with n; auto.
Qed.

End Separating__Separated.
(* end hide *)


Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

Require Import FcEtt.imports.

Require Export FcEtt.ett_inf.
Require Export FcEtt.ett_ind.
Require Import FcEtt.tactics.

Require Import FcEtt.utils.
Require Import FcEtt.toplevel.

(* This file contains these results:

   -- the context is well-formed in any judgement
   -- all components are locally closed in any judgement
  *)

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

Lemma ctx_wff_mutual :
  (forall G0 a A, Typing G0 a A -> Ctx G0) /\
  (forall G0 phi,   PropWff G0 phi -> Ctx G0) /\
  (forall G0 D p1 p2, Iso G0 D p1 p2 -> Ctx G0) /\
  (forall G0 D A B T R,   DefEq G0 D A B T R -> Ctx G0) /\
  (forall G0, Ctx G0 -> True).
Proof.
  eapply typing_wff_iso_defeq_mutual; auto.
Qed.

Definition Typing_Ctx := first ctx_wff_mutual.
Definition PropWff_Ctx := second ctx_wff_mutual.
Definition Iso_Ctx := third ctx_wff_mutual.
Definition DefEq_Ctx := fourth ctx_wff_mutual.

Hint Resolve Typing_Ctx PropWff_Ctx Iso_Ctx DefEq_Ctx.

Fixpoint ctx_nom (G : context) := match G with
  | nil => nil
  | (x, Tm _) :: G' => (x, Nom) :: ctx_nom G'
  | (x, Co _) :: G' => ctx_nom G'
  end.

Lemma Ctx_uniq : forall G, Ctx G -> uniq G.
  induction G; try auto.
  inversion 1; subst; solve_uniq.
Qed.

Lemma dom_rctx_le_ctx : forall G, dom (ctx_nom G) [<=] dom G.
Proof. intros; induction G; simpl. fsetdec.
       destruct a, s. simpl. fsetdec. fsetdec.
Qed.

Lemma notin_ctx_rctx : forall x G, x `notin` (dom G) -> x `notin` dom (ctx_nom G).
Proof. intros. induction G. auto. destruct a, s; simpl in *.
       all : pose (P := H); apply notin_add_2 in P; fsetdec.
Qed.

Lemma ctx_to_rctx_uniq : forall G, Ctx G -> uniq (ctx_nom G).
Proof. intros G. induction G; intros.
        - simpl; auto.
        - inversion H; subst; simpl. apply Ctx_uniq in H.
          apply IHG in H2. econstructor; eauto.
          assert (P : dom (ctx_nom G) [<=] dom G).
          { apply dom_rctx_le_ctx. } fsetdec.
          inversion H. apply IHG; auto.
Qed.

Lemma ctx_to_rctx_binds_tm : forall G x A, binds x (Tm A) G ->
                                             binds x Nom (ctx_nom G).
Proof. intros G. induction G; intros; simpl; eauto.
       destruct a, s. apply binds_cons_1 in H. inversion H; eauto.
       inversion H0. inversion H2. subst. auto.
       apply binds_cons_1 in H. inversion H. inversion H0. inversion H2.
       eauto.
Qed.

Hint Resolve Ctx_uniq.

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

Lemma RolePath_lc : forall a R, RolePath a R -> lc_tm a.
Proof. intros. induction H; eauto.
Qed.

Lemma ValuePath_lc : forall F a, ValuePath a F -> lc_tm a.
Proof. intros. induction H; eauto.
Qed.

Lemma CasePath_lc : forall F a R, CasePath R a F -> lc_tm a.
Proof. intros. induction H; eauto using ValuePath_lc.
Qed.

Lemma PatternContexts_lc2 : forall W G D F p A B, PatternContexts W G D F A p B -> lc_tm p.
Proof. intros. induction H; eauto.
Qed.

Lemma Rename_lc2 : forall p b p' b' D D', Rename p b p' b' D D' -> lc_tm b.
Proof. induction 1; eauto. Qed.

Lemma Rename_lc4 : forall p b p' b' D D', Rename p b p' b' D D' -> lc_tm b'.
Proof. induction 1; eauto using tm_subst_tm_tm_lc_tm. Qed.

Lemma roleing_lc : (forall W a R, roleing W a R -> lc_tm a).
Proof. induction 1; eauto. Qed.

Lemma Value_lc : forall R a, Value R a -> lc_tm a.
Proof. intros. induction H; eauto using CasePath_lc.
Qed.

Hint Resolve PatternContexts_lc2 roleing_lc Value_lc : lc.

Lemma MatchSubst_lc1 : forall a p b b', MatchSubst a p b b' →  lc_tm a.
Proof.
  induction 1; auto.
Qed.

Lemma MatchSubst_lc2 : forall a p b b', MatchSubst a p b b' →  lc_tm p.
Proof.
  induction 1; auto.
Qed.

Lemma MatchSubst_lc3 : forall a p b b', MatchSubst a p b b' →  lc_tm b.
Proof.
  induction 1; auto.
Qed.

Lemma MatchSubst_lc4 : forall a p b b', MatchSubst a p b b' →  lc_tm b'.
Proof.
  induction 1;
    eauto using tm_subst_tm_tm_lc_tm, co_subst_co_tm_lc_tm.
Qed.

Lemma ApplyArgs_lc1 : forall a b1 b1',  ApplyArgs a b1 b1' -> lc_tm a.
Proof.
  intros. induction H; auto.
Qed.
Lemma ApplyArgs_lc2 : forall a b1 b1',  ApplyArgs a b1 b1' -> lc_tm b1.
Proof.
  intros. induction H; auto.
Qed.
Lemma ApplyArgs_lc3 : forall a b1 b1',  ApplyArgs a b1 b1' -> lc_tm b1'.
Proof.
  intros. induction H; auto.
Qed.

Lemma Par_lc1 : forall W a a' R, Par W a a' R → lc_tm a.
Proof. induction 1; eauto using roleing_lc, MatchSubst_lc1.
Qed.

Lemma Par_lc2 : forall W a a' R, Par W a a' R → lc_tm a'.
Proof.
  intros. induction H; eauto.
  all: try with binds do ltac:(fun h =>
     apply toplevel_inversion in h; inversion h; autofwd).

  all: try solve [eauto 2 using roleing_lc, MatchSubst_lc4].
  all: try solve [lc_solve].
  econstructor; eauto using ApplyArgs_lc3.
Qed.

Hint Resolve MatchSubst_lc1 MatchSubst_lc4 ApplyArgs_lc2 ApplyArgs_lc3 Par_lc1 Par_lc2 : lc.

Lemma lc_mutual :
  (forall G0 a A, Typing G0 a A -> lc_tm a /\ lc_tm A) /\
  (forall G0 phi , PropWff G0 phi -> lc_constraint phi) /\
  (forall G0 D p1 p2,  Iso G0 D p1 p2 -> lc_constraint p1 /\ lc_constraint p2) /\
  (forall G0 D A B T R, DefEq G0 D A B T R -> lc_tm A /\ lc_tm B /\ lc_tm T) /\
  (forall G0, Ctx G0 -> forall x s , binds x s G0 -> lc_sort s).
Proof.
  eapply typing_wff_iso_defeq_mutual.
  all: TacticsInternals.pre; basic_solve_n 2.
  all: split_hyp.
  all: lc_solve.
Qed.

Definition Typing_lc  := first lc_mutual.
Definition PropWff_lc := second lc_mutual.
Definition Iso_lc     := third lc_mutual.
Definition DefEq_lc   := fourth lc_mutual.
Definition Ctx_lc     := fifth lc_mutual.

Lemma Typing_lc1 : forall G0 a A, Typing G0 a A -> lc_tm a.
Proof.
  intros. apply (first lc_mutual) in H. destruct H. auto.
Qed.
Lemma Typing_lc2 : forall G0 a A, Typing G0 a A -> lc_tm A.
Proof.
  intros. apply (first lc_mutual) in H. destruct H. auto.
Qed.

Lemma Iso_lc1 : forall G0 D p1 p2 , Iso G0 D p1 p2  -> lc_constraint p1.
Proof.
  intros. apply (third lc_mutual) in H. destruct H. auto.
Qed.
Lemma Iso_lc2 : forall G0 D p1 p2 , Iso G0 D p1 p2 -> lc_constraint p2.
Proof.
  intros. apply (third lc_mutual) in H. destruct H. auto.
Qed.
Lemma DefEq_lc1 : forall G0 D A B T R,   DefEq G0 D A B T R -> lc_tm A.
Proof.
  intros. apply (fourth lc_mutual) in H. destruct H. auto.
Qed.

Lemma DefEq_lc2 : forall G0 D A B T R,   DefEq G0 D A B T R -> lc_tm B.
Proof.
  intros. apply (fourth lc_mutual) in H. split_hyp. auto.
Qed.
Lemma DefEq_lc3 : forall G0 D A B T R,   DefEq G0 D A B T R -> lc_tm T.
Proof.
  intros. apply (fourth lc_mutual) in H. split_hyp. auto.
Qed.

Hint Resolve Typing_lc1 Typing_lc2 Iso_lc1 Iso_lc2 DefEq_lc1 DefEq_lc2 DefEq_lc3 Ctx_lc : lc.

Lemma Toplevel_lc : forall c s, binds c s toplevel -> lc_sig_sort s.
Proof. induction Sig_toplevel.
       - intros. inversion H.
       - intros. destruct H1. inversion H1. subst.
         simpl in H0. eauto. eauto with lc.
         eauto.
       - intros.
         with binds do fun h => destruct (binds_cons_1  _ _ _ _ _ _ h); basic_solve.
         autofwd.
         subst. econstructor. all: eauto 3 with lc.
         all: eauto using PatternContexts_lc2, roleing_lc, Typing_lc1.
Qed.

Lemma AppsPath_lc : forall R a F Apps,  AppsPath R a F Apps -> lc_tm a.
Proof.
  intros; induction H; auto.
Qed.

Hint Resolve AppsPath_lc.

Lemma Beta_lc1 : forall a a' R, Beta a a' R -> lc_tm a.
Proof.
  intros.  induction H; auto.
  all: try with AxiomUnfold do ltac:(fun h => inversion h; subst).
  - eapply Value_lc in H0. eauto.
  - eauto 2 with lc.
  - constructor; eauto 3 with lc.
  - lc_solve.
  Unshelve.
  all: auto.
Qed.

Lemma Beta_lc2 : forall a a' R, Beta a a' R -> lc_tm a'.
Proof.
  intros.  induction H; auto.
  all: try with AxiomUnfold do ltac:(fun h => inversion h; subst; eauto).
  - apply Value_lc in H0. inversion H0.
    apply lc_body_tm_wrt_tm; auto.
  - inversion H. apply lc_body_tm_wrt_co; auto.
  - with binds do ltac:(fun h => apply Toplevel_lc in h; inversion h).
    subst.
    eauto 2 with lc.
  - lc_solve.
Qed.

Lemma reduction_in_one_lc : forall a a' R, reduction_in_one a a' R -> lc_tm a -> lc_tm a'.
Proof.
   induction 1; intros; try (eapply Beta_lc2; eauto 1; fail).
   lc_solve.
   lc_solve.
   lc_solve.
   inversion H2. econstructor; eauto 2.
Qed.

Lemma axiom_body_lc : forall F p b A R Rs, binds F (Ax p b A R Rs) toplevel ->
      lc_tm b.
Proof. intros. apply toplevel_inversion in H.
       autofwd.
       lc_solve.
Qed.


Require Import VST.floyd.proofauto.
Require Import fastpile.
Require Import spec_stdlib.

Record FastpileConcreteAPD:= {
  countrep: Z -> val -> mpred;
  countrep_local_facts: forall s p, countrep s p |-- !! isptr p;
  countrep_valid_pointer: forall s p, countrep s p |-- valid_pointer p;
  count_freeable: val -> mpred
}.
#[export] Hint Resolve countrep_local_facts : saturate_local.
#[export] Hint Resolve countrep_valid_pointer : valid_pointer.

Definition tpile := Tstruct _pile noattr.

Local Open Scope assert.

Section FastpileConcASI.
Variable M: MallocFreeAPD.
Variable FCP: FastpileConcreteAPD.

Definition Pile_new_spec :=
 DECLARE _Pile_new
 WITH gv: globals
 PRE [ ] PROP() PARAMS () GLOBALS (gv) SEP(mem_mgr M gv)
 POST[ tptr tpile ]
   EX p: val,
      PROP() LOCAL(temp ret_temp p)
      SEP(countrep FCP 0 p; count_freeable FCP p; mem_mgr M gv).

Definition Pile_add_spec :=
 DECLARE _Pile_add
 WITH p: val, n: Z, s: Z, gv: globals
 PRE [ tptr tpile, tint ]
    PROP(0 <= n <= Int.max_signed)
    PARAMS (p; Vint (Int.repr n)) GLOBALS (gv)
    SEP(countrep FCP s p; mem_mgr M gv)
 POST[ tvoid ]
    PROP() LOCAL()
    SEP(countrep FCP (n+s) p; mem_mgr M gv).

Definition Pile_count_spec :=
 DECLARE _Pile_count
 WITH p: val, s: Z
 PRE [ tptr tpile  ]
    PROP()
    PARAMS (p) GLOBALS ()
    SEP(countrep FCP s p)
 POST[ tint ]
   EX s':Z,
      PROP(s <= Int.max_signed -> s'=s)
      LOCAL(temp ret_temp (Vint (Int.repr s')))
      SEP(countrep FCP s p).

Definition Pile_free_spec :=
 DECLARE _Pile_free
 WITH p: val, s: Z, gv: globals
 PRE [ tptr tpile  ]
    PROP()
    PARAMS (p) GLOBALS (gv)
    SEP(countrep FCP s p; count_freeable FCP p; mem_mgr M gv)
 POST[ tvoid ]
    PROP() LOCAL() SEP(mem_mgr M gv).

Definition FastpileConcreteASI:funspecs := [ Pile_new_spec; Pile_add_spec; Pile_count_spec; Pile_free_spec].

End FastpileConcASI.


(** * Equidistribution theorems for cotrees, itrees, CF trees, and cpGCL. *)

Set Implicit Arguments.
Set Contextual Implicit.

From Coq Require Import
  Basics
  List
  Morphisms
  Equality
  Lia
.

Import ListNotations.
Local Open Scope program_scope.

From ITree Require Import
  ITree ITreeFacts.
Import ITreeNotations.
Local Open Scope itree_scope.

From Paco Require Import paco.

From algco Require Import
  aCPO
  axioms
  cocwp
  cocwp_facts
  colist
  cotree
  cpo
  misc
  mu
  order
  prod
  eR
  (* set *)
  tactics
.

Local Open Scope eR_scope.
Local Open Scope order_scope.
(* Local Open Scope set_scope. *)

Inductive is_stream_prefix {A} : list A -> colist A -> Prop :=
| is_stream_prefix_nil : forall s, is_stream_prefix [] s
| is_stream_prefix_cons : forall x l s,
    is_stream_prefix l s ->
    is_stream_prefix (x :: l) (cocons x s).

Lemma is_stream_prefix_consistent_pair {A} (a b : list A) (l : colist A) :
  is_stream_prefix a l ->
  is_stream_prefix b l ->
  list_le a b \/ list_le b a.
Proof.
  revert b l; induction a; simpl; intros b l Ha Hb.
  { left; constructor. }
  inv Ha; inv Hb.
  { right; constructor. }
  eapply IHa in H1; eauto.
  destruct H1 as [H|H].
  - left; constructor; auto.
  - right; constructor; auto.
Qed.

(* Definition bitstring_set (l : list bool) : set (colist bool) := *)
(*   is_stream_prefix l. *)

(* #[global] *)
(*   Instance ToSet_bitstring : ToSet (list bool) (colist bool) := *)
(*   { to_set := bitstring_set }. *)

Definition bitstring_measure (l : list bool) : eR :=
  1 / 2 ^ length l.

Lemma list_le_stream_prefix_trans {A} (a b : list A) (c : colist A) :
  list_le a b ->
  is_stream_prefix b c ->
  is_stream_prefix a c.
Proof.
  revert b c; induction a; intros b c Hab Hbc.
  { constructor. }
  inv Hab; inv Hbc.
  constructor; eapply IHa; eauto.
Qed.

Lemma is_stream_prefix_inj {A} (l : list A) :
  is_stream_prefix l (inj l).
Proof. induction l; constructor; auto. Qed.

(* Lemma bitstring_incomparable_disjoint (a b : list bool) : *)
(*   incomparable a b <-> partition [[ a ]] [[ b ]]. *)
(* Proof. *)
(*   unfold incomparable, disjoint, to_set; simpl. *)
(*   unfold bitstring_set. *)
(*   split. *)
(*   - intros Hinc l. *)
(*     contra HC; apply Hinc. *)
(*     apply Classical_Prop.not_or_and in HC. *)
(*     destruct HC as [H0 H1]. *)
(*     apply Classical_Prop.NNPP in H0. *)
(*     apply Classical_Prop.NNPP in H1. *)
(*     eapply is_stream_prefix_consistent_pair; eauto. *)
(*   - intros H [HC|HC]. *)
(*     + specialize (H (inj b)). *)
(*       destruct H as [H|H]. *)
(*       * apply H. *)
(*         eapply list_le_stream_prefix_trans; eauto. *)
(*         apply is_stream_prefix_inj. *)
(*       * apply H, is_stream_prefix_inj. *)
(*     + specialize (H (inj a)). *)
(*       destruct H as [H|H]. *)
(*       * apply H, is_stream_prefix_inj. *)
(*       * apply H. *)
(*         eapply list_le_stream_prefix_trans; eauto. *)
(*         apply is_stream_prefix_inj. *)
(* Qed. *)

(* Lemma bitstream_ext a b : *)
(*   [[ a ]] = [[ b ]] -> *)
(*   a = b. *)
(* Proof. *)
(*   simpl; unfold bitstring_set. *)
(*   intro Hab. *)
(*   apply eq_set_eq in Hab. *)
(*   unfold set_eq in Hab. *)
(*   revert Hab; revert b; induction a; intros b Hab. *)
(*   - specialize (Hab conil). *)
(*     destruct Hab as [H0 H1]. *)
(*     specialize (H0 is_stream_prefix_nil). *)
(*     inv H0; auto. *)
(*   - destruct b. *)
(*     { specialize (Hab conil). *)
(*       destruct Hab as [H0 H1]. *)
(*       specialize (H1 is_stream_prefix_nil). *)
(*       inv H1. } *)
(*     pose proof Hab as Hab'. *)
(*     specialize (Hab (cocons a (inj a0))). *)
(*     destruct Hab as [H0 H1]. *)
(*     assert (H: is_stream_prefix (a :: a0) (cocons a (inj a0))). *)
(*     { constructor; apply is_stream_prefix_inj. } *)
(*     apply H0 in H; clear H0. *)
(*     inv H; f_equal. *)
(*     apply IHa. *)
(*     intro l; specialize (Hab' (cocons a l)); destruct Hab' as [H0 H1']. *)
(*     split; intro H. *)
(*     + specialize (H0 (is_stream_prefix_cons H)); inv H0; auto. *)
(*     + specialize (H1' (is_stream_prefix_cons H)); inv H1'; auto. *)
(* Qed. *)

(* Lemma bitstream_measure_proper a b : *)
(*   [[ a ]] = [[ b ]] -> *)
(*   bitstring_measure a = bitstring_measure b. *)
(* Proof. intro Hab; apply bitstream_ext in Hab; subst; reflexivity. Qed. *)

(* #[global] *)
(*   Program *)
(*   Instance Measurable_bitstring : Measurable (list bool) (colist bool) := *)
(*   { mu := bitstring_measure }. *)
(* Next Obligation. apply bitstream_measure_proper; auto. Qed. *)

Definition Sigma01 : Type := cotree bool (list bool).

(* Definition measure {A T} `{Measurable A T} (U : cotree bool A) : eR := *)
(*   tcosum mu U. *)

(* Lemma coset_le_cotree_all_some (a b : Sigma01) : *)
(*   [[ a ]] ⊑ [[ b ]] -> *)
(*   cotree_all (fun x => cotree_some (fun y => y ⊑ x) b) a. *)
(* Proof. *)
(* Admitted. *)

(* Lemma kdfg {A} (t : cotree bool A) : *)
(*   cotree_all (fun x => cotree_some (eq x) cobot) t -> *)
(*   t = cobot. *)
(* Proof with eauto with cotree order. *)
(*   intro Hall. *)
(*   destruct t; auto; apply coop_elim with (i := S (S O)) in Hall... *)
(*   - unfold atree_all in Hall. simpl in Hall. *)
(*     apply cotree_some_bot in Hall; contradiction. *)
(*   - unfold atree_all in Hall. simpl in Hall. *)
(*     unfold compose in Hall. *)
(*     simpl in Hall. *)

(** IDEA: define stream of all bitstreams, then general construction
    of Sigma01 stream of cotree by filtering out elements of the
    stream not in the cotree. Prove their elements coincide and both
    are partitionings, and that those together imply their measures
    are equal. *)

(* #[global] *)
(*   Program *)
(*   Instance Measurable_Sigma01 : Measurable Sigma01 (colist bool) := *)
(*   { mu := measure }. *)
(* Next Obligation. *)
(*   apply eq_set_eq in H. *)
(*   unfold set_eq in H. *)
(*   unfold bitstring_set in H. *)

(*   apply Proper_co_general_ext; eauto with mu order. *)
(*   intro i. *)
(*   simpl; unfold flip. *)
(*   revert Hab Hba; induction i; intros Hab Hba; simpl. *)
(*   { reflexivity. } *)
(*   destruct a. *)
(*   - destruct b; auto. *)
(*     + apply cotree_all_elim_leaf in Hba. *)
(*       apply cotree_some_bot in Hba; contradiction. *)
(*     + unfold asum. simpl. *)
(*       unfold compose in *. *)

(*       eapply IHi in Hba; auto. *)
(*       destruct i. *)
(*       { eRauto. } *)
(*       simpl in *. *)

(*       pose proof Hba as Hba'. *)
(*       apply cotree_all_elim_node with (b:=true) in Hba. *)
(*       apply cotree_all_elim_node with (b:=false) in Hba'. *)

(* Qed. *)

(** TODO: generalize to class of measurable types (ToSet with
    measure). *)
(* Definition measure (U : Sigma01) : eR := *)
(*   mu (fun bs => 1 / 2 ^ length bs) U. *)
(* #[global] Hint Unfold measure : mu. *)

(* Lemma dfgdfg (U V : Sigma01) : *)
(*   [[ U ]] = [[ V ]] -> *)
(*   measure U = measure V. *)

Definition cotree_union {A} (U V : cotree bool A) : cotree bool A :=
  conode (fun b : bool => if b then U else V).

Lemma Sigma01_union_pairwise_disjoint (U V : Sigma01) :
  cotree_pairwise_disjoint U ->
  cotree_pairwise_disjoint V ->
  cotree_disjoint U V ->
  cotree_pairwise_disjoint (cotree_union U V).
Proof with eauto with cotree order.
  intros HU HV [HVU HUV].
  apply coop_intro...
  intro i; simpl; unfold flip.
  unfold cotree_union.
  destruct i.
  { constructor. }
  apply coop_elim with (i:=i) in HU...
  apply coop_elim with (i:=i) in HV...
  apply coop_elim with (i:=i) in HVU...
  apply coop_elim with (i:=i) in HUV...
  simpl in *; unfold flip in *.
  constructor.
  - intros []; auto.
  - split; eapply atree_all_impl; eauto; simpl;
      intros bs Hbs; apply coop_elim with (i:=i) in Hbs...
Qed.

Definition alist_union {A} : list (cotree bool A) -> cotree bool A :=
  fold ⊥ cotree_union.

#[global]
  Instance monotone_alist_union {A}
  : Proper (leq ==> leq) (@alist_union A).
Proof.
  unfold alist_union.
  intro a; induction a; intros b Hab; unfold flip; simpl.
  { constructor. }
  unfold cotree_union.
  inv Hab; simpl.
  constructor; intros [].
  - reflexivity.
  - apply IHa; auto.
Qed.
#[global] Hint Resolve monotone_alist_union : colist.

Definition colist_union {A} : colist (cotree bool A) -> cotree bool A :=
  co alist_union.

Inductive alist_pairwise_disjoint {A} `{OType A} : list (cotree bool A) -> Prop :=
| alist_pairwise_disjoint_nil : alist_pairwise_disjoint []
| alist_pairwise_disjoint_cons : forall t l,
    (* cotree_pairwise_disjoint t -> *)
    alist_pairwise_disjoint l ->
    list_forall (cotree_disjoint t) l ->
    alist_pairwise_disjoint (t :: l).

#[global]
  Instance antimonotone_alist_pairwise_disjoint {A} `{OType A}
  : Proper (leq ==> flip leq) (@alist_pairwise_disjoint A _).
Proof.
  intro a; induction a; intros b Hab Hb.
  { constructor. }
  inv Hab; inv Hb.
  constructor; auto.
  - eapply IHa; eauto.
  - eapply antimonotone_list_forall; eauto.
Qed.
#[global] Hint Resolve antimonotone_alist_pairwise_disjoint : colist.

Definition colist_pairwise_disjoint {A} `{OType A} : colist (cotree bool A) -> Prop :=
  coop alist_pairwise_disjoint.

Lemma continuous_pair_plus :
  wcontinuous (fun f : bool -> eR => f false + f true).
Proof.
  intros ch Hch f Hsup; unfold compose.
  apply supremum_sum.
  { intro i; apply Hch. }
  { intro i; apply Hch. }
  { apply apply_supremum; auto. }
  { apply apply_supremum; auto. }
Qed.

(* Lemma countable_additivity (l : colist Sigma01) : *)
(*   measure (colist_union l) = cosum (comap measure l). *)
(* Proof with eauto with order colist cotree aCPO mu eR. *)
(*   unfold colist_union. *)
(*   rewrite co_co_ext... *)
(*   2: { apply continuous_wcontinuous, continuous_co, monotone_asum. } *)
(*   unfold comap, cofold. *)
(*   rewrite co_co_ext with (g := cosum)... *)
(*   2: { apply continuous_wcontinuous, continuous_co... } *)
(*   eapply Proper_co_ext; eauto. *)
(*   { apply monotone_compose. *)
(*     - apply monotone_alist_union. *)
(*     - apply continuous_monotone, continuous_co, monotone_asum. } *)
(*   { apply monotone_compose. *)
(*     - apply monotone_amap. *)
(*     - apply continuous_monotone, continuous_co... } *)
(*   clear l; unfold compose. *)
(*   unfold alist_union. *)
(*   unfold measure, tcosum, asum, cosum, cofold. *)
(*   ext b; induction b; simpl. *)
(*   { rewrite co_tfold_bot', co_fold_nil'; reflexivity. } *)
(*   unfold cotree_union. *)
(*   rewrite co_tfold_node'... *)
(*   2: { apply continuous_pair_plus. } *)
(*   unfold compose. *)
(*   unfold map_f in *. *)
(*   rewrite co_fold_cons'... *)
(*   2: { intro; apply continuous_eRplus. } *)
(*   rewrite eRplus_comm. *)
(*   f_equal; apply IHb. *)
(* Qed. *)

(* Lemma countable_additivity (l : colist Sigma01) : *)
(*   colist_pairwise_disjoint l -> *)
(*   measure (colist_union l) = cosum (comap measure l). *)
(* Proof with eauto with order colist cotree aCPO mu eR. *)
(*   intro Hpart. *)
(*   unfold colist_union. *)
(*   rewrite co_co_ext... *)
(*   2: { apply continuous_wcontinuous, continuous_co... } *)
(*   unfold comap, cofold. *)
(*   rewrite co_co_ext with (g := cosum)... *)
(*   2: { apply continuous_wcontinuous, continuous_co... } *)
(*   eapply Proper_co_P_ext; eauto. *)
(*   { apply antimonotone_alist_pairwise_disjoint. } *)
(*   { apply monotone_compose. *)
(*     - apply monotone_alist_union. *)
(*     - apply continuous_monotone, continuous_co, monotone_amu. } *)
(*   { apply monotone_compose. *)
(*     - apply monotone_amap. *)
(*     - apply continuous_monotone, continuous_co, monotone_asum. } *)
(*   clear l Hpart; unfold compose. *)
(*   unfold alist_union. *)
(*   unfold measure, mu, amu, cosum, cofold. *)
(*   intro b; induction b; simpl; intro Hpart. *)
(*   { rewrite co_tfold_bot', co_fold_nil'; reflexivity. } *)
(*   unfold cotree_union. *)
(*   rewrite co_tfold_node'... *)
(*   2: { apply continuous_pair_plus. } *)
(*   unfold compose. *)
(*   inv Hpart. *)
(*   unfold map_f in *. *)
(*   rewrite co_fold_cons'... *)
(*   2: { intro; apply continuous_eRplus. } *)
(*   apply IHb in H1. *)
(*   rewrite eRplus_comm. *)
(*   f_equal; apply H1. *)
(* Qed. *)

Fixpoint count {A} (P : A -> Prop) (l : list A) : nat :=
  match l with
  | [] => O
  | x :: xs => if classicT (P x) then S (count P xs) else count P xs
  end.

Definition freq {A} (P : A -> Prop) (l : list A) :=
  INeR (count P l) / INeR (length l).

Definition in_Sigma01 (U : Sigma01) (s : colist bool) : Prop :=
  cotree_some (fun l => is_stream_prefix l s) U.

Definition mu (U : Sigma01) : eR :=
  tcosum bitstring_measure U.

Definition uniform (bitstreams : nat -> colist bool) : Prop :=
  forall U : Sigma01,
    cotree_pairwise_disjoint U ->
    converges (freq (in_Sigma01 U) ∘ seq_prefix bitstreams) (mu U).

Inductive produces {A} (P : A -> Prop) : colist bool -> cotree bool A -> Prop :=
| produces_leaf : forall bs x, P x -> produces P bs (coleaf x)
| produces_node : forall b bs k,
    produces P bs (k b) ->
    produces P (cocons b bs) (conode k).

Lemma list_rel_count {A B} (P : A -> Prop) (Q : B -> Prop) (l1 : list A) (l2 : list B) :
  list_rel (fun x y => P x <-> Q y) l1 l2 ->
  count P l1 = count Q l2.
Proof.
  induction 1; simpl; auto.
  repeat destruct_classic; auto.
  - apply H in p; congruence.
  - apply H in q; congruence.
Qed.

Lemma produces_in_sigma01 {A} (x : A) (bs : colist bool) (P : A -> bool) (t : cotree bool A) :
  produces (eq x) bs t ->
  in_Sigma01 (cotree_preimage P t) bs <-> is_true (P x).
Proof.
  unfold in_Sigma01.
  induction 1; subst.
  - rewrite cotree_preimage_leaf.
    split.
    + intro Hsome.
      destruct (P x0); auto.
      apply co_elim in Hsome; eauto with cotree order.
      destruct Hsome as [i Hsome].
      destruct i; inv Hsome.
    + unfold is_true; intro HP.
      destruct (P x0); try congruence.
      apply co_intro with (S O); eauto with cotree order.
      constructor; constructor.
  - rewrite cotree_preimage_node; split.
    + intro Hsome.
      apply co_elim in Hsome; eauto with cotree order.
      destruct Hsome as [i Hsome].
      apply IHproduces.
      apply atree_some_exists in Hsome.
      destruct Hsome as [l [H1 H2] ].
      apply atree_some_exists in H1.
      destruct H1 as [l' [Hsome Hl] ]; subst.
      inv H2.
      { destruct i; simpl in Hsome.
        - inv Hsome.
        - destruct Hsome as [c H0].
          unfold compose in H0. simpl in H0.
          rewrite tprefix_map in H0.
          apply atree_some_map in H0.
          unfold compose in H0.
          apply atree_some_exists in H0.
          destruct H0 as [l [H0 Heq] ].
          inv Heq. }
      destruct i.
      { inv Hsome. }
      { simpl in Hsome; unfold flip in Hsome; simpl in Hsome.
        unfold compose in Hsome.
        destruct Hsome as [c H1].
        unfold compose in H1.
        rewrite tprefix_map in H1.
        apply atree_some_map in H1.
        apply atree_some_exists in H1.
        destruct H1 as [l' [Hsome Hl'] ].
        inv Hl'.
        eapply co_intro; eauto with cotree order.
        apply atree_some_exists; exists l'; split; eauto.
        apply Hsome. }
    + unfold is_true; intro HPx.
      unfold cotree_some.
      apply IHproduces in HPx.
      apply co_elim in HPx; eauto with cotree order.
      destruct HPx as [i Hi].
      apply co_intro with (S i); eauto with cotree order.
      simpl; unfold flip; simpl.
      econstructor.
      unfold compose.
      rewrite tprefix_map.
      apply atree_map_some.
      unfold compose.
      eapply atree_some_impl; try apply Hi.
      intros l Hl; constructor; auto.
Qed.

Record SamplingEnvironment : Type :=
  mkSampleEnvironment
    { bitstreams : nat -> colist bool
    ; bitstreams_uniform : uniform bitstreams }.

(** Cotree sampling theorem. *)
Section cotree_equidistribution.
  Context (env : SamplingEnvironment) (A : Type) (t : cotree bool A) (P : A -> bool).

  Variable samples : nat -> A.
  Hypothesis bitstreams_samples : forall i, produces (eq (samples i)) (env.(bitstreams) i) t.

  Lemma cotree_freq_bitstreams_samples (n : nat) :
    freq (in_Sigma01 (cotree_preimage P t)) (seq_prefix env.(bitstreams) n) =
      freq (fun x : A => is_true (P x)) (seq_prefix samples n).
  Proof.
    unfold freq; f_equal.
    2: { f_equal; rewrite 2!length_seq_prefix; reflexivity. }
    f_equal; apply list_rel_count, list_rel_prefix.
    intro i; specialize (@bitstreams_samples i).
    apply produces_in_sigma01; auto.
  Qed.

  Theorem cotree_samples_equidistributed :
    converges (freq (is_true ∘ P) ∘ seq_prefix samples)
      (cotwp (fun s => if P s then 1 else 0) t).
  Proof.
    intros eps Heps.
    pose proof env.(bitstreams_uniform) as Huniform.
    specialize (Huniform _ (pairwise_disjoint_cotree_preimage P t) _ Heps).
    destruct Huniform as [n0 Huniform].
    exists n0; intros n Hn; specialize (Huniform n Hn).
    unfold compose in *.
    rewrite cotwp_tcosum_preimage'.
    unfold mu in Huniform.
    rewrite <- cotree_freq_bitstreams_samples; apply Huniform.
  Qed.
End cotree_equidistribution.

Print Assumptions cotree_samples_equidistributed.


(* THIS FILE IS JUST THE BEGINNING OF AN EXPERIMENTAL SKETCH!
  We explore whether multivariate first-order Taylor expansions,
  in the style of FPTaylor, might be useful.
 *)

Require Import Reals ZArith Lra Lia IntervalFlocq3.Tactic.
Import Raux.
From Flocq3 Require Import IEEE754.Binary Zaux.
Require Import Setoid.

Import Coq.Lists.List ListNotations.
Import Tree. (* must import this _after_ List *)
Import Interval Private Interval_helper I2 IT2.IH I2.T Xreal Eval.Reify.

Import Basic.
Import Bool.
From vcfloat Require Import Prune.

Lemma doppler1_test:
  forall
  (v_v : R)
  (BOUND : 20 <= v_v <= 2e4)
  (v_u : R)
  (BOUND0 : -100 <= v_u <= 100)
  (v_t : R)
  (BOUND1 : -30 <= v_t <= 50)
  (e0 : R)
  (E : Rabs e0 <= powerRZ 2 (-1075))
  (e1 : R)
  (E0 : Rabs e1 <= powerRZ 2 (-1075))
  (e3 : R)
  (E2 : Rabs e3 <= powerRZ 2 (-1075))
  (e4 : R)
  (E3 : Rabs e4 <= powerRZ 2 (-1075))
  (e8 : R)
  (E7 : Rabs e8 <= powerRZ 2 (-1075))
  (e9 : R)
  (E8 : Rabs e9 <= powerRZ 2 (-1075))
  (d : R)
  (E10 : Rabs d <= powerRZ 2 (-53))
  (d0 : R)
  (E11 : Rabs d0 <= powerRZ 2 (-53))
  (d1 : R)
  (E12 : Rabs d1 <= powerRZ 2 (-53))
  (d2 : R)
  (E13 : Rabs d2 <= powerRZ 2 (-53))
  (d3 : R)
  (E14 : Rabs d3 <= powerRZ 2 (-53))
  (d6 : R)
  (E17 : Rabs d6 <= powerRZ 2 (-53))
  (a := 2915025227559731 / 8796093022208 : R)
  (b := 5404319552844595 / 9007199254740992 : R),
 {bound: R |
Rabs
  ((- ((a + (b * v_t * (1 + d) + e1)) * (1 + d1) + e0) * v_v *
    (1 + d2) + e8) /
   ((((a + (b * v_t * (1 + d) + e1)) * (1 + d1) + e0 + v_u) *
     (1 + d0) + e4) *
    (((a + (b * v_t * (1 + d) + e1)) * (1 + d1) + e0 + v_u) *
     (1 + d0) + e4) * (1 + d6) + e3) * (1 + d3) + e9 -
   - (a + b * v_t) * v_v *
   / ((a + b * v_t + v_u) * (a + b * v_t + v_u)))
   <= bound}.
Proof. intros.
evar (bound: R).
exists bound. (*eexists.*)
unfold a, b.

simple_reify.

Definition bind2 (f: expr -> expr -> expr) (x1: option expr) (x2: option expr) : option expr :=
 match x1, x2 with
 | Some y1, Some y2 => Some (f y1 y2)
 | _, _ => None
 end.

Definition Mul' (e1 e2: expr) :=
 match e1, e2 with
 | Econst (Int 0) , _ => zeroexpr
 | _, Econst (Int 0) => zeroexpr
 | Econst (Int 1) , _ => e2
 | _, Econst (Int 1) => e1
 | _, _ => Ebinary Mul e1 e2
 end.

Definition Div' (e1 e2: expr) :=
 match e1, e2 with
 | Econst (Int 0) , _ => zeroexpr
 | _, Econst (Int 1) => e1
 | _, _ => Ebinary Div e1 e2
 end.

Definition Neg' (e1: expr) :=
 match e1 with Econst (Int 0) => zeroexpr | _ => e1 end.

Definition Sqr' (e1: expr) :=
 match e1 with
 | Econst (Int 0) => zeroexpr
 | Econst (Int 1) => oneexpr
 | _ => e1
 end.

Print Add0.

Definition partial_deriv (x: nat) : expr -> option expr :=
 fix aux (e: expr) : option expr :=
 match e with
 | Evar y => Some (if Nat.eqb x y then oneexpr else zeroexpr)
 | Econst _ => Some zeroexpr
 | Eunary Neg e1 => option_map Neg' (aux e1)
 | Eunary Inv e1 => option_map (fun d => Neg' (Div' d (Sqr' e1))) (aux e1)
 | Eunary Sqr e => option_map (Mul' (Econst (Int 2))) (aux e)
 | Ebinary Add e1 e2 => bind2 Add0 (aux e1) (aux e2)
 | Ebinary Sub e1 e2 => bind2 Sub0 (aux e1) (aux e2)
 | Ebinary Mul e1 e2 => bind2 (fun d1 d2 => Add0 (Mul' e1 d2) (Mul' e2 d1)) (aux e1) (aux e2)
 | Ebinary Div e1 e2 => bind2 (fun d1 d2 => Div' (Sub0 (Mul' e2 d1) (Mul' e1 d2)) (Sqr' e2))
            (aux e1) (aux e2)
 | e => None
 end.

Fixpoint option_list {A} (al: list (option A)) : option (list A) :=
 match al with
 | nil => Some nil
 | Some x :: r => option_map (cons x) (option_list r)
 | None :: _ => None
 end.

Definition gradient (vars: list R) e  :=
 option_list (map (fun x => partial_deriv x e) (seq.iota 0 (length vars))).

assert (
 match partial_deriv 3%nat __expr with
  | Some d => eval d __vars = 0%R
 | _ => False
 end).
cbv -[IZR].
repeat change (?A * / ?B) with (A/B).
fold a. fold b.
clear __expr.

pose (vars := seq.iota 0 (length __vars)).

Search (list (option _) -> option (list _)).
assert (partial_deriv 3%nat __expr = None).
cbv.

cbv [partial_deriv __expr Nat.eqb ].

Check option_map.


Require Import Coq.ZArith.BinInt.
Require Import Coq.Init.Byte.
Require Import coqutil.Word.Bitwidth.
Require Import coqutil.Tactics.rewr.
Require Import coqutil.Map.Interface.
Require Import bedrock2.SepAuto.
Require Import bedrock2.Array.
Require Import bedrock2.groundcbv.
Require Import bedrock2.TransferSepsOrder.
Require Import bedrock2.SepCalls.

Section SepLog.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word byte}.
  Context {word_ok: word.ok word} {mem_ok: map.ok mem}.

  Lemma array_app{E : Type}{elem: sep_predicate mem E}{sz: Z}:
    forall (xs ys: list E) (start : word),
      (start :-> xs ++ ys : array elem (word.of_Z sz)) =
      (sep (start :-> xs : array elem (word.of_Z sz))
           (word.add start (word.of_Z (sz * Z.of_nat (Datatypes.length xs))) :-> ys
             : array elem (word.of_Z sz))).
  Proof.
    intros.
    eapply iff1ToEq.
    etransitivity.
    1: eapply array_append.
    cancel.
    cancel_seps_at_indices 0%nat 0%nat. {
      f_equal. f_equal.
      destruct width_cases; ZnWords.
    }
    reflexivity.
  Qed.

  Lemma access_elem_in_array: forall a a' E (elem: sep_predicate mem E) sz fullLength,
      0 < sz < 2 ^ width ->
      let i := Z.to_nat (word.unsigned (word.sub a' a) / sz) in
      (word.unsigned (word.sub a' a) mod sz = 0 /\
       (* only here to make sure automation picks the right array *)
       (i < fullLength)%nat) ->
      forall vs vs1 v vs2,
        (* connected with /\ because it needs to be solved by considering both at once *)
        vs = vs1 ++ [v] ++ vs2 /\ List.length vs1 = i ->
        iff1 (a :-> vs : array elem (word.of_Z sz))
             (sep (a' :-> v : elem)
                  (seps [a :-> vs1 : array elem (word.of_Z sz);
                         word.add a (word.of_Z (sz * Z.of_nat (S i))) :-> vs2
                           : array elem (word.of_Z sz)])).
  Proof.
    unfold seps.
    intros. fwd.
    cbn [List.app].
    etransitivity.
    1: eapply array_append.
    cbn [Array.array].
    cancel.
    cancel_seps_at_indices 0%nat 0%nat. {
      f_equal. rewrite H1p1.
      destruct width_cases; ZnWords.
    }
    cancel_seps_at_indices 0%nat 0%nat. {
      f_equal. destruct width_cases; ZnWords.
    }
    reflexivity.
  Qed.

  Lemma access_subarray: forall a a' E (elem: sep_predicate mem E) sz n fullLength,
      0 < sz < 2 ^ width ->
      let i := Z.to_nat (word.unsigned (word.sub a' a) / sz) in
      (word.unsigned (word.sub a' a) mod sz = 0 /\
       (* only here to make sure automation picks the right array *)
       (i + n <= fullLength)%nat) ->
      forall vs vs1 vs2 vs3,
        vs = vs1 ++ vs2 ++ vs3 /\ List.length vs1 = i /\ List.length vs2 = n ->
        iff1 (a :-> vs : array elem (word.of_Z sz))
             (sep (a' :-> vs2 : array elem (word.of_Z sz))
                  (seps [a :-> vs1 : array elem (word.of_Z sz);
                         word.add a (word.of_Z (sz * Z.of_nat (i + n))) :-> vs3
                           : array elem (word.of_Z sz)])).
  Proof.
    intros.
    unfold seps.
    intros. fwd.
    rewrite 2array_append.
    cancel.
    cancel_seps_at_indices 0%nat 0%nat. {
      f_equal. rewrite H1p1.
      destruct width_cases; ZnWords.
    }
    cancel_seps_at_indices 0%nat 0%nat. {
      f_equal. destruct width_cases; ZnWords.
    }
    reflexivity.
  Qed.

  Lemma access_suffix: forall a a' E (elem: sep_predicate mem E) sz lenPrefix,
      0 < sz < 2 ^ width ->
      word.sub a' a = word.mul (word.of_Z sz) (word.of_Z (Z.of_nat lenPrefix)) ->
      forall vs vs1 vs2,
        vs = vs1 ++ vs2 /\ List.length vs1 = lenPrefix ->
        iff1 (a :-> vs : array elem (word.of_Z sz))
             (sep (a' :-> vs2 : array elem (word.of_Z sz))
                  (seps [a :-> vs1 : array elem (word.of_Z sz)])).
  Proof.
    intros. intros. fwd.
    rewrite array_app. cbn [seps].
    cancel. cbn [seps].
    match goal with
    | |- iff1 (?x :-> _ : _) _ => replace x with a'
    end.
    1: reflexivity.
    destruct width_cases; ZnWords.
  Qed.

  Lemma access_tail: forall a a' E (elem: sep_predicate mem E) sz,
      0 < sz < 2 ^ width ->
      word.sub a' a = word.of_Z sz ->
      forall v vs,
        iff1 (a :-> List.cons v vs : array elem (word.of_Z sz))
             (sep (a' :-> vs : array elem (word.of_Z sz))
                  (seps [a :-> v : elem])).
  Proof.
    intros. intros. cbn.
    cancel. cbn [seps].
    match goal with
    | |- iff1 (Array.array _ _ ?x _) _ => replace x with a'
    end.
    1: reflexivity.
    destruct width_cases; ZnWords.
  Qed.
End SepLog.

Ltac destruct_bool_vars :=
  repeat match goal with
         | H: context[if ?b then _ else _] |- _ =>
             is_var b; let t := type of b in constr_eq t bool; destruct b
         end.

Ltac concrete_list_length l :=
  lazymatch l with
  | cons ?h ?t => let r := concrete_list_length t in constr:(S r)
  | nil => constr:(O)
  | List.app ?l1 ?l2 =>
      let r1 := concrete_list_length l1 in
      let r2 := concrete_list_length l2 in
      let r := eval cbv in (r1 + r2)%nat in constr:(r)
  | List.map _ ?l' => concrete_list_length l'
  | List.unfoldn _ ?n _ =>
      let n' := groundcbv n in
      lazymatch isnatcst n' with
      | true => constr:(n')
      end
  | _ => let l' := eval unfold l in l in concrete_list_length l'
  end.

Ltac rewr_with_eq e :=
  lazymatch type of e with
  | ?LHS = _ => progress (pattern LHS; eapply rew_zoom_bw; [exact e|])
  end.

Ltac list_length_simpl_step_in_goal :=
  match goal with
  | |- context[@List.length ?T ?l] =>
      let n := concrete_list_length l in change (@List.length T l) with n
  | |- context[List.length (List.skipn ?n ?l)] => rewr_with_eq (List.length_skipn n l)
  | |- context[List.length (List.firstn ?n ?l)] => rewr_with_eq (List.firstn_length n l)
  | |- context[List.length (?l1 ++ ?l2)] => rewr_with_eq (List.app_length l1 l2)
  | |- context[List.length (?h :: ?t)] => rewr_with_eq (List.length_cons h t)
  | |- context[List.length (List.map ?f ?l)] => rewr_with_eq (List.map_length f l)
  | |- context[List.length (List.unfoldn ?step ?n ?start)] =>
      rewr_with_eq (List.length_unfoldn step n start)
  | |- context[List.length (List.repeat ?v ?n)] => rewr_with_eq (List.repeat_length v n)
  end.

Goal forall (l1 l2: list Z) (a: Z),
    a + Z.of_nat (List.length (l1 ++ l2)) =
    Z.of_nat (List.length l1) + Z.of_nat (List.length l2) + a.
Proof.
  intros. list_length_simpl_step_in_goal.
Abort.

(* Only rewrites below the line, because rewriting above the line should already
   have been done (or will be done later), but the goal below the line might be the
   sidecondition of another rewrite lemma that's being tried and thus did not yet
   appear anywhere in the context before.
   For example, trying to rewrite with List.firstn_all2 creates a sidecondition
   containing a (List.length l) that did not yet have any chance to get
   simplified.
   For efficiency, we only use rewrite lemmas here that don't have sideconditions
   themselves, and use the simplest possible homemade rewr_with_eq to avoid any
   unexpected performance pitfalls of Coq's existing rewrite tactics. *)
Ltac list_length_rewrites_without_sideconds_in_goal :=
  repeat list_length_simpl_step_in_goal.

Ltac listZnWords :=
  destruct_bool_vars;
  unfold List.upd, List.upds;
  list_length_rewrites_without_sideconds_in_goal;
  ZnWords.

Section WithA.
  Context {A: Type}.

  Lemma list_expose_nth{inhA: inhabited A}: forall (vs: list A) i,
      (i < List.length vs)%nat ->
      vs = List.firstn i vs ++ [List.nth i vs default] ++ List.skipn (S i) vs /\
        List.length (List.firstn i vs) = i.
  Proof.
    intros. rewrite List.firstn_nth_skipn by assumption.
    rewrite List.firstn_length_le by Lia.lia. auto.
  Qed.

  Lemma list_expose_subarray: forall (vs: list A) i n,
      (i + n <= List.length vs)%nat ->
      vs = List.firstn i vs ++ List.firstn n (List.skipn i vs) ++ List.skipn (i + n) vs /\
        List.length (List.firstn i vs) = i /\
        List.length (List.firstn n (List.skipn i vs)) = n.
  Proof.
    intros. list_length_rewrites_without_sideconds_in_goal. ssplit; [ | Lia.lia..].
    rewrite <- (List.firstn_skipn i vs) at 1. f_equal.
    rewrite <- (List.firstn_skipn n (List.skipn i vs)) at 1. f_equal.
    rewrite List.skipn_skipn. f_equal. apply Nat.add_comm.
  Qed.
End WithA.

Notation word_array := (array Scalars.scalar (word.of_Z 4)).

Ltac concrete_sz_bounds :=
  lazymatch goal with
  | |- 0 < ?sz < 2 ^ ?width =>
      lazymatch isZcst sz with
      | true => lazymatch isZcst width with
                | true => split; reflexivity
                end
      end
  end.

(* Hints in three different DBs indicating how to find the rewrite lemma,
   how to solve its sideconditions for the split direction, and how to solve its
   sideconditions for the merge direction: *)

(* split_sepclause_goal: *)

#[export] Hint Extern 1
  (split_sepclause (?a :-> ?vsAll : array ?elem (word.of_Z ?sz)) (?a' :-> _ : ?elem) _ _) =>
  unshelve (epose proof (access_elem_in_array a a' _ elem sz (List.length vsAll) _ _));
  [ concrete_sz_bounds | listZnWords | shelve ]
: split_sepclause_goal.

#[export] Hint Extern 1
  (split_sepclause (?a :-> ?vsAll : array ?elem (word.of_Z ?sz))
                   (?a' :-> ?vsPart : array ?elem (word.of_Z ?sz)) _ ?G) =>
  (* most likely, vsPart is still an evar (because it's universally quantified by the
     callee's correctness lemma), so we have to search for its desired length in G,
     but maybe it has a concrete structure (eg [?a; ?b; ?c]), in which case
     concrete_list_length can find that length *)
  let n := match G with
           | _ /\ ?C => match C with context[List.length vsPart = ?n] => n end
           | _ => concrete_list_length vsPart
           end in
  unshelve (epose proof (access_subarray a a' _ elem sz n (List.length vsAll) _ _));
  [ concrete_sz_bounds | listZnWords | shelve ]
: split_sepclause_goal.

#[export] Hint Extern 1 (split_sepclause (?a  :-> ?vs1 ++ ?vs2 : array ?elem (word.of_Z ?sz))
                                         (?a' :-> ?vs2 : array ?elem (word.of_Z ?sz)) _ _) =>
  unshelve (epose proof (access_suffix a a' _ elem sz (List.length vs1) _ _));
  [ concrete_sz_bounds | listZnWords | shelve ]
: split_sepclause_goal.

#[export] Hint Extern 1
  (split_sepclause (?a  :-> (_ :: ?vsTail) : array ?elem (word.of_Z ?sz))
                   (?a' :-> ?vsTail : array ?elem (word.of_Z ?sz)) _ _) =>
  unshelve (epose proof (access_tail a a' _ elem sz _ _));
  [ concrete_sz_bounds | listZnWords | shelve ]
: split_sepclause_goal.

(* split_sepclause_sidecond: *)

#[export] Hint Extern 1 (_ = ?l ++ [_] ++ _ /\ List.length ?l = _) =>
  eapply list_expose_nth; listZnWords
: split_sepclause_sidecond.

#[export] Hint Extern 1
 (_ = ?l1 ++ ?l2 ++ ?l3 /\ List.length ?l1 = _ /\ List.length ?l2 = _) =>
  eapply list_expose_subarray; listZnWords
: split_sepclause_sidecond.

(* merge_sepclause_sidecond: *)

#[export] Hint Extern 1 (@eq (list _) ?listL ?listR /\ @eq nat ?lenL ?lenR) =>
  assert_fails (has_evar lenL);
  assert_fails (has_evar lenR);
  is_evar listL; split; [ reflexivity | listZnWords ]
: merge_sepclause_sidecond.

(* TODO make more generic *)
#[export] Hint Extern 1 (?listL = ?listR1 ++ ?listR2 /\ ?lenR1 = _ /\ ?lenR2 = _) =>
  apply_in_hyps @map.getmany_of_list_length; rewrite List.length_unfoldn in *;
  is_evar listL; split; [ reflexivity | split; listZnWords ]
: merge_sepclause_sidecond.

(* TODO make more generic *)
#[export] Hint Extern 1
  (?listL = ?listR1 ++ ?listR2 ++ ?listR3 /\ ?lenR1 = ?i /\ ?lenR2 = ?n) =>
  apply_in_hyps @map.getmany_of_list_length; rewrite ?List.length_unfoldn in *;
  is_evar listL; split; [ reflexivity | split; listZnWords ]
: merge_sepclause_sidecond.

(* Hints to simplify/cleanup the expressions that were created by repeated
   splitting and merging of sep clauses: *)
#[export] Hint Rewrite
  List.firstn_all2
  List.skipn_all2
  List.firstn_eq_O
  List.skipn_eq_O
  Nat.min_l
  Nat.min_r
using (unfold List.upd, List.upds;
       list_length_rewrites_without_sideconds_in_goal;
       ZnWords)
: fwd_rewrites.