From sflib Require Import sflib.
Require Import Coq.Classes.RelationClasses.
From Fairness Require Import Axioms NatStructs.
From Fairness Require Import PCM.
Require Import String Lia Program.

Set Implicit Arguments.

Module NatMapRALarge.
  Section MAP.
    Variable A: Type.

    Definition car := option (NatMap.t A).

    Definition unit: car := Some (NatMap.empty A).

    Definition add (m0 m1: car): car :=
      match m0, m1 with
      | Some m0, Some m1 =>
          if (NatStructs.disjoint m0 m1) then Some (NatMapP.update m0 m1) else None
      | _, _ => None
      end.

    Definition wf (m: car): Prop :=
      match m with
      | None => False
      | _ => True
      end.

    Definition core (m: car): car := unit.

    Global Program Instance t: URA.t := {
        car := car;
        unit := unit;
        _add := add;
        _wf := wf;
        core := core;
      }
    .
    Next Obligation.
      unfold add. des_ifs.
      { f_equal. apply disjoint_union_comm. apply disjoint_true_iff; auto. }
      { rewrite disjoint_comm in Heq. clarify. }
      { rewrite disjoint_comm in Heq. clarify. }
    Qed.
    Next Obligation.
      unfold add. des_ifs.
      { f_equal. rewrite union_assoc. auto. }
      { rewrite disjoint_true_iff in *.
        apply Disjoint_union in Heq0. des.
        hexploit (proj2 (Disjoint_union t2 t t3)).
        { split.
          { apply NatMapP.Disjoint_sym. auto. }
          { apply NatMapP.Disjoint_sym. auto. }
        }
        i. apply NatMapP.Disjoint_sym in H.
        apply disjoint_true_iff in H. clarify.
      }
      { rewrite disjoint_true_iff in *.
        apply Disjoint_union in Heq0. des.
        apply disjoint_true_iff in Heq0. clarify.
      }
      { rewrite disjoint_true_iff in *.
        apply NatMapP.Disjoint_sym in Heq2.
        apply Disjoint_union in Heq2. des.
        hexploit (proj2 (Disjoint_union t t3 t2)).
        { split; auto. apply NatMapP.Disjoint_sym. auto. }
        i. apply disjoint_true_iff in H. clarify.
      }
      { rewrite disjoint_true_iff in *.
        apply NatMapP.Disjoint_sym in Heq1.
        apply Disjoint_union in Heq1. des.
        apply NatMapP.Disjoint_sym in Heq3.
        apply disjoint_true_iff in Heq3. clarify.
      }
    Qed.
    Next Obligation.
      unseal "ra". unfold add, unit. des_ifs.
      hexploit Disjoint_empty. i.
      apply disjoint_true_iff in H. rewrite H in *. clarify.
    Qed.
    Next Obligation.
      unseal "ra". ss.
    Qed.
    Next Obligation.
      unseal "ra". unfold add in *. des_ifs.
    Qed.
    Next Obligation.
      unseal "ra". ss. des_ifs. f_equal.
      rewrite union_empty. auto.
    Qed.
    Next Obligation.
      exists unit. unseal "ra". unfold add, core, unit. des_ifs.
    Qed.

    Definition singleton (k: nat) (a: A): car := Some (NatMap.add k a (NatMap.empty A)).

    Lemma singleton_unique k0 a0 k1 a1
          (WF: URA.wf (singleton k0 a0 ⋅ singleton k1 a1))
      :
      k0 <> k1.
    Proof.
      ii. ur in WF. des_ifs.
      rewrite disjoint_true_iff in *.
      eapply Heq. split.
      { apply NatMapP.F.add_in_iff. eauto. }
      { apply NatMapP.F.add_in_iff. eauto. }
    Qed.

    Lemma extends_iff m0 m1
      :
      URA.extends (Some m0) (Some m1)
      <->
        (forall k a (FIND: NatMap.find k m0 = Some a), NatMap.find k m1 = Some a).
    Proof.
      split.
      { ii. rr in H. des. ur in H. des_ifs.
        apply NatMap.find_1. apply NatMapP.update_mapsto_iff.
        apply NatMap.find_2 in FIND. right. split; auto.
        apply disjoint_true_iff in Heq.
        ii. eapply Heq; eauto. split; eauto.
        apply NatMapP.F.in_find_iff. apply NatMap.find_1 in FIND. ii. clarify.
      }
      { i. exists (Some (NatMapP.diff m1 m0)).
        ur. des_ifs.
        { f_equal. apply nm_eq_is_equal.
          apply NatMapP.F.Equal_mapsto_iff. i.
          rewrite NatMapP.update_mapsto_iff.
          rewrite NatMapP.diff_mapsto_iff. split; i; des; auto.
          { apply NatMap.find_2. eapply H.
            apply NatMap.find_1. auto.
          }
          { destruct (NatMap.find k m0) eqn:FIND.
            { apply NatMap.find_1 in H0.
              hexploit H; eauto. i. clarify.
              right. split; auto.
              { apply NatMap.find_2; auto. }
              { ii. apply NatMapP.diff_in_iff in H0. des.
                eapply H2. apply NatMapP.F.in_find_iff. ii. clarify.
              }
            }
            { left. split; auto. ii.
              apply NatMapP.F.in_find_iff in H1. ss.
            }
          }
        }
        { apply disjoint_false_iff in Heq.
          exfalso. eapply Heq. ii. des.
          apply NatMapP.diff_in_iff in H1. des. ss.
        }
      }
    Qed.

    Lemma extends_singleton_iff m k a
      :
      URA.extends (singleton k a) (Some m)
      <->
        (NatMap.find k m = Some a).
    Proof.
      unfold singleton. rewrite extends_iff. split; i.
      { eapply H. apply nm_find_add_eq. }
      { rewrite NatMapP.F.add_o in FIND. des_ifs. }
    Qed.

    Lemma add_local_update m k a
          (NONE: NatMap.find k m = None)
      :
      Auth.local_update (Some m) unit (Some (NatMap.add k a m)) (singleton k a).
    Proof.
      ii. des. ur in FRAME. des_ifs. split; ss.
      { ur. ss. }
      rr. ur. des_ifs.
      { apply disjoint_true_iff in Heq.
        apply NatMapP.Disjoint_sym in Heq.
        apply Disjoint_add in Heq. des.
        f_equal. eapply eq_ext_is_eq. ii.
        rewrite ! NatMapP.F.add_mapsto_iff.
        rewrite ! NatMapP.update_mapsto_iff.
        rewrite ! NatMapP.F.add_mapsto_iff.
        rewrite NatMapP.F.empty_mapsto_iff.
        rewrite <- NatMapP.F.not_find_in_iff in NONE.
        rewrite NatMapP.update_in_iff in NONE.
        split; i; des; subst; auto.
        right. split; auto. ii. subst.
        eapply Heq. apply NatMapP.F.in_find_iff.
        apply NatMap.find_1 in H. ii. clarify.
      }
      { exfalso. apply disjoint_false_iff in Heq. apply Heq.
        apply NatMapP.Disjoint_sym.
        eapply Disjoint_add. split.
        { apply NatMapP.F.not_find_in_iff in NONE.
          rewrite NatMapP.update_in_iff in NONE.
          ii. eapply NONE; eauto.
        }
        { apply Disjoint_empty. }
      }
    Qed.

    Lemma remove_local_update m k a
      :
      Auth.local_update (Some m) (singleton k a) (Some (NatMap.remove k m)) unit.
    Proof.
      ii. des. ur in FRAME. des_ifs. split; ss.
      { ur. ss. }
      rr. unfold unit. ur. f_equal.
      apply disjoint_true_iff in Heq.
      apply NatMapP.Disjoint_sym in Heq.
      apply Disjoint_add in Heq. des.
      eapply eq_ext_is_eq. ii.
      rewrite ! NatMapP.F.remove_mapsto_iff.
      rewrite ! NatMapP.update_mapsto_iff.
      rewrite ! NatMapP.F.add_mapsto_iff.
      rewrite NatMapP.F.empty_mapsto_iff.
      split; i; des; subst; auto.
      { splits; auto. ii. subst. eapply Heq.
        apply NatMapP.F.in_find_iff.
        apply NatMap.find_1 in H. ii. clarify.
      }
      { split; auto. right; auto. }
    Qed.
  End MAP.
End NatMapRALarge.

From Fairness Require Import IProp IPM.
From iris.bi Require Import derived_laws. Import bi.

Section SUM.
  Context `{Σ: GRA.t}.

  Fixpoint list_prop_sum A (P: A -> iProp) (l: list A): iProp :=
    match l with
    | [] => True
    | hd::tl => P hd ** list_prop_sum P tl
    end.

  Lemma list_prop_sum_wand (A: Type) (P0 P1 : A → iProp)
        (l: list A)
    :
    (list_prop_sum P0 l)
      -∗
      (list_prop_sum (fun a => P0 a -* P1 a) l)
      -∗
      (list_prop_sum P1 l).
  Proof.
    induction l; ss.
    { iIntros. auto. }
    iIntros "[HD0 TL0] [HD1 TL1]". iSplitL "HD0 HD1".
    { iApply ("HD1" with "HD0"). }
    { iApply (IHl with "TL0 TL1"). }
  Qed.

  Lemma list_prop_sum_perm A P (l0 l1: list A)
        (PERM: Permutation l0 l1)
    :
    list_prop_sum P l0 ⊢ list_prop_sum P l1.
  Proof.
    induction PERM; ss.
    { iIntros "[H0 H1]". iFrame. iApply IHPERM. auto. }
    { iIntros "[H0 [H1 H2]]". iFrame. }
    { etrans; eauto. }
  Qed.

  Lemma list_prop_sum_nil A (P: A -> iProp)
    :
    ⊢ list_prop_sum P [].
  Proof.
    ss. auto.
  Qed.

  Lemma list_prop_sum_cons_fold A (P: A -> iProp) hd tl
    :
    (P hd ** list_prop_sum P tl)
      -∗
      (list_prop_sum P (hd::tl)).
  Proof.
    ss.
  Qed.

  Lemma list_prop_sum_cons_unfold A (P: A -> iProp) hd tl
    :
    (list_prop_sum P (hd::tl))
      -∗
      (P hd ** list_prop_sum P tl).
  Proof.
    ss.
  Qed.

  Lemma list_prop_sum_split A (P: A -> iProp) l0 l1
    :
    (list_prop_sum P (l0 ++ l1))
      -∗
      (list_prop_sum P l0 ** list_prop_sum P l1).
  Proof.
    induction l0; ss.
    { iIntros "SAT". iFrame. }
    { iIntros "[INTERP SAT]". iFrame. iApply IHl0; auto. }
  Qed.

  Lemma list_prop_sum_combine A (P: A -> iProp) l0 l1
    :
    (list_prop_sum P l0 ** list_prop_sum P l1)
      -∗
      (list_prop_sum P (l0 ++ l1)).
  Proof.
    induction l0; ss.
    { iIntros "[_ SAT]". auto. }
    { iIntros "[[INTERP SAT0] SAT1]". iFrame.
      iApply IHl0. iFrame.
    }
  Qed.

  Lemma list_prop_sum_add A (P: A -> iProp) l a
    :
    (P a ** list_prop_sum P l)
      -∗
      (list_prop_sum P (l++[a])).
  Proof.
    iIntros "[NEW SAT]". iApply list_prop_sum_combine. iFrame.
  Qed.

  Lemma list_prop_sum_impl A (P0 P1: A -> iProp) l
        (IMPL: forall a, P0 a ⊢ P1 a)
    :
    (list_prop_sum P0 l)
      -∗
      (list_prop_sum P1 l).
  Proof.
    induction l; ss.
    iIntros "[HD TL]". iSplitL "HD".
    { iApply (IMPL with "HD"). }
    { iApply (IHl with "TL"). }
  Qed.

  Lemma list_prop_sum_sepconj A (P0 P1: A -> iProp) l
    :
    ((list_prop_sum P0 l) ∗ (list_prop_sum P1 l))
      -∗
      list_prop_sum (fun a => (P0 a) ∗ (P1 a)) l.
  Proof.
    induction l; ss; auto.
    iIntros "[[HD1 TL1] [HD2 TL2]]". iFrame. iApply IHl. iFrame.
  Qed.

  Lemma list_prop_sepconj_sum A (P0 P1: A -> iProp) l
    :
    (list_prop_sum (fun a => (P0 a) ∗ (P1 a)) l)
      -∗
      ((list_prop_sum P0 l) ∗ (list_prop_sum P1 l)).
  Proof.
    induction l; ss; auto.
    iIntros "[[HD1 HD2] TL]". iFrame. iApply IHl. iFrame.
  Qed.

  Lemma list_prop_sum_impl2 A (P0 P1 Q: A -> iProp) l
        (IMPL: forall a, (P0 a ∗ P1 a) -∗ Q a)
    :
    ((list_prop_sum P0 l) ∗ (list_prop_sum P1 l))
      -∗
      list_prop_sum Q l.
  Proof.
    iIntros "SUMs". iApply list_prop_sum_impl. 2: iApply list_prop_sum_sepconj; iFrame.
    i. ss.
  Qed.

  Lemma list_prop_sum_persistent A (P: A -> iProp) l
        (PERSIST: forall a, Persistent (P a))
    :
    (list_prop_sum P l) -∗ (□ list_prop_sum P l).
  Proof.
    induction l.
    { iIntros "_". ss. }
    ss. iIntros "[#P Ps]".
    iApply intuitionistically_sep_2. iSplitL "P".
    - iModIntro. auto.
    - iApply IHl; iFrame.
  Qed.

  Global Program Instance Persistent_list_prop_sum
         A (P: A -> iProp) l (PERSIST: forall a, Persistent (P a)) : Persistent (list_prop_sum P l).
  Next Obligation.
  Proof.
    intros. iIntros "Ps". iPoseProof (list_prop_sum_persistent with "Ps") as "Ps". auto.
  Qed.

  Lemma list_map_forall2 A B (f: A -> B)
        l
    :
    List.Forall2 (fun a b => b = f a) l (List.map f l).
  Proof.
    induction l; ss. econs; eauto.
  Qed.

  Lemma list_prop_sum_forall2 A B
        (R: A -> B -> Prop)
        (P: A -> iProp) (Q: B -> iProp)
        la lb
        (FORALL: List.Forall2 R la lb)
        (IMPL: forall a b (INA: List.In a la) (INB: List.In b lb),
            R a b -> P a ⊢ Q b)
    :
    (list_prop_sum P la)
      -∗
      (list_prop_sum Q lb).
  Proof.
    revert IMPL. induction FORALL; i; ss.
    iIntros "[HD TL]". iSplitL "HD".
    { iApply (IMPL with "HD"); auto. }
    { iApply (IHFORALL with "TL"). auto. }
  Qed.

  Lemma list_prop_sum_or_cases_l
        A (P0 P1: A -> iProp) l
    :
    (list_prop_sum (fun a => (P0 a ∨ P1 a)) l)
      -∗
      ((list_prop_sum P0 l) ∨ (∃ a, (⌜List.In a l⌝) ∗ (P1 a))).
  Proof.
    induction l.
    { iIntros "_". iLeft. ss. }
    ss. iIntros "[[C0|C1] SUM]".
    - iPoseProof (IHl with "SUM") as "[S0|S1]". iLeft; iFrame.
      iRight. iDestruct "S1" as "[% [%IN P1]]". iExists a0. iFrame. iPureIntro. auto.
    - iRight. iExists a. iFrame. iPureIntro. auto.
  Qed.

  Lemma list_prop_sum_or_cases_r
        A (P0 P1: A -> iProp) l
    :
    (list_prop_sum (fun a => (P0 a ∨ P1 a)) l)
      -∗
      ((list_prop_sum P1 l) ∨ (∃ a, (⌜List.In a l⌝) ∗ (P0 a))).
  Proof.
    iIntros "SUM". iApply list_prop_sum_or_cases_l. iApply list_prop_sum_impl. 2: iFrame.
    i. iIntros "[C0|C1]"; iFrame.
  Qed.

  Lemma list_prop_sum_pull_bupd
        Q
        A (P: A -> iProp) l
    :
    (list_prop_sum (fun a => #=( Q )=> P a) l)
      -∗
      #=( Q )=>(list_prop_sum P l).
  Proof.
    induction l.
    { iIntros "_". ss. }
    ss. iIntros "[PA SUM]". iSplitL "PA"; iFrame. iApply IHl. iFrame.
  Qed.

  Lemma list_prop_sum_pull_bupd_default
        A (P: A -> iProp) l
    :
    (list_prop_sum (fun a => #=> P a) l)
      -∗
      #=>(list_prop_sum P l).
  Proof.
    induction l.
    { iIntros "_". ss. }
    ss. iIntros "[PA SUM]". iSplitL "PA"; iFrame. iApply IHl. iFrame.
  Qed.

  Lemma list_prop_sum_in_split
        A (P: A -> iProp) l a
        (IN: In a l)
    :
    (list_prop_sum (fun a => P a) l)
      -∗ ((P a) ∗ ((P a) -∗ (list_prop_sum (fun a => P a) l))).
  Proof.
    iIntros "SUM". apply in_split in IN. des. rewrite cons_middle in IN. clarify.
    iPoseProof (list_prop_sum_split with "SUM") as "[SL SR]".
    iPoseProof (list_prop_sum_split with "SR") as "[SM SR]".
    iSplitL "SM". ss. iDestruct "SM" as "[PA _]". iFrame.
    iIntros "PA".
    iAssert (list_prop_sum (fun a0 => P a0) (a :: (l1 ++ l2)))%I with "[SL SR PA]" as "SP".
    { ss. iFrame. iApply list_prop_sum_combine. iFrame. }
    iApply (list_prop_sum_perm with "SP"). rewrite app_assoc. rewrite app_comm_cons.
    apply Permutation_app_tail. apply Permutation_cons_append.
  Qed.

  Lemma list_prop_sum_map
        A (P0: A -> iProp)
        B (P1: B -> iProp)
        l (f: A -> B)
        (MAP: forall a, (P0 a) -∗ (P1 (f a)))
    :
    (list_prop_sum P0 l)
      -∗
      (list_prop_sum P1 (List.map f l)).
  Proof.
    induction l; ss.
    iIntros "[HD TL]". iSplitL "HD".
    { iApply (MAP with "HD"). }
    { iApply (IHl with "TL"). }
  Qed.

  Definition natmap_prop_sum A (f: NatMap.t A) (P: nat -> A -> iProp) :=
    list_prop_sum (fun '(k, v) => P k v) (NatMap.elements f).

  Lemma natmap_prop_sum_empty A P
    :
    ⊢ natmap_prop_sum (NatMap.empty A) P.
  Proof.
    unfold natmap_prop_sum. ss. auto.
  Qed.

  Lemma natmap_prop_remove_find A (f: NatMap.t A) P k v
        (FIND: NatMap.find k f = Some v)
    :
    (natmap_prop_sum f P)
      -∗
      (P k v ** natmap_prop_sum (NatMap.remove k f) P).
  Proof.
    hexploit NatMap.elements_1.
    { eapply NatMap.find_2; eauto. }
    i. eapply SetoidList.InA_split in H. des.
    destruct y. inv H. ss. subst.
    unfold natmap_prop_sum. rewrite H0.
    iIntros "H".
    iPoseProof (list_prop_sum_perm with "H") as "H".
    { instantiate (1:=(k0,a)::(l1 ++ l2)).
      symmetry. apply Permutation_middle.
    }
    iEval (ss) in "H". iDestruct "H" as "[H0 H1]". iFrame.
    iApply (list_prop_sum_perm with "H1").
    symmetry. eapply Permutation_remove.
    rewrite H0. symmetry. apply Permutation_middle.
  Qed.

  Lemma natmap_prop_remove A (f: NatMap.t A) P k
    :
    (natmap_prop_sum f P)
      -∗
      (natmap_prop_sum (NatMap.remove k f) P).
  Proof.
    destruct (NatMap.find k f) eqn:EQ.
    { iIntros "H". iPoseProof (natmap_prop_remove_find with "H") as "[_ H]"; eauto. }
    replace (NatMap.remove k f) with f; auto.
    eapply eq_ext_is_eq. ii.
    rewrite NatMapP.F.remove_mapsto_iff. split.
    { i. split; auto. ii.
      eapply NatMap.find_1 in H. clarify.
    }
    { i. des. auto. }
  Qed.

  Lemma natmap_prop_sum_add A P k v (f: NatMap.t A)
    :
    (natmap_prop_sum f P)
      -∗
      (P k v)
      -∗
      (natmap_prop_sum (NatMap.add k v f) P).
  Proof.
    destruct (NatMapP.F.In_dec f k).
    { rewrite <- nm_add_rm_eq. iIntros "H0 H1".
      unfold natmap_prop_sum.
      iApply list_prop_sum_perm.
      { symmetry. eapply Permutation_add; eauto. apply NatMap.remove_1; auto. }
      iPoseProof (natmap_prop_remove with "H0") as "H0".
      ss. iFrame.
    }
    { unfold natmap_prop_sum. iIntros "H0 H1".
      iApply list_prop_sum_perm.
      { symmetry. eapply Permutation_add; eauto. }
      ss. iFrame.
    }
  Qed.

  Lemma natmap_prop_sum_persistent A (P: nat -> A -> iProp) m
        (PERSIST: forall n a, Persistent (P n a))
    :
    (natmap_prop_sum m P) -∗ (□ natmap_prop_sum m P).
  Proof.
    unfold natmap_prop_sum. apply list_prop_sum_persistent. i. des_ifs.
  Qed.

  Global Program Instance Persistent_natmap_prop_sum
         A (P: nat -> A -> iProp) m
         (PERSIST: forall n a, Persistent (P n a)) : Persistent (natmap_prop_sum m P).
  Next Obligation.
  Proof.
    intros. iIntros "Ps". iPoseProof (natmap_prop_sum_persistent with "Ps") as "Ps". auto.
  Qed.

  Lemma natmap_prop_sum_in A P k a (m: NatMap.t A)
        (FIND: NatMap.find k m = Some a)
    :
    (natmap_prop_sum m P)
      -∗
      (P k a).
  Proof.
    iIntros "MAP". iPoseProof (natmap_prop_remove_find with "MAP") as "[H0 H1]".
    { eauto. }
    eauto.
  Qed.

  Lemma natmap_prop_sum_impl A P0 P1 (m: NatMap.t A)
        (IMPL: forall k a (IN: NatMap.find k m = Some a), P0 k a ⊢ P1 k a)
    :
    (natmap_prop_sum m P0)
      -∗
      (natmap_prop_sum m P1).
  Proof.
    revert IMPL. pattern m. eapply nm_ind.
    { iIntros. iApply natmap_prop_sum_empty. }
    i. iIntros "MAP".
    iPoseProof (natmap_prop_remove_find with "MAP") as "[H0 H1]".
    { eapply nm_find_add_eq. }
    iPoseProof (IMPL with "H0") as "H0".
    { rewrite nm_find_add_eq. auto. }
    iApply (natmap_prop_sum_add with "[H1] H0").
    iApply IH.
    { i. eapply IMPL. rewrite NatMapP.F.add_o; eauto. des_ifs. }
    { rewrite nm_find_none_rm_add_eq; auto. }
  Qed.

  Lemma natmap_prop_sum_wand (A: Type) P0 P1 (m: NatMap.t A)
    :
    (natmap_prop_sum m P0)
      -∗
      (natmap_prop_sum m (fun k v => P0 k v -* P1 k v))
      -∗
      (natmap_prop_sum m P1).
  Proof.
    pattern m. eapply nm_ind.
    { iIntros. iApply natmap_prop_sum_empty. }
    i. iIntros "MAP IMPL".
    iPoseProof (natmap_prop_remove_find with "MAP") as "[H0 H1]".
    { eapply nm_find_add_eq. }
    iPoseProof (natmap_prop_remove_find with "IMPL") as "[G0 G1]".
    { eapply nm_find_add_eq. }
    iApply (natmap_prop_sum_add with "[H1 G1] [H0 G0]").
    { rewrite nm_find_none_rm_add_eq; auto. iApply (IH with "H1 G1"). }
    { iApply ("G0" with "H0"). }
  Qed.

  Lemma natmap_prop_sum_impl_strong (A: Type) P0 P1 Q (m: NatMap.t A)
        (IMPL: forall k v, P0 k v ** Q ⊢ P1 k v ** Q)
    :
    (natmap_prop_sum m P0 ** Q)
      -∗
      (natmap_prop_sum m P1 ** Q).
  Proof.
    pattern m. eapply nm_ind.
    { iIntros "[SUM H]". iFrame. }
    i. iIntros "[MAP H]".
    iPoseProof (natmap_prop_remove_find with "MAP") as "[H0 H1]".
    { eapply nm_find_add_eq. }
    rewrite nm_find_none_rm_add_eq; [|auto].
    iPoseProof (IH with "[H1 H]") as "[H1 H]".
    { iFrame. }
    iPoseProof (IMPL with "[H0 H]") as "[H0 H]".
    { iFrame. }
    iFrame. iApply (natmap_prop_sum_add with "H1 H0").
  Qed.

  Lemma natmap_prop_sum_or_cases_l
        A (P0 P1: nat -> A -> iProp) m
    :
    (natmap_prop_sum m (fun k a => (P0 k a ∨ P1 k a)))
      -∗
      ((natmap_prop_sum m P0) ∨ (∃ k a, (⌜NatMap.find k m = Some a⌝) ∗ (P1 k a))).
  Proof.
    unfold natmap_prop_sum. iIntros "SUM".
    iPoseProof (list_prop_sum_or_cases_l with "[SUM]") as "SUM".
    { iApply list_prop_sum_impl. 2: iFrame. i. ss. des_ifs. iIntros "[P0|P1]".
      - iLeft. instantiate (1:=fun '(k, a) => P0 k a). ss.
      - iRight. instantiate (1:=fun '(k, a) => P1 k a). ss.
    }
    iDestruct "SUM" as "[SUM|ELSE]".
    { iFrame. }
    iRight. iDestruct "ELSE" as "[% [IN P]]". des_ifs. do 2 iExists _. iFrame.
    iPure "IN" as IN. iPureIntro. remember (NatMap.elements m) as ml.
    assert (ND: SetoidList.NoDupA (NatMap.eq_key (elt:=_)) ml).
    { subst. apply NatMap.elements_3w. }
    rewrite NatMapP.F.elements_o. rewrite <- Heqml. clear m Heqml.
    eapply SetoidList.In_InA in IN.
    { eapply SetoidList.findA_NoDupA; eauto. }
    econs; ss.
    - econs; des; clarify.
    - econs; des; clarify; auto. rewrite <- H0. auto. rewrite <- H1; auto.
  Qed.

  Lemma natmap_prop_sum_or_cases_r
        A (P0 P1: nat -> A -> iProp) m
    :
    (natmap_prop_sum m (fun k a => (P0 k a ∨ P1 k a)))
      -∗
      ((natmap_prop_sum m P1) ∨ (∃ k a, (⌜NatMap.find k m = Some a⌝) ∗ (P0 k a))).
  Proof.
    iIntros "SUM". iApply natmap_prop_sum_or_cases_l. iApply natmap_prop_sum_impl. 2: iFrame.
    i. iIntros "[C0|C1]"; iFrame.
  Qed.

  Lemma natmap_prop_sum_pull_bupd
        Q
        A (P: nat -> A -> iProp) m
    :
    (natmap_prop_sum m (fun k a => #=( Q )=> P k a))
      -∗
      #=( Q )=>(natmap_prop_sum m P).
  Proof.
    unfold natmap_prop_sum. iIntros "SUM".
    iPoseProof (list_prop_sum_pull_bupd with "[SUM]") as "SUM".
    { iApply list_prop_sum_impl. 2: iFrame. i. ss. des_ifs.
      instantiate (1:=fun '(k, a) => P k a). ss.
    }
    iFrame.
  Qed.

  Lemma natmap_prop_sum_pull_bupd_default
        A (P: nat -> A -> iProp) m
    :
    (natmap_prop_sum m (fun k a => #=> P k a))
      -∗
      #=>(natmap_prop_sum m P).
  Proof.
    unfold natmap_prop_sum. iIntros "SUM".
    iPoseProof (list_prop_sum_pull_bupd_default with "[SUM]") as "SUM".
    { iApply list_prop_sum_impl. 2: iFrame. i. ss. des_ifs.
      instantiate (1:=fun '(k, a) => P k a). ss.
    }
    iFrame.
  Qed.

  Lemma natmap_prop_sum_sepconj A (P0 P1: nat -> A -> iProp) m
    :
    ((natmap_prop_sum m P0) ∗ (natmap_prop_sum m P1))
      -∗
      natmap_prop_sum m (fun k a => (P0 k a) ∗ (P1 k a)).
  Proof.
    unfold natmap_prop_sum . iIntros "SUM".
    iPoseProof (list_prop_sum_sepconj with "SUM") as "SUM". iApply list_prop_sum_impl. 2: iFrame.
    i. ss. des_ifs; ss.
  Qed.

  Lemma natmap_prop_sepconj_sum A (P0 P1: nat -> A -> iProp) m
    :
    (natmap_prop_sum m (fun k a => (P0 k a) ∗ (P1 k a)))
      -∗
      ((natmap_prop_sum m P0) ∗ (natmap_prop_sum m P1)).
  Proof.
    unfold natmap_prop_sum. iIntros "SUM".
    iPoseProof (list_prop_sepconj_sum with "[SUM]") as "SUM".
    { iApply list_prop_sum_impl. 2: iFrame. i. destruct a.
      instantiate (1:=fun '(k, a) => P1 k a). instantiate (1:=fun '(k, a) => P0 k a). ss.
    }
    iFrame.
  Qed.

  Lemma natmap_prop_sum_impl2 A (P0 P1 Q: nat -> A -> iProp) m
        (IMPL: forall k a, (P0 k a ∗ P1 k a) -∗ Q k a)
    :
    ((natmap_prop_sum m P0) ∗ (natmap_prop_sum m P1))
      -∗
      natmap_prop_sum m Q.
  Proof.
    iIntros "SUMs". iApply natmap_prop_sum_impl. 2: iApply natmap_prop_sum_sepconj; iFrame.
    i. ss.
  Qed.

  Lemma natmap_prop_sum_find_remove
        A (P: nat -> A -> iProp) m k a
        (FIND: NatMap.find k m = Some a)
    :
    (natmap_prop_sum m (fun k a => P k a))
      -∗ ((P k a) ∗ ((P k a) -∗ (natmap_prop_sum m (fun k a => P k a)))).
  Proof.
    unfold natmap_prop_sum. set (P' := fun x => P (fst x) (snd x)). remember (k, a) as x.
    cut
  (list_prop_sum (λ x, P' x) (NatMap.elements (elt:=A) m) -∗
                 P' x ∗ (P' x -∗ list_prop_sum (λ x, P' x) (NatMap.elements (elt:=A) m))).
    { subst. subst P'. ss. i. replace (λ '(k0, v), P k0 v) with (λ x : nat * A, P x.1 x.2). auto.
      extensionality x. destruct x. ss.
    }
    iIntros "SUMs". iApply (list_prop_sum_in_split with "SUMs").
    subst. apply InA_In'. rewrite NatMapP.F.elements_o in FIND.
    apply SetoidList.findA_NoDupA in FIND; eauto.
    apply NatMap.elements_3w.
  Qed.

End SUM.

Section UPDNATMAP.
  Variable A: Type.
  Context `{NATMAPRA: @GRA.inG (Auth.t (NatMapRALarge.t A)) Σ}.

  Lemma NatMapRALarge_find_some m k a
    :
    (OwnM (Auth.black (Some m: NatMapRALarge.t A)))
      -∗
      (OwnM (Auth.white (NatMapRALarge.singleton k a: NatMapRALarge.t A)))
      -∗
      (⌜NatMap.find k m = Some a⌝).
  Proof.
    iIntros "B W". iCombine "B W" as "BW". iOwnWf "BW".
    eapply Auth.auth_included in H. eapply NatMapRALarge.extends_singleton_iff in H. auto.
  Qed.

  Lemma NatMapRALarge_singleton_unique k0 k1 a0 a1
    :
    (OwnM (Auth.white (NatMapRALarge.singleton k0 a0: NatMapRALarge.t A)))
      -∗
      (OwnM (Auth.white (NatMapRALarge.singleton k1 a1: NatMapRALarge.t A)))
      -∗
      (⌜k0 <> k1⌝).
  Proof.
    iIntros "W0 W1". iCombine "W0 W1" as "W". iOwnWf "W".
    ur in H. eapply NatMapRALarge.singleton_unique in H. auto.
  Qed.

  Lemma NatMapRALarge_remove m k a
    :
    (OwnM (Auth.black (Some m: NatMapRALarge.t A)))
      -∗
      (OwnM (Auth.white (NatMapRALarge.singleton k a: NatMapRALarge.t A)))
      -∗
      #=>(OwnM (Auth.black (Some (NatMap.remove k m): NatMapRALarge.t A))).
  Proof.
    iIntros "B W". iCombine "B W" as "BW". iApply OwnM_Upd. 2: iFrame.
    eapply Auth.auth_dealloc. eapply NatMapRALarge.remove_local_update.
  Qed.

  Lemma NatMapRALarge_add m k a
        (NONE: NatMap.find k m = None)
    :
    (OwnM (Auth.black (Some m: NatMapRALarge.t A)))
      -∗
      #=>((OwnM (Auth.black (Some (NatMap.add k a m): NatMapRALarge.t A)
                            ⋅ Auth.white (NatMapRALarge.singleton k a: NatMapRALarge.t A)))
         ).
  Proof.
    iIntros "B". iApply OwnM_Upd. 2: iFrame.
    eapply Auth.auth_alloc. eapply NatMapRALarge.add_local_update. auto.
  Qed.

End UPDNATMAP.


Require Import Lists.List.
Require Import Sorting.Permutation.
Require Import Fin.
Require Import Vector.
Require Import Logic.Eqdep_dec.
Require Import Arith.PeanoNat.
Require Import Arith.Peano_dec.

Class ConstructorSpec (Ctor: Set) :=
  { contraVariantArity : Ctor -> nat;
    coVariantArity : Ctor -> nat;
    epsilon: Ctor -> Prop }.

Class ConstructorRelation (Ctor: Set) `{ConstructorSpec Ctor}
      (R : forall C D,
          (Fin.t (contraVariantArity C) -> Fin.t (contraVariantArity D)) ->
          (Fin.t (coVariantArity D) -> Fin.t (coVariantArity C)) -> Prop) :=
  { reflexivity: forall C f g,
      (forall k, f k = k) ->
      (forall k, g k = k) ->
      R C C f g;
    transitivity:
      forall C D E f g f' g' f'f gg',
        (forall k, f'f k = f' (f k)) ->
        (forall k, gg' k = g (g' k)) ->
        R C D f g -> R D E f' g' -> R C E f'f gg';
    contraMap_unique:
      forall C D f f' g g',
        R C D f g -> R C D f' g' -> forall x, g x = g' x;
    epsilon_monotonicity:
      forall C D f g, R C D f g -> epsilon C -> epsilon D }.

Module Type ConstructorSpecification.
  Parameter Ctor: Set.
  Parameter CtorSpec: ConstructorSpec Ctor.
  Parameter R: forall C D,
      (Fin.t (contraVariantArity C) -> Fin.t (contraVariantArity D)) ->
      (Fin.t (coVariantArity D) -> Fin.t (coVariantArity C)) -> Prop.
  Parameter CtorRel: ConstructorRelation Ctor R.

  Parameter Ctor_eq_dec: forall (C D: Ctor), { C = D } + { C <> D }.
End ConstructorSpecification.

Module Type SubtypeSystem(Import Spec: ConstructorSpecification).

  Unset Elimination Schemes.
  Inductive IntersectionType: Set :=
  | Constr : forall C,
      t (IntersectionType) (contraVariantArity C) ->
      t (IntersectionType) (coVariantArity C) ->
      IntersectionType
  | Inter: IntersectionType -> IntersectionType -> IntersectionType.

  (* Boilerplate for induction/recursion on nested vectors *)
  Fixpoint IntersectionType_rect
           (P: IntersectionType -> Type)
           (constr_case:
              forall C
                (contraArgs: t (IntersectionType) (contraVariantArity C))
                (coArgs: t (IntersectionType) (coVariantArity C)),
                (forall k, P (nth contraArgs k)) ->
                (forall k, P (nth coArgs k)) ->
                P (Constr C contraArgs coArgs))
           (inter_case: forall sigma tau, P sigma -> P tau -> P (Inter sigma tau))
           (sigma: IntersectionType) {struct sigma}: P (sigma) :=
    match sigma with
    | Constr C contraArgs coArgs =>
      constr_case C contraArgs coArgs
                  ((fix contra_prf n (xs: t IntersectionType n) {struct xs}: forall k, P (nth xs k) :=
                      match xs as xs' in t _ n' return (forall (k : Fin.t n'), P (nth xs' k)) with
                      | nil _ => fun k => Fin.case0 (fun k => P (nth (nil _) k)) k
                      | cons _ x _ xs =>
                        fun k =>
                          Fin.caseS' k (fun k => P (nth (cons _ x _ xs) k))
                                     (IntersectionType_rect P constr_case inter_case x)
                                     (contra_prf _ xs)
                      end) _ contraArgs)
                  ((fix co_prf n (xs: t IntersectionType n) {struct xs}: forall k, P (nth xs k) :=
                      match xs as xs' in t _ n' return (forall (k : Fin.t n'), P (nth xs' k)) with
                      | nil _ => fun k => Fin.case0 (fun k => P (nth (nil _) k)) k
                      | cons _ x _ xs =>
                        fun k =>
                          Fin.caseS' k (fun k => P (nth (cons _ x _ xs) k))
                                     (IntersectionType_rect P constr_case inter_case x)
                                     (co_prf _ xs)
                      end) _ coArgs)
    | Inter sigma tau =>
      inter_case sigma tau
                 (IntersectionType_rect P constr_case inter_case sigma)
                 (IntersectionType_rect P constr_case inter_case tau)
    end.
  Definition IntersectionType_ind
             (P : IntersectionType -> Prop)
             (constr_case:
                forall C
                  (contraArgs: t (IntersectionType) (contraVariantArity C))
                  (coArgs: t (IntersectionType) (coVariantArity C)),
                  (forall k, P (nth contraArgs k)) ->
                  (forall k, P (nth coArgs k)) ->
                  P (Constr C contraArgs coArgs))
             (inter_case: forall sigma tau, P sigma -> P tau -> P (Inter sigma tau))
             (sigma: IntersectionType): P (sigma) :=
    IntersectionType_rect P constr_case inter_case sigma.

  Definition IntersectionType_rec
             (P : IntersectionType -> Set)
             (constr_case:
                forall C
                  (contraArgs: t (IntersectionType) (contraVariantArity C))
                  (coArgs: t (IntersectionType) (coVariantArity C)),
                  (forall k, P (nth contraArgs k)) ->
                  (forall k, P (nth coArgs k)) ->
                  P (Constr C contraArgs coArgs))
             (inter_case: forall sigma tau, P sigma -> P tau -> P (Inter sigma tau))
             (sigma: IntersectionType): P (sigma) :=
    IntersectionType_rect P constr_case inter_case sigma.

  (* Helper lemmas *)
  Lemma Vector_tl_ineq:
    forall {T} (x : T) {n} xs ys, xs <> ys -> cons T x n xs <> cons T x n ys.
  Proof.
    intros T x n xs ys ineq.
    intro devil.
    injection devil as devil.
    contradict ineq.
    apply inj_pair2_eq_dec.
    - apply Nat.eq_dec.
    - exact devil.
  Qed.
  Definition Vector_eq_dec:
    forall {T} {n}
      (t_eq_dec: forall (x y: T), {x = y} + {x <> y}) (xs ys: t T n), {xs = ys} + {xs <> ys}.
  Proof.
    intros T n t_eq_dec xs.
    induction xs as [ | x n xs IH ]; intros ys.
    - apply (fun P prf => case0 P prf ys).
      left; reflexivity.
    - apply (caseS' ys).
      clear ys; intros y ys.
      destruct (t_eq_dec x y) as [ x_eq | x_ineq ].
      + rewrite x_eq.
        destruct (IH ys) as [ xs_eq | ].
        * rewrite xs_eq.
          left; reflexivity.
        * right; apply Vector_tl_ineq; assumption.
      + right; intro devil; inversion devil.
        contradiction x_ineq.
  Defined.

  (* Decidable syntactic equality on types (helpful e.g. for pattern matching) *)
  Fixpoint IntersectionType_eq_dec (sigma: IntersectionType): forall tau, { sigma = tau } + { sigma <> tau }.
  Proof.
    intro tau.
    destruct sigma as [ C contraArgs coArgs | sigma1 sigma2 ];
      destruct tau as [ D contraArgs' coArgs' | tau1 tau2 ];
      try solve [ right; intro devil; inversion devil ].
    - destruct (Ctor_eq_dec C D) as [ prf | disprf ];
        [ | right; intro devil; inversion devil; contradiction ].
      revert contraArgs' coArgs'.
      rewrite <- prf.
      clear D prf.
      intros contraArgs' coArgs'.
      destruct (Vector_eq_dec IntersectionType_eq_dec contraArgs contraArgs') as [ eq | ineq ];
        [ | right; intro devil; inversion devil as [ contraArgs_eq ] ].
      + destruct (Vector_eq_dec IntersectionType_eq_dec coArgs coArgs') as [ eq' | ineq' ];
          [ rewrite eq; rewrite eq'; left; reflexivity
          | right; intro devil; inversion devil as [ [ contraArgs_eq coArgs_eq ] ] ].
        * apply ineq'.
          revert coArgs_eq.
          clear ...
          intro coArgs_eq.
          assert (coArgs_eq': existT (fun n => t IntersectionType n) (coVariantArity C) coArgs =
                existT (fun n => t IntersectionType n) (coVariantArity C) coArgs').
          { remember (existT (fun n => t IntersectionType n) (coVariantArity C) coArgs) as lhs eqn:lhs_eq.
            dependent rewrite coArgs_eq in lhs_eq.
            rewrite lhs_eq.
            reflexivity. }
          clear coArgs_eq.
          revert coArgs coArgs' coArgs_eq'.
          generalize (coVariantArity C).
          intros n coArgs coArgs' coArgs_eq.
          induction coArgs.
          { apply (fun r => case0 _ r coArgs').
            reflexivity. }
          { revert coArgs_eq.
            apply (caseS' coArgs'); clear coArgs'; intros arg' coArgs' coArgs_eq.
            inversion coArgs_eq as [ [ arg'_eq coArgs_eq' ] ].
            apply f_equal.
            auto.  }
      + apply ineq.
        assert (contraArgs_eq': existT (fun n => t IntersectionType n) (contraVariantArity C) contraArgs =
                existT (fun n => t IntersectionType n) (contraVariantArity C) contraArgs').
        { remember (existT (fun n => t IntersectionType n) (contraVariantArity C) contraArgs) as lhs eqn:lhs_eq.
          dependent rewrite contraArgs_eq in lhs_eq.
          rewrite lhs_eq.
          reflexivity. }
        clear ineq devil contraArgs_eq.
        revert contraArgs contraArgs' contraArgs_eq'.
        clear ...
        generalize (contraVariantArity C).
        intros n contraArgs contraArgs' contraArgs_eq.
        induction contraArgs.
        * apply (fun r => case0 _ r contraArgs').
          reflexivity.
        * revert contraArgs_eq.
          apply (caseS' contraArgs'); clear contraArgs'; intros arg' contraArgs' contraArgs_eq.
          inversion contraArgs_eq as [ [ arg'_eq contraArgs_eq' ] ].
          apply f_equal.
          auto.
    - destruct (IntersectionType_eq_dec sigma1 tau1) as [ prf1 | disprf1 ];
        [ rewrite prf1 | right; intro devil; inversion devil; contradiction ];
        destruct (IntersectionType_eq_dec sigma2 tau2) as [ prf2 | disprf2 ];
        [ rewrite prf2 | right; intro devil; inversion devil; contradiction ];
        left; reflexivity.
  Defined.

  Set Elimination Schemes.

  (* Helper stuff to unclutter definitions *)
  Import ListNotations.
  Import EqNotations.

  Definition fixContraArity
             {contraArity: nat}
             {k: nat} {ctors: t Ctor (S k)}
             (arityOk: forall i, contraArity = contraVariantArity (nth ctors i))
             {i: Fin.t k}
             (f: Fin.t contraArity -> Fin.t contraArity):
    Fin.t (contraVariantArity (nth ctors (FS i))) -> Fin.t (contraVariantArity (nth ctors F1)) :=
    rew [fun n => Fin.t n -> _ ] arityOk (FS i) in
      rew [fun n => _ -> Fin.t n] arityOk F1 in f.

  Definition fixCoArity
             {coArity: nat}
             {k: nat} {ctors: t Ctor (S k)}
             (arityOk: forall i, coArity = coVariantArity (nth ctors i))
             {i: Fin.t k}
             (f: Fin.t coArity -> Fin.t coArity):
    Fin.t (coVariantArity (nth ctors F1)) -> Fin.t (coVariantArity (nth ctors (FS i))) :=
    rew [fun n => Fin.t n -> _ ] arityOk F1 in
      rew [fun n => _ -> Fin.t n] arityOk (FS i) in f.

  Fixpoint positions (n : nat): t (Fin.t n) n :=
    match n with
    | O => nil _
    | S n => cons _ F1 _ (map FS (positions n))
    end.

  Lemma positions_spec: forall n k, nth (positions n) k = k.
  Proof.
    intro n.
    induction n as [ | n IHn ]; intro k.
    - inversion k.
    - remember (S n) as n' eqn:n'_eq.
      destruct k.
      + reflexivity.
      + simpl.
        injection n'_eq as n_eq.
        revert k.
        rewrite n_eq.
        intro k.
        rewrite (nth_map _ _ _ _ (eq_refl k)).
        rewrite (IHn k).
        reflexivity.
  Qed.

  Definition makeConstructor
             {k : nat} {coArity contraArity: nat}
             (ctors: t Ctor k)
             (contraArgs: t (t IntersectionType contraArity) k)
             (coArgs: t (t IntersectionType coArity) k)
             (contraArityOk: forall i, contraArity = contraVariantArity (nth ctors i))
             (coArityOk: forall i, coArity = coVariantArity (nth ctors i))
             (i: Fin.t k): IntersectionType :=
    Constr (nth ctors i)
           (rew (contraArityOk i) in nth contraArgs i)
           (rew (coArityOk i) in nth coArgs i).

  (* The subtype system *)
  Inductive LEQ: list IntersectionType -> IntersectionType -> Prop :=
  | CtorLeft: forall C contraArgs coArgs rho Gamma Gamma',
      Permutation Gamma' ((Constr C contraArgs coArgs) :: Gamma) ->
      LEQ Gamma rho  ->
      LEQ Gamma' rho
  | InterRight: forall Gamma sigma tau, LEQ Gamma sigma -> LEQ Gamma tau -> LEQ Gamma (Inter sigma tau)
  | InterLeft: forall Gamma sigma tau rho Gamma' Gamma'',
      Permutation Gamma' (sigma :: tau :: Gamma) ->
      Permutation Gamma'' (Inter sigma tau :: Gamma) ->
      LEQ Gamma' rho ->
      LEQ Gamma'' rho
  | CtorRight:
      forall k contraArity coArity
        (ctors: t Ctor (S k))
        (contraArgs: t (t IntersectionType contraArity) (S k))
        (coArgs: t (t IntersectionType coArity) (S k))
        (fs: t (Fin.t contraArity -> Fin.t contraArity) k)
        (gs: t (Fin.t coArity -> Fin.t coArity) k)
        (contraArityOk: forall i, contraArity = contraVariantArity (nth ctors i))
        (coArityOk: forall i, coArity = coVariantArity (nth ctors i))
        (Gamma: list IntersectionType),
        (k = 0 -> epsilon (hd ctors)) ->
        (forall (i: Fin.t k),
            R (nth ctors (FS i)) (nth ctors F1)
              (fixContraArity contraArityOk (nth fs i))
              (fixCoArity coArityOk (nth gs i))) ->
        (forall i j,
            LEQ (nth (nth contraArgs F1) j :: []) (nth (nth contraArgs (FS i)) ((nth fs i) j))) ->
        (forall i, exists Gamma,
              Permutation (to_list (map (fun j => nth (nth coArgs (FS j)) ((nth gs j) i)) (positions k))) Gamma /\
              LEQ Gamma (nth (nth coArgs F1) i)) ->
        Permutation
          Gamma
          (to_list (map (fun i => makeConstructor ctors contraArgs coArgs contraArityOk coArityOk (FS i))
                        (positions k))) ->
        LEQ Gamma (makeConstructor ctors contraArgs coArgs contraArityOk coArityOk F1).

  (* Derived rules *)

  Lemma sigmaLeft:
    forall Gamma Gamma' sigma rho,
      Permutation Gamma' (sigma :: Gamma) ->
      LEQ Gamma rho -> LEQ Gamma' rho.
  Proof.
    intros Gamma Gamma' sigma.
    revert Gamma Gamma'.
    induction sigma as [ C contraArgs coArgs IHcontra IHco | sigma1 sigma2  IHsigma1 IHsigma2 ];
      intros Gamma Gamma' rho permPrf rhoPrf.
    - apply (CtorLeft C contraArgs coArgs rho Gamma); assumption.
    - apply (InterLeft Gamma sigma1 sigma2 rho (sigma1::sigma2::Gamma) Gamma').
      + apply Permutation_refl.
      + assumption.
      + eapply IHsigma1; [ apply Permutation_refl | ].
        eapply IHsigma2; [ apply Permutation_refl | ].
        assumption.
  Qed.

  Lemma sigmaRefl: forall sigma, LEQ [sigma] sigma.
  Proof.
    intro sigma.
    induction sigma as [ C contraArgs coArgs IHcontra IHco | sigma1 sigma2 IHsigma1 IHsigma2].
    - set (ctors := cons _ C _ (cons _ C _ (nil _))).
      assert (contraArityOk : forall i, contraVariantArity C = contraVariantArity (nth ctors i)).
      { intro i.
        apply (Fin.caseS' i); [ reflexivity | clear i; intro i ].
        apply (Fin.caseS' i); [ reflexivity | clear i; intro i ].
        inversion i. }
      assert (coArityOk : forall i, coVariantArity C = coVariantArity (nth ctors i)).
      { intro i.
        apply (Fin.caseS' i); [ reflexivity | clear i; intro i ].
        apply (Fin.caseS' i); [ reflexivity | clear i; intro i ].
        inversion i. }
      generalize (CtorRight 1 (contraVariantArity C) (coVariantArity C)
                            (cons _ C _ (cons _ C _ (nil _)))
                            (cons _ contraArgs _ (cons _ contraArgs _ (nil _)))
                            (cons _ coArgs _ (cons _ coArgs _ (nil _)))
                            (cons _ (fun x => x) _ (nil _))
                            (cons _ (fun x => x) _ (nil _))
                            contraArityOk coArityOk
                            [Constr C contraArgs coArgs]
                            (fun k_eq =>
                               False_ind _ (match k_eq in _ = n return match n with | 1 => True | _ => False end with
                                            | eq_refl => I
                                            end))).
      unfold makeConstructor.
      rewrite (UIP_dec (Nat.eq_dec) (contraArityOk F1) eq_refl).
      rewrite (UIP_dec (Nat.eq_dec) (coArityOk F1) eq_refl).
      simpl.
      intro result; apply result; clear result.
      + intro i.
        apply (Fin.caseS' i); [ clear i | intro devil; inversion devil ].
        simpl.
        apply reflexivity.
        * intro k.
          unfold fixContraArity.
          simpl.
          match goal with
          | [|- (rew [fun n => _] ?p1 in _) k = _ ] =>
            set (eq1 := p1); simpl in eq1;
              rewrite (UIP_dec (Nat.eq_dec) eq1 eq_refl);
              simpl
          end.
          match goal with
          | [|- (rew [fun n => _] ?p1 in _) k = _ ] =>
            set (eq2 := p1); simpl in eq2;
              rewrite (UIP_dec (Nat.eq_dec) eq2 eq_refl);
              simpl
          end.
          reflexivity.
        * intro k.
          unfold fixCoArity.
          simpl.
          match goal with
          | [|- (rew [fun n => _] ?p1 in _) k = _ ] =>
            set (eq1 := p1); simpl in eq1;
              rewrite (UIP_dec (Nat.eq_dec) eq1 eq_refl);
              simpl
          end.
          match goal with
          | [|- (rew [fun n => _] ?p1 in _) k = _ ] =>
            set (eq2 := p1); simpl in eq2;
              rewrite (UIP_dec (Nat.eq_dec) eq2 eq_refl);
              simpl
          end.
          reflexivity.
      + intro i.
        apply (Fin.caseS' i); [ clear i | intro devil; inversion devil ].
        simpl.
        exact IHcontra.
      + intro i.
        eexists; split; [ apply Permutation_refl | ].
        apply IHco.
      + rewrite (UIP_dec (Nat.eq_dec) (contraArityOk (FS F1)) eq_refl).
        rewrite (UIP_dec (Nat.eq_dec) (coArityOk (FS F1)) eq_refl).
        reflexivity.
    - apply (InterLeft List.nil sigma1 sigma2 _ _ _ (Permutation_refl _) (Permutation_refl _)).
      apply InterRight.
      + apply (sigmaLeft _ (sigma1 :: sigma2 :: []) sigma2 sigma1 (perm_swap _ _ _) IHsigma1).
      + apply (sigmaLeft _ (sigma1 :: sigma2 :: []) sigma1 sigma2 (Permutation_refl _) IHsigma2).
  Qed.

End SubtypeSystem.


Require Import progs.ghost.
Require Import mailbox.verif_atomics.
Require Import progs.conclib.
Require Import floyd.library.
Require Import floyd.sublist.
Require Import mailbox.kvnode.

Set Bullet Behavior "Strict Subproofs".

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(*Definition release2_spec := DECLARE _release2 release2_spec.
Definition freelock2_spec := DECLARE _freelock2 (freelock2_spec _).
Definition spawn_spec := DECLARE _spawn spawn_spec.*)

Definition tnode := Tstruct _node noattr.

Opaque upto.

Definition make_loads lv := map (fun v => Load (vint v)) lv.

(* Invariant for version number: Every write increases it, and the version of each data location is at least the
   most recently read version. *)
(* Invariant for each location: The "rounded up" version number is at least the location's version. *)

Definition round_up i := i + i mod 2.
Definition round_down i := i - i mod 2.

(* Do we really need the hists? *)
(* Ghost vars act as write permissions. *)
Definition ver_R g gsh gv lg (h : list hist_el) v := ghost_master v g * ghost_var gsh v gv *
  fold_right sepcon emp (map (ghost_snap (round_down v)) lg).
Definition loc_R g gsh gl gv (h : list hist_el) (v : Z) := EX ver : Z, EX ver' : Z,
  !!(repable_signed ver' /\ ver <= round_up ver') &&
  ghost_master ver g * ghost_var gsh ver gl * ghost_snap ver' gv.

Notation "'WITH'  x1 : t1 , x2 : t2 , x3 : t3 , x4 : t4 , x5 : t5 , x6 : t6 , x7 : t7 , x8 : t8 , x9 : t9 , x10 : t10 , x11 : t11 , x12 : t12 , x13 : t13 , x14 : t14 , x15 : t15 'PRE'  [ u , .. , v ] P 'POST' [ tz ] Q" :=
     (NDmk_funspec ((cons u%formals .. (cons v%formals nil) ..), tz) cc_default (t1*t2*t3*t4*t5*t6*t7*t8*t9*t10*t11*t12*t13*t14*t15)
           (fun x => match x with (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15) => P%assert end)
           (fun x => match x with (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15) => Q%assert end))
            (at level 200, x1 at level 0, x2 at level 0, x3 at level 0, x4 at level 0,
             x5 at level 0, x6 at level 0, x7 at level 0, x8 at level 0, x9 at level 0,
              x10 at level 0, x11 at level 0, x12 at level 0,  x13 at level 0, x14 at level 0,
               x15 at level 0,
             P at level 100, Q at level 100).

Definition read_spec :=
 DECLARE _read
 WITH n : val, out : val, sh : share, version : val, locs : list val, gv : val, gsh : share, gv' : val,
   gv2 : val, lg : list val, lgl : list val, hv : hist, ghosts : list val, hists : list hist, v0 : Z
 PRE [ _n OF tptr tnode, _out OF tptr tint ]
  PROP (readable_share sh; Zlength lg = 8; Zlength ghosts = 8; Zlength hists = 8; v0 mod 2 = 0)
  LOCAL (temp _n n; temp _out out)
  SEP (data_at sh tnode (version, locs) n; data_at_ Tsh (tarray tint 8) out;
       atomic_loc_hist sh version gv 0 (ver_R gv2 gsh gv' lg) hv; ghost_snap v0 gv2;
       fold_right sepcon emp (map (fun i => atomic_loc_hist sh (Znth i locs Vundef) (Znth i ghosts Vundef) 0
         (loc_R (Znth i lg Vundef) gsh (Znth i lgl Vundef) gv2) (Znth i hists [])) (upto 8));
       fold_right sepcon emp (map (ghost_snap v0) lg))
 POST [ tvoid ]
  EX failvs : list Z, EX loops : Z, EX v : Z, EX hv' : hist, EX vals : list Z, EX hists' : list hist,
  PROP (v mod 2 = 0; add_events hv (make_loads (failvs ++ [v; v])) hv'; Forall repable_signed failvs;
        Forall repable_signed vals; Zlength hists' = 8; loops <= Zlength failvs)
  LOCAL ()
  SEP (data_at sh tnode (version, locs) n; data_at Tsh (tarray tint 8) (map (fun x => vint x) vals) out;
       atomic_loc_hist sh version gv 0 (ver_R gv2 gsh gv' lg) hv'; ghost_snap v gv2;
       fold_right sepcon emp (map (fun i => EX fails : list Z,
         !!(add_events (Znth i hists []) (make_loads (fails ++ [Znth i vals 0])) (Znth i hists' []) /\
            Zlength fails = loops) &&
         atomic_loc_hist sh (Znth i locs Vundef) (Znth i ghosts Vundef) 0
           (loc_R (Znth i lg Vundef) gsh (Znth i lgl Vundef) gv2) (Znth i hists' [])) (upto 8));
       fold_right sepcon emp (map (ghost_snap v) lg)).

Notation "'WITH'  x1 : t1 , x2 : t2 , x3 : t3 , x4 : t4 , x5 : t5 , x6 : t6 , x7 : t7 , x8 : t8 , x9 : t9 , x10 : t10 , x11 : t11 , x12 : t12 , x13 : t13 , x14 : t14 , x15 : t15 , x16 : t16 , x17 : t17 'PRE'  [ u , .. , v ] P 'POST' [ tz ] Q" :=
     (NDmk_funspec ((cons u%formals .. (cons v%formals nil) ..), tz) cc_default (t1*t2*t3*t4*t5*t6*t7*t8*t9*t10*t11*t12*t13*t14*t15*t16*t17)
           (fun x => match x with (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17) => P%assert end)
           (fun x => match x with (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17) => Q%assert end))
            (at level 200, x1 at level 0, x2 at level 0, x3 at level 0, x4 at level 0,
             x5 at level 0, x6 at level 0, x7 at level 0, x8 at level 0, x9 at level 0,
              x10 at level 0, x11 at level 0, x12 at level 0,  x13 at level 0, x14 at level 0,
               x15 at level 0, x16 at level 0, x17 at level 0,
             P at level 100, Q at level 100).

(* For now, we guarantee only one writer by using a ghost variable as a write permission. *)
Definition write_spec :=
 DECLARE _write
 WITH n : val, input : val, sh : share, version : val, locs : list val, vals : list Z, gv : val, gv2 : val,
   gsh1 : share, gsh2 : share, gv' : val, lg : list val, lgl : list val, hv : hist, ghosts : list val,
   hists : list hist, v : Z
 PRE [ _n OF tptr tnode, _in OF tptr tint ]
  PROP (readable_share sh; Forall repable_signed vals; Zlength lg = 8; Zlength lgl = 8; Zlength ghosts = 8;
        Zlength hists = 8; v mod 2 = 0; readable_share gsh1; readable_share gsh2; sepalg.join gsh1 gsh2 Tsh)
  LOCAL (temp _n n; temp _in input)
  SEP (data_at sh tnode (version, locs) n; data_at Tsh (tarray tint 8) (map (fun x => vint x) vals) input;
       atomic_loc_hist sh version gv 0 (ver_R gv2 gsh2 gv' lg) hv; ghost_snap v gv2; ghost_var gsh1 v gv';
       fold_right sepcon emp (map (fun i => atomic_loc_hist sh (Znth i locs Vundef) (Znth i ghosts Vundef) 0
         (loc_R (Znth i lg Vundef) gsh2 (Znth i lgl Vundef) gv2) (Znth i hists [])) (upto 8));
       fold_right sepcon emp (map (ghost_snap v) lg); fold_right sepcon emp (map (ghost_var gsh1 v) lgl))
 POST [ tvoid ]
  EX hv' : hist, EX hists' : list hist,
  PROP (add_events hv [Load (vint v); Store (vint (v + 1)); Store (vint (v + 2))] hv'; Zlength hists' = 8;
        (v + 2) mod 2 = 0)
  LOCAL ()
  SEP (data_at sh tnode (version, locs) n; data_at Tsh (tarray tint 8) (map (fun x => vint x) vals) input;
       atomic_loc_hist sh version gv 0 (ver_R gv2 gsh2 gv' lg) hv'; ghost_snap (v + 2) gv2;
       ghost_var gsh1 (v + 2) gv';
       fold_right sepcon emp (map (fun i =>
       !!(add_events (Znth i hists []) [Store (vint (Znth i vals 0))] (Znth i hists' [])) &&
       atomic_loc_hist sh (Znth i locs Vundef) (Znth i ghosts Vundef) 0
         (loc_R (Znth i lg Vundef) gsh2 (Znth i lgl Vundef) gv2) (Znth i hists' [])) (upto 8));
       fold_right sepcon emp (map (ghost_snap (v + 2)) lg);
       fold_right sepcon emp (map (ghost_var gsh1 (v + 2)) lgl)).

Definition Gprog : funspecs := ltac:(with_library prog [load_SC_spec; store_SC_spec; read_spec; write_spec]).

Ltac cancel_for_forward_call ::= repeat (rewrite ?sepcon_andp_prop', ?sepcon_andp_prop);
  repeat (apply andp_right; [auto; apply prop_right; auto|]); fast_cancel.

Lemma snap_snap_max : forall v1 v2 p,
  ghost_snap v1 p * ghost_snap v2 p = ghost_snap v1 p * ghost_snap (Z.max v1 v2) p.
Proof.
  intros; rewrite ghost_snap_join'.
  replace (Z.max v1 v2) with (Z.max v1 (Z.max v1 v2)) at 1.
  rewrite <- ghost_snap_join'; auto.
  { rewrite Z.max_r, Z.max_comm; auto.
    apply Z.le_max_l. }
Qed.

Lemma snaps_snaps_max : forall {cs : compspecs} (v1 v2 : Z) lg,
  @view_shift cs
    (fold_right sepcon emp (map (ghost_snap v1) lg) * fold_right sepcon emp (map (ghost_snap v2) lg))
    (fold_right sepcon emp (map (ghost_snap v1) lg) * fold_right sepcon emp (map (ghost_snap (Z.max v1 v2)) lg)).
Proof.
  induction lg; simpl; repeat intro; auto.
  rewrite <- sepcon_assoc, (sepcon_comm _ (ghost_snap _ _)), <- sepcon_assoc.
  rewrite (sepcon_comm (ghost_snap _ _)), snap_snap_max.
  rewrite sepcon_assoc, sepcon_comm, flatten_sepcon_in_SEP.
  eapply IHlg, semax_pre; [|eauto].
  go_lowerx; entailer!.
Qed.

Lemma snaps_snaps_le : forall {cs : compspecs} v lg (lv : list Z) (Hlen : Zlength lv = Zlength lg),
 @view_shift cs
    (fold_right sepcon emp (map (ghost_snap v) lg) *
     fold_right sepcon emp (map (fun '(v, g) => ghost_snap v g) (combine lv lg)))
    (fold_right sepcon emp (map (ghost_snap v) lg) * EX lv : list Z, !!(Zlength lv = Zlength lg /\
       Forall (fun v' => v <= v') lv) &&
     fold_right sepcon emp (map (fun '(v, g) => ghost_snap v g) (combine lv lg))).
Proof.
  induction lg; simpl; repeat intro.
  - apply Zlength_nil_inv in Hlen; subst; simpl.
    eapply semax_pre; [|eauto].
    go_lowerx.
    Exists (@nil Z); entailer!.
  - destruct lv; [symmetry in Hlen; apply Zlength_nil_inv in Hlen; discriminate | simpl].
    rewrite <- sepcon_assoc, (sepcon_comm _ (ghost_snap _ _)), <- sepcon_assoc.
    rewrite (sepcon_comm _ (ghost_snap _ _)), snap_snap_max.
    rewrite sepcon_assoc, sepcon_comm, flatten_sepcon_in_SEP.
    apply IHlg; auto.
    { rewrite !Zlength_cons in *; omega. }
    eapply semax_pre; [|eauto]; go_lowerx.
    Intros lv'; Exists (Z.max v z :: lv'); simpl; entailer!.
    split; [rewrite !Zlength_cons; omega|].
    constructor; auto.
    apply Zmax_bound_l; omega.
Qed.

Lemma land_1 : forall i, Z.land i 1 = i mod 2.
Proof.
  intros; apply Z.land_ones with (n := 1); omega.
Qed.

Lemma round_down_mono : forall v1 v2, v1 <= v2 -> round_down v1 <= round_down v2.
Proof.
  intros; unfold round_down.
  destruct (eq_dec v1 v2); [subst; omega|].
  exploit (Z_mod_lt v1 2); [computable|].
  exploit (Z_mod_lt v2 2); [computable|].
  omega.
Qed.

Lemma round_up_max_distr : forall v1 v2, round_up (Z.max v1 v2) = Z.max (round_up v1) (round_up v2).
Proof.
  intros; unfold round_up.
  exploit (Z_mod_lt v1 2); [computable|].
  exploit (Z_mod_lt v2 2); [computable|].
  intros; destruct (Z.max_spec v1 v2) as [(? & ->) | (? & ->)]; [rewrite Z.max_r | rewrite Z.max_l]; auto;
    try omega.
  destruct (eq_dec v1 v2); subst; omega.
Qed.

Lemma body_read : semax_body Vprog Gprog f_read read_spec.
Proof.
  start_function.
  apply semax_pre with (P' := EX failvs : list Z, EX loops : Z, EX hv' : hist, EX hists' : list hist, EX v0 : Z,
    PROP (add_events hv (make_loads failvs) hv'; Forall repable_signed failvs; Zlength hists' = 8;
          loops <= Zlength failvs)
    LOCAL (temp _n n; temp _out out)
    SEP (@data_at CompSpecs sh tnode (version, locs) n; data_at_ Tsh (tarray tint 8) out;
         atomic_loc_hist sh version gv 0 (ver_R gv2 gsh gv' lg) hv'; ghost_snap v0 gv2;
         fold_right sepcon emp (map (fun i => EX fails : list Z,
           !!(add_events (Znth i hists []) (make_loads fails) (Znth i hists' []) /\ Zlength fails = loops) &&
           atomic_loc_hist sh (Znth i locs Vundef) (Znth i ghosts Vundef) 0
             (loc_R (Znth i lg Vundef) gsh (Znth i lgl Vundef) gv2) (Znth i hists' [])) (upto 8));
         EX lv : list Z, !!(Zlength lv = 8) &&
             fold_right sepcon emp (map (fun '(v, g) => ghost_snap v g) (combine lv lg)))).
  { Exists (@nil Z) 0 hv hists v0 (repeat v0 8).
    rewrite combine_const2, map_map by (simpl; omega); entailer!.
    apply sepcon_derives; auto.
    apply sepcon_list_derives; rewrite !Zlength_map; auto; intros.
    erewrite !Znth_map, !Znth_upto by (auto; rewrite Zlength_upto in *; omega).
    Exists (@nil Z); entailer!. }
  eapply semax_loop; [|forward; unfold loop2_ret_assert; apply drop_tc_environ].
  - Intros failvs loops hv' hists' v1 lv.
    forward.
    unfold atomic_loc_hist at 1; rewrite atomic_loc_isptr; Intros.
    forward.
    assert (sh <> Share.bot) by (intro; subst; contradiction unreadable_bot).
    forward_call (AL_witness sh version gv 0 (ver_R gv2 gsh gv' lg) hv'
      (ghost_snap v1 gv2 * fold_right sepcon emp (map (fun '(v, g) => ghost_snap v g) (combine lv lg)))
      (fun v => !!(v1 <= v) && ghost_snap v gv2 *
        EX lv : list Z, !!(Zlength lv = 8 /\ Forall (fun v' => round_down v <= v') lv) &&
         fold_right sepcon emp (map (fun '(v, g) => ghost_snap v g) (combine lv lg)))).
    { split; auto.
      apply AL_hist_spec; auto; repeat intro.
      unfold ver_R in *.
      rewrite <- !sepcon_assoc, (sepcon_comm _ (ghost_snap _ _)), <- 2sepcon_assoc.
      rewrite sepcon_assoc, 2flatten_sepcon_in_SEP.
      assert_PROP (v1 <= v).
      { rewrite snap_master_join'; go_lowerx; entailer!. }
      eapply snap_master_update' with (v' := v); [omega|].
      focus_SEP 2; apply snaps_snaps_le; [omega|].
      eapply semax_pre; [|eauto].
      go_lowerx.
      Intros lv'; Exists lv'; entailer!. }
    Intros v; simpl; Intros hv1 lv1.
    match goal with |-semax _ (PROP () (LOCALx ?Q (SEPx ?R))) _ _ =>
      forward_if (PROP (Z.testbit v 0 = false) (LOCALx Q (SEPx R))) end.
    { eapply semax_pre; [|apply semax_continue].
      unfold POSTCONDITION, abbreviate, overridePost.
      destruct (eq_dec EK_continue EK_normal); [discriminate|].
      unfold loop1_ret_assert.
      Exists (failvs ++ [v]) loops hv1 hists' v; entailer!.
      - split; [unfold make_loads; rewrite map_app; eapply add_events_trans; eauto|].
        split; [rewrite Forall_app; auto|].
        rewrite Zlength_app, Zlength_cons, Zlength_nil; omega.
      - Exists lv1; entailer!. }
    { forward.
      entailer!.
      unfold Int.one in *; rewrite and_repr, land_1, Zmod_odd in *.
      destruct (Z.odd v); auto; discriminate. }
    Intros.
    forward_for_simple_bound 8 (EX i : Z, EX vals : list Z, PROP (Zlength vals = i; Forall repable_signed vals)
      LOCAL (temp _snap (vint v); temp _ver version; temp _n n; temp _out out)
      SEP (atomic_loc_hist sh version gv 0 (ver_R gv2 gsh gv' lg) hv1;
           @data_at CompSpecs sh tnode (version, locs) n;
           data_at Tsh (tarray tint 8) (map (fun x : Z => vint x) vals ++ repeat Vundef (Z.to_nat (8 - i))) out;
           EX hists'' : list hist, !!(Zlength hists'' = 8 /\ sublist i 8 hists'' = sublist i 8 hists') &&
           fold_right sepcon emp (map (fun j => EX fails : list Z, !!(add_events (Znth j hists [])
             (if zlt j i then make_loads (fails ++ [Znth j vals 0]) else make_loads fails) (Znth j hists'' []) /\
             Zlength fails = loops) &&
             atomic_loc_hist sh (Znth j locs Vundef) (Znth j ghosts Vundef) 0
               (loc_R (Znth j lg Vundef) gsh (Znth j lgl Vundef) gv2) (Znth j hists'' [])) (upto 8));
           EX v' : Z, EX lv' : list Z, !!(repable_signed v' /\ Zlength lv' = 8 /\
             Forall (fun vl => round_down v <= vl) lv' /\
             Forall (fun vl => vl <= round_up v') (sublist 0 i lv')) && ghost_snap v' gv2 *
             fold_right sepcon emp (map (fun '(v, g) => ghost_snap v g) (combine lv' lg)))).
    { Exists (@nil Z) hists' v lv1; unfold atomic_loc_hist at 2; rewrite data_at__eq, sublist_nil; entailer!. }
    + (* loop body *)
      Intros hists'' v' lv'.
      rewrite extract_nth_sepcon with (i := i) by (rewrite Zlength_map; auto).
      erewrite Znth_map, Znth_upto by (auto; simpl; omega); Intros.
      destruct (zlt i i); [omega|].
      Intros fails.
      rewrite extract_nth_sepcon with (i := i)(l := map _ _) by (rewrite Zlength_map, Zlength_combine, Z.min_l;
        auto; omega).
      rewrite Znth_map with (d' := (0, Vundef)), Znth_combine by (rewrite ?Zlength_combine, ?Z.min_l; omega).
      unfold atomic_loc_hist at 2; rewrite (atomic_loc_isptr _ (Znth i locs Vundef)); Intros.
      forward.
      assert (round_down v <= Znth i lv' 0) by (apply Forall_Znth; auto; omega).
      forward_call (AL_witness sh (Znth i locs Vundef) (Znth i ghosts Vundef) 0
        (loc_R (Znth i lg Vundef) gsh (Znth i lgl Vundef) gv2) (Znth i hists'' [])
        (ghost_snap v' gv2 * ghost_snap (Znth i lv' 0) (Znth i lg Vundef))
        (fun _ => EX ver : Z, EX ver' : Z, !!(repable_signed ver' /\ round_down v <= ver <= round_up ver') &&
           ghost_snap (Z.max ver' v') gv2 * ghost_snap ver (Znth i lg Vundef))).
      { split; auto.
        apply AL_hist_spec; auto; repeat intro.
        unfold loc_R in *.
        erewrite exp_sepcon1, extract_nth_exists_in_SEP with (n := O); [|simpl; eauto].
        Intro ver; simpl.
        erewrite exp_sepcon1, extract_nth_exists_in_SEP with (n := O); [|simpl; eauto].
        Intro ver'; simpl.
        erewrite !sepcon_andp_prop', extract_prop_in_SEP with (n := O); [|simpl; eauto].
        Intros; simpl.
        rewrite <- !sepcon_assoc, sepcon_comm, <- !sepcon_assoc.
        rewrite sepcon_assoc, 2flatten_sepcon_in_SEP.
        assert_PROP (Znth i lv' 0 <= ver).
        { rewrite snap_master_join'; go_lowerx; entailer!. }
        eapply snap_master_update' with (v'0 := ver); [omega|].
        rewrite snap_snap_max.
        eapply semax_pre; [|eauto].
        go_lowerx.
        Exists ver ver' ver ver'; entailer!. }
      Intros vi; simpl; Intros hi vers; destruct vers as (ver, ver').
      gather_SEP 3 8; rewrite replace_nth_sepcon.
      forward.
      Exists (x ++ [vi]) (upd_Znth i hists'' hi) (Z.max ver' v') (upd_Znth i lv' ver).
      rewrite map_app.
      replace (8 - (i + 1)) with (8 - (Zlength (map (fun x => vint x) x ++ [vint vi])))
        by (rewrite Zlength_app, Zlength_cons, Zlength_nil, Zlength_map; subst; auto).
      simpl map; rewrite <- upd_complete_gen by (rewrite Zlength_map; omega).
      match goal with H : sublist _ _ hists'' = sublist _ _ hists' |- _ =>
        rewrite sublist_next with (i0 := i)(l := hists'')(d := []),
          sublist_next with (i0 := i)(l := hists')(d := []) in H by (auto; omega); inv H end.
      rewrite combine_upd_Znth1 with (d := Vundef), <- upd_Znth_map by omega.
      subst; rewrite Zlength_map, !Zlength_app, !Zlength_cons, !Zlength_nil; entailer!.
      { split; [rewrite Forall_app; auto|].
        rewrite !upd_Znth_Zlength by omega.
        split; [|split].
        * split; auto.
          rewrite sublist_upd_Znth_r by omega; auto.
        * destruct (Z.max_spec ver' v') as [(? & ->) | (? & ->)]; auto.
        * split; auto.
          rewrite sublist_upd_Znth_lr, Z.sub_0_r by omega.
          split; [apply Forall_upd_Znth; auto; tauto|].
          rewrite sublist_split with (mid := Zlength x) by omega.
          rewrite upd_Znth_app2; rewrite !Zlength_sublist; try omega.
          rewrite Z.sub_0_r, Zminus_diag, sublist_len_1 with (d := 0), upd_Znth0, sublist_1_cons by omega.
          rewrite Zlength_cons, sublist_nil, Forall_app; repeat constructor.
          -- eapply Forall_impl; [|eauto]; simpl; intros.
             rewrite round_up_max_distr; apply Zmax_bound_r; tauto.
          -- rewrite round_up_max_distr; apply Zmax_bound_l; tauto. }
      rewrite replace_nth_sepcon; apply sepcon_list_derives; rewrite upd_Znth_Zlength; rewrite !Zlength_map;
        auto; intros.
      erewrite Znth_map, Znth_upto by (auto; rewrite Zlength_upto in *; omega).
      destruct (eq_dec i (Zlength x)).
      * subst; rewrite !upd_Znth_same by (rewrite ?Zlength_map; auto; omega).
        Exists fails.
        destruct (zlt (Zlength x) (Zlength x + 1)); [|omega].
        rewrite app_Znth2, Zminus_diag, Znth_0_cons by omega.
        entailer!.
        unfold make_loads; rewrite map_app; eapply add_events_trans; eauto.
      * rewrite !upd_Znth_diff' by (rewrite ?Zlength_map; auto; omega).
        erewrite Znth_map, Znth_upto by (auto; rewrite Zlength_upto in *; omega).
        Intros fails'; Exists fails'; entailer!.
        destruct (zlt i (Zlength x)), (zlt i (Zlength x + 1)); try omega; auto.
        rewrite app_Znth1; auto.
    + Intros vals hists'' v' lv'.
      unfold atomic_loc_hist at 1; Intros.
      forward_call (AL_witness sh version gv 0 (ver_R gv2 gsh gv' lg) hv1 (ghost_snap v' gv2)
        (fun v => !!(v' <= v) && ghost_snap v gv2)).
      { split; auto.
        apply AL_hist_spec; auto; repeat intro.
        unfold ver_R in *.
        rewrite sepcon_comm, <- !sepcon_assoc.
        assert_PROP (v' <= v2).
        { rewrite snap_master_join'; go_lowerx; entailer!. }
        rewrite 2flatten_sepcon_in_SEP.
        eapply snap_master_update' with (v'0 := v2); [omega|].
        eapply semax_pre; [|eauto].
        go_lowerx; entailer!. }
      Intros v2; simpl; Intros hv2.
      rewrite app_nil_r.
      rewrite Z.testbit_false, Zdiv_1_r in * by omega.
      match goal with |-semax _ (PROP () (LOCALx ?Q (SEPx ?R))) _ _ =>
        forward_if (PROP (v2 <> v) (LOCALx Q (SEPx R))) end.
      * forward.
        Exists failvs loops v hv2 vals hists''; unfold atomic_loc_hist at 2; entailer!.
        { unfold make_loads; rewrite map_app; eapply add_events_trans; eauto.
          eapply add_events_trans with (le := [_]); eauto. }
        apply sepcon_derives; [auto|].
        apply sepcon_list_derives; rewrite !Zlength_map, Zlength_combine, Z.min_l; try omega.
        intros; erewrite Znth_map with (d' := (0, Vundef)), Znth_map, Znth_combine
          by (rewrite ?Zlength_combine, ?Z.min_l; omega).
        replace (Znth i lv' 0) with v; auto.
        match goal with H : Forall _ lv' |- _ => apply Forall_Znth with (i0 := i)(d := 0) in H end; auto.
        match goal with H : Forall _ (sublist _ _ lv') |- _ =>
          rewrite sublist_same in H by (auto; omega); apply Forall_Znth with (i0 := i)(d := 0) in H end; auto.
        unfold round_down, round_up in *.
        exploit (Z_mod_lt v' 2); [computable|].
        destruct (eq_dec v' v); subst; omega.
      * forward.
        entailer!.
      * intros; unfold overridePost.
        destruct (eq_dec ek EK_normal); [subst | apply drop_tc_environ].
        unfold POSTCONDITION, abbreviate, loop1_ret_assert.
        Intros; Exists (failvs ++ [v; v2]) (loops + 1) hv2 hists'' v2; unfold atomic_loc_hist at 2; entailer!.
        { rewrite Forall_app, Zlength_app, !Zlength_cons, Zlength_nil; repeat (constructor; auto); [|omega].
          unfold make_loads; rewrite map_app; eapply add_events_trans; eauto.
          eapply add_events_trans with (le := [_]); eauto. }
        Exists lv'; entailer!.
        apply sepcon_list_derives; rewrite !Zlength_map; auto; intros.
        erewrite !Znth_map, !Znth_upto by (auto; rewrite Zlength_upto in *; omega).
        Intros fails; Exists (fails ++ [Znth i vals 0]); entailer!.
        destruct (zlt i 8); [|rewrite Zlength_upto in *; simpl in *; omega].
        rewrite Zlength_app, Zlength_cons, Zlength_nil; split; auto.
Qed.

Lemma ver_R_precise : forall g gsh gv lg v, precise (EX h : _, ver_R g gsh gv lg h v).
Proof.
  intros; unfold ver_R.
  rewrite exp_trivial by (exact []).
  unfold ghost_snap, ghost_master; repeat apply precise_sepcon; auto.
  { apply ghost_precise. }
  apply precise_fold_right.
  rewrite Forall_map, Forall_forall; simpl; intros.
  apply ghost_precise.
Qed.
Hint Resolve ver_R_precise.

Lemma loc_R_precise : forall g gsh gl gv v, precise (EX h : _, loc_R g gsh gl gv h v).
Proof.
  intros; unfold loc_R.
  rewrite exp_trivial by (exact []).
  unfold ghost_master, ghost_snap.
  apply derives_precise' with (Q := (EX sm : (option Z * option Z), ghost sm g) *
    (EX v : Z, ghost_var gsh v gl) * (EX sm : (option Z * option Z), ghost sm gv));
    [|repeat apply precise_sepcon; try apply ex_ghost_precise; apply ghost_var_precise].
  Intros ver ver'; Exists (@None Z, Some ver) (Some ver', @None Z) ver; auto.
Qed.
Hint Resolve loc_R_precise.

Lemma body_write : semax_body Vprog Gprog f_write write_spec.
Proof.
  start_function.
  unfold atomic_loc_hist at 1; Intros.
  rewrite atomic_loc_isptr; Intros.
  forward.
  assert (sh <> Share.bot) by (intro; subst; contradiction unreadable_bot).
  (* The ghost_var guarantees that no one else has changed the version. *)
  forward_call (AL_witness sh version gv 0 (ver_R gv2 gsh2 gv' lg) hv
    (ghost_var gsh1 v gv') (fun v' => !!(v' = v) && ghost_var gsh1 v gv')).
  { split; auto.
    apply AL_hist_spec; auto; repeat intro.
    unfold ver_R in *.
    rewrite !flatten_sepcon_in_SEP.
    gather_SEP 3 1.
    assert_PROP (v = v0).
    { go_lowerx; apply sepcon_derives_prop, ghost_var_inj; auto. }
    eapply semax_pre; [|eauto].
    go_lowerx; entailer!. }
  Intros v'; simpl; Intros hv1; subst.
  assert (repable_signed (v + 1)) by admit. (* version stays in range *)
  assert ((v + 1) mod 2 = 1) as Hdirty.
  { rewrite Zplus_mod; replace (v mod 2) with 0.
    rewrite !Zmod_small by (try apply Z_mod_lt; computable); auto. }
  forward_call (AS_witness sh version gv 0 (ver_R gv2 gsh2 gv' lg) hv1 (v + 1)
    (ghost_snap v gv2 * ghost_var gsh1 v gv') (ghost_snap (v + 1) gv2 * ghost_var gsh1 (v + 1) gv')).
  { split; [|split; auto].
    apply AS_hist_spec; auto.
    repeat intro.
    unfold ver_R in *.
    rewrite <- !sepcon_assoc, !flatten_sepcon_in_SEP.
    gather_SEP 4 1.
    assert_PROP (v = v').
    { go_lowerx; apply sepcon_derives_prop, ghost_var_inj; auto. }
    subst v'; erewrite ghost_var_share_join by eauto.
    apply ghost_var_update with (v' := v + 1).
    erewrite <- (ghost_var_share_join _ _ _ _ _ SH2).
    gather_SEP 3 1.
    apply snap_master_update' with (v' := v + 1); [omega|].
    eapply semax_pre; [|eauto].
    unfold round_down.
    replace (v mod 2) with 0; rewrite Hdirty, Z.sub_0_r, Z.add_simpl_r.
    go_lowerx; entailer!. }
  Intros hv2.
  exploit (add_events_trans hv); eauto; intro.
  assert_PROP (Zlength vals = 8).
  { entailer!.
    rewrite Zlength_map in *; auto. }
  rewrite <- seq_assoc.
  forward_for_simple_bound 8 (EX i : Z, EX hists' : list hist, PROP (Zlength hists' = i)
    LOCAL (temp _v (vint v); temp _ver version; temp _n n; temp _in input)
    SEP (atomic_loc_hist sh version gv 0 (ver_R gv2 gsh2 gv' lg) hv2;
         ghost_snap (v + 1) gv2; ghost_var gsh1 (v + 1) gv'; @data_at CompSpecs sh tnode (version, locs) n;
         data_at Tsh (tarray tint 8) (map (fun x : Z => vint x) vals) input;
         fold_right sepcon emp (map (fun j =>
           !!(j < i -> add_events (Znth j hists []) [Store (vint (Znth j vals 0))] (Znth j hists' [])) &&
           atomic_loc_hist sh (Znth j locs Vundef) (Znth j ghosts Vundef) 0
             (loc_R (Znth j lg Vundef) gsh2 (Znth j lgl Vundef) gv2)
             (if zlt j i then Znth j hists' [] else Znth j hists [])) (upto 8));
         fold_right sepcon emp (map (ghost_snap (v + 2)) (sublist 0 i lg));
         fold_right sepcon emp (map (ghost_var gsh1 (v + 2)) (sublist 0 i lgl));
         fold_right sepcon emp (map (ghost_snap v) (sublist i 8 lg));
         fold_right sepcon emp (map (ghost_var gsh1 v) (sublist i 8 lgl)))).
  { Exists (@nil hist); rewrite !sublist_nil, !sublist_same by auto; unfold atomic_loc_hist at 2; entailer!.
    apply sepcon_list_derives; rewrite !Zlength_map; auto; intros.
    erewrite !Znth_map, !Znth_upto by (auto; rewrite Zlength_upto in *; omega).
    apply andp_right; [apply prop_right; omega|].
    destruct (zlt i 0); [omega | auto]. }
  - (* loop body *)
    rewrite extract_nth_sepcon with (i := i) by (rewrite Zlength_map; auto).
    erewrite Znth_map, Znth_upto by (auto; simpl; omega); Intros.
    destruct (zlt i i); [omega|].
    rewrite sublist_next with (i0 := i)(d := Vundef) by (auto; omega); simpl.
    rewrite sublist_next with (i0 := i)(d := Vundef) by (auto; omega); simpl.
    unfold atomic_loc_hist at 2; rewrite (atomic_loc_isptr _ (Znth i locs Vundef)); Intros.
    forward.
    forward.
    forward_call (AS_witness sh (Znth i locs Vundef) (Znth i ghosts Vundef) 0
      (loc_R (Znth i lg Vundef) gsh2 (Znth i lgl Vundef) gv2) (Znth i hists []) (Znth i vals 0)
      (ghost_snap (v + 1) gv2 * ghost_snap v (Znth i lg Vundef) * ghost_var gsh1 v (Znth i lgl Vundef))
      (ghost_snap (v + 1) gv2 * ghost_snap (v + 2) (Znth i lg Vundef) * ghost_var gsh1 (v + 2) (Znth i lgl Vundef))).
    { split; [|split; auto; apply Forall_Znth; auto; omega].
      apply AS_hist_spec; auto.
      repeat intro.
      unfold loc_R in *.
      erewrite exp_sepcon1, extract_nth_exists_in_SEP with (n := O); [|simpl; eauto].
      Intro ver; simpl.
      erewrite exp_sepcon1, extract_nth_exists_in_SEP with (n := O); [|simpl; eauto].
      Intro ver'; simpl.
      erewrite !sepcon_andp_prop', extract_prop_in_SEP with (n := O); [|simpl; eauto].
      Intros; simpl.
      rewrite <- !sepcon_assoc, !flatten_sepcon_in_SEP.
      gather_SEP 1 5.
      assert_PROP (ver = v).
      { go_lowerx; apply sepcon_derives_prop, ghost_var_inj; auto. }
      subst; erewrite ghost_var_share_join by eauto.
      apply ghost_var_update with (v'0 := v + 2).
      erewrite <- (ghost_var_share_join _ _ _ _ _ SH2).
      gather_SEP 4 1.
      apply snap_master_update' with (v'0 := v + 2); [omega|].
      gather_SEP 3 2; rewrite snap_snap_max.
      eapply semax_pre; [|eauto].
      go_lowerx.
      Exists (v + 2) (Z.max (v + 1) ver'); entailer!.
      split; [destruct (Z.max_spec (v + 1) ver') as [(? & ->) | (? & ->)]; auto|].
      rewrite round_up_max_distr; apply Zmax_bound_l.
      unfold round_up; replace (v mod 2) with 0; rewrite Hdirty; omega. }
    rewrite sublist_split with (mid := i)(hi := i + 1), sublist_len_1 with (d := Vundef), map_app, sepcon_app
      by omega.
    rewrite sublist_split with (mid := i)(hi := i + 1), sublist_len_1 with (d := Vundef), map_app, sepcon_app
      by omega.
    Intros h'; Exists (x ++ [h']); rewrite Zlength_app, Zlength_cons, Zlength_nil; entailer!.
    rewrite replace_nth_sepcon; apply sepcon_list_derives; rewrite upd_Znth_Zlength; rewrite !Zlength_map; auto.
    intros.
    erewrite Znth_map, Znth_upto by (auto; rewrite Zlength_upto in *; omega).
    destruct (eq_dec i (Zlength x)).
    + subst; rewrite upd_Znth_same by (rewrite Zlength_map; auto).
      destruct (zlt (Zlength x) (Zlength x + 1)); [|omega].
      rewrite app_Znth2, Zminus_diag, Znth_0_cons by omega.
      apply andp_right; auto.
      apply prop_right; auto.
    + rewrite upd_Znth_diff' by (rewrite ?Zlength_map; auto).
      erewrite Znth_map, Znth_upto by (auto; rewrite Zlength_upto in *; omega).
      Intros.
      destruct (zlt i (Zlength x)), (zlt i (Zlength x + 1)); try omega.
      * rewrite app_Znth1 by auto.
        apply andp_right; auto.
        apply prop_right; auto.
      * apply andp_right; auto.
        apply prop_right; omega.
  - Intros hists'.
    unfold atomic_loc_hist at 1; Intros.
    rewrite !sublist_nil, !sublist_same by auto.
    assert ((v + 2) mod 2 = 0) as Hclean.
    { rewrite Zplus_mod.
      replace (v mod 2) with 0; rewrite Z_mod_same_full, Zmod_0_l; auto. }
    forward_call (AS_witness sh version gv 0 (ver_R gv2 gsh2 gv' lg) hv2 (v + 2)
      (ghost_snap (v + 1) gv2 * ghost_var gsh1 (v + 1) gv' * fold_right sepcon emp (map (ghost_snap (v + 2)) lg))
      (ghost_snap (v + 2) gv2 * ghost_var gsh1 (v + 2) gv' * fold_right sepcon emp (map (ghost_snap (v + 2)) lg))).
    { split; [|split; auto].
      apply AS_hist_spec; auto.
      repeat intro.
      unfold ver_R in *.
      rewrite <- !sepcon_assoc, !flatten_sepcon_in_SEP.
      gather_SEP 4 1.
      assert_PROP (v + 1 = v').
      { go_lowerx; apply sepcon_derives_prop, ghost_var_inj; auto. }
      subst v'; erewrite ghost_var_share_join by eauto.
      apply ghost_var_update with (v' := v + 2).
      erewrite <- (ghost_var_share_join _ _ _ _ _ SH2).
      gather_SEP 3 1.
      apply snap_master_update' with (v' := v + 2); [omega|].
      gather_SEP 3 2.
      apply snaps_snaps_max; rewrite Z.max_l by (unfold round_down; omega).
      eapply semax_pre; [|eauto].
      unfold round_down; rewrite Hclean, Z.sub_0_r.
      go_lowerx; entailer!.
      { admit. (* version stays in range *) } }
    Intros hv3.
    forward.
    Exists hv3 hists'; unfold atomic_loc_hist at 2; entailer!.
    + eapply add_events_trans with (le := [_; _]); eauto.
    + apply sepcon_list_derives; rewrite !Zlength_map; auto; intros.
      erewrite !Znth_map, !Znth_upto by (auto; rewrite Zlength_upto in *; omega).
      Intros; destruct (zlt i 8); [|rewrite Zlength_upto in *; simpl in *; omega].
      apply andp_right; auto.
      apply prop_right; auto.
Admitted.

(*(* Steps to linearizability:
   A single thread sees a sequence of reads and writes.
   The join of a collection of sequences of reads and writes, if consistent, is equivalent to a sequence of reads
   and writes. *)
Inductive lin_op := Read (v : Z) (vals : list Z) | Write (v : Z) (vals : list Z).

Fixpoint do_op h1 op h2 :=
  match op with
  | Read v vals => Z.testbit v 0 = false /\ exists failvs, Forall repable_signed failvs /\
      add_events (fst h1) (make_loads (failvs ++ [v; v])) (fst h2) /\ exists loops,
      forall i, 0 <= i < 8 -> exists fails, Zlength fails = loops /\
        add_events (Znth i (snd h1) []) (make_loads (fails ++ [Znth i vals 0])) (Znth i (snd h2) [])
  | Write v vals =>
      add_events (fst h1) [Load (vint v); Store (vint (Z.lor v 1)); Store (vint (v + 2))] (fst h2) /\
      forall i, 0 <= i < 8 -> add_events (Znth i (snd h1) []) [Store (vint (Znth i vals 0))] (Znth i (snd h2) [])
  end.

Inductive do_ops h : list lin_op -> hist * list hist -> Prop :=
| do_ops_nil : do_ops h [] h
| do_ops_cons : forall a la h' h'' (Hh' : do_op h a h') (Hh'' : do_ops h' la h''), do_ops h (a :: la) h''.

(* For now, we're relying on there being only one writer. *)
Lemma full_hist_writes : forall w lr v (Hv : full_hist' (concat (w :: lr)) v) (Hw : NoDup (map fst w))
  (Hr : Forall (fun h => exists lv, map snd h = make_loads lv) lr), full_hist' w v.
Proof.
  intros; eapply full_hist'_drop; eauto.
  { simpl; apply incl_appl, incl_refl. }
  simpl; intros ?? Hin Hout ??.
  rewrite in_app in Hin; destruct Hin as [? | Hin]; [contradiction|].
  rewrite in_concat in Hin; destruct Hin as (h & ? & ?).
  rewrite Forall_forall in Hr; exploit Hr; eauto; intros (? & Hsnd).
  assert (In e (map snd h)) as He by (rewrite in_map_iff; do 2 eexists; eauto; auto).
  unfold make_loads in Hsnd; rewrite Hsnd, in_map_iff in He; destruct He as (? & ? & ?); subst; contradiction.
Qed.

Definition empty_state := ([] : hist, repeat ([] : hist) 8).

Definition make_reads le := map (fun '(v, lv) => Read v lv) le.
Definition make_writes le := map (fun '(v, lv) => Write v lv) le.

Lemma read_written : forall w lr writes reads v vals (Hw : do_ops empty_state (make_writes writes) w)
  (Hlr : Forall2 (fun rs r => do_ops empty_state (make_reads rs) r) reads lr)
  (Hfullv : full_hist' (concat (map fst (w :: lr))) v)
  (Hvals : Zlength vals = 8) (Hfullvs : forall i, 0 <= i < 8 ->
    full_hist' (concat (map (fun l => Znth i (snd l) []) (w :: lr))) (vint (Znth i vals 0))),
  incl (concat reads) writes.
Proof.
  repeat intro.
  rewrite in_concat in H; destruct H as (r & Hr & Hin).
  (* We actually need the memory model here. Since there's no connection between histories on different
     locations, we don't know that the write of the version number happens before the writes to the bodies.
     How can we recover this information? With a ghost variable marking the version number on each location? *)
  *)


Require Import Coq.Program.Program Coq.Unicode.Utf8 CoRN.stdlib_omissions.Pair.
Generalizable All Variables.

(** In the following type class, r is an "output parameter" in the sense
 that we will have unification infer it. We cannot turn r into a field instead,
 because that would hide it behind a projection, which hinders further
 scrutiny. *)

Class PointFree {T} (f r: T): Prop := pointfree_eq: f = r.

(** If no other instances match, give up and declare the thing point-free: *)

#[global]
Instance proper_pf {T} (x: T): PointFree x x | 9.
Proof. firstorder. Qed.

(** Instances for various forms of lambdas: *)

#[global]
Instance eta_pf {A B} (f: A → B) `{!PointFree f f'}: PointFree (λ x, f x) (f' ∘ id)  | 10.
Proof. firstorder. Qed.

#[global]
Instance const_pf {A B} (b: B): PointFree (λ _: A, b) (const b).
Proof. firstorder. Qed.

#[global]
Instance id_pf {A}: PointFree (λ x: A, x) id.
Proof. firstorder. Qed.

#[global]
Instance pair_pf {A B C} (f: A → B) (g: A → C) `{!PointFree f f'} `{!PointFree g g'}:
   PointFree (λ x: A, (f x, g x)) (map_pair f' g' ∘ diagonal).
Proof. compute. rewrite PointFree0, PointFree1. reflexivity. Qed.
  (* This one may not be strictly needed in the presence of binapp_pf below. *)

#[global]
Instance compose_pf {A B C} (f: B → C) (g: A → B)
  `{!PointFree f f'} `{!PointFree g g'}: PointFree (λ x, f (g x)) (f' ∘ g').
Proof. compute. rewrite PointFree0, PointFree1. reflexivity. Qed.

#[global]
Instance binapp_pf {A B C D} (f: A → B → C) (g: D → A) (h: D → B)
  `{!PointFree f f'} `{!PointFree g g'} `{!PointFree h h'}:
     PointFree (λ x: D, f (g x) (h x)) (uncurry f' ∘ map_pair g' h' ∘ diagonal).
Proof. compute. rewrite PointFree0, PointFree1, PointFree2. reflexivity. Qed.

#[global]
Instance uncur_pf {A B C} (f: A → B → C) `{!PointFree (λ p, f (fst p) (snd p)) f'}: PointFree (uncurry (λ x: A, f x)) f'.
Proof. compute. rewrite <- PointFree0. reflexivity. Qed.

(*
  (* In the following tests, the Print's should show that the second argument inferred for PointFree is actually point-free. *)
Definition test0: PointFree (@fst (unit*unit) unit) _ := _.
Check test0.
Definition test1: PointFree (λ x: unit * unit * unit, fst x) _ := _.
Check test1.
Definition test2: PointFree (λ x: unit * unit * unit, fst (fst x)) _ := _.
Check test2.
Definition test3: PointFree (λ x: unit, (x, x)) _ := _.
Check test3.
Definition test4: PointFree (λ x: unit, const x (const x x)) _ := _.
Check test4.
Definition test5: PointFree (uncurry (λ x y: unit, const x (const y x))) _ := _.
Check test5.
Definition test6: PointFree (uncurry (λ x y: unit, id y)) _ := _.
Check test6.
Definition test7: PointFree (uncurry (λ x y: unit, x)) _ := _.
Check test7.

(* Todo: The set of instances currently generates "uncurry const" (which is equivalent to "fst") sometimes (e.g. for test4 above).
 If this turns out to be annoying, we can probably get rid of it by adding more specialized and prioritized instances. *)
*)


Set warnings "-notation-overridden,-parsing".
Require Import Framework_SOS.
Require Import Framework_common.
From Coq Require Import BinNat.
From Coq Require Import omega.Omega.
From Coq Require Import Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Bool.Bool.

Local Open Scope Z_scope.

(** Defining a few variable names as notational shorthands will make
    examples easier to read: *)

Definition w : string := "w".
Definition x : string := "x".
Definition y : string := "y".
Definition z : string := "z".

Bind Scope while_scope with Aexp.
Bind Scope while_scope with Bexp.
Bind Scope while_scope with Stm.
Delimit Scope while_scope with while.

Notation "x + y" := (APlus x y) (at level 50, left associativity).
Notation "x - y" := (AMinus x y) (at level 50, left associativity).
Notation "x * y" := (AMult x y) (at level 40, left associativity).
Notation "x <= y" := (BLe x y) (at level 70, no associativity).
Notation "x = y" := (BEq x y) (at level 70, no associativity).
Notation "x && y" := (BAnd x y) (at level 40, left associativity).
Notation "'~' b" := (BNot b) (at level 75, right associativity).
Open Scope while.

(*tiny derivation squences*)

Example triv_1:
<< x::= (1+3); SKIP, (y!->3, z!->3)>> ==> <<SKIP, x!->4, y!->3, z!->3>>.

Proof.
  - eapply SSCompII.
    + eapply SSAss. reflexivity.
Qed.

Example triv_2:

<< x::=4; SKIP, (x!->1, y!->3, z!->3)>> ==> <<SKIP, x!->4, y!->3, z!->3>>.
Proof.
  eapply stm_eq.
  - eapply SSCompII.
    + eapply SSAss. reflexivity.
  - apply conf_eq_rn. eq_states.
Qed.

Example triv_3:

<< x::=y, (x!->1, y!->4, z!->3)>> ==> << x!->4, y!->4, z!->3>>.
Proof.
  eapply stm_eq.
  eapply SSAss. reflexivity.
  apply conf_eq_fn.
  eq_states.
  Qed.

Example triv_4:

<< x::=y; SKIP, (x!->1, y!->7, z!->3)>> ==> <<SKIP, x!->7, y!->7, z!->3>>.
Proof.
   eapply stm_eq.
  - eapply SSCompII. (*note the 7-s*)
    + eapply SSAss. reflexivity.
  - apply conf_eq_rn. eq_states.
    Qed.

Example triv_5:

<< y::=x; SKIP, (x!->1, y!->7, z!->3)>> ==> <<SKIP, y!->1, x!->1, z!->3>>.
Proof.
  eapply stm_eq.
  - eapply SSCompII. (*note the 7-s*)
    + eapply SSAss. reflexivity.
  - apply conf_eq_rn. eq_states.
     Qed.

(*two tiny derivation trees*)
Example triv_6_multi:

<< x::=4; SKIP, (x!->1, y!->3, z!->3)>> ==>* << x!->4, y!->3, z!->3>>.

Proof.

  - eapply multistep.
    + eapply SSCompII.
      * eapply SSAss. reflexivity.
    + eapply multistep. eapply SSSkip.
   eapply no_stm_eq.
   eapply multirefl. apply conf_eq_fn. eq_states.
     Qed.

Example triv_7_lecture:
<< z ::=x; x ::= y; y ::=z, (x!->3, y!->4,  z!->5)>> ==>*
    (*<< ( x!->4, y!-> 3, z!-> 3, x!->3, y!->4,  z!->5)>>.*)
    << (y!->3, x!->4, z!->3, x!->3, y!-> 4, z!-> 5)>>.
Proof.
  - eapply multistep.
    + apply SSCompII. apply SSAss. reflexivity.
    + apply multistep with (<<y ::=z, x!->4, z!-> 3, x!->3, y!->4,  z!->5>>).
      * apply SSCompII. apply SSAss. reflexivity.
      * apply multistep with <<(y!->3, x!->4, z!->3, x!->3, y!-> 4, z!-> 5)>>.
        apply SSAss. reflexivity.
   eapply no_stm_eq.
   eapply multirefl. apply conf_eq_fn. eq_states. Qed.
    (*<< ( x!->4, y!-> 3, z!-> 3, x!->3, y!->4,  z!->5)>>.*)
    (*<< (y!->3, x!->4, z!->3, x!->3, y!-> 4, z!-> 5)>>.*)
(*the power of eapply*)
Example triv_7_lecture':
<< z ::=x; x ::= y; y ::=z, (x!->3, y!->4,  z!->5)>> ==>*
    << (y!->3, x!->4, z!->3)>>.
Proof.
  - apply multistep with <<x ::= y; y ::=z, z!->3, x!->3, y!-> 4, z!-> 5>>.
    + apply SSCompII. apply SSAss. reflexivity.
    + eapply multistep.
      * apply SSCompII. apply SSAss. reflexivity.
      * eapply multistep. apply SSAss. reflexivity.
   eapply no_stm_eq.
   eapply multirefl. apply conf_eq_fn. eq_states. Qed.

(*when will we need to use comp1*)
Example triv_7_lecture'':
<< (z ::=x; x ::= y); y ::=z, (x!->3, y!->4,  z!->5)>> ==>*
    << (y!->3, x!->4, z!->3)>>.
Proof.
  - apply multistep with <<x::=y; y ::=z,  z!->3, x!->3, y!-> 4, z!-> 5>>.
    + eapply SSCompI. (*<--- Used Comp 1! *)
      * apply SSCompII. apply SSAss. reflexivity.
    + apply multistep with <<y ::=z, x!->4, z!-> 3, x!->3, y!->4,  z!->5>>.
      * apply SSCompII. apply SSAss. reflexivity.
      * apply multistep with << (y!->3, x!->4, z!->3, x!->3, y!-> 4, z!-> 5)>>.
       apply SSAss. reflexivity.
   eapply no_stm_eq.
   eapply multirefl. apply conf_eq_fn. eq_states.
   Qed.

Definition triv_8_while: Stm :=
  x ::= 2;
  WHILE (~ (x=1))
  DO x ::= (AId x - 1)
  .

(*using apply, so that it is easier to see the step whem reading the proof*)
Example proof_8_while:
  <<triv_8_while , empty_State>> ==>* << x!->1>>.
Proof.
  unfold triv_8_while.
  - apply multistep with   <<WHILE (~ (x=1))
                          DO x ::= (x - 1 )
                          , x!->2>>.
    + apply SSCompII. apply SSAss. reflexivity.
    + eapply multistep.
      * apply SSWhile.
      * eapply multistep.
             ** apply SSIftrue. reflexivity.
             ** eapply multistep.
                  apply SSCompII. apply SSAss. reflexivity.
                  eapply multistep.
                  *** apply SSWhile.
                  *** eapply multistep.
                      apply SSIffalse. reflexivity.
                         eapply multistep. apply SSSkip.
   eapply no_stm_eq.
   eapply multirefl. apply conf_eq_fn. eq_states. Qed.

Example proof_8_while':
  <<triv_8_while;SKIP, empty_State>> ==>* << x!->1>>.
Proof.
  unfold triv_8_while.
  - eapply multistep.
    + apply SSCompI. (* <-- NEW*)
      apply SSCompII. apply SSAss. reflexivity.
    + eapply multistep.
      ++ apply SSCompI. apply SSWhile.
      ++ eapply multistep.
          * apply SSCompI. apply SSIftrue. reflexivity.
          * eapply multistep.
              ** apply SSCompI. apply SSCompII. apply SSAss. reflexivity.
              ** eapply multistep.
                *** apply SSCompI. apply SSWhile.
                *** eapply multistep.
                      -- apply SSCompI. apply SSIffalse. reflexivity.
                      -- eapply multistep.
                          apply SSCompII. apply SSSkip.
                          eapply multistep.   apply SSSkip.
    (*wrap_up_star.*)
   eapply no_stm_eq.
   eapply multirefl. apply conf_eq_fn. eq_states. Qed.

(*using apply, so that it is easier to see the step whem reading the proof*)
Example proof_8_while_details:
  <<triv_8_while, empty_State>> ==>* << x!->1, x!->2>>.
Proof.
  unfold triv_8_while.
  - apply multistep with   <<WHILE (~ (x=1))
                          DO x ::= (x - 1 )
                          , x!->2>>.
    + apply SSCompII. apply SSAss. reflexivity.
    + apply multistep with <<IF_ (~(x=1)) THEN( x ::= (x - 1 );
                                              WHILE (~ (x=1))
                                              DO x ::= (x - 1 )
                                              )
                                         ELSE SKIP, x!->2>>.
      * apply SSWhile.
      * apply multistep with <<x ::= (x - 1 );
                              WHILE (~ (x=1))
                              DO x ::= (x - 1) , x!->2>>.
             ** apply SSIftrue. reflexivity.
             ** apply multistep  with <<WHILE (~ (x=1))
                                      DO x ::= (x - 1) , x!->1, x!->2>>.
                  apply SSCompII. apply SSAss. reflexivity.
                  apply multistep with <<IF_ (~(x=1)) THEN( x ::= (x - 1 );
                                              WHILE (~ (x=1))
                                              DO x ::= (x - 1 )
                                              )
                                         ELSE SKIP, x!-> 1, x!->2>>.
                  *** apply SSWhile.
                  *** apply multistep with <<SKIP, x!->1, x!->2>>.
                      apply SSIffalse. reflexivity.
                         apply multistep with << x!->1, x!->2>>.
                         apply SSSkip. apply multirefl. Qed.

(*trying to use apply here is especially tedious, but helps to
show where there are differences with the prevoiuos example. *)
Example proof_8_while_detail'':
  <<triv_8_while;SKIP, empty_State>> ==>* << x!->1, x!->2>>.
Proof.
  unfold triv_8_while.
  - apply multistep with   <<(WHILE (~ (x=1))
                          DO x ::= (x - 1 ))
                          ;SKIP, x!->2>>. (*<-- added ; SKIP*)
    + apply SSCompI. (* <-- NEW*)
      apply SSCompII. apply SSAss. reflexivity.
    +  apply multistep with   <<(IF_ (~(x=1)) THEN( x ::= (x - 1 );
                                              WHILE (~ (x=1))
                                              DO x ::= (x - 1 )
                                              )
                                         ELSE SKIP); SKIP, x!->2>>.
      ++ apply SSCompI. apply SSWhile.
      ++ apply multistep with <<(x::=(x-1);
                                WHILE (~ (x=1))
                                DO x ::= (x - 1 )
                                ); SKIP
                                , x!->2>>.
          * apply SSCompI. apply SSIftrue. reflexivity.
          * apply multistep with <<(WHILE (~ (x=1))
                                DO x ::= (x - 1 ))
                                ; SKIP
                                , x!->1, x!->2>>.
              ** apply SSCompI. apply SSCompII. apply SSAss. reflexivity.
              ** apply multistep with   <<(IF_ (~(x=1)) THEN( x ::= (x - 1 );
                                              WHILE (~ (x=1))
                                              DO x ::= (x - 1 )
                                              )
                                         ELSE SKIP); SKIP, x!->1, x!->2>>.
                *** apply SSCompI. apply SSWhile.
                *** apply multistep with <<SKIP; SKIP, x!->1, x!->2>>.
                      -- apply SSCompI. apply SSIffalse. reflexivity.
                      -- apply multistep with <<SKIP, x!->1, x!->2>>.
                          apply SSCompII. apply SSSkip.
                          apply multistep with <<x!->1, x!->2>>.
                          apply SSSkip. apply multirefl. Qed.

(* This works now, but not with the small steps expressions. *)
Example test:
<< x::= 1+1+1, empty_State>> ==> <<x!->3>>.
Proof.
  eapply SSAss. reflexivity.

Close Scope while.


Require Export Iron.Language.SystemF2Effect.Step.Frame.
Require Export Iron.Language.SystemF2Effect.Step.Preservation.
Require Export Iron.Language.SystemF2Effect.Store.
Require Export Iron.Language.SystemF2Effect.Type.Relation.SubsVisibleT.

(********************************************************************)
(* Multistep evaluation. *)
Inductive Steps
    :  store -> stprops -> stack -> exp
    -> store -> stprops -> stack -> exp -> Prop :=
 | SsNone
   :  forall ss sp fs x
   ,  Steps  ss  sp  fs  x   ss  sp  fs  x

 | SsCons
   :  forall ss1 sp1 fs1 x1
             ss2 sp2 fs2 x2
             ss3 sp3 fs3 x3
   ,  StepF  ss1 sp1 fs1 x1  ss2 sp2 fs2 x2
   -> Steps  ss2 sp2 fs2 x2  ss3 sp3 fs3 x3
   -> Steps  ss1 sp1 fs1 x1  ss3 sp3 fs3 x3.

Hint Constructors Steps.

(********************************************************************)
Lemma steps_trans
 :  forall ss1 sp1 fs1 x1
           ss2 sp2 fs2 x2
           ss3 sp3 fs3 x3
 ,  Steps  ss1 sp1 fs1 x1  ss2 sp2 fs2 x2
 -> Steps  ss2 sp2 fs2 x2  ss3 sp3 fs3 x3
 -> Steps  ss1 sp1 fs1 x1  ss3 sp3 fs3 x3.
Proof.
 intros.
 induction H; eauto.
Qed.

Lemma steps_extends_stprops
 :  forall ss sp fs x  ss' sp' fs' x'
 ,  Steps  ss sp fs x  ss' sp' fs' x'
 -> extends sp' sp.
Proof.
 intros.
 induction H. eauto.
 eapply stepF_extends_stprops in H.
 eapply extends_trans; eauto.
Qed.

(* Preservation for multi-step evaluation. *)
Lemma steps_preservation
 :  forall se  sp  ss  fs  x
               sp' ss' fs' x'
           t   e
 ,  WfFS   se  sp  ss  fs
 -> LiveS  ss  fs
 -> LiveE  fs  e
 -> TypeC  nil nil se  sp  fs  x   t   e
 -> Steps  ss  sp  fs  x   ss' sp' fs' x'
 -> (exists se' e'
    ,  WfFS    se' sp' ss' fs'
    /\ LiveS   ss' fs'
    /\ LiveE   fs' e'
    /\ SubsVisibleT nil sp' sp e e'
    /\ TypeC    nil nil se' sp' fs' x' t e').
Proof.
 intros. gen se e.
 induction H3; intros.
 - exists se. exists e.
   intuition.
   eapply subsVisibleT_refl.
   inverts H2. eauto.

 - lets D: preservation H2 H; eauto.
   destruct D  as [se2].
   destruct H5 as [e2].  rip.
   spec IHSteps se2.     rip.
   spec IHSteps e2.      rip.
   destruct IHSteps as [se3].
   destruct H9      as [e3].
   exists se3. exists e3.
   intuition.
   + eapply subsVisibleT_trans; eauto.
     * eapply subsVisibleT_stprops_extends.
       eapply steps_extends_stprops; eauto.
       eauto.

     * have (extends sp2 sp1)
        by (eapply stepF_extends_stprops; eauto).
       eapply subsVisibleT_spVis_strengthen; eauto.
Qed.