From iris.algebra Require Export cmra.
From stdpp Require Export list.
From iris.base_logic Require Import base_logic.
From iris.algebra Require Import updates local_updates.
Set Default Proof Using "Type".

Section cofe.
Context {A : ofeT}.
Implicit Types l : list A.

Instance list_dist : Dist (list A) := λ n, Forall2 (dist n).

Lemma list_dist_lookup n l1 l2 : l1 ≡{n}≡ l2 ↔ ∀ i, l1 !! i ≡{n}≡ l2 !! i.
Proof. setoid_rewrite dist_option_Forall2. apply Forall2_lookup. Qed.

Global Instance cons_ne : NonExpansive2 (@cons A) := _.
Global Instance app_ne : NonExpansive2 (@app A) := _.
Global Instance length_ne n : Proper (dist n ==> (=)) (@length A) := _.
Global Instance tail_ne : NonExpansive (@tail A) := _.
Global Instance take_ne : NonExpansive (@take A n) := _.
Global Instance drop_ne : NonExpansive (@drop A n) := _.
Global Instance list_lookup_ne i :
  NonExpansive (lookup (M:=list A) i).
Proof. intros ????. by apply dist_option_Forall2, Forall2_lookup. Qed.
Global Instance list_alter_ne n f i :
  Proper (dist n ==> dist n) f →
  Proper (dist n ==> dist n) (alter (M:=list A) f i) := _.
Global Instance list_insert_ne i :
  NonExpansive2 (insert (M:=list A) i) := _.
Global Instance list_inserts_ne i :
  NonExpansive2 (@list_inserts A i) := _.
Global Instance list_delete_ne i :
  NonExpansive (delete (M:=list A) i) := _.
Global Instance option_list_ne : NonExpansive (@option_list A).
Proof. intros ????; by apply Forall2_option_list, dist_option_Forall2. Qed.
Global Instance list_filter_ne n P `{∀ x, Decision (P x)} :
  Proper (dist n ==> iff) P →
  Proper (dist n ==> dist n) (filter (B:=list A) P) := _.
Global Instance replicate_ne :
  NonExpansive (@replicate A n) := _.
Global Instance reverse_ne : NonExpansive (@reverse A) := _.
Global Instance last_ne : NonExpansive (@last A).
Proof. intros ????; by apply dist_option_Forall2, Forall2_last. Qed.
Global Instance resize_ne n :
  NonExpansive2 (@resize A n) := _.

Definition list_ofe_mixin : OfeMixin (list A).
Proof.
  split.
  - intros l k. rewrite equiv_Forall2 -Forall2_forall.
    split; induction 1; constructor; intros; try apply equiv_dist; auto.
  - apply _.
  - rewrite /dist /list_dist. eauto using Forall2_impl, dist_S.
Qed.
Canonical Structure listC := OfeT (list A) list_ofe_mixin.

Program Definition list_chain
    (c : chain listC) (x : A) (k : nat) : chain A :=
  {| chain_car n := default x (c n !! k) |}.
Next Obligation. intros c x k n i ?. by rewrite /= (chain_cauchy c n i). Qed.
Definition list_compl `{Cofe A} : Compl listC := λ c,
  match c 0 with
  | [] => []
  | x :: _ => compl ∘ list_chain c x <$> seq 0 (length (c 0))
  end.
Global Program Instance list_cofe `{Cofe A} : Cofe listC :=
  {| compl := list_compl |}.
Next Obligation.
  intros ? n c; rewrite /compl /list_compl.
  destruct (c 0) as [|x l] eqn:Hc0 at 1.
  { by destruct (chain_cauchy c 0 n); auto with lia. }
  rewrite -(λ H, length_ne _ _ _ (chain_cauchy c 0 n H)); last lia.
  apply Forall2_lookup=> i. rewrite -dist_option_Forall2 list_lookup_fmap.
  destruct (decide (i < length (c n))); last first.
  { rewrite lookup_seq_ge ?lookup_ge_None_2; auto with lia. }
  rewrite lookup_seq //= (conv_compl n (list_chain c _ _)) /=.
  destruct (lookup_lt_is_Some_2 (c n) i) as [? Hcn]; first done.
  by rewrite Hcn.
Qed.

Global Instance list_ofe_discrete : OfeDiscrete A → OfeDiscrete listC.
Proof. induction 2; constructor; try apply (discrete _); auto. Qed.

Global Instance nil_discrete : Discrete (@nil A).
Proof. inversion_clear 1; constructor. Qed.
Global Instance cons_discrete x l : Discrete x → Discrete l → Discrete (x :: l).
Proof. intros ??; inversion_clear 1; constructor; by apply discrete. Qed.
End cofe.

Arguments listC : clear implicits.

(** Functor *)
Lemma list_fmap_ext_ne {A} {B : ofeT} (f g : A → B) (l : list A) n :
  (∀ x, f x ≡{n}≡ g x) → f <$> l ≡{n}≡ g <$> l.
Proof. intros Hf. by apply Forall2_fmap, Forall_Forall2, Forall_true. Qed.
Instance list_fmap_ne {A B : ofeT} (f : A → B) n:
  Proper (dist n ==> dist n) f → Proper (dist n ==> dist n) (fmap (M:=list) f).
Proof. intros Hf l k ?; by eapply Forall2_fmap, Forall2_impl; eauto. Qed.
Definition listC_map {A B} (f : A -n> B) : listC A -n> listC B :=
  CofeMor (fmap f : listC A → listC B).
Instance listC_map_ne A B : NonExpansive (@listC_map A B).
Proof. intros n f g ? l. by apply list_fmap_ext_ne. Qed.

Program Definition listCF (F : cFunctor) : cFunctor := {|
  cFunctor_car A B := listC (cFunctor_car F A B);
  cFunctor_map A1 A2 B1 B2 fg := listC_map (cFunctor_map F fg)
|}.
Next Obligation.
  by intros F A1 A2 B1 B2 n f g Hfg; apply listC_map_ne, cFunctor_ne.
Qed.
Next Obligation.
  intros F A B x. rewrite /= -{2}(list_fmap_id x).
  apply list_fmap_equiv_ext=>y. apply cFunctor_id.
Qed.
Next Obligation.
  intros F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -list_fmap_compose.
  apply list_fmap_equiv_ext=>y; apply cFunctor_compose.
Qed.

Instance listCF_contractive F :
  cFunctorContractive F → cFunctorContractive (listCF F).
Proof.
  by intros ? A1 A2 B1 B2 n f g Hfg; apply listC_map_ne, cFunctor_contractive.
Qed.

(* CMRA *)
Section cmra.
  Context {A : ucmraT}.
  Implicit Types l : list A.
  Local Arguments op _ _ !_ !_ / : simpl nomatch.

  Instance list_op : Op (list A) :=
    fix go l1 l2 := let _ : Op _ := @go in
    match l1, l2 with
    | [], _ => l2
    | _, [] => l1
    | x :: l1, y :: l2 => x ⋅ y :: l1 ⋅ l2
    end.
  Instance list_pcore : PCore (list A) := λ l, Some (core <$> l).

  Instance list_valid : Valid (list A) := Forall (λ x, ✓ x).
  Instance list_validN : ValidN (list A) := λ n, Forall (λ x, ✓{n} x).

  Lemma cons_valid l x : ✓ (x :: l) ↔ ✓ x ∧ ✓ l.
  Proof. apply Forall_cons. Qed.
  Lemma cons_validN n l x : ✓{n} (x :: l) ↔ ✓{n} x ∧ ✓{n} l.
  Proof. apply Forall_cons. Qed.
  Lemma app_valid l1 l2 : ✓ (l1 ++ l2) ↔ ✓ l1 ∧ ✓ l2.
  Proof. apply Forall_app. Qed.
  Lemma app_validN n l1 l2 : ✓{n} (l1 ++ l2) ↔ ✓{n} l1 ∧ ✓{n} l2.
  Proof. apply Forall_app. Qed.

  Lemma list_lookup_valid l : ✓ l ↔ ∀ i, ✓ (l !! i).
  Proof.
    rewrite {1}/valid /list_valid Forall_lookup; split.
    - intros Hl i. by destruct (l !! i) as [x|] eqn:?; [apply (Hl i)|].
    - intros Hl i x Hi. move: (Hl i); by rewrite Hi.
  Qed.
  Lemma list_lookup_validN n l : ✓{n} l ↔ ∀ i, ✓{n} (l !! i).
  Proof.
    rewrite {1}/validN /list_validN Forall_lookup; split.
    - intros Hl i. by destruct (l !! i) as [x|] eqn:?; [apply (Hl i)|].
    - intros Hl i x Hi. move: (Hl i); by rewrite Hi.
  Qed.
  Lemma list_lookup_op l1 l2 i : (l1 ⋅ l2) !! i = l1 !! i ⋅ l2 !! i.
  Proof.
    revert i l2. induction l1 as [|x l1]; intros [|i] [|y l2];
      by rewrite /= ?left_id_L ?right_id_L.
  Qed.
  Lemma list_lookup_core l i : core l !! i = core (l !! i).
  Proof.
    rewrite /core /= list_lookup_fmap.
    destruct (l !! i); by rewrite /= ?Some_core.
  Qed.

  Lemma list_lookup_included l1 l2 : l1 ≼ l2 ↔ ∀ i, l1 !! i ≼ l2 !! i.
  Proof.
    split.
    { intros [l Hl] i. exists (l !! i). by rewrite Hl list_lookup_op. }
    revert l1. induction l2 as [|y l2 IH]=>-[|x l1] Hl.
    - by exists [].
    - destruct (Hl 0) as [[z|] Hz]; inversion Hz.
    - by exists (y :: l2).
    - destruct (IH l1) as [l3 ?]; first (intros i; apply (Hl (S i))).
      destruct (Hl 0) as [[z|] Hz]; inversion_clear Hz; simplify_eq/=.
      + exists (z :: l3); by constructor.
      + exists (core x :: l3); constructor; by rewrite ?cmra_core_r.
  Qed.

  Definition list_cmra_mixin : CmraMixin (list A).
  Proof.
    apply cmra_total_mixin.
    - eauto.
    - intros n l l1 l2; rewrite !list_dist_lookup=> Hl i.
      by rewrite !list_lookup_op Hl.
    - intros n l1 l2 Hl; by rewrite /core /= Hl.
    - intros n l1 l2; rewrite !list_dist_lookup !list_lookup_validN=> Hl ? i.
      by rewrite -Hl.
    - intros l. rewrite list_lookup_valid. setoid_rewrite list_lookup_validN.
      setoid_rewrite cmra_valid_validN. naive_solver.
    - intros n x. rewrite !list_lookup_validN. auto using cmra_validN_S.
    - intros l1 l2 l3; rewrite list_equiv_lookup=> i.
      by rewrite !list_lookup_op assoc.
    - intros l1 l2; rewrite list_equiv_lookup=> i.
      by rewrite !list_lookup_op comm.
    - intros l; rewrite list_equiv_lookup=> i.
      by rewrite list_lookup_op list_lookup_core cmra_core_l.
    - intros l; rewrite list_equiv_lookup=> i.
      by rewrite !list_lookup_core cmra_core_idemp.
    - intros l1 l2; rewrite !list_lookup_included=> Hl i.
      rewrite !list_lookup_core. by apply cmra_core_mono.
    - intros n l1 l2. rewrite !list_lookup_validN.
      setoid_rewrite list_lookup_op. eauto using cmra_validN_op_l.
    - intros n l.
      induction l as [|x l IH]=> -[|y1 l1] [|y2 l2] Hl Heq;
        (try by exfalso; inversion Heq).
      + by exists [], [].
      + exists [], (x :: l); inversion Heq; by repeat constructor.
      + exists (x :: l), []; inversion Heq; by repeat constructor.
      + destruct (IH l1 l2) as (l1'&l2'&?&?&?),
          (cmra_extend n x y1 y2) as (y1'&y2'&?&?&?);
          [by inversion_clear Heq; inversion_clear Hl..|].
        exists (y1' :: l1'), (y2' :: l2'); repeat constructor; auto.
  Qed.
  Canonical Structure listR := CmraT (list A) list_cmra_mixin.

  Global Instance list_unit : Unit (list A) := [].
  Definition list_ucmra_mixin : UcmraMixin (list A).
  Proof.
    split.
    - constructor.
    - by intros l.
    - by constructor.
  Qed.
  Canonical Structure listUR := UcmraT (list A) list_ucmra_mixin.

  Global Instance list_cmra_discrete : CmraDiscrete A → CmraDiscrete listR.
  Proof.
    split; [apply _|]=> l; rewrite list_lookup_valid list_lookup_validN=> Hl i.
    by apply cmra_discrete_valid.
  Qed.

  Global Instance list_core_id l : (∀ x : A, CoreId x) → CoreId l.
  Proof.
    intros ?; constructor; apply list_equiv_lookup=> i.
    by rewrite list_lookup_core (core_id_core (l !! i)).
  Qed.

  (** Internalized properties *)
  Lemma list_equivI {M} l1 l2 : l1 ≡ l2 ⊣⊢ (∀ i, l1 !! i ≡ l2 !! i : uPred M).
  Proof. uPred.unseal; constructor=> n x ?. apply list_dist_lookup. Qed.
  Lemma list_validI {M} l : ✓ l ⊣⊢ (∀ i, ✓ (l !! i) : uPred M).
  Proof. uPred.unseal; constructor=> n x ?. apply list_lookup_validN. Qed.
End cmra.

Arguments listR : clear implicits.
Arguments listUR : clear implicits.

Instance list_singletonM {A : ucmraT} : SingletonM nat A (list A) := λ n x,
  replicate n ε ++ [x].

Section properties.
  Context {A : ucmraT}.
  Implicit Types l : list A.
  Implicit Types x y z : A.
  Local Arguments op _ _ !_ !_ / : simpl nomatch.
  Local Arguments cmra_op _ !_ !_ / : simpl nomatch.
  Local Arguments ucmra_op _ !_ !_ / : simpl nomatch.

  Lemma list_lookup_opM l mk i : (l ⋅? mk) !! i = l !! i ⋅ (mk ≫= (!! i)).
  Proof. destruct mk; by rewrite /= ?list_lookup_op ?right_id_L. Qed.

  Global Instance list_op_nil_l : LeftId (=) (@nil A) op.
  Proof. done. Qed.
  Global Instance list_op_nil_r : RightId (=) (@nil A) op.
  Proof. by intros []. Qed.

  Lemma list_op_app l1 l2 l3 :
    (l1 ++ l3) ⋅ l2 = (l1 ⋅ take (length l1) l2) ++ (l3 ⋅ drop (length l1) l2).
  Proof.
    revert l2 l3.
    induction l1 as [|x1 l1]=> -[|x2 l2] [|x3 l3]; f_equal/=; auto.
  Qed.
  Lemma list_op_app_le l1 l2 l3 :
    length l2 ≤ length l1 → (l1 ++ l3) ⋅ l2 = (l1 ⋅ l2) ++ l3.
  Proof. intros ?. by rewrite list_op_app take_ge // drop_ge // right_id_L. Qed.

  Lemma list_lookup_validN_Some n l i x : ✓{n} l → l !! i ≡{n}≡ Some x → ✓{n} x.
  Proof. move=> /list_lookup_validN /(_ i)=> Hl Hi; move: Hl. by rewrite Hi. Qed.
  Lemma list_lookup_valid_Some l i x : ✓ l → l !! i ≡ Some x → ✓ x.
  Proof. move=> /list_lookup_valid /(_ i)=> Hl Hi; move: Hl. by rewrite Hi. Qed.

  Lemma list_op_length l1 l2 : length (l1 ⋅ l2) = max (length l1) (length l2).
  Proof. revert l2. induction l1; intros [|??]; f_equal/=; auto. Qed.

  Lemma replicate_valid n (x : A) : ✓ x → ✓ replicate n x.
  Proof. apply Forall_replicate. Qed.
  Global Instance list_singletonM_ne i :
    NonExpansive (@list_singletonM A i).
  Proof. intros n l1 l2 ?. apply Forall2_app; by repeat constructor. Qed.
  Global Instance list_singletonM_proper i :
    Proper ((≡) ==> (≡)) (list_singletonM i) := ne_proper _.

  Lemma elem_of_list_singletonM i z x : z ∈ ({[i := x]} : list A) → z = ε ∨ z = x.
  Proof.
    rewrite elem_of_app elem_of_list_singleton elem_of_replicate. naive_solver.
  Qed.
  Lemma list_lookup_singletonM i x : ({[ i := x ]} : list A) !! i = Some x.
  Proof. induction i; by f_equal/=. Qed.
  Lemma list_lookup_singletonM_ne i j x :
    i ≠ j →
    ({[ i := x ]} : list A) !! j = None ∨ ({[ i := x ]} : list A) !! j = Some ε.
  Proof. revert j; induction i; intros [|j]; naive_solver auto with lia. Qed.
  Lemma list_singletonM_validN n i x : ✓{n} ({[ i := x ]} : list A) ↔ ✓{n} x.
  Proof.
    rewrite list_lookup_validN. split.
    { move=> /(_ i). by rewrite list_lookup_singletonM. }
    intros Hx j; destruct (decide (i = j)); subst.
    - by rewrite list_lookup_singletonM.
    - destruct (list_lookup_singletonM_ne i j x) as [Hi|Hi]; first done;
        rewrite Hi; by try apply (ucmra_unit_validN (A:=A)).
  Qed.
  Lemma list_singleton_valid  i x : ✓ ({[ i := x ]} : list A) ↔ ✓ x.
  Proof.
    rewrite !cmra_valid_validN. by setoid_rewrite list_singletonM_validN.
  Qed.
  Lemma list_singletonM_length i x : length {[ i := x ]} = S i.
  Proof.
    rewrite /singletonM /list_singletonM app_length replicate_length /=; lia.
  Qed.

  Lemma list_core_singletonM i (x : A) : core {[ i := x ]} ≡ {[ i := core x ]}.
  Proof.
    rewrite /singletonM /list_singletonM.
    by rewrite {1}/core /= fmap_app fmap_replicate (core_id_core ∅).
  Qed.
  Lemma list_op_singletonM i (x y : A) :
    {[ i := x ]} ⋅ {[ i := y ]} ≡ {[ i := x ⋅ y ]}.
  Proof.
    rewrite /singletonM /list_singletonM /=.
    induction i; constructor; rewrite ?left_id; auto.
  Qed.
  Lemma list_alter_singletonM f i x :
    alter f i ({[i := x]} : list A) = {[i := f x]}.
  Proof.
    rewrite /singletonM /list_singletonM /=. induction i; f_equal/=; auto.
  Qed.
  Global Instance list_singleton_core_id i (x : A) :
    CoreId x → CoreId {[ i := x ]}.
  Proof. by rewrite !core_id_total list_core_singletonM=> ->. Qed.

  (* Update *)
  Lemma list_singleton_updateP (P : A → Prop) (Q : list A → Prop) x :
    x ~~>: P → (∀ y, P y → Q [y]) → [x] ~~>: Q.
  Proof.
    rewrite !cmra_total_updateP=> Hup HQ n lf /list_lookup_validN Hv.
    destruct (Hup n (default ε (lf !! 0))) as (y&?&Hv').
    { move: (Hv 0). by destruct lf; rewrite /= ?right_id. }
    exists [y]; split; first by auto.
    apply list_lookup_validN=> i.
    move: (Hv i) Hv'. by destruct i, lf; rewrite /= ?right_id.
  Qed.
  Lemma list_singleton_updateP' (P : A → Prop) x :
    x ~~>: P → [x] ~~>: λ k, ∃ y, k = [y] ∧ P y.
  Proof. eauto using list_singleton_updateP. Qed.
  Lemma list_singleton_update x y : x ~~> y → [x] ~~> [y].
  Proof.
    rewrite !cmra_update_updateP; eauto using list_singleton_updateP with subst.
  Qed.

  Lemma app_updateP (P1 P2 Q : list A → Prop) l1 l2 :
    l1 ~~>: P1 → l2 ~~>: P2 →
    (∀ k1 k2, P1 k1 → P2 k2 → length l1 = length k1 ∧ Q (k1 ++ k2)) →
    l1 ++ l2 ~~>: Q.
  Proof.
    rewrite !cmra_total_updateP=> Hup1 Hup2 HQ n lf.
    rewrite list_op_app app_validN=> -[??].
    destruct (Hup1 n (take (length l1) lf)) as (k1&?&?); auto.
    destruct (Hup2 n (drop (length l1) lf)) as (k2&?&?); auto.
    exists (k1 ++ k2). rewrite list_op_app app_validN.
    by destruct (HQ k1 k2) as [<- ?].
  Qed.
  Lemma app_update l1 l2 k1 k2 :
    length l1 = length k1 →
    l1 ~~> k1 → l2 ~~> k2 → l1 ++ l2 ~~> k1 ++ k2.
  Proof. rewrite !cmra_update_updateP; eauto using app_updateP with subst. Qed.

  Lemma cons_updateP (P1 : A → Prop) (P2 Q : list A → Prop) x l :
    x ~~>: P1 → l ~~>: P2 → (∀ y k, P1 y → P2 k → Q (y :: k)) → x :: l ~~>: Q.
  Proof.
    intros. eapply (app_updateP _ _ _ [x]);
      naive_solver eauto using list_singleton_updateP'.
  Qed.
  Lemma cons_updateP' (P1 : A → Prop) (P2 : list A → Prop) x l :
    x ~~>: P1 → l ~~>: P2 → x :: l ~~>: λ k, ∃ y k', k = y :: k' ∧ P1 y ∧ P2 k'.
  Proof. eauto 10 using cons_updateP. Qed.
  Lemma cons_update x y l k : x ~~> y → l ~~> k → x :: l ~~> y :: k.
  Proof. rewrite !cmra_update_updateP; eauto using cons_updateP with subst. Qed.

  Lemma list_middle_updateP (P : A → Prop) (Q : list A → Prop) l1 x l2 :
    x ~~>: P → (∀ y, P y → Q (l1 ++ y :: l2)) → l1 ++ x :: l2 ~~>: Q.
  Proof.
    intros. eapply app_updateP.
    - by apply cmra_update_updateP.
    - by eapply cons_updateP', cmra_update_updateP.
    - naive_solver.
  Qed.
  Lemma list_middle_update l1 l2 x y : x ~~> y → l1 ++ x :: l2 ~~> l1 ++ y :: l2.
  Proof.
    rewrite !cmra_update_updateP=> ?; eauto using list_middle_updateP with subst.
  Qed.

(* FIXME
  Lemma list_middle_local_update l1 l2 x y ml :
    x ~l~> y @ ml ≫= (!! length l1) →
    l1 ++ x :: l2 ~l~> l1 ++ y :: l2 @ ml.
  Proof.
    intros [Hxy Hxy']; split.
    - intros n; rewrite !list_lookup_validN=> Hl i; move: (Hl i).
      destruct (lt_eq_lt_dec i (length l1)) as [[?|?]|?]; subst.
      + by rewrite !list_lookup_opM !lookup_app_l.
      + rewrite !list_lookup_opM !list_lookup_middle // !Some_op_opM; apply (Hxy n).
      + rewrite !(cons_middle _ l1 l2) !assoc.
        rewrite !list_lookup_opM !lookup_app_r !app_length //=; lia.
    - intros n mk; rewrite !list_lookup_validN !list_dist_lookup => Hl Hl' i.
      move: (Hl i) (Hl' i).
      destruct (lt_eq_lt_dec i (length l1)) as [[?|?]|?]; subst.
      + by rewrite !list_lookup_opM !lookup_app_l.
      + rewrite !list_lookup_opM !list_lookup_middle // !Some_op_opM !inj_iff.
        apply (Hxy' n).
      + rewrite !(cons_middle _ l1 l2) !assoc.
        rewrite !list_lookup_opM !lookup_app_r !app_length //=; lia.
  Qed.
  Lemma list_singleton_local_update i x y ml :
    x ~l~> y @ ml ≫= (!! i) → {[ i := x ]} ~l~> {[ i := y ]} @ ml.
  Proof. intros; apply list_middle_local_update. by rewrite replicate_length. Qed.
*)
End properties.

(** Functor *)
Instance list_fmap_cmra_morphism {A B : ucmraT} (f : A → B)
  `{!CmraMorphism f} : CmraMorphism (fmap f : list A → list B).
Proof.
  split; try apply _.
  - intros n l. rewrite !list_lookup_validN=> Hl i. rewrite list_lookup_fmap.
    by apply (cmra_morphism_validN (fmap f : option A → option B)).
  - intros l. apply Some_proper. rewrite -!list_fmap_compose.
    apply list_fmap_equiv_ext, cmra_morphism_core, _.
  - intros l1 l2. apply list_equiv_lookup=>i.
    by rewrite list_lookup_op !list_lookup_fmap list_lookup_op cmra_morphism_op.
Qed.

Program Definition listURF (F : urFunctor) : urFunctor := {|
  urFunctor_car A B := listUR (urFunctor_car F A B);
  urFunctor_map A1 A2 B1 B2 fg := listC_map (urFunctor_map F fg)
|}.
Next Obligation.
  by intros F ???? n f g Hfg; apply listC_map_ne, urFunctor_ne.
Qed.
Next Obligation.
  intros F A B x. rewrite /= -{2}(list_fmap_id x).
  apply list_fmap_equiv_ext=>y. apply urFunctor_id.
Qed.
Next Obligation.
  intros F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -list_fmap_compose.
  apply list_fmap_equiv_ext=>y; apply urFunctor_compose.
Qed.

Instance listURF_contractive F :
  urFunctorContractive F → urFunctorContractive (listURF F).
Proof.
  by intros ? A1 A2 B1 B2 n f g Hfg; apply listC_map_ne, urFunctor_contractive.
Qed.


(** * Theorems for [ITree.Basics.Function] *)

(* begin hide *)
From Coq Require Import
     Morphisms.

From ITree Require Import
     Basics.Basics
     Basics.Category
     Basics.Function.

Import CatNotations.
Local Open Scope cat_scope.
(* end hide *)

#[global]
 Instance subrelation_eeq_eqeq {A B} :
  @subrelation (A -> B) eq2 (@eq A ==> @eq B)%signature.
Proof. congruence. Qed.

#[global]
 Instance Equivalence_eeq {A B} : @Equivalence (Fun A B) eq2.
Proof. constructor; congruence. Qed.

#[global]
 Instance Proper_cat {A B C : Type} :
  @Proper (Fun A B -> Fun B C -> Fun A C) (eq2 ==> eq2 ==> eq2) cat.
Proof. cbv; congruence. Qed.

#[global]
 Instance cat_Fun_CatIdL : CatIdL Fun.
Proof. red; reflexivity. Qed.

#[global]
 Instance cat_Fun_CatIdR : CatIdR Fun.
Proof. red; reflexivity. Qed.

#[global]
 Instance cat_Fun_assoc : CatAssoc Fun.
Proof. red; reflexivity. Qed.

#[global]
 Instance InitialObject_void : InitialObject Fun void :=
  fun _ _ v => match v : void with end.

#[global]
 Instance eeq_case_sum {A B C} :
  @Proper (Fun A C -> Fun B C -> Fun (A + B) C)
          (eq2 ==> eq2 ==> eq2) case_.
Proof. cbv; intros; subst; destruct _; auto. Qed.

#[global]
 Instance Category_Fun : Category Fun.
Proof.
  constructor; typeclasses eauto.
Qed.

#[global]
 Instance Coproduct_Fun : Coproduct Fun sum.
Proof.
  constructor.
  - intros a b c f g.
    cbv; reflexivity.
  - intros a b c f g.
    cbv; reflexivity.
  - intros a b c f g fg Hf Hg [x | y]; cbv in *; auto.
  - typeclasses eauto.
Qed.


Require Import VST.veric.rmaps.
Require Import VST.concurrency.conclib.
Require Import VST.progs.conc_queue.
Require Import SetoidList.
Require Import VST.floyd.library.

Set Bullet Behavior "Strict Subproofs".

Require Export VST.floyd.Funspec_old_Notation.
#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition tqueue := Tstruct _queue noattr.
Definition tqueue_t := Tstruct _queue_t noattr.

Definition MAX := 10.

(* Ghost histories in the style of
   History-based Verification of Functional Behaviour of Concurrent Programs,
   Blom, Huisman, and Zharieva-Stojanovski (VerCors)
   Twente tech report, 2015 *)

Inductive hist_el {A} := QAdd (p : val) (v : A) | QRem (p : val) (v : A).
Notation hist A := (list (@hist_el A)).
Fixpoint consistent {A} (h : hist A) a b :=
  match h with
  | [] => a = b
  | QAdd p v :: h' => consistent h' (a ++ [(p, v)]) b
  | QRem p v :: h' => match a with [] => False | v' :: q' => v' = (p, v) /\ consistent h' q' b end
  end.
Notation feasible h := (exists b, consistent h [] b).

Parameter ghost : forall (sh : share) {t} (f : share * hist t) (p : val), mpred.
(*Parameter ghost_factory : mpred.

Axiom ghost_alloc : forall Espec D P Q R C P',
  semax(Espec := Espec) D (PROPx P (LOCALx Q (SEPx (ghost_factory :: R)))) C P' ->
  semax D (PROPx P (LOCALx Q (SEPx R))) C P'.
Axiom new_ghost : forall Espec D P Q R C P' t v,
  semax(Espec := Espec) D (PROPx P (LOCALx Q (SEPx (ghost_factory ::
    (EX p : val, ghost Tsh t v p) :: R)))) C P' ->
  semax D (PROPx P (LOCALx Q (SEPx (ghost_factory :: R)))) C P'.
Axiom alloc_conflict : ghost_factory * ghost_factory |-- FF.*)

(* In effect, we want two different ways of splitting/combining history shares.
   One combines the histories as well; the other guarantees injectivity on histories. *)

(* This is definitely unsound, since we can repeat it. *)
Axiom new_ghost : forall {CS : compspecs} {Espec : OracleKind} D P Q R C P' t' t v p,
  semax D (PROPx P (LOCALx Q (SEPx (ghost Tsh (Tsh, ([] : hist t')) p :: data_at Tsh t v p :: R)))) C P' ->
  semax D (PROPx P (LOCALx Q (SEPx (data_at Tsh t v p :: R)))) C P'.

Inductive list_incl {A} : list A -> list A -> Prop :=
| incl_nil l : list_incl [] l
| incl_skip l1 a l2 (Hincl : list_incl l1 l2) : list_incl l1 (a :: l2)
| incl_cons a l1 l2 (Hincl : list_incl l1 l2) : list_incl (a :: l1) (a :: l2).
Hint Constructors list_incl.

Inductive interleave {A} : list (list A) -> list A -> Prop :=
| interleave_nil ls (Hnil : Forall (fun l => l = []) ls) : interleave ls []
| interleave_cons ls i a l l' (Hcons : Znth i ls [] = a :: l) (Hrest : interleave (upd_Znth i ls l) l') :
    interleave ls (a :: l').

Axiom ghost_share_join : forall sh1 sh2 sh t (h1 h2 : hist t) p, sepalg.join sh1 sh2 Tsh -> list_incl h1 h2 ->
  ghost sh1 (sh, h1) p * ghost sh2 (Tsh, h2) p = ghost Tsh (Tsh, h2) p.
Axiom hist_share_join : forall sh sh1 sh2 sh' t (h1 h2 : hist t) p, sepalg.join sh1 sh2 sh' ->
  ghost sh (sh1, h1) p * ghost sh (sh2, h2) p = EX h' : hist t, !!(interleave [h1; h2] h') && ghost sh (sh', h') p.
Axiom hist_add : forall {CS : compspecs} {Espec : OracleKind} D P Q R C P' t (h : hist t) e p,
  feasible (h ++ [e]) ->
  semax D (PROPx P (LOCALx Q (SEPx (ghost Tsh (Tsh, h ++ [e]) p :: R)))) C P' ->
  semax D (PROPx P (LOCALx Q (SEPx (ghost Tsh (Tsh, h) p :: R)))) C P'.
Axiom ghost_inj : forall sh1 sh2 sh t (h1 h2 : hist t) p, ghost sh1 (sh, h1) p * ghost sh2 (Tsh, h2) p
  |-- !!(list_incl h1 h2).
Axiom ghost_inj_Tsh : forall sh1 sh2 t (h1 h2 : hist t) p, ghost sh1 (Tsh, h1) p * ghost sh2 (Tsh, h2) p
  |-- !!(h1 = h2).
(* Should this be an axiom? *)
Axiom ghost_feasible : forall sh t (h : hist t) p, ghost sh (Tsh, h) p |-- !!(feasible h).

Axiom ghost_conflict : forall sh1 sh2 t (v1 v2 : share * hist t) p,
  ghost sh1 v1 p * ghost sh2 v2 p |-- !!sepalg.joins sh1 sh2.

(* We would prefer to let the queue hold arbitrarily complex data, not necessarily associated with a C type.
   For now, the mpred embedding can't handle type application, so we have to default to data_at instead of
   taking a general predicate for the queue, and that means the data is always of a C type. *)
Definition q_lock_pred' (t : type) P p (vals : list (val * reptype t)) head (addc remc : val) lock gsh h :=
  !!(Zlength vals <= MAX /\ 0 <= head < MAX /\ consistent h [] vals) &&
  (data_at Tsh tqueue (rotate (complete MAX (map fst vals)) head MAX, (vint (Zlength vals),
                      (vint head, (vint ((head + Zlength vals) mod MAX), (addc, remc))))) p *
   cond_var Tsh addc * cond_var Tsh remc * malloc_token Tsh (sizeof tqueue_t) p *
   malloc_token Tsh (sizeof tcond) addc * malloc_token Tsh (sizeof tcond) remc *
   malloc_token Tsh (sizeof tlock) lock * ghost gsh (Tsh, h) p *
   fold_right sepcon emp (map (fun x => let '(p, v) := x in
     !!(P v) && (data_at Tsh t v p * malloc_token Tsh (sizeof t) p)) vals)).

Definition q_lock_pred A P p lock gsh := EX vals : list (val * reptype A), EX head : Z,
  EX addc : val, EX remc : val, EX h : hist _, q_lock_pred' A P p vals head addc remc lock gsh h.

Definition lqueue lsh t P p lock gsh1 gsh2 (h : hist (reptype t)) :=
  !!(sepalg.join gsh1 gsh2 Tsh /\ field_compatible tqueue_t [] p) &&
  (field_at lsh tqueue_t [StructField _lock] lock p *
   lock_inv lsh lock (q_lock_pred t P p lock gsh2) * ghost gsh1 (lsh, h) p).

Lemma lqueue_feasible : forall A P p lock gsh1 gsh2 (h : hist (reptype A)),
  lqueue Tsh A P p lock gsh1 gsh2 h = !!(feasible h) && lqueue Tsh A P p lock gsh1 gsh2 h.
Proof.
  intros; rewrite andp_comm; apply add_andp.
  unfold lqueue; Intros.
  setoid_rewrite add_andp with (P0 := ghost gsh1 (Tsh, h) p); [|apply ghost_feasible].
  Intros; apply prop_right; auto.
Qed.

(*Definition PredType := ArrowType (ConstType val) (ArrowType (DependentType 0) Mpred).
Definition q_new_type := ProdType (ConstType (share * share)) PredType.

Program Definition q_new_spec' := mk_funspec (nil, tptr tqueue_t) cc_default q_new_type
  (fun (ts: list Type) (x: share * share * (val -> nth 0 ts unit -> mpred)) => let '(gsh1, gsh2, P) := x in
    PROP (sepalg.join gsh1 gsh2 Tsh)
    LOCAL ()
    SEP ())
  (fun (ts: list Type) (x: share * share * (val -> nth 0 ts unit -> mpred)) => let '(gsh1, gsh2, P) := x in
    EX newq : val, EX lock : val,
    PROP ()
    LOCAL (temp ret_temp newq)
    SEP (lqueue Tsh (nth 0 ts unit) P newq lock gsh1 gsh2 [])) _ _.
Next Obligation.
Proof.
  replace _ with (fun (ts : list Type) (x : share * share * (val -> nth 0 ts unit -> mpred)) rho =>
    PROP (let '(gsh1, gsh2, P) := x in sepalg.join gsh1 gsh2 Tsh) LOCAL () SEP () rho).
  apply (PROP_LOCAL_SEP_super_non_expansive q_new_type [fun _ => _] [] []); repeat constructor.
  hnf; intros.
  destruct x as ((?, ?), ?); auto.
  { repeat extensionality.
    destruct x0 as ((?, ?), ?); auto. }
Qed.
Next Obligation.
Proof.

(* How do we prove super_non_expansive of an existential? Use exp_approx from veric/seplog / veric/Clight_seplog. *)
Admitted.*)

Definition surely_malloc_spec' :=
   WITH n:Z
   PRE [ _n OF tuint ]
       PROP (0 <= n <= Int.max_unsigned)
       LOCAL (temp _n (Vint (Int.repr n)))
       SEP ()
    POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP (malloc_token Tsh n p * memory_block Tsh n p).
Definition surely_malloc_spec prog := DECLARE (ext_link_prog prog "surely_malloc") surely_malloc_spec'.

Definition q_new_spec' :=
  WITH Q : {t : type & reptype t -> Prop}, gsh1 : share, gsh2 : share
  PRE [ ]
   PROP (sepalg.join gsh1 gsh2 Tsh)
   LOCAL ()
   SEP ()
  POST [ tptr tqueue_t ]
   let (t, P) := Q in
   EX newq : val, EX lock : val,
   PROP () LOCAL (temp ret_temp newq)
   SEP (lqueue Tsh t P newq lock gsh1 gsh2 []).
Definition q_new_spec prog := DECLARE (ext_link_prog prog "q_new") q_new_spec'.

Notation q_new_args t P := (existT (fun t => @reptype CompSpecs t -> Prop) t P).

Definition q_del_spec' :=
  WITH Q : {t : type & ((reptype t -> Prop) * hist (reptype t))%type}, p : val, lock : val, gsh1 : share, gsh2 : share
  PRE [ _tgt OF (tptr tqueue_t) ]
   let (t, R) := Q in let (P, h) := R in
   PROP (consistent h [] [])
   LOCAL (temp _tgt p)
   SEP (lqueue Tsh t P p lock gsh1 gsh2 h)
  POST [ tvoid ]
   PROP ()
   LOCAL ()
   SEP ().
Definition q_del_spec prog := DECLARE (ext_link_prog prog "q_del") q_del_spec'.

Notation q_rem_args t P h := (existT (fun t => ((@reptype CompSpecs t -> Prop) * hist (@reptype CompSpecs t))%type) t (P, h)).

Definition q_add_spec' :=
  WITH sh : share, Q : {t : type & ((reptype t -> Prop) * hist (reptype t) * reptype t)%type}, p : val, lock : val,
       e : val, gsh1 : share, gsh2 : share
  PRE [ _tgt OF (tptr tqueue_t), _r OF (tptr tvoid) ]
   let (t, R) := Q in let (S, v) := R in let (P, h) := S in
   PROP (readable_share sh; P v)
   LOCAL (temp _tgt p; temp _r e)
   SEP (lqueue sh t P p lock gsh1 gsh2 h; data_at Tsh t v e; malloc_token Tsh (sizeof t) e)
  POST [ tvoid ]
   let (t, R) := Q in let (S, v) := R in let (P, h) := S in
   PROP ()
   LOCAL ()
   SEP (lqueue sh t P p lock gsh1 gsh2 (h ++ [QAdd e v])).
Definition q_add_spec prog := DECLARE (ext_link_prog prog "q_add") q_add_spec'.

Notation q_add_args t P h v := (existT (fun t =>
  ((@reptype CompSpecs t -> Prop) * hist (@reptype CompSpecs t) * @reptype CompSpecs t)%type) t (P, h, v)).

Definition q_remove_spec' :=
  WITH sh : share, Q : {t : type & ((reptype t -> Prop) * hist (reptype t))%type}, p : val, lock : val, gsh1 : share, gsh2 : share
  PRE [ _tgt OF (tptr tqueue_t) ]
   let (t, R) := Q in let (P, h) := R in
   PROP (readable_share sh)
   LOCAL (temp _tgt p)
   SEP (lqueue sh t P p lock gsh1 gsh2 h)
  POST [ tptr tvoid ]
   let (t, R) := Q in let (P, h) := R in
   EX e : val, EX v : reptype t,
   PROP (P v)
   LOCAL (temp ret_temp e)
   SEP (lqueue sh t P p lock gsh1 gsh2 (h ++ [QRem e v]); data_at Tsh t v e; malloc_token Tsh (sizeof t) e).
Definition q_remove_spec prog := DECLARE (ext_link_prog prog "q_remove") q_remove_spec'.

Definition q_tryremove_spec' :=
  WITH sh : share, Q : {t : type & ((reptype t -> Prop) * hist (reptype t))%type}, p : val, lock : val, gsh1 : share, gsh2 : share
  PRE [ _tgt OF (tptr tqueue_t) ]
   let (t, R) := Q in let (P, h) := R in
   PROP (readable_share sh)
   LOCAL (temp _tgt p)
   SEP (lqueue sh t P p lock gsh1 gsh2 h)
  POST [ tptr tvoid ]
   let (t, R) := Q in let (P, h) := R in
   EX e : val,
   PROP ()
   LOCAL (temp ret_temp e)
   SEP (if eq_dec e nullval then lqueue sh t P p lock gsh1 gsh2 h else
        (EX v : reptype t, !!(P v) &&
         (lqueue sh t P p lock gsh1 gsh2 (h ++ [QRem e v]) * data_at Tsh t v e * malloc_token Tsh (sizeof t) e))).
Definition q_tryremove_spec prog := DECLARE (ext_link_prog prog "q_tryremove") q_tryremove_spec'.

Lemma lock_precise : forall sh p lock (Hsh : readable_share sh),
  precise (field_at sh tqueue_t [StructField _lock] lock p).
Proof.
  intros.
  unfold field_at, at_offset; apply precise_andp2.
  rewrite data_at_rec_eq; simpl; auto.
Qed.

Lemma interleave_single : forall {A} (l l' : list A), interleave [l] l' = (l' = l).
Proof.
  intros; apply prop_ext; split; intro; subst.
  - remember [l] as l0; revert dependent l; induction H; intros; subst.
    + inv Hnil; auto.
    + exploit (Znth_inbounds i [l0] []).
      { rewrite Hcons; discriminate. }
      intro; assert (i = 0) by (rewrite Zlength_cons, Zlength_nil in *; lia).
      subst; rewrite Znth_0_cons in Hcons; subst.
      rewrite upd_Znth0, sublist_nil in IHinterleave; specialize (IHinterleave _ eq_refl); subst; auto.
  - induction l; econstructor; auto.
    + instantiate (2 := 0); rewrite Znth_0_cons; eauto.
    + rewrite upd_Znth0, sublist_nil; auto.
Qed.

Lemma interleave_remove_nil : forall {A} ls (l' : list A),
  interleave ([] :: ls) l' <-> interleave ls l'.
Proof.
  split; intro.
  - remember ([] :: ls) as l0; revert dependent ls; induction H; intros; subst.
    + inv Hnil; constructor; auto.
    + destruct (Z_le_dec i 0).
      { destruct (eq_dec i 0); [subst; rewrite Znth_0_cons in Hcons | rewrite Znth_underflow in Hcons];
          try discriminate; try lia. }
      rewrite Znth_pos_cons in Hcons; [econstructor; eauto | lia].
      apply IHinterleave.
      setoid_rewrite upd_Znth_app2 with (l1 := [[]]); auto.
      rewrite Zlength_cons, Zlength_nil.
      destruct (Z_le_dec (i - 1) (Zlength ls0)); [lia | rewrite Znth_overflow in Hcons; [discriminate | lia]].
  - induction H.
    + constructor; auto.
    + destruct (zlt i 0); [rewrite Znth_underflow in Hcons; [discriminate | auto]|].
      econstructor.
      * rewrite Znth_pos_cons, Z.add_simpl_r; eauto; lia.
      * setoid_rewrite upd_Znth_app2 with (l1 := [[]]); rewrite Zlength_cons, Zlength_nil.
        rewrite Z.add_simpl_r; auto.
        { destruct (Z_le_dec i (Zlength ls)); [lia | rewrite Znth_overflow in Hcons; [discriminate | lia]]. }
Qed.

Corollary interleave_remove_nils : forall {A} ls0 ls (l' : list A), Forall (fun l => l = []) ls0 ->
  interleave (ls0 ++ ls) l' <-> interleave ls l'.
Proof.
  induction ls0; [reflexivity | intros].
  inv H; simpl; rewrite interleave_remove_nil; auto.
Qed.

Lemma interleave_trans : forall {A} ls1 ls2 (l' l'' : list A)
  (Hl' : interleave ls1 l') (Hl'' : interleave (l' :: ls2) l''), interleave (ls1 ++ ls2) l''.
Proof.
  intros until 1; revert ls2 l''; induction Hl'; intros.
  - rewrite interleave_remove_nil in Hl''; rewrite interleave_remove_nils; auto.
  - remember ((a :: l') :: ls2) as ls0; revert dependent ls2; revert dependent l'; revert dependent a;
      induction Hl''; intros; subst.
    { inv Hnil; discriminate. }
    exploit (Znth_inbounds i ls []).
    { rewrite Hcons0; discriminate. }
    intro; destruct (eq_dec i0 0).
    + subst; rewrite Znth_0_cons in Hcons; inv Hcons.
      econstructor.
      * rewrite app_Znth1; eauto; lia.
      * rewrite upd_Znth_app1; auto.
        rewrite upd_Znth0, sublist_1_cons, sublist_same in Hl''; auto.
        rewrite Zlength_cons; lia.
    + exploit (Znth_inbounds i0 ((a0 :: l'0) :: ls2) []).
      { rewrite Hcons; discriminate. }
      intro; rewrite Znth_pos_cons in Hcons; [|lia].
      econstructor.
      * rewrite app_Znth2, Z.add_simpl_r; eauto; lia.
      * rewrite Zlength_cons in *; rewrite upd_Znth_app2, Z.add_simpl_r; [|lia].
        eapply IHHl''; eauto.
        rewrite upd_Znth_cons; auto; lia.
Qed.

Lemma lqueue_share_join : forall t P sh1 sh2 sh p lock gsh1 gsh2 h1 h2
  (Hsh1 : readable_share sh1) (Hsh2 : readable_share sh2) (Hjoin : sepalg.join sh1 sh2 sh),
  lqueue sh1 t P p lock gsh1 gsh2 h1 * lqueue sh2 t P p lock gsh1 gsh2 h2 =
  EX h' : hist _, !!(interleave [h1; h2] h') && lqueue sh t P p lock gsh1 gsh2 h'.
Proof.
  intros; unfold lqueue; normalize.
  rewrite sepcon_comm, (sepcon_comm _ (ghost _ _ _)), <- !sepcon_assoc, (sepcon_comm _ (ghost _ _ _)).
  erewrite hist_share_join; eauto.
  rewrite !sepcon_assoc, (sepcon_comm _ (lock_inv sh2 _ _)), <- (sepcon_assoc (lock_inv _ _ _)).
  erewrite lock_inv_share_join; eauto.
  rewrite (sepcon_comm _ (field_at _ _ _ _ _)), <- (sepcon_assoc (field_at _ _ _ _ _)).
  erewrite field_at_share_join; eauto.
  normalize.
  f_equal; extensionality.
  normalize.
  rewrite sepcon_assoc, sepcon_comm; f_equal; f_equal.
  apply prop_ext; tauto.
Qed.

Corollary lqueue_share_join_nil : forall t P sh1 sh2 sh p lock gsh1 gsh2
  (Hsh1 : readable_share sh1) (Hsh2 : readable_share sh2) (Hjoin : sepalg.join sh1 sh2 sh),
  lqueue sh t P p lock gsh1 gsh2 [] |--
  lqueue sh1 t P p lock gsh1 gsh2 [] * lqueue sh2 t P p lock gsh1 gsh2 [].
Proof.
  intros; erewrite lqueue_share_join; eauto.
  Exists ([] : hist (reptype t)); entailer!; constructor; auto.
Qed.

Corollary lqueue_shares_join : forall t P p lock sh1 sh2 sh shs h hs
  (Hlen : length shs = length hs)
  (Hsplit : forall i, 0 <= i < Zlength shs ->
    let '(a, b) := Znth i shs (sh, sh) in
    readable_share a /\ readable_share b /\ sepalg.join a b (fst (Znth (i + 1) shs (sh, sh)))),
  lqueue (fst (Znth 0 shs (sh, sh))) t P p lock sh1 sh2 h *
  fold_right sepcon emp (map (fun x => let '(sh, h) := x in lqueue sh t P p lock sh1 sh2 h)
    (combine (map snd shs) hs)) |--
  EX h' : hist _, !!(interleave (h :: hs) h') && lqueue sh t P p lock sh1 sh2 h'.
Proof.
  induction shs; destruct hs; try discriminate; simpl; intros.
  - Exists h; rewrite interleave_single; entailer!.
  - rewrite Znth_0_cons; simpl.
    rewrite Zlength_cons in Hsplit.
    exploit (Hsplit 0).
    { rewrite Zlength_correct; lia. }
    rewrite !Znth_0_cons; destruct a; intros (? & ? & ?).
    erewrite <- sepcon_assoc, lqueue_share_join; eauto.
    simpl; rewrite Znth_pos_cons, Zminus_diag; [|lia].
    Intros h'.
    eapply derives_trans; [apply IHshs; auto|].
    { intros; specialize (Hsplit (i + 1)).
      rewrite !Znth_pos_cons, !Z.add_simpl_r in Hsplit; try lia.
      apply Hsplit; lia. }
    Intros h''.
    Exists h''; entailer!.
    eapply interleave_trans with (ls1 := [h; l]); eauto.
Qed.

Lemma all_ptrs : forall t P vals, fold_right sepcon emp (map (fun x => let '(p, v) := x in
  !!(P v) && (data_at Tsh t v p * malloc_token Tsh (sizeof t) p)) vals) |--
  !!(Forall isptr (map fst vals)).
Proof.
  induction vals; simpl; intros; entailer.
  destruct a.
  rewrite data_at_isptr.
  eapply derives_trans; [apply saturate_aux20 with (P' := isptr v)|].
  { Intros; apply prop_right; auto. }
  { apply IHvals; auto. }
  normalize.
Qed.

Lemma vals_precise : forall r t P vals1 vals2 r1 r2
  (Hvals : map fst vals1 = map fst vals2)
  (Hvals1 : predicates_hered.app_pred(A := compcert_rmaps.R.rmap) (fold_right sepcon emp
    (map (fun x => let '(p, v) := x in !!(P v) && (data_at Tsh t v p * malloc_token Tsh (sizeof t) p)) vals1)) r1)
  (Hvals2 : predicates_hered.app_pred(A := compcert_rmaps.R.rmap) (fold_right sepcon emp
    (map (fun x => let '(p, v) := x in !!(P v) && (data_at Tsh t v p * malloc_token Tsh (sizeof t) p)) vals2)) r2)
  (Hr1 : sepalg.join_sub r1 r) (Hr2 : sepalg.join_sub r2 r), r1 = r2.
Proof.
  induction vals1; simpl; intros; destruct vals2; inversion Hvals.
  - apply sepalg.same_identity with (a := r); auto.
    { destruct Hr1 as (? & H); specialize (Hvals1 _ _ H); subst; auto. }
    { destruct Hr2 as (? & H); specialize (Hvals2 _ _ H); subst; auto. }
  - destruct a, p; simpl in *; subst.
    destruct Hvals1 as (? & r1b & ? & (? & r1a & ? & ? & Hh1 & Hm1) & ?),
      Hvals2 as (? & r2b & ? & (? & r2a & ? & ? & Hh2 & Hm2) & ?).
    exploit malloc_token_precise.
    { apply Hm1. }
    { apply Hm2. }
    { join_sub. }
    { join_sub. }
    assert (r1a = r2a); [|intros; subst].
    { apply data_at_data_at_ in Hh1; apply data_at_data_at_ in Hh2.
      eapply data_at__precise with (sh := Tsh); auto; eauto; join_sub. }
    assert (r1b = r2b); [|subst].
    { eapply IHvals1; eauto; join_sub. }
    join_inj.
Qed.

Axiom ghost_precise : forall sh {t} p, precise (EX f : share * hist (reptype t), ghost sh f p).

Lemma tqueue_inj : forall r (buf1 buf2 : list val) len1 len2 head1 head2 tail1 tail2
  (addc1 addc2 remc1 remc2 : val) p r1 r2
  (Hp1 : predicates_hered.app_pred(A := compcert_rmaps.R.rmap)
     (data_at Tsh tqueue (buf1, (vint len1, (vint head1, (vint tail1, (addc1, remc1))))) p) r1)
  (Hp2 : predicates_hered.app_pred(A := compcert_rmaps.R.rmap)
     (data_at Tsh tqueue (buf2, (vint len2, (vint head2, (vint tail2, (addc2, remc2))))) p) r2)
  (Hr1 : sepalg.join_sub r1 r) (Hr2 : sepalg.join_sub r2 r)
  (Hbuf1 : Forall (fun v => v <> Vundef) buf1) (Hl1 : Zlength buf1 = MAX)
  (Hbuf2 : Forall (fun v => v <> Vundef) buf2) (Hl2 : Zlength buf2 = MAX)
  (Haddc1 : addc1 <> Vundef) (Haddc2 : addc2 <> Vundef) (Hremc1 : remc1 <> Vundef) (Hremc2 : remc2 <> Vundef),
  r1 = r2 /\ buf1 = buf2 /\ Int.repr len1 = Int.repr len2 /\ Int.repr head1 = Int.repr head2 /\
  Int.repr tail1 = Int.repr tail2 /\ addc1 = addc2 /\ remc1 = remc2.
Proof.
  intros.
  unfold data_at in Hp1, Hp2; erewrite field_at_Tstruct in Hp1, Hp2; try reflexivity; try apply JMeq_refl.
  simpl in Hp1, Hp2; unfold withspacer in Hp1, Hp2; simpl in Hp1, Hp2.
  destruct Hp1 as (? & ? & ? & (? & Hb1) & ? & ? & ? & (? & Hlen1) & ? & ? & ? & (? & Hhead1) & ? & ? & ? &
    (? & Htail1) & ? & ? & ? & (? & Hadd1) & ? & Hrem1).
  destruct Hp2 as (? & ? & ? & (? & Hb2) & ? & ? & ? & (? & Hlen2) & ? & ? & ? & (? & Hhead2) & ? & ? & ? &
    (? & Htail2) & ? & ? & ? & (? & Hadd2) & ? & Hrem2); unfold at_offset in *.
  assert (readable_share Tsh) as Hread by auto.
  exploit (mapsto_inj _ _ _ _ _ _ _ r Hread Hrem1 Hrem2); auto; try join_sub.
  exploit (mapsto_inj _ _ _ _ _ _ _ r Hread Hadd1 Hadd2); auto; try join_sub.
  exploit (mapsto_inj _ _ _ _ _ _ _ r Hread Htail1 Htail2); auto; try join_sub; try discriminate.
  exploit (mapsto_inj _ _ _ _ _ _ _ r Hread Hhead1 Hhead2); auto; try join_sub; try discriminate.
  exploit (mapsto_inj _ _ _ _ _ _ _ r Hread Hlen1 Hlen2); auto; try join_sub; try discriminate.
  exploit (data_at_ptr_array_inj _ _ _ _ _ _ _ _ r Hread Hb1 Hb2); auto; try join_sub.
  unfold repinject.
  intros (? & ?) (? & ?) (? & ?) (? & ?) (? & ?) (? & ?); subst; join_inj.
  repeat split; auto; congruence.
Qed.

Lemma q_inv_precise : forall t P p lock gsh2, precise (q_lock_pred t P p lock gsh2).
Proof.
  unfold q_lock_pred, q_lock_pred'; intros ???????? H1 H2 Hw1 Hw2.
  destruct H1 as (vals1 & head1 & addc1 & remc1 & h1 & (? & ? & ?) & ? & ? & ? & (? & ? & ? & (? & ? & ? &
    (? & ? & ? & (? & ? & ? & (? & ? & ? & (? & ? & ? & (? & ? & ? & (Hq1 & Haddc1)) & Hremc1) & Htv1) & Hta1) &
    Htr1) & Htl1) & Hghost1) & Hvals1),
  H2 as (vals2 & head2 & addc2 & remc2 & h2 & (? & ? & ?) & ? & ? & ? & (? & ? & ? & (? & ? & ? &
    (? & ? & ? & (? & ? & ? & (? & ? & ? & (? & ? & ? & (? & ? & ? & (Hq2 & Haddc2)) & Hremc2) & Htv2) & Hta2) &
    Htr2) & Htl2) & Hghost2) & Hvals2).
  pose proof (all_ptrs _ _ _ _ Hvals1) as Hptrs1.
  pose proof (all_ptrs _ _ _ _ Hvals2) as Hptrs2.
  exploit (tqueue_inj w _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ Hq1 Hq2); try join_sub.
  { apply Forall_rotate, Forall_complete; auto; [|discriminate].
    eapply Forall_impl; [|apply Hptrs1]; destruct a; try contradiction; discriminate. }
  { rewrite Zlength_rotate; try rewrite Zlength_complete; try lia; rewrite Zlength_map; auto. }
  { apply Forall_rotate, Forall_complete; auto; [|discriminate].
    eapply Forall_impl; [|apply Hptrs2]; destruct a; try contradiction; discriminate. }
  { rewrite Zlength_rotate; try rewrite Zlength_complete; try lia; rewrite Zlength_map; auto. }
  { rewrite cond_var_isptr in Haddc1; destruct Haddc1, addc1; try contradiction; discriminate. }
  { rewrite cond_var_isptr in Haddc2; destruct Haddc2, addc2; try contradiction; discriminate. }
  { rewrite cond_var_isptr in Hremc1; destruct Hremc1, remc1; try contradiction; discriminate. }
  { rewrite cond_var_isptr in Hremc2; destruct Hremc2, remc2; try contradiction; discriminate. }
  intros (? & ? & Hlen & ? & ? & ? & ?); subst.
  exploit (ghost_precise(t := t) gsh2 p w).
  { eexists; apply Hghost1. }
  { eexists; apply Hghost2. }
  { join_sub. }
  { join_sub. }
  intro; subst.
  assert (head1 = head2) as ->.
  { apply repr_inj_unsigned; auto; split; try lia; transitivity MAX; try lia; unfold MAX; computable. }
  assert (length vals1 = length vals2).
  { apply repr_inj_unsigned in Hlen; rewrite Zlength_correct in Hlen.
    rewrite Zlength_correct in Hlen; Omega0.
    - split; [rewrite Zlength_correct; lia|]; transitivity MAX; try lia; unfold MAX; computable.
    - split; [rewrite Zlength_correct; lia|]; transitivity MAX; try lia; unfold MAX; computable. }
  assert (map fst vals1 = map fst vals2) as Heq.
  { eapply complete_inj; [|rewrite !map_length; auto].
    eapply rotate_inj; eauto; try lia.
    repeat rewrite length_complete; try rewrite Zlength_map; auto.
    rewrite Zlength_complete; try rewrite Zlength_map; lia. }
  rewrite Heq in *.
  exploit (vals_precise w _ _ _ _ _ _ Heq Hvals1 Hvals2); auto; try join_sub.
  assert (readable_share Tsh) as Hread by auto.
  exploit (cond_var_precise _ _ Hread w _ _ Haddc1 Haddc2); try join_sub.
  exploit (cond_var_precise _ _ Hread w _ _ Hremc1 Hremc2); try join_sub.
  exploit (malloc_token_precise _ _ _ w _ _ Hta1 Hta2); try join_sub.
  exploit (malloc_token_precise _ _ _ w _ _ Htr1 Htr2); try join_sub.
  exploit (malloc_token_precise _ _ _ w _ _ Htv1 Htv2); try join_sub.
  exploit (malloc_token_precise _ _ _ w _ _ Htl1 Htl2); try join_sub.
  intros; subst; join_inj.
Qed.

Lemma q_inv_positive : forall t P p lock gsh2, positive_mpred (q_lock_pred t P p lock gsh2).
Proof.
  intros; simpl.
  repeat (apply ex_positive; intro).
  apply positive_andp2.
  do 7 apply positive_sepcon1; apply positive_sepcon2; auto.
Qed.
#[export] Hint Resolve q_inv_precise q_inv_positive.

Lemma lqueue_precise : forall lsh t P p lock gsh1 gsh2,
  precise (EX h : hist (reptype t), lqueue lsh t P p lock gsh1 gsh2 h).
Proof.
  intros; unfold lqueue.
  apply derives_precise' with (Q := field_at lsh tqueue_t [StructField conc_queue._lock] lock p *
    lock_inv lsh lock (q_lock_pred t P p lock gsh2) * EX f : share * hist (reptype t), ghost gsh1 f p).
  - entailer!.
    Exists (lsh, h); auto.
  - repeat apply precise_sepcon; auto.
    apply ghost_precise.
Qed.
#[export] Hint Resolve lqueue_precise.

Lemma lqueue_isptr : forall lsh t P p lock gsh1 gsh2 h, lqueue lsh t P p lock gsh1 gsh2 h =
  !!isptr p && lqueue lsh t P p lock gsh1 gsh2 h.
Proof.
  intros; eapply local_facts_isptr with (P := fun p => lqueue lsh t P p lock gsh1 gsh2 h); eauto.
  unfold lqueue; rewrite field_at_isptr; Intros; apply prop_right; auto.
Qed.

Lemma list_incl_refl : forall {A} (l : list A), list_incl l l.
Proof.
  induction l; auto.
Qed.
#[export] Hint Resolve list_incl_refl.

Lemma consistent_inj : forall {t} (h : hist t) a b b' (Hb : consistent h a b) (Hb' : consistent h a b'), b = b'.
Proof.
  induction h; simpl; intros.
  - subst; auto.
  - destruct a; eauto.
    destruct a0; [contradiction|].
    destruct Hb, Hb'; eauto.
Qed.

Lemma consistent_trans : forall {t} (h1 h2 : hist t) a b c, consistent h1 a b -> consistent h2 b c ->
  consistent (h1 ++ h2) a c.
Proof.
  induction h1; simpl; intros; subst; auto.
  destruct a; eauto.
  destruct a0; [contradiction | destruct H; eauto].
Qed.

Corollary consistent_snoc_add : forall {t} (h : hist t) a b e v, consistent h a b ->
  consistent (h ++ [QAdd e v]) a (b ++ [(e, v)]).
Proof.
  intros; eapply consistent_trans; simpl; eauto.
Qed.

Corollary consistent_cons_rem : forall {t} (h : hist t) a b e v, consistent h a ((e, v) :: b) ->
  consistent (h ++ [QRem e v]) a b.
Proof.
  intros; eapply consistent_trans; eauto; simpl; auto.
Qed.

Lemma list_incl_app2 : forall {A} (l l1 l2 : list A), list_incl l l2 -> list_incl l (l1 ++ l2).
Proof.
  induction l1; auto; intros.
  simpl; constructor; auto.
Qed.

Lemma list_incl_app : forall {A} (l1 l2 l1' l2' : list A), list_incl l1 l2 -> list_incl l1' l2' ->
  list_incl (l1 ++ l1') (l2 ++ l2').
Proof.
  induction 1; intros.
  - simpl; apply list_incl_app2; auto.
  - simpl; constructor; auto.
  - simpl; constructor 3; auto.
Qed.

Definition is_add {A} (a : @hist_el A):= match a with QAdd _ _ => true | _ => false end.

Lemma consistent_adds : forall {A} (h : hist A) (Hadds : forallb is_add h = true),
  exists l, h = map (fun x => let '(p, v) := x in QAdd p v) l /\
    forall h2 a b, consistent (h ++ h2) a b <-> consistent h2 (a ++ l) b.
Proof.
  induction h; simpl; intros.
  - exists []; split; auto; intros; rewrite app_nil_r; reflexivity.
  - rewrite andb_true_iff in Hadds; destruct Hadds, a; try discriminate.
    destruct IHh as (l & ? & IH); auto; subst.
    exists ((p, v) :: l); split; auto; intros; rewrite IH, <- app_assoc; reflexivity.
Qed.

Corollary consistent_insert_rem : forall {A} (h1 h2 : hist A) a b p v (Hadds : forallb is_add h1 = true),
  consistent (h1 ++ h2) a b -> consistent (h1 ++ QRem p v :: h2) ((p, v) :: a) b.
Proof.
  intros.
  destruct (consistent_adds _ Hadds) as (l & ? & Hh1).
  rewrite Hh1 in *; simpl; auto.
Qed.

Lemma interleave_In : forall {A} ls (l' : list A) x (Hinter : interleave ls l'),
  In x l' <-> exists l, In l ls /\ In x l.
Proof.
  induction 1.
  - split; intro; [contradiction|].
    destruct H as (? & ? & ?).
    rewrite Forall_forall in Hnil; exploit Hnil; eauto; intro; subst; auto.
  - simpl; rewrite IHHinter.
    exploit (Znth_inbounds i ls []); [rewrite Hcons; discriminate | intro Hi].
    split; intro.
    + destruct H.
      * subst; exists (x :: l); split; simpl; auto.
        rewrite <- Hcons; apply Znth_In; auto.
      * destruct H as (l1 & Hl1 & ?).
        apply In_upd_Znth in Hl1; destruct Hl1; eauto.
        subst; exists (a :: l); split; simpl; auto.
        rewrite <- Hcons; apply Znth_In; auto.
    + destruct H as (l1 & Hl1 & ?).
      destruct (In_Znth _ _ [] Hl1) as (i' & ? & Hi').
      destruct (eq_dec i' i).
      * subst; rewrite Hcons in *; subst.
        destruct H; auto.
        right; exists l; split; auto.
        apply upd_Znth_In.
      * right; eexists; erewrite <- upd_Znth_diff in Hi'; [split; eauto; rewrite <- Hi'; apply Znth_In | | |];
          rewrite ?upd_Znth_Zlength; auto.
Qed.

Lemma add_first : forall {A} ls (h : hist A) a b
  (Hinter : interleave ls h) (Hcon : consistent h a b),
  exists h1 h2, interleave (map (filter is_add) ls) h1 /\
                interleave (map (filter (fun a => negb (is_add a))) ls) h2 /\ consistent (h1 ++ h2) a b.
Proof.
  intros until 1; revert a b; induction Hinter; intros.
  - exists [], []; simpl; repeat split; auto; constructor.
    + rewrite Forall_forall in *; intros.
      rewrite in_map_iff in H; destruct H as (? & ? & ?); subst.
      exploit Hnil; eauto; intro; subst; auto.
    + rewrite Forall_forall in *; intros.
      rewrite in_map_iff in H; destruct H as (? & ? & ?); subst.
      exploit Hnil; eauto; intro; subst; auto.
  - simpl in Hcon.
    exploit (Znth_inbounds i ls []); [rewrite Hcons; discriminate | intro].
    destruct a.
    + specialize (IHHinter _ _ Hcon); destruct IHHinter as (h1 & h2 & Hh1 & Hh2 & ?).
      exists (QAdd p v :: h1), h2; repeat split; auto.
      * econstructor.
        { rewrite Znth_map with (d' := []), Hcons; simpl; eauto. }
        rewrite upd_Znth_map; auto.
      * erewrite <- upd_Znth_map, upd_Znth_triv in Hh2; auto.
        { rewrite Zlength_map; auto. }
        rewrite Znth_map', Hcons; auto.
    + destruct a0; [contradiction | destruct Hcon as (? & Hcon); subst].
      specialize (IHHinter _ _ Hcon); destruct IHHinter as (h1 & h2 & Hh1 & Hh2 & ?).
      exists h1, (QRem p v :: h2); repeat split.
      * erewrite <- upd_Znth_map, upd_Znth_triv in Hh1; auto.
        { rewrite Zlength_map; auto. }
        rewrite Znth_map', Hcons; auto.
      * econstructor.
        { rewrite Znth_map with (d' := []), Hcons; simpl; eauto. }
        rewrite upd_Znth_map; auto.
      * apply consistent_insert_rem; auto.
        rewrite forallb_forall; intros ? Hin.
        rewrite interleave_In in Hin; [|eauto].
        destruct Hin as (? & Hin & Hin'); rewrite in_map_iff in Hin.
        destruct Hin as (? & ? & Hin); subst.
        rewrite filter_In in Hin'; destruct Hin'; auto.
Qed.

Lemma interleave_reorder : forall {A} ls1 ls2 (l l' : list A),
  interleave (ls1 ++ l :: ls2) l' <-> interleave (l :: ls1 ++ ls2) l'.
Proof.
  split; intro.
  - remember (ls1 ++ l :: ls2) as l0; revert dependent ls2; revert l ls1; induction H; intros; subst.
    + constructor; rewrite Forall_app in Hnil.
      destruct Hnil as (? & Hnil); inv Hnil; constructor; auto; rewrite Forall_app; auto.
    + exploit (Znth_inbounds i (ls1 ++ l0 :: ls2) []); [rewrite Hcons; discriminate | intro].
      destruct (zlt i (Zlength ls1)); [|rewrite app_Znth2 in Hcons; auto; destruct (eq_dec (i - Zlength ls1) 0)].
      * rewrite app_Znth1 in Hcons; auto.
        econstructor; [rewrite Znth_pos_cons, app_Znth1, Z.add_simpl_r; eauto; lia|].
        rewrite upd_Znth_cons, upd_Znth_app1; try lia.
        apply IHinterleave.
        rewrite upd_Znth_app1, Z.add_simpl_r; [auto | lia].
      * rewrite e, Znth_0_cons in Hcons; subst.
        econstructor; [rewrite Znth_0_cons; eauto|].
        rewrite upd_Znth0, sublist_1_cons, sublist_same; auto; [|rewrite Zlength_cons; lia].
        apply IHinterleave.
        rewrite upd_Znth_app2, e, upd_Znth0, sublist_1_cons, sublist_same; auto;
          rewrite Zlength_app, Zlength_cons in *; lia.
      * rewrite Znth_pos_cons in Hcons; [|lia].
        replace (i - Zlength ls1 - 1) with ((i - 1) - Zlength ls1) in Hcons by lia.
        assert (i > 0) by (rewrite Zlength_correct in *; lia).
        econstructor; [rewrite Znth_pos_cons, app_Znth2; eauto; lia|].
        rewrite Zlength_app, Zlength_cons in *.
        rewrite upd_Znth_cons, upd_Znth_app2; auto; try lia.
        apply IHinterleave.
        rewrite upd_Znth_app2, upd_Znth_cons; rewrite ?Zlength_cons; try lia.
        replace (i - Zlength ls1 - 1) with (i - 1 - Zlength ls1); Omega0.
  - remember (l :: ls1 ++ ls2) as l0; revert dependent ls2; revert l ls1; induction H; intros; subst.
    + inv Hnil; constructor.
      rewrite Forall_app in H2; destruct H2; rewrite Forall_app; split; auto.
    + exploit (Znth_inbounds i (l0 :: ls1 ++ ls2) []); [rewrite Hcons; discriminate | intro].
      destruct (eq_dec i 0); [|rewrite Znth_pos_cons in Hcons; [destruct (zlt (i - 1) (Zlength ls1)) | lia]].
      * subst; rewrite Znth_0_cons in Hcons; subst.
        econstructor; [rewrite app_Znth2, Zminus_diag, Znth_0_cons; eauto; lia|].
        rewrite upd_Znth_app2, Zminus_diag, upd_Znth0, sublist_1_cons, sublist_same; auto;
          try rewrite Zlength_cons, !Zlength_correct; try lia.
        apply IHinterleave.
        rewrite upd_Znth0, sublist_1_cons, sublist_same; auto; rewrite Zlength_cons; lia.
      * rewrite app_Znth1 in Hcons; auto.
        econstructor; [rewrite app_Znth1; eauto|].
        rewrite upd_Znth_app1; [|lia].
        apply IHinterleave.
        rewrite upd_Znth_cons, upd_Znth_app1; auto; lia.
      * rewrite app_Znth2 in Hcons; auto.
        replace (i - 1 - Zlength ls1) with (i - Zlength ls1 - 1) in Hcons by lia.
        econstructor; [rewrite app_Znth2, Znth_pos_cons; eauto; lia|].
        rewrite upd_Znth_app2, upd_Znth_cons; try rewrite Zlength_cons, Zlength_app in *; try lia.
        apply IHinterleave.
        rewrite upd_Znth_cons, upd_Znth_app2; try lia.
        replace (i - 1 - Zlength ls1) with (i - Zlength ls1 - 1); auto; lia.
Qed.

Corollary interleave_remove_nil' : forall {A} ls1 ls2 (l' : list A),
  interleave (ls1 ++ [] :: ls2) l' <-> interleave (ls1 ++ ls2) l'.
Proof.
  intros; rewrite interleave_reorder, interleave_remove_nil; reflexivity.
Qed.

Lemma consistent_rems : forall {A} (h : hist A) a b (Hrems : forallb (fun x => negb (is_add x)) h = true),
  consistent h a b ->
  exists l, a = l ++ b /\ h = map (fun x => let '(p, v) := x in QRem p v) l.
Proof.
  induction h; simpl; intros.
  - subst; exists []; auto.
  - rewrite andb_true_iff in Hrems; destruct Hrems.
    destruct a; [discriminate|].
    destruct a0; [contradiction | destruct H as (? & Hcon); subst].
    exploit IHh; eauto; intros (l & ? & ?); subst.
    exists ((p, v) :: l); auto.
Qed.

Lemma interleave_map_inj : forall {A B} (f : A -> B) ls l' (Hinj : forall x y, f x = f y -> x = y),
  interleave (map (map f) ls) (map f l') -> interleave ls l'.
Proof.
  intros.
  remember (map (map f) ls) as ls0; remember (map f l') as l1; revert dependent l'; revert dependent ls;
    induction H; intros; subst.
  - destruct l'; [|discriminate].
    constructor.
    rewrite Forall_forall in *; intros l Hin.
    exploit (Hnil (map f l)).
    { rewrite in_map_iff; eauto. }
    destruct l; auto; discriminate.
  - destruct l'0; [discriminate | inv Heql1].
    change [] with (map f []) in Hcons; rewrite Znth_map' in Hcons.
    destruct (Znth i ls0 []) eqn: Hi; [discriminate | inv Hcons].
    exploit Hinj; [eassumption | intro; subst].
    econstructor; eauto.
    apply IHinterleave; auto.
    apply upd_Znth_map.
Qed.

Lemma interleave_combine : forall {A B} ls1 ls2 (l1 : list A) (l2 : list B)
  (Hls : Forall2 (fun la lb => length la = length lb) ls1 ls2)
  (Hlen : length l1 = length l2),
  interleave (map (fun x => let '(la, lb) := x in combine la lb) (combine ls1 ls2)) (combine l1 l2) ->
  interleave ls1 l1 /\ interleave ls2 l2.
Proof.
  intros.
  remember (map (fun x => let '(la, lb) := x in combine la lb) (combine ls1 ls2)) as ls0;
    remember (combine l1 l2) as l0; revert dependent l2; revert l1; revert dependent ls2; revert ls1;
    induction H; intros; subst.
  - destruct l1, l2; try discriminate.
    pose proof (mem_lemmas.Forall2_Zlength Hls).
    split; constructor.
    + rewrite Forall_forall in *; intros l1 Hin.
      destruct (In_Znth _ _ [] Hin) as (i & ? & ?).
      exploit (Hnil (combine l1 (Znth i ls2 []))).
      { rewrite in_map_iff; eexists (_, _); split; eauto.
        subst; rewrite <- Znth_combine; auto.
        apply Znth_In; rewrite Zlength_combine, Z.min_l; auto; lia. }
      exploit (Forall2_Znth _ _ _ [] [] Hls); eauto.
      intros; subst.
      destruct (Znth i ls1 []); auto.
      destruct (Znth i ls2 []); discriminate.
    + rewrite Forall_forall in *; intros l2 Hin.
      destruct (In_Znth _ _ [] Hin) as (i & ? & ?).
      exploit (Hnil (combine (Znth i ls1 []) l2)).
      { rewrite in_map_iff; eexists (_, _); split; eauto.
        subst; rewrite <- Znth_combine; auto.
        apply Znth_In; rewrite Zlength_combine, Z.min_l; auto; lia. }
      exploit (Forall2_Znth _ _ _ [] [] Hls); [rewrite H; eauto|].
      intros; subst.
      destruct (Znth i ls2 []); auto.
      destruct (Znth i ls1 []); discriminate.
  - destruct l1, l2; try discriminate.
    pose proof (mem_lemmas.Forall2_Zlength Hls).
    inv Heql0; inv Hlen.
    change [] with ((fun x : list A * list B => let '(la, lb) := x in combine la lb) ([], [])) in Hcons.
    rewrite Znth_map', Znth_combine in Hcons; auto.
    destruct (Znth i ls1 []) as [|? la] eqn: Ha1; [discriminate|].
    destruct (Znth i ls2 []) as [|? lb] eqn: Ha2; [discriminate|].
    inv Hcons.
    exploit (Znth_inbounds i ls1 []); [rewrite Ha1; discriminate | intro].
    exploit (IHinterleave (upd_Znth i ls1 la) (upd_Znth i ls2 lb)); eauto.
    { apply Forall2_upd_Znth; auto; [|lia].
      exploit (Forall2_Znth _ _ _ [] [] Hls); eauto.
      rewrite Ha1, Ha2; intro Hlen; inv Hlen; auto. }
    { change (combine la lb) with ((fun x : list A * list B => let '(la, lb) := x in combine la lb) (la, lb)).
      rewrite upd_Znth_map, combine_upd_Znth; auto. }
    intros (? & ?); split; econstructor; eauto.
Qed.

Fixpoint total_length {A} (l : list (list A)) :=
  match l with
  | [] => 0
  | l :: rest => Zlength l + total_length rest
  end.

Lemma total_length_app : forall {A} (l1 l2 : list (list A)),
  total_length (l1 ++ l2) = total_length l1 + total_length l2.
Proof.
  induction l1; auto; intros; simpl.
  rewrite IHl1; lia.
Qed.

Lemma total_length_upd : forall {A} ls i (l : list A), 0 <= i < Zlength ls ->
  total_length (upd_Znth i ls l) = total_length ls - Zlength (Znth i ls []) + Zlength l.
Proof.
  intros; unfold upd_Znth.
  replace ls with (sublist 0 i ls ++ sublist i (Zlength ls) ls) at 4.
  rewrite !total_length_app; simpl.
  rewrite sublist_next with (i0 := i)(d := []); auto; try lia.
  simpl; lia.
  { rewrite <- sublist_split, sublist_same; auto; lia. }
Qed.

Lemma Zlength_interleave : forall {A} ls (l : list A), interleave ls l ->
  Zlength l = total_length ls.
Proof.
  induction 1.
  - rewrite Zlength_nil.
    induction ls; auto; simpl.
    inv Hnil.
    rewrite Zlength_nil, <- IHls; auto.
  - exploit (Znth_inbounds i ls []); [rewrite Hcons; discriminate | intro].
    rewrite total_length_upd, Hcons in IHinterleave; auto.
    rewrite Zlength_cons in *; lia.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import coqutil.Word.Interface coqutil.Word.Bitwidth.
Require Import coqutil.Map.Interface.
Require Import coqutil.Tactics.ltac_list_ops.
Require Import coqutil.Tactics.Tactics.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.SepLib.
Require Export bedrock2.sepapp.

Inductive record_field_description{width: Z}{BW: Bitwidth width}{word: word.word width}
  {mem: map.map word Byte.byte}(R: Type): Type :=
| mk_record_field_description(F: Type)(getter: R -> F)(pred: F -> word -> mem -> Prop).

Arguments mk_record_field_description{width}{BW}{word}{mem}{R}{F}.

(* Given a record_field_description for some type R and a variable r of type R,
   looks up the size of that record field (might depend on r) using typeclass search,
   and returns it as a sized_predicate *)
Ltac infer_size r descr :=
  lazymatch descr with
  | mk_record_field_description ?getter ?pred =>
      constr:(mk_sized_predicate (pred (getter r)) _)
  end.

Ltac create_predicate fields :=
  lazymatch type of fields with
  | list (record_field_description ?R) =>
      lazymatch goal with
      | r: R |- @word.rep _ _ -> @map.rep _ _ _ -> Prop =>
          let res := map_with_ltac ltac:(infer_size r) fields in
          exact (sepapps res)
      end
  end.

#[export] Hint Extern 20 (PredicateSize ?p) =>
  let h := head p in unfold h; typeclasses eauto
: typeclass_instances.

Notation "'record!' fields" := ltac:(create_predicate fields)
  (at level 10, only parsing).

(* The user can decide whether to put the array size between /**# #**/ or not.
   C compilers will not accept arbitrary Coq expressions in uncommented sizes,
   but we do not attempt to check that in Coq, because it seems that
   there is no way to distinguish whether the user wrote `3` or `(Zpos (xI xH))`. *)
Declare Custom Entry c_array_size.
Notation "x" := x (in custom c_array_size at level 2, x constr at level 0).
Notation "/* *# x #* */" := x (in custom c_array_size at level 2, x constr at level 100).

Declare Custom Entry c_type_as_predicate.
Notation "'uintptr_t'" := uintptr (in custom c_type_as_predicate).
Notation "'uint32_t'" := (uint 32) (in custom c_type_as_predicate).
Notation "'uint16_t'" := (uint 16) (in custom c_type_as_predicate).
Notation "'uint8_t'" := (uint 8) (in custom c_type_as_predicate).
Notation "'NOT_C!(' x )" := x (in custom c_type_as_predicate, x constr).

Declare Custom Entry c_struct_field.
Declare Scope c_struct_field_scope.
Open Scope c_struct_field_scope.
Notation "'c_struct_field:(' x ')'" := x
  (at level 0, x custom c_struct_field at level 2, format "c_struct_field:( x )")
  : c_struct_field_scope.
Notation "pred fieldname ;" := (mk_record_field_description fieldname pred)
  (in custom c_struct_field at level 2,
   pred custom c_type_as_predicate at level 0,
   fieldname constr at level 0)
  : c_struct_field_scope.
Notation "pred fieldname [ sz ] ;" :=
  (mk_record_field_description fieldname (array pred sz))
  (in custom c_struct_field at level 2,
   pred custom c_type_as_predicate at level 0,
   fieldname constr at level 0,
   sz custom c_array_size at level 2)
  : c_struct_field_scope.

Declare Custom Entry c_struct_field_list.
Notation "'c_struct_field_list:(' x ')'" := x (x custom c_struct_field_list)
  : c_struct_field_scope.
Notation "{ x1 .. xN }" := (cons x1 .. (cons xN nil) ..)
  (in custom c_struct_field_list at level 2,
   x1 custom c_struct_field, xN custom c_struct_field).

Notation ".* */ 'typedef' 'struct' '__attribute__' '((__packed__))' fs name ; /* *" :=
  (match fs with (* <-- typechecking x before passing it to Ltac improves error messages *)
   | name => (* <-- name given to record in C is ignored by Coq *)
       ltac:(create_predicate fs)
   end)
  (at level 200, fs custom c_struct_field_list at level 2, only parsing).

Module Examples_TODO_move.

  Definition ARPOperationRequest: Z := 1.
  Definition ARPOperationReply: Z := 2.

  Record ARPPacket := mkARPPacket {
    htype: Z; (* hardware type *)
    ptype: Z; (* protocol type *)
    hlen: Z;  (* hardware address length (6 for MAC addresses) *)
    plen: Z;  (* protocol address length (4 for IPv4 addresses) *)
    oper: Z;
    sha: list Z; (* sender hardware address *)
    spa: list Z; (* sender protocol address *)
    tha: list Z; (* target hardware address *)
    tpa: list Z; (* target protocol address *)
  }.

  Record EthernetHeader := mkEthernetHeader {
    dstMAC: list Z;
    srcMAC: list Z;
    etherType: Z;
  }.

  Record var_size_foo := {
    foo_size: Z;
    foo_stuff: Z;
    foo_payload: list Z;
  }.

  Section WithMem.
    Local Open Scope Z_scope.
    Context {width: Z} {BW: Bitwidth width}
            {word: word.word width} {word_ok: word.ok word}
            {mem: map.map word Byte.byte} {mem_ok: map.ok mem}.

    Goal c_struct_field:(uint32_t foo_size;) =
         mk_record_field_description foo_size (uint 32).
    Proof. reflexivity. Abort.

    Goal forall l, c_struct_field:(uint16_t foo_payload[/**# Z.of_nat (S l) #**/];) =
             mk_record_field_description foo_payload (array (uint 16) (Z.of_nat (S l))).
    Proof. reflexivity. Abort.

    Goal c_struct_field:(uint16_t foo_payload[4];) =
         mk_record_field_description foo_payload (array (uint 16) 4).
    Proof. reflexivity. Abort.

    Goal forall r, c_struct_field_list:({
      uint32_t foo_size;
      uint32_t foo_stuff;
      uint32_t foo_payload[/**# foo_size r #**/];
    }) =
    (cons (mk_record_field_description foo_size (uint 32))
    (cons (mk_record_field_description foo_stuff (uint 32))
    (cons (mk_record_field_description foo_payload (array (uint 32) (foo_size r))) nil))).
    Proof. reflexivity. Abort.

    Definition var_size_foo_t(r: var_size_foo): word -> mem -> Prop := .**/
      typedef struct __attribute__ ((__packed__)) {
        uint32_t foo_size;
        uint32_t foo_stuff;
        uint8_t foo_payload[/**# foo_size r #**/];
      } var_size_foo_t;
    /**.

    Goal forall p, (_ : PredicateSize (var_size_foo_t p)) = 8 + (foo_size p * 1).
    Proof. intros. reflexivity. Abort.

    Definition ARPPacket_t(r: ARPPacket): word -> mem -> Prop := .**/
      typedef struct __attribute__ ((__packed__)) {
        uint16_t htype;
        uint16_t ptype;
        uint8_t hlen;
        uint8_t plen;
        uint16_t oper;
        uint8_t sha[6];
        uint8_t spa[4];
        uint8_t tha[6];
        uint8_t tpa[4];
      } ARPPacket_t;
    /**.

    Goal forall p, (_ : PredicateSize (ARPPacket_t p)) = 28.
    Proof. intros. reflexivity. Abort.

    Definition EthernetHeader_t(r: EthernetHeader): word -> mem -> Prop := .**/
      typedef struct __attribute__ ((__packed__)) {
        uint8_t dstMAC[6];
        uint8_t srcMAC[6];
        uint16_t etherType;
      } EthernetHeader_t;
    /**.

    Goal forall p, (_ : PredicateSize (EthernetHeader_t p)) = 14.
    Proof. intros. reflexivity. Abort.

    (* not a Lemma because this kind of goal will be solved inline by sepcalls canceler *)
    Goal forall (bs: list Z) (R: mem -> Prop) a m (Rest: EthernetHeader -> Prop),
        sep (array (uint 8) 14 bs a) R m ->
        exists h, sep (EthernetHeader_t h a) R m /\ Rest h.
    Proof.
      intros.
      eexists (mkEthernetHeader _ _ _).
      unfold EthernetHeader_t.
      cbn.
    Abort.
  End WithMem.
End Examples_TODO_move.


Require Import VST.sepcomp.semantics.

Require Import VST.compcert.lib.Coqlib.
Require Import VST.compcert.lib.Maps.
Require Import VST.compcert.lib.Integers.
Require Import VST.compcert.lib.Axioms.

Require Import compcert.common.Values.
Require Import compcert.common.Memory.
Require Import compcert.common.Events.
Require Import compcert.common.AST.
Require Import compcert.common.Globalenvs.

Require Import VST.sepcomp.mem_lemmas.

(** *I'm overloading the definition of coresemantics. **)
(* Bellow, I produce a way of lifting the old coresemantics to the new one. *)
(* This is bad design and should be changed. *)
Record ThreadSemantics {G C M : Type} : Type :=
  { (*nat is thread id. It should not be seen by the code.*)
    initial_core : nat -> G -> val -> list val -> option C
  ; at_external : C -> option (external_function * list val)
  ; after_external : option val -> C -> option C
  ; halted : C -> option val
  ; corestep : G -> C -> M -> C -> M -> Prop

  ; corestep_not_at_external:
      forall ge m q m' q', corestep ge q m q' m' -> at_external q = None
  ; corestep_not_halted:
      forall ge m q m' q', corestep ge q m q' m' -> halted q = None
  ; at_external_halted_excl:
      forall q, at_external q = None \/ halted q = None }.

Arguments CoreSemantics : clear implicits.

Inductive mem_step m m' : Prop :=
    mem_step_storebytes: forall b ofs bytes,
       Mem.storebytes m b ofs bytes = Some m' -> mem_step m m'
  | mem_step_alloc: forall lo hi b',
       Mem.alloc m lo hi = (m',b') -> mem_step m m'
  | mem_step_freelist: forall l,
       Mem.free_list m l = Some m' -> mem_step m m'
  (*Some non-observable external calls are not a single alloc/free/store-step*)
  | mem_step_trans: forall m'',
       mem_step m m'' -> mem_step m'' m' -> mem_step m m'.

Local Notation "a # b" := (PMap.get b a) (at level 1).
Record perm_lesseq (m m': mem):= {
  perm_le_Cur:
    forall b ofs, Mem.perm_order'' ((Mem.mem_access m')#b ofs Cur) ((Mem.mem_access m)#b ofs Cur)
; perm_le_Max:
    forall b ofs, Mem.perm_order'' ((Mem.mem_access m')#b ofs Max) ((Mem.mem_access m)#b ofs Max)
; perm_le_cont:
    forall b ofs, Mem.perm m b ofs Cur Readable ->
     ZMap.get ofs (Mem.mem_contents m') !! b= ZMap.get ofs (Mem.mem_contents m) !! b
; perm_le_nb: Mem.nextblock m = Mem.nextblock m'
}.

(* Memory semantics are CoreSemantics that are specialized to CompCert memories
   and evolve memory according to mem_step. Previous notion CoopCoreSem is deprecated,
   but for now retained in file CoopCoreSem.v *)
Record MemSem {G C} :=
  { csem :> @CoreSemantics G C mem

  ; corestep_mem : forall g c m c' m' (CS: corestep csem g c m c' m'), mem_step m m'
  (*later, we'll want to add the following constraint
  ; corestep_incr_perm: forall g c m c' m' (CS: corestep csem g c m c' m')  m1 (PLE: perm_lesseq m m1),
         exists m1', corestep csem g c m1 c' m1' /\ perm_lesseq m' m1'*)
  }.

Arguments MemSem : clear implicits.


Require Import null_wind2_spec.

Definition type_LF_156 :=  PLAN ->  OBJ ->  nat ->  nat ->  nat ->  nat ->  nat ->  nat ->  nat -> (Prop * (List.list term)).

Definition F_156 : type_LF_156:= (fun  u5 u3 u1 u2 u4 _ _ _ _ => ((le u1 u2) = false -> (le (plus (time u3) u2) u4) = true -> (wind u5 u4 u1 u2) = Nil -> (sortedT (Cons u3 u5)) = true -> u5 = Nil, (Term id_le ((model_nat u1):: (model_nat u2)::nil))::(Term id_false nil)::(Term id_le ((Term id_plus ((Term id_time ((model_OBJ u3)::nil)):: (model_nat u2)::nil)):: (model_nat u4)::nil))::(Term id_true nil)::(Term id_wind ((model_PLAN u5):: (model_nat u4):: (model_nat u1):: (model_nat u2)::nil))::(Term id_Nil nil)::(Term id_sortedT ((Term id_Cons ((model_OBJ u3):: (model_PLAN u5)::nil))::nil))::(Term id_true nil)::(model_PLAN u5)::(Term id_Nil nil)::nil)).
Definition F_170 : type_LF_156:= (fun   _ u3 u1 u2 u4 _ _ _ _ => ((le u1 u2) = false -> (le (plus (time u3) u2) u4) = true -> (wind Nil u4 u1 u2) = Nil -> true = true -> Nil = Nil, (Term id_le ((model_nat u1):: (model_nat u2)::nil))::(Term id_false nil)::(Term id_le ((Term id_plus ((Term id_time ((model_OBJ u3)::nil)):: (model_nat u2)::nil)):: (model_nat u4)::nil))::(Term id_true nil)::(Term id_wind ((Term id_Nil nil):: (model_nat u4):: (model_nat u1):: (model_nat u2)::nil))::(Term id_Nil nil)::(Term id_true nil)::(Term id_true nil)::(Term id_Nil nil)::(Term id_Nil nil)::nil)).
Definition F_182 : type_LF_156:= (fun  u10  _ u1 u2 u4 u6 u7 u8 u9 => ((le u1 u2) = false -> (le (plus (time (C u7 u8)) u2) u4) = true -> (wind (Cons (C u6 u9) u10) u4 u1 u2) = Nil -> false = true -> (le u6 u7) = false -> (Cons (C u6 u9) u10) = Nil, (Term id_le ((model_nat u1):: (model_nat u2)::nil))::(Term id_false nil)::(Term id_le ((Term id_plus ((Term id_time ((Term id_C ((model_nat u7):: (model_nat u8)::nil))::nil)):: (model_nat u2)::nil)):: (model_nat u4)::nil))::(Term id_true nil)::(Term id_wind ((Term id_Cons ((Term id_C ((model_nat u6):: (model_nat u9)::nil)):: (model_PLAN u10)::nil)):: (model_nat u4):: (model_nat u1):: (model_nat u2)::nil))::(Term id_Nil nil)::(Term id_false nil)::(Term id_true nil)::(Term id_le ((model_nat u6):: (model_nat u7)::nil))::(Term id_false nil)::(Term id_Cons ((Term id_C ((model_nat u6):: (model_nat u9)::nil)):: (model_PLAN u10)::nil))::(Term id_Nil nil)::nil)).
Definition F_176 : type_LF_156:= (fun  u10  _ u1 u2 u4 u6 u7 u8 u9 => ((le u1 u2) = false -> (le (plus (time (C u7 u8)) u2) u4) = true -> (wind (Cons (C u6 u9) u10) u4 u1 u2) = Nil -> (sortedT (Cons (C u6 u9) u10)) = true -> (le u6 u7) = true -> (Cons (C u6 u9) u10) = Nil, (Term id_le ((model_nat u1):: (model_nat u2)::nil))::(Term id_false nil)::(Term id_le ((Term id_plus ((Term id_time ((Term id_C ((model_nat u7):: (model_nat u8)::nil))::nil)):: (model_nat u2)::nil)):: (model_nat u4)::nil))::(Term id_true nil)::(Term id_wind ((Term id_Cons ((Term id_C ((model_nat u6):: (model_nat u9)::nil)):: (model_PLAN u10)::nil)):: (model_nat u4):: (model_nat u1):: (model_nat u2)::nil))::(Term id_Nil nil)::(Term id_sortedT ((Term id_Cons ((Term id_C ((model_nat u6):: (model_nat u9)::nil)):: (model_PLAN u10)::nil))::nil))::(Term id_true nil)::(Term id_le ((model_nat u6):: (model_nat u7)::nil))::(Term id_true nil)::(Term id_Cons ((Term id_C ((model_nat u6):: (model_nat u9)::nil)):: (model_PLAN u10)::nil))::(Term id_Nil nil)::nil)).
Definition F_185 : type_LF_156:= (fun  u10  _ u1 u2 u4 u6 u7 u9 _ => ((le u1 u2) = false -> (le (plus u7 u2) u4) = true -> (wind (Cons (C u6 u9) u10) u4 u1 u2) = Nil -> (sortedT (Cons (C u6 u9) u10)) = true -> (le u6 u7) = true -> (Cons (C u6 u9) u10) = Nil, (Term id_le ((model_nat u1):: (model_nat u2)::nil))::(Term id_false nil)::(Term id_le ((Term id_plus ((model_nat u7):: (model_nat u2)::nil)):: (model_nat u4)::nil))::(Term id_true nil)::(Term id_wind ((Term id_Cons ((Term id_C ((model_nat u6):: (model_nat u9)::nil)):: (model_PLAN u10)::nil)):: (model_nat u4):: (model_nat u1):: (model_nat u2)::nil))::(Term id_Nil nil)::(Term id_sortedT ((Term id_Cons ((Term id_C ((model_nat u6):: (model_nat u9)::nil)):: (model_PLAN u10)::nil))::nil))::(Term id_true nil)::(Term id_le ((model_nat u6):: (model_nat u7)::nil))::(Term id_true nil)::(Term id_Cons ((Term id_C ((model_nat u6):: (model_nat u9)::nil)):: (model_PLAN u10)::nil))::(Term id_Nil nil)::nil)).
Definition F_194 : type_LF_156:= (fun  u10  _ u1 u2 u4 u6 u7 u9 _ => ((le u1 u2) = false -> (le (plus u7 u2) u4) = true -> (Cons (C u6 u9) (wind u10 u4 u1 u2)) = Nil -> (sortedT (Cons (C u6 u9) u10)) = true -> (le u6 u7) = true -> (le (plus u6 u2) u4) = true -> (le (plus u6 u1) u4) = false -> (Cons (C u6 u9) u10) = Nil, (Term id_le ((model_nat u1):: (model_nat u2)::nil))::(Term id_false nil)::(Term id_le ((Term id_plus ((model_nat u7):: (model_nat u2)::nil)):: (model_nat u4)::nil))::(Term id_true nil)::(Term id_Cons ((Term id_C ((model_nat u6):: (model_nat u9)::nil)):: (Term id_wind ((model_PLAN u10):: (model_nat u4):: (model_nat u1):: (model_nat u2)::nil))::nil))::(Term id_Nil nil)::(Term id_sortedT ((Term id_Cons ((Term id_C ((model_nat u6):: (model_nat u9)::nil)):: (model_PLAN u10)::nil))::nil))::(Term id_true nil)::(Term id_le ((model_nat u6):: (model_nat u7)::nil))::(Term id_true nil)::(Term id_le ((Term id_plus ((model_nat u6):: (model_nat u2)::nil)):: (model_nat u4)::nil))::(Term id_true nil)::(Term id_le ((Term id_plus ((model_nat u6):: (model_nat u1)::nil)):: (model_nat u4)::nil))::(Term id_false nil)::(Term id_Cons ((Term id_C ((model_nat u6):: (model_nat u9)::nil)):: (model_PLAN u10)::nil))::(Term id_Nil nil)::nil)).
Definition F_202 : type_LF_156:= (fun  u10  _ u1 u2 u4 u6 u7 u9 _ => ((le u1 u2) = false -> (le (plus u7 u2) u4) = true -> (Cons (C u6 u9) Nil) = Nil -> (sortedT (Cons (C u6 u9) u10)) = true -> (le u6 u7) = true -> (le (plus u6 u2) u4) = true -> (le (plus u6 u1) u4) = true -> (Cons (C u6 u9) u10) = Nil, (Term id_le ((model_nat u1):: (model_nat u2)::nil))::(Term id_false nil)::(Term id_le ((Term id_plus ((model_nat u7):: (model_nat u2)::nil)):: (model_nat u4)::nil))::(Term id_true nil)::(Term id_Cons ((Term id_C ((model_nat u6):: (model_nat u9)::nil)):: (Term id_Nil nil)::nil))::(Term id_Nil nil)::(Term id_sortedT ((Term id_Cons ((Term id_C ((model_nat u6):: (model_nat u9)::nil)):: (model_PLAN u10)::nil))::nil))::(Term id_true nil)::(Term id_le ((model_nat u6):: (model_nat u7)::nil))::(Term id_true nil)::(Term id_le ((Term id_plus ((model_nat u6):: (model_nat u2)::nil)):: (model_nat u4)::nil))::(Term id_true nil)::(Term id_le ((Term id_plus ((model_nat u6):: (model_nat u1)::nil)):: (model_nat u4)::nil))::(Term id_true nil)::(Term id_Cons ((Term id_C ((model_nat u6):: (model_nat u9)::nil)):: (model_PLAN u10)::nil))::(Term id_Nil nil)::nil)).
Definition F_198 : type_LF_156:= (fun  u10  _ u1 u2 u4 u6 u7 u9 _ => ((le u1 u2) = false -> (le (plus u7 u2) u4) = true -> (wind u10 u4 u1 u2) = Nil -> (sortedT (Cons (C u6 u9) u10)) = true -> (le u6 u7) = true -> (le (plus u6 u2) u4) = false -> (Cons (C u6 u9) u10) = Nil, (Term id_le ((model_nat u1):: (model_nat u2)::nil))::(Term id_false nil)::(Term id_le ((Term id_plus ((model_nat u7):: (model_nat u2)::nil)):: (model_nat u4)::nil))::(Term id_true nil)::(Term id_wind ((model_PLAN u10):: (model_nat u4):: (model_nat u1):: (model_nat u2)::nil))::(Term id_Nil nil)::(Term id_sortedT ((Term id_Cons ((Term id_C ((model_nat u6):: (model_nat u9)::nil)):: (model_PLAN u10)::nil))::nil))::(Term id_true nil)::(Term id_le ((model_nat u6):: (model_nat u7)::nil))::(Term id_true nil)::(Term id_le ((Term id_plus ((model_nat u6):: (model_nat u2)::nil)):: (model_nat u4)::nil))::(Term id_false nil)::(Term id_Cons ((Term id_C ((model_nat u6):: (model_nat u9)::nil)):: (model_PLAN u10)::nil))::(Term id_Nil nil)::nil)).

Definition LF_156 := [F_156, F_170, F_182, F_176, F_185, F_194, F_202, F_198].

Function f_156 (u5: PLAN) (u3: OBJ) {struct u5} : bool :=
 match u5, u3 with
| Nil, _ => true
| (Cons (C u6 u9) u10), (C u7 u8) => true
end.

Hypothesis true_154: forall u1 u2 u3 u4, (le (plus u1 u2) u3) = true -> (le u4 u1) = true -> (le (plus u4 u2) u3) = false -> False.

Lemma main_156 : forall F, In F LF_156 -> forall u1, forall u2, forall u3, forall u4, forall u5, forall u6, forall u7, forall u8, forall u9, (forall F', In F' LF_156 -> forall e1, forall e2, forall e3, forall e4, forall e5, forall e6, forall e7, forall e8, forall e9, less (snd (F' e1 e2 e3 e4 e5 e6 e7 e8 e9)) (snd (F u1 u2 u3 u4 u5 u6 u7 u8 u9)) -> fst (F' e1 e2 e3 e4 e5 e6 e7 e8 e9)) -> fst (F u1 u2 u3 u4 u5 u6 u7 u8 u9).
Proof.
intros F HF u1 u2 u3 u4 u5 u6 u7 u8 u9; case_In HF; intro Hind.

	(* GENERATE on [ 156 ] *)

rename u1 into _u5. rename u2 into _u3. rename u3 into _u1. rename u4 into _u2. rename u5 into _u4. rename u6 into d_u6. rename u7 into d_u7. rename u8 into d_u8. rename u9 into d_u9.
rename _u5 into u5. rename _u3 into u3. rename _u1 into u1. rename _u2 into u2. rename _u4 into u4.

revert Hind.

pattern u5, u3, (f_156 u5 u3). apply f_156_ind.

(* case [ 170 ] *)

intros _u5 _u3.  intro eq_1. intro. intro Heq3. rewrite <- Heq3.  intro HFabs0.
assert (Hind := HFabs0 F_170). clear HFabs0.
assert (HFabs0 : fst (F_170 Nil _u3 u1 u2 u4 0 0 0 0)).
apply Hind. trivial_in 1. unfold snd. unfold F_170. unfold F_156. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_156. unfold F_170.
auto.

intros _u5 _u3. intro u6. intro u9. intro u10.  intro eq_1. intro u7. intro u8.  intro eq_2.  intro HFabs0.
case_eq (le u6 u7); [intro H | intro H].

(* case [ 176 ] *)

assert (Hind := HFabs0 F_176). clear HFabs0.
assert (HFabs0 : fst (F_176 u10 (C 0 0 ) u1 u2 u4 u6 u7 u8 u9)).
apply Hind. trivial_in 3. unfold snd. unfold F_176. unfold F_156. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_156. unfold F_176. simpl in H. repeat(simpl; rewrite H). repeat(simpl in HFabs0; rewrite H in HFabs0). try (auto || (intro H0; contradict H0)).
auto.

(* case [ 182 ] *)

assert (Hind := HFabs0 F_182). clear HFabs0.
assert (HFabs0 : fst (F_182 u10 (C 0 0 ) u1 u2 u4 u6 u7 u8 u9)).
apply Hind. trivial_in 2. unfold snd. unfold F_182. unfold F_156. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_156. unfold F_182. simpl in H. repeat(simpl; rewrite H). repeat(simpl in HFabs0; rewrite H in HFabs0). try (auto || (intro H0; contradict H0)).
auto.

	(* TAUTOLOGY on [ 170 ] *)

unfold fst. unfold F_170.
auto.

	(* NEGATIVE CLASH on [ 182 ] *)

unfold fst. unfold F_182. intros. try discriminate.

	(* REWRITING on [ 176 ] *)

rename u1 into _u10. rename u2 into d_u2. rename u3 into _u1. rename u4 into _u2. rename u5 into _u4. rename u6 into _u6. rename u7 into _u7. rename u8 into _u8. rename u9 into _u9.
rename _u10 into u10. rename _u1 into u1. rename _u2 into u2. rename _u4 into u4. rename _u6 into u6. rename _u7 into u7. rename _u8 into u8. rename _u9 into u9.
assert (Res := Hind F_185). clear Hind.
assert (HFabs1 : fst (F_185 u10 (C 0 0 ) u1 u2 u4 u6 u7 u9 0)).
apply Res. trivial_in 4. unfold snd. unfold F_185. unfold F_176. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_176. unfold fst in HFabs1. unfold F_185 in HFabs1.
pattern u7, u8. simpl (time _). cbv beta.
 simpl. auto.

	(* TOTAL CASE REWRITING on [ 185 ] *)

rename u1 into _u10. rename u2 into d_u2. rename u3 into _u1. rename u4 into _u2. rename u5 into _u4. rename u6 into _u6. rename u7 into _u7. rename u8 into _u9. rename u9 into d_u9.
rename _u10 into u10. rename _u1 into u1. rename _u2 into u2. rename _u4 into u4. rename _u6 into u6. rename _u7 into u7. rename _u9 into u9.
assert (H: ((le (plus u6 u2) u4) = true) /\ ((le (plus u6 u1) u4) = false) \/ ((le (plus u6 u2) u4) = false) \/ ((le (plus u6 u2) u4) = true) /\ ((le (plus u6 u1) u4) = true)).

destruct ((le (plus u6 u1) u4)); destruct ((le (plus u6 u2) u4)); auto.

destruct H as [[H H0]|[H|[H H0]]].

(* rewriting with the axiom [ 119 ] *)

assert (H1 := Hind F_194). clear Hind.
assert (HFabs0 : fst (F_194 u10 (C 0 0 ) u1 u2 u4 u6 u7 u9 0)).
apply H1. trivial_in 5. unfold snd. unfold F_194. unfold F_185. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_185. unfold F_194. unfold fst in HFabs0. unfold F_194 in HFabs0. simpl in HFabs0.
pattern u6.
pattern u2.
pattern u4.
pattern u1.
pattern u9.
pattern u10.
simpl (wind _ _ _ _). cbv beta. try unfold wind. try rewrite H. try rewrite H0. try unfold wind in HFabs0. try rewrite H in HFabs0. try rewrite H0 in HFabs0. auto.

(* rewriting with the axiom [ 120 ] *)

assert (H1 := Hind F_198). clear Hind.
assert (HFabs0 : fst (F_198 u10 (C 0 0 ) u1 u2 u4 u6 u7 u9 0)).
apply H1. trivial_in 7. unfold snd. unfold F_198. unfold F_185. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_185. unfold F_198. unfold fst in HFabs0. unfold F_198 in HFabs0. simpl in HFabs0.
pattern u6.
pattern u2.
pattern u4.
pattern u9.
pattern u10.
pattern u1.
simpl (wind _ _ _ _). cbv beta. try unfold wind. try rewrite H. try rewrite H0. try unfold wind in HFabs0. try rewrite H in HFabs0. try rewrite H0 in HFabs0. auto.

(* rewriting with the axiom [ 121 ] *)

assert (H1 := Hind F_202). clear Hind.
assert (HFabs0 : fst (F_202 u10 (C 0 0 ) u1 u2 u4 u6 u7 u9 0)).
apply H1. trivial_in 6. unfold snd. unfold F_202. unfold F_185. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_185. unfold F_202. unfold fst in HFabs0. unfold F_202 in HFabs0. simpl in HFabs0.
pattern u6.
pattern u2.
pattern u4.
pattern u1.
pattern u9.
pattern u10.
simpl (wind _ _ _ _). cbv beta. try unfold wind. try rewrite H. try rewrite H0. try unfold wind in HFabs0. try rewrite H in HFabs0. try rewrite H0 in HFabs0. auto.

	(* NEGATIVE CLASH on [ 194 ] *)

unfold fst. unfold F_194. intros. try discriminate.

	(* NEGATIVE CLASH on [ 202 ] *)

unfold fst. unfold F_202. intros. try discriminate.

	(* SUBSUMPTION on [ 198 ] *)

rename u1 into _u10. rename u2 into d_u2. rename u3 into _u1. rename u4 into _u2. rename u5 into _u4. rename u6 into _u6. rename u7 into _u7. rename u8 into _u9. rename u9 into d_u9.
rename _u10 into u10. rename _u1 into u1. rename _u2 into u2. rename _u4 into u4. rename _u6 into u6. rename _u7 into u7. rename _u9 into u9.
unfold fst. unfold F_198. specialize true_154 with (u1 := u7) (u2 := u2) (u3 := u4) (u4 := u6). intro L. intros. contradict L. (auto || symmetry; auto).

Qed.

(* the set of all formula instances from the proof *)
Definition S_156 := fun f => exists F, In F LF_156 /\ exists e1, exists e2, exists e3, exists e4, exists e5, exists e6, exists e7, exists e8, exists e9, f = F e1 e2 e3 e4 e5 e6 e7 e8 e9.

Theorem all_true_156: forall F, In F LF_156 -> forall u1: PLAN, forall u2: OBJ, forall u3: nat, forall u4: nat, forall u5: nat, forall u6: nat, forall u7: nat, forall u8: nat, forall u9: nat, fst (F u1 u2 u3  u4  u5  u6  u7  u8  u9).
Proof.
let n := constr:(9) in
let p := constr:(S(S(n))) in
intros;
let G := fresh "G" in
let x := fresh "x" in
apply wf_subset with (R:=@snd_rpo_mul P Prop max_size) (S:=S_156);
[(* 1 *) apply wf_snd_rpo_mul, prec_wf
|(* 2 *) idtac
|(* 3 *) eexists; split; [ eassumption | idtac]; do_nat n ltac:(eexists); reflexivity
];

intros x G;
do_nat p ltac:(elim G; intro; clear G; intro G);
rewrite G in * |- *; clear G; clear x;
intro G;
apply main_156;
 [assumption | idtac];
intros;
apply G;
 [ idtac | assumption ];
eexists; split;
 [idtac | do_nat n ltac:(eexists); reflexivity];
assumption.
Qed.

Theorem true_156: forall (u5: PLAN) (u3: OBJ) (u1: nat) (u2: nat) (u4: nat), (le u1 u2) = false -> (le (plus (time u3) u2) u4) = true -> (wind u5 u4 u1 u2) = Nil -> (sortedT (Cons u3 u5)) = true -> u5 = Nil.
Proof.
do 5 intro.
apply (all_true_156 F_156);
 (trivial_in 0) ||
 (repeat constructor).
Qed.


Definition UU := Type.

Definition dirprodpair {X Y : UU} := existT (fun x : X => Y).

Definition funtoprodtoprod {X Y Z : UU} : { a : X -> Y & X -> Z }.
Proof.
  refine (dirprodpair _ (fun x => _)).