From sflib Require Import sflib.
From Paco Require Import paco.
Require Import Coq.Classes.RelationClasses Lia Program.
From Fairness Require Export ITreeLib WFLibLarge FairBeh NatStructsLarge Mod pind.

Set Implicit Arguments.

Module SCMem.
  Definition pointer := (nat * nat)%type.

  Variant val: Type :=
    | val_nat (n: nat)
    | val_ptr (p: pointer)
  .

  Let ident := val.

  Definition unwrap_ptr (v: val): option pointer :=
    match v with
    | val_nat _ => None
    | val_ptr p => Some p
    end.

  Definition ptr_eq_dec (p0 p1: pointer): {p0 = p1} + {p0 <> p1}.
  Proof.
    destruct p0 as [blk0 ofs0], p1 as [blk1 ofs1].
    destruct (PeanoNat.Nat.eq_dec blk0 blk1).
    - destruct (PeanoNat.Nat.eq_dec ofs0 ofs1).
      + left. f_equal; assumption.
      + right. ii. inject H. apply n. reflexivity.
    - right. ii. inject H. apply n. reflexivity.
  Qed.

  Definition val_null: val := val_nat 0.

  Definition val_eq_dec (v0 v1: val): {v0 = v1} + {v0 <> v1}.
  Proof.
    destruct v0 as [n0|p0], v1 as [n1|p1].
    - destruct (PeanoNat.Nat.eq_dec n0 n1).
      + left. f_equal; assumption.
      + right. ii. inject H. apply n. reflexivity.
    - right. ii. inject H.
    - right. ii. inject H.
    - destruct (ptr_eq_dec p0 p1).
      + left. f_equal; assumption.
      + right. ii. inject H. apply n. reflexivity.
  Qed.

  Definition val_add (v: val) (n: nat): val :=
    match v with
    | val_nat v => val_nat (v + n)
    | val_ptr (blk, ofs) => val_ptr (blk, ofs + n)
    end.

  Record t :=
    mk
      {
        contents:> nat -> nat -> option val;
        next_block: nat;
      }.

  Definition wf (m: t): Prop :=
    forall blk ofs v (SOME: m.(contents) blk ofs = Some v),
      blk < m.(next_block).

  Definition has_permission (m: t) (ptr: val): bool :=
    match unwrap_ptr ptr with
    | Some (blk, ofs) =>
        if (m.(contents) blk ofs) then true else false
    | None => false
    end.

  Definition val_compare (m: t) (v0 v1: val): option bool :=
    match v0, v1 with
    | val_nat n0, val_nat n1 => Some (if (PeanoNat.Nat.eq_dec n0 n1) then true else false)
    | val_nat n, val_ptr p
    | val_ptr p, val_nat n =>
        if (has_permission m (val_ptr p))
        then Some false else None
    | val_ptr p0, val_ptr p1 =>
        if (has_permission m (val_ptr p0) && has_permission m (val_ptr p1))%bool then
          Some (if (ptr_eq_dec p0 p1) then true else false)
        else None
    end.

  Definition alloc (m: t) (size: nat): t * val :=
    let nb := (m.(next_block)) in
    (mk (fun blk => if (PeanoNat.Nat.eq_dec blk nb)
                    then
                      fun ofs =>
                        if Compare_dec.le_gt_dec size ofs
                        then None
                        else Some (val_nat 0)
                    else m.(contents) blk) (S nb), val_ptr (nb, 0)).

  Definition mem_update (m: t) (blk: nat) (ofs: nat) (v: val): t :=
    mk (fun blk' => if (PeanoNat.Nat.eq_dec blk' blk)
                    then
                      fun ofs' => if (PeanoNat.Nat.eq_dec ofs' ofs)
                                  then Some v
                                  else m.(contents) blk' ofs'
                    else m.(contents) blk') m.(next_block).

  Definition store (m: t) (ptr: val) (v: val): option t :=
    match unwrap_ptr ptr with
    | Some (blk, ofs) =>
        if (m.(contents) blk ofs)
        then Some (mem_update m blk ofs v)
        else None
    | None => None
    end.

  Definition load (m: t) (ptr: val): option val :=
    match unwrap_ptr ptr with
    | Some (blk, ofs) =>
        m.(contents) blk ofs
    | _ => None
    end.

  Definition compare (m: t) (v0: val) (v1: val): option bool :=
    val_compare m v0 v1.

  Definition faa (m: t) (ptr: val) (addend: nat): option (t * val) :=
    match (load m ptr) with
    | None => None
    | Some v =>
        match (store m ptr (val_add v addend)) with
        | Some m => Some (m, v)
        | None => None
        end
    end.

  Definition cas (m: t) (ptr: val) (v_old: val) (v_new: val):
    option (t + unit) :=
    match (load m ptr) with
    | Some v =>
        match (val_compare m v v_old) with
        | None => None
        | Some true =>
            match store m ptr v_new with
            | Some m_new => Some (inl m_new)
            | None => None
            end
        | Some false =>
            Some (inr tt)
        end
    | None => None
    end.

  Definition alloc_fun:
    ktree (programE ident t) nat val :=
    fun sz =>
      m <- trigger (Get id);;
      let (m, v) := alloc m sz in
      _ <- trigger (Put m);;
      Ret v
  .

  Definition store_fun:
    ktree (programE ident t) (val * val) unit :=
    fun '(vptr, v) =>
      m <- trigger (Get id);;
      m <- unwrap (store m vptr v);;
      _ <- trigger (Put m);;
      Ret tt
  .

  Definition load_fun:
    ktree (programE ident t) val val :=
    fun vptr =>
      m <- trigger (Get id);;
      v <- unwrap (load m vptr);;
      Ret v
  .

  Definition faa_fun:
    ktree (programE ident  t) (val * nat) val :=
    fun '(vptr, addend) =>
      m <- trigger (Get id);;
      '(m, v) <- unwrap (faa m vptr addend);;
      _ <- trigger (Put m);;
      Ret v
  .

  Definition cas_fun:
    ktree (programE ident t) (val * val * val) bool :=
    fun '(vptr, v_old, v_new) =>
      m <- trigger (Get id);;
      mb <- unwrap (cas m vptr v_old v_new);;
      match mb with
      | inl m =>
          _ <- trigger (Put m);;
          Ret true
      | inr _ =>
          Ret false
      end
  .

  Definition cas_weak_fun:
    ktree (programE ident t) (val * val * val) bool :=
    fun '(vptr, v_old, v_new) =>
      m <- trigger (Get id);;
      b <- trigger (Choose bool);;
      if (b: bool)
      then
        mb <- unwrap (cas m vptr v_old v_new);;
        match mb with
        | inl m =>
            _ <- trigger (Put m);;
            Ret true
        | inr _ =>
            Ret false
        end
      else
        if has_permission m vptr
        then
          _ <- trigger (Fair (fun i => if val_eq_dec i vptr then Flag.fail else Flag.success));;
          Ret false
        else UB
  .

  Definition compare_fun:
    ktree (programE ident t) (val * val) bool :=
    fun '(v0, v1) =>
      m <- trigger (Get id);;
      b <- unwrap (compare m v0 v1);;
      Ret b
  .

  Definition empty: t := mk (fun _ _ => None) 0.

  Fixpoint initialize (m: t) (l: list nat): t * list val :=
    match l with
    | hd::tl =>
        let (m, vs) := initialize m tl in
        let (m, v) := alloc m hd in
        (m, v::vs)
    | [] => (m, [])
    end.

  Definition init_gvars (l: list nat): list val := snd (initialize empty l).

  Definition init_mem (l: list nat): t := fst (initialize empty l).

  Definition mod (gvars: list nat): Mod.t :=
    Mod.mk
      (init_mem gvars)
      (Mod.get_funs [("alloc", Mod.wrap_fun alloc_fun);
                     ("store", Mod.wrap_fun store_fun);
                     ("load", Mod.wrap_fun load_fun);
                     ("faa", Mod.wrap_fun faa_fun);
                     ("cas", Mod.wrap_fun cas_fun);
                     ("cas_weak", Mod.wrap_fun cas_weak_fun);
                     ("compare", Mod.wrap_fun compare_fun)
      ]).
End SCMem.

From Fairness Require Import PCM IProp IPM StateRA MonotonePCM.

Section MEMRA.
  Definition memRA: URA.t := (nat ==> nat ==> (Auth.t (Excl.t SCMem.val)))%ra.

  Context `{MEMRA: @GRA.inG memRA Σ}.

  Definition memory_resource_black (m: SCMem.t): memRA :=
    fun blk ofs =>
      match m.(SCMem.contents) blk ofs with
      | Some v => Auth.black (Excl.just v: Excl.t SCMem.val)
      | None => Auth.black (Excl.just (SCMem.val_nat 0): Excl.t SCMem.val) ⋅ Auth.white (Excl.just (SCMem.val_nat 0): Excl.t SCMem.val)
      end.

  Definition points_to_white (blk ofs: nat) (v: SCMem.val): memRA :=
    fun blk' ofs' =>
      if (PeanoNat.Nat.eq_dec blk' blk)
      then if (PeanoNat.Nat.eq_dec ofs' ofs)
           then Auth.white (Excl.just v: Excl.t SCMem.val)
           else URA.unit
      else URA.unit
  .

  Fixpoint points_tos_white (blk ofs: nat) (vs: list SCMem.val): memRA :=
    match vs with
    | vhd::vtl =>
        points_to_white blk ofs vhd ⋅ points_tos_white blk (ofs + 1) vtl
    | [] => URA.unit
    end
  .

  Lemma points_tos_white_eq blk ofs vs blk' ofs'
    :
    points_tos_white blk ofs vs blk' ofs' =
      if (PeanoNat.Nat.eq_dec blk' blk)
      then
        if (Compare_dec.le_gt_dec ofs ofs')
        then
          match nth_error vs (ofs' - ofs) with
          | Some v => Auth.white (Excl.just v: Excl.t SCMem.val)
          | _ => URA.unit
          end
        else URA.unit
      else URA.unit.
  Proof.
    revert blk ofs blk' ofs'. induction vs; ss; i.
    { des_ifs. destruct (ofs' - ofs); ss. }
    ur. ur. rewrite IHvs. unfold points_to_white.
    destruct (PeanoNat.Nat.eq_dec blk' blk); ss.
    2:{ r_solve. }
    subst. destruct (PeanoNat.Nat.eq_dec ofs' ofs).
    { subst. des_ifs; try by exfalso; lia.
      { rewrite PeanoNat.Nat.sub_diag in Heq. ss. inv Heq. r_solve. }
      { rewrite PeanoNat.Nat.sub_diag in Heq. ss. }
    }
    { des_ifs; try by exfalso; lia.
      { replace (ofs' - ofs) with (S (ofs' - (ofs + 1))) in Heq0 by lia.
        ss. clarify. r_solve.
      }
      { replace (ofs' - ofs) with (S (ofs' - (ofs + 1))) in Heq0 by lia.
        ss. clarify.
      }
      { replace (ofs' - ofs) with (S (ofs' - (ofs + 1))) in Heq0 by lia.
        ss. clarify.
      }
      { replace (ofs' - ofs) with (S (ofs' - (ofs + 1))) in Heq0 by lia.
        ss. clarify. r_solve.
      }
      { r_solve.
      }
    }
  Qed.

  Definition memory_black (m: SCMem.t): iProp :=
    OwnM (memory_resource_black m) ∧ ⌜SCMem.wf m⌝.

  Definition points_to (p: SCMem.val) (v: SCMem.val): iProp :=
    match p with
    | SCMem.val_ptr (blk, ofs) => OwnM (points_to_white blk ofs v)
    | _ => False
    end.

  Fixpoint points_tos (p: SCMem.val) (vs: list SCMem.val): iProp :=
    match vs with
    | vhd::vtl =>
        points_to p vhd ** points_tos (SCMem.val_add p 1) vtl
    | [] => True
    end.

  Lemma points_tos_to_resource blk ofs vs
    :
    (OwnM (points_tos_white blk ofs vs))
      -∗
      (points_tos (SCMem.val_ptr (blk, ofs)) vs).
  Proof.
    revert blk ofs. induction vs; ss; i.
    { auto. }
    iIntros "[H0 H1]".
    iPoseProof (IHvs with "H1") as "H1". iFrame.
  Qed.

  Lemma resource_to_points_to blk ofs vs
    :
    (points_tos (SCMem.val_ptr (blk, ofs)) vs)
      -∗
      (OwnM (points_tos_white blk ofs vs)).
  Proof.
    revert blk ofs. induction vs; ss; i.
    { iIntros "_". iPoseProof (@OwnM_unit _ _ MEMRA) as "H". auto. }
    iIntros "[H0 H1]". iSplitL "H0"; auto.
    iApply IHvs. auto.
  Qed.

  Definition memory_empty_resource: memRA :=
    memory_resource_black SCMem.empty.

  Lemma memory_empty_wf: URA.wf memory_empty_resource.
  Proof.
    ur. i. ur. i. ur. unfold memory_empty_resource.
    ur. split; ss. exists ε. r_solve.
  Qed.

  Fixpoint init_points_tos_resource (nb: nat) (l: list nat): memRA :=
    match l with
    | [] => URA.unit
    | sz::tl =>
        points_tos_white (nb + length tl) 0 (repeat (SCMem.val_nat 0) sz) ⋅ init_points_tos_resource nb tl
    end.

  Fixpoint init_points_tos (l: list nat) (vs: list SCMem.val): iProp :=
    match l, vs with
    | sz::tl, vhd::vtl => points_tos vhd (repeat (SCMem.val_nat 0) sz) ** init_points_tos tl vtl
    | [], [] => True
    | _, _ => False
    end.

  Definition memory_init_resource (l: list nat): memRA :=
    memory_resource_black (SCMem.init_mem l) ⋅ init_points_tos_resource 0 l.

  Lemma pointwise_updatabable M K (a b: URA.pointwise K M)
        (POINTWISE: forall k, URA.updatable (a k) (b k))
    :
    URA.updatable a b.
  Proof.
    ii. ur. ur in H. i. eapply POINTWISE; eauto.
  Qed.

  Lemma memory_alloc_updatable m0 sz m1 p
        (ALLOC : SCMem.alloc m0 sz = (m1, p))
        (WF : SCMem.wf m0)
    :
    URA.updatable (memory_resource_black m0)
                  (memory_resource_black m1 ⋅ points_tos_white (SCMem.next_block m0) 0 (repeat (SCMem.val_nat 0) sz)).
  Proof.
    eapply pointwise_updatabable. i.
    eapply pointwise_updatabable. i.
    ur. ur. rewrite points_tos_white_eq.
    unfold SCMem.alloc in ALLOC. inv ALLOC.
    unfold memory_resource_black. ss. des_ifs; try by exfalso; lia.
    { eapply WF in Heq. lia. }
    { eapply WF in Heq. lia. }
    { rewrite URA.unit_id. reflexivity. }
    { eapply WF in Heq. lia. }
    { eapply WF in Heq. lia. }
    { rewrite PeanoNat.Nat.sub_0_r in Heq1.
      hexploit nth_error_repeat; eauto. rewrite Heq1. i. clarify.
    }
    { rewrite PeanoNat.Nat.sub_0_r in Heq1.
      hexploit nth_error_repeat; eauto. rewrite Heq1. i. clarify.
    }
    { rewrite PeanoNat.Nat.sub_0_r in Heq1.
      assert (LT: k0 < length (repeat (SCMem.val_nat 0) sz)).
      { eapply nth_error_Some. rewrite Heq1. ss. }
      rewrite repeat_length in LT. lia.
    }
    { rewrite URA.unit_id. reflexivity. }
    { rewrite URA.unit_id. reflexivity. }
  Qed.

  Lemma memory_ra_alloc m0 sz m1 p
        (ALLOC: SCMem.alloc m0 sz = (m1, p))
    :
    (memory_black m0)
      -∗
      (#=> (memory_black m1 ** points_tos p (repeat (SCMem.val_nat 0) sz))).
  Proof.
    unfold memory_black. iIntros "[BLACK %WF]".
    iAssert (#=> (OwnM (memory_resource_black m1 ⋅ points_tos_white (m0.(SCMem.next_block)) 0 (repeat (SCMem.val_nat 0) sz)))) with "[BLACK]" as "> [BLACK WHITE]".
    { iApply (OwnM_Upd with "BLACK").
      eapply memory_alloc_updatable; eauto.
    }
    unfold SCMem.alloc in ALLOC. inv ALLOC.
    iModIntro. iFrame. iSplit.
    { iPureIntro. ii. ss. des_ifs. eapply WF in SOME; eauto. }
    { iApply points_tos_to_resource. ss. }
  Qed.

  Lemma initialize_next_block m0 l m1 vs
        (INIT: SCMem.initialize m0 l = (m1, vs))
    :
    m1.(SCMem.next_block) = m0.(SCMem.next_block) + length l.
  Proof.
    revert m0 m1 vs INIT. induction l; i; ss.
    { clarify. }
    { des_ifs. ss. eapply IHl in Heq. rewrite Heq. auto. }
  Qed.

  Lemma initialize_wf m0 l m1 vs
        (INIT: SCMem.initialize m0 l = (m1, vs))
        (WF: SCMem.wf m0)
    :
    SCMem.wf m1.
  Proof.
    revert m0 m1 vs INIT WF. induction l; i; ss.
    { clarify. }
    { des_ifs. ii. ss. des_ifs. exploit IHl; eauto. }
  Qed.

  Lemma memory_init_iprop l
    :
    OwnM (memory_init_resource l) -∗ (memory_black (SCMem.init_mem l) ** init_points_tos l (SCMem.init_gvars l)).
  Proof.
    iIntros "[BLACK WHITE]". unfold memory_black. iFrame. iSplit.
    { iPureIntro. induction l; ss. unfold SCMem.init_mem in *. ii. ss.
      des_ifs. ss. des_ifs. eapply IHl in SOME; eauto.
    }
    unfold SCMem.init_gvars.
    iStopProof. change 0 with (SCMem.next_block SCMem.empty).
    generalize (SCMem.empty). induction l; i; ss.
    { auto. }
    des_ifs. ss. inv Heq. iIntros "[POINT OWN]".
    change (S (SCMem.next_block t)) with (SCMem.next_block (fst (SCMem.alloc t a))).
    iPoseProof (IHl with "OWN") as "OWN". rewrite Heq0. ss. iFrame.
    iPoseProof (points_tos_to_resource with "POINT") as "POINT".
    replace (SCMem.next_block t0) with (SCMem.next_block t + length l); auto.
    eapply initialize_next_block in Heq0. lia.
  Qed.

  Lemma memory_init_resource_wf l
    :
    URA.wf (memory_init_resource l).
  Proof.
    assert (URA.updatable memory_empty_resource (memory_init_resource l)).
    2:{ exploit (H URA.unit); rewrite URA.unit_id; auto. eapply memory_empty_wf. }
    unfold memory_init_resource.
    unfold memory_empty_resource. unfold SCMem.init_mem.
    change 0 with (SCMem.next_block SCMem.empty).
    cut (SCMem.wf SCMem.empty).
    2:{ ii. ss. }
    generalize SCMem.empty. induction l; i.
    { ss. rewrite URA.unit_id. reflexivity. }
    { etransitivity; eauto. ss. des_ifs; ss.
      rewrite URA.add_assoc. eapply URA.updatable_add; [|reflexivity].
      hexploit memory_alloc_updatable.
      { instantiate (2:=fst (SCMem.alloc _ _)).
        instantiate (1:=snd (SCMem.alloc _ _)). ss.
      }
      { eapply initialize_wf; eauto. }
      i. etrans; eauto. eapply URA.updatable_add.
      { unfold SCMem.alloc. ss. reflexivity. }
      { eapply initialize_next_block in Heq. rewrite Heq. reflexivity. }
    }
    Unshelve. all: ss.
  Qed.

  Lemma memory_ra_load m l v
    :
    (memory_black m)
      -∗
      (points_to l v)
      -∗
      (⌜SCMem.load m l = Some v /\ SCMem.has_permission m l = true⌝).
  Proof.
    iIntros "[BLACK %WF] WHITE".
    unfold memory_black, points_to. des_ifs.
    iCombine "BLACK WHITE" as "OWN". iOwnWf "OWN".
    ur in H. specialize (H n). ur in H. specialize (H n0).
    unfold memory_resource_black, points_to_white in H. des_ifs.
    { ur in H. des. unfold URA.extends in H. des. ur in H. des_ifs.
      iPureIntro. splits; auto.
      unfold SCMem.has_permission. ss. rewrite Heq. ss.
    }
    { ur in H. des. unfold URA.extends in H. des. ur in H. des_ifs. }
  Qed.

  Lemma memory_ra_store m0 l v0 v1
    :
    (memory_black m0)
      -∗
      (points_to l v0)
      -∗
      ∃ m1,
        ((⌜SCMem.store m0 l v1 = Some m1⌝)
           ** #=> (memory_black m1 ** points_to l v1)).
  Proof.
    iIntros "[BLACK %WF] WHITE".
    unfold memory_black, points_to. des_ifs.
    iCombine "BLACK WHITE" as "OWN". iOwnWf "OWN".
    ur in H. specialize (H n). ur in H. specialize (H n0).
    unfold memory_resource_black, points_to_white in H. des_ifs.
    2:{ ur in H. des. unfold URA.extends in H. des. ur in H. des_ifs. }
    unfold SCMem.store. ss. des_ifs. iExists _.
    iSplit; eauto.
    iAssert (#=> OwnM (memory_resource_black (SCMem.mem_update m0 n n0 v1) ⋅  points_to_white n n0 v1)) with "[OWN]" as "> [BLACK WHITE]".
    { iApply (OwnM_Upd with "OWN").
      apply pointwise_updatabable. i. ur.
      apply pointwise_updatabable. i. ur.
      unfold memory_resource_black, points_to_white. ss. des_ifs.
      eapply Auth.auth_update. ii. des. split; ss.
      { ur. ss. }
      { ur in FRAME. ur. des_ifs. }
    }
    { ss. iModIntro. iFrame. iPureIntro.
      unfold SCMem.mem_update. ii. ss. des_ifs; eauto.
    }
  Qed.

  Lemma memory_ra_faa m0 l v addend
    :
    (memory_black m0)
      -∗
      (points_to l v)
      -∗
      ∃ m1,
        ((⌜SCMem.faa m0 l addend = Some (m1, v)⌝)
           ** #=> (memory_black m1 ** points_to l (SCMem.val_add v addend))).
  Proof.
    iIntros "BLACK POINT". unfold SCMem.faa.
    iPoseProof (memory_ra_load with "BLACK POINT") as "%". des. rewrite H.
    iPoseProof (memory_ra_store with "BLACK POINT") as "[% [% H]]".
    iExists m1. rewrite H1. iFrame. auto.
  Qed.

  Lemma memory_ra_compare_nat m n0 n1
    :
    SCMem.compare m (SCMem.val_nat n0) (SCMem.val_nat n1) = Some (if PeanoNat.Nat.eq_dec n0 n1 then true else false).
  Proof.
    ss.
  Qed.

  Lemma memory_ra_compare_ptr_left m n l v
    :
    (memory_black m)
      -∗
      (points_to l v)
      -∗
      (⌜SCMem.compare m (SCMem.val_nat n) l = Some false⌝).
  Proof.
    iIntros "BLACK POINT". ss.
    iPoseProof (memory_ra_load with "BLACK POINT") as "%". des.
    unfold SCMem.unwrap_ptr in H. des_ifs.
  Qed.

  Lemma memory_ra_compare_ptr_right m n l v
    :
    (memory_black m)
      -∗
      (points_to l v)
      -∗
      (⌜SCMem.compare m l (SCMem.val_nat n) = Some false⌝).
  Proof.
    iIntros "BLACK POINT". ss.
    iPoseProof (memory_ra_load with "BLACK POINT") as "%". des.
    unfold SCMem.compare, SCMem.val_compare. des_ifs.
  Qed.

  Lemma memory_ra_compare_ptr_same m l v
    :
    (memory_black m)
      -∗
      (points_to l v)
      -∗
      (⌜SCMem.compare m l l = Some true⌝).
  Proof.
    iIntros "BLACK POINT". ss.
    iPoseProof (memory_ra_load with "BLACK POINT") as "%". des.
    unfold SCMem.compare, SCMem.val_compare. des_ifs.
  Qed.

  Lemma memory_ra_compare_ptr_both m l0 v0 l1 v1
    :
    (memory_black m)
      -∗
      (points_to l0 v0)
      -∗
      (points_to l1 v1)
      -∗
      (⌜SCMem.compare m l0 l1 = Some false⌝).
  Proof.
    iIntros "BLACK POINT0 POINT1". ss.
    iPoseProof (memory_ra_load with "BLACK POINT0") as "%". des.
    iPoseProof (memory_ra_load with "BLACK POINT1") as "%". des.
    unfold SCMem.compare, SCMem.val_compare. des_ifs.
    ss. des_ifs. iCombine "POINT0 POINT1" as "POINT". iOwnWf "POINT".
    ur in H. ur in H. specialize (H n). specialize (H n0). ur in H.
    unfold points_to_white in H. des_ifs. inv Heq1. ur in H. ss.
  Qed.
End MEMRA.

Global Opaque points_to memory_black SCMem.load SCMem.store SCMem.faa SCMem.alloc.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D M Dprime : Universe, ((wd_ D A /\ (wd_ A B /\ (wd_ D B /\ (wd_ C A /\ (wd_ C B /\ (wd_ C M /\ (wd_ D M /\ (wd_ M B /\ (wd_ M Dprime /\ (col_ M A B /\ (col_ M C D /\ col_ M Dprime D))))))))))) -> col_ M C Dprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Aprime Bprime Cprime O : Universe, ((wd_ B O /\ (wd_ C O /\ (wd_ Bprime O /\ (wd_ Cprime O /\ (wd_ A O /\ (wd_ Aprime O /\ (wd_ A Aprime /\ (wd_ A B /\ (wd_ C B /\ (col_ O A B /\ (col_ O B C /\ (col_ O Aprime Bprime /\ (col_ O Bprime Cprime /\ (col_ O A C /\ (col_ O Aprime Cprime /\ col_ O B Bprime))))))))))))))) -> col_ O A Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From iris.algebra Require Import excl auth cmra gmap agree gset numbers.
From iris.algebra.lib Require Import frac_agree.
From iris.heap_lang Require Export notation locations lang.
From iris.base_logic.lib Require Export invariants.
From iris.program_logic Require Export atomic.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode par.
From iris.bi.lib Require Import fractional.
Set Default Proof Using "All".
Require Import general_multicopy.

Section util.
  Context {Σ} `{!heapG Σ, !multicopyG Σ}.
  Notation iProp := (iProp Σ).
  Local Notation "m !1 i" := (nzmap_total_lookup i m) (at level 20).

  Global Instance HnP_t_laterable (r n: Node) γ_t lc T :
              Laterable (if decide (n = r)
                         then own γ_t (●{1 / 2} MaxNat T) ∗ clock lc T
                         else True)%I.
  Proof.
    destruct (decide (n = r)); apply timeless_laterable; apply _.
  Qed.

  Lemma inFP_domm γ_f n D : inFP γ_f n -∗ own γ_f (● D) -∗ ⌜n ∈ D⌝.
  Proof.
    iIntros "FP HD".
    iPoseProof (own_valid_2 _ _ _ with "[$HD] [$FP]") as "H'".
    iDestruct "H'" as %H'.
    apply auth_both_valid_discrete in H'.
    destruct H' as [H' _].
    apply gset_included in H'.
    iPureIntro. set_solver.
  Qed.

  Lemma own_alloc_set (S: gset K): True ==∗
          ∃ (γ: gmap K gname), ([∗ set] k ∈ S, own (γ !!! k) (● (MaxNat 0))).
  Proof.
    iIntros "_".
    iInduction S as [| s S] "IH" using set_ind_L.
    - iModIntro. iExists _. try done.
    - iMod (own_alloc (● (MaxNat 0))) as (γs)"H'".
      { rewrite auth_auth_valid. try done. }
      iDestruct "IH" as ">IH".
      iDestruct "IH" as (γ)"IH".
      iModIntro. iExists (<[s := γs]> γ).
      rewrite (big_sepS_delete _ ({[s]} ∪ S) s); last by set_solver.
      iSplitL "H'". by rewrite lookup_total_insert.
      assert (({[s]} ∪ S) ∖ {[s]} = S) as HS. set_solver.
      rewrite HS.
      iApply (big_sepS_mono
                  (λ y, own (γ !!! y) (● {| max_nat_car := 0 |}) )%I
                  (λ y, own (<[s:=γs]> γ !!! y) (● {| max_nat_car := 0 |}))%I
                  S); try done.
      intros k k_in_S. iFrame. iIntros "H'".
      rewrite lookup_total_insert_ne; last by set_solver.
      done.
      (* No idea what is happening here *)
      Unshelve. exact (∅: gmap K gname).
  Qed.

  Lemma ghost_heap_sync γ_gh n γ_en γ_cn γ_bn γ_qn γ_cirn
                                      γ_en' γ_cn' γ_bn' γ_qn' γ_cirn' :
    own γ_gh (◯ {[n := ghost_loc γ_en γ_cn γ_bn γ_qn γ_cirn]})
      -∗ own γ_gh (◯ {[n := ghost_loc γ_en' γ_cn' γ_bn' γ_qn' γ_cirn']})
          -∗ ⌜γ_en = γ_en'⌝ ∗ ⌜γ_cn = γ_cn'⌝ ∗ ⌜γ_bn = γ_bn'⌝
             ∗ ⌜γ_qn = γ_qn'⌝ ∗ ⌜γ_cirn = γ_cirn'⌝.
  Proof.
    iIntros "H1 H2". iCombine "H1" "H2" as "H".
    iPoseProof (own_valid with "H") as "Valid".
    iDestruct "Valid" as %Valid.
    rewrite auth_frag_valid in Valid *; intros Valid.
    apply singleton_valid in Valid.
    apply to_agree_op_inv in Valid.
    apply leibniz_equiv in Valid.
    inversion Valid.
    by iPureIntro.
  Qed.

  Lemma ghost_heap_update γ_gh (hγ: gmap Node per_node_gl) n
                                γ_en γ_cn γ_bn γ_qn γ_cirn :
    ⌜n ∉ dom (gset Node) hγ⌝ -∗
          own γ_gh (● hγ) ==∗
            own γ_gh (● <[n := ghost_loc γ_en γ_cn γ_bn γ_qn γ_cirn]> hγ)
          ∗ own γ_gh (◯ {[n := ghost_loc γ_en γ_cn γ_bn γ_qn γ_cirn]}).
  Proof.
    iIntros "%". rename H into n_notin_hγ.
    iIntros "Hown". set (<[ n := ghost_loc γ_en γ_cn γ_bn γ_qn γ_cirn ]> hγ) as hγ'.
    iDestruct (own_update _ _
        (● hγ' ⋅ ◯ {[ n := ghost_loc γ_en γ_cn γ_bn γ_qn γ_cirn ]})
               with "Hown") as "Hown".
    { apply auth_update_alloc.
      rewrite /hγ'.
      apply alloc_local_update; last done.
      by rewrite <-not_elem_of_dom. }
    iMod (own_op with "Hown") as "[Ht● Ht◯]".
    iModIntro. iFrame.
  Qed.

  Lemma frac_eq γ_e γ_c γ_b γ_q es Cn Bn Qn es' Cn' Bn' Qn' :
              frac_ghost_state γ_e γ_c γ_b γ_q es Cn Bn Qn -∗
                  frac_ghost_state γ_e γ_c γ_b γ_q es' Cn' Bn' Qn' -∗
                    ⌜es = es'⌝ ∗ ⌜Cn = Cn'⌝ ∗ ⌜Bn = Bn'⌝ ∗ ⌜Qn = Qn'⌝.
  Proof.
    iIntros "H1 H2". unfold frac_ghost_state.
    iDestruct "H1" as "(H1_es & H1_c & H1_b & H1_q)".
    iDestruct "H2" as "(H2_es & H2_c & H2_b & H2_q)".
    iPoseProof (own_valid_2 _ _ _ with "[$H1_es] [$H2_es]") as "Hes".
    iPoseProof (own_valid_2 _ _ _ with "[$H1_c] [$H2_c]") as "Hc".
    iPoseProof (own_valid_2 _ _ _ with "[$H1_b] [$H2_b]") as "Hb".
    iPoseProof (own_valid_2 _ _ _ with "[$H1_q] [$H2_q]") as "Hq".
    iDestruct "Hes" as %Hes. iDestruct "Hc" as %Hc.
    iDestruct "Hb" as %Hb. iDestruct "Hq" as %Hq.
    apply frac_agree_op_valid in Hes. destruct Hes as [_ Hes].
    apply frac_agree_op_valid in Hc. destruct Hc as [_ Hc].
    apply frac_agree_op_valid in Hb. destruct Hb as [_ Hb].
    apply frac_agree_op_valid in Hq. destruct Hq as [_ Hq].
    apply leibniz_equiv_iff in Hes.
    apply leibniz_equiv_iff in Hc.
    apply leibniz_equiv_iff in Hb.
    apply leibniz_equiv_iff in Hq.
    iPureIntro. repeat split; try done.
  Qed.

  Lemma frac_update γ_e γ_c γ_b γ_q es Cn Bn Qn es' Cn' Bn' Qn' :
              frac_ghost_state γ_e γ_c γ_b γ_q es Cn Bn Qn ∗
                 frac_ghost_state γ_e γ_c γ_b γ_q es Cn Bn Qn ==∗
                      frac_ghost_state γ_e γ_c γ_b γ_q es' Cn' Bn' Qn' ∗
                        frac_ghost_state γ_e γ_c γ_b γ_q es' Cn' Bn' Qn'.
  Proof.
    iIntros "(H1 & H2)".
    iDestruct "H1" as "(H1_es & H1_c & H1_b & H1_q)".
    iDestruct "H2" as "(H2_es & H2_c & H2_b & H2_q)".
    iCombine "H1_es H2_es" as "Hes".
    iEval (rewrite <-frac_agree_op) in "Hes".
    iEval (rewrite Qp_half_half) in "Hes".
    iCombine "H1_c H2_c" as "Hc".
    iEval (rewrite <-frac_agree_op) in "Hc".
    iEval (rewrite Qp_half_half) in "Hc".
    iCombine "H1_b H2_b" as "Hb".
    iEval (rewrite <-frac_agree_op) in "Hb".
    iEval (rewrite Qp_half_half) in "Hb".
    iCombine "H1_q H2_q" as "Hq".
    iEval (rewrite <-frac_agree_op) in "Hq".
    iEval (rewrite Qp_half_half) in "Hq".
    iMod ((own_update (γ_e) (to_frac_agree 1 es)
                  (to_frac_agree 1 es')) with "[$Hes]") as "Hes".
    { apply cmra_update_exclusive.
      unfold valid, cmra_valid. simpl. unfold prod_valid.
      split; simpl; try done. }
    iEval (rewrite <-Qp_half_half) in "Hes".
    iEval (rewrite frac_agree_op) in "Hes".
    iDestruct "Hes" as "(H1_es & H2_es)".
    iMod ((own_update (γ_c) (to_frac_agree 1 Cn)
                  (to_frac_agree 1 Cn')) with "[$Hc]") as "Hc".
    { apply cmra_update_exclusive.
      unfold valid, cmra_valid. simpl. unfold prod_valid.
      split; simpl; try done. }
    iEval (rewrite <-Qp_half_half) in "Hc".
    iEval (rewrite frac_agree_op) in "Hc".
    iDestruct "Hc" as "(H1_c & H2_c)".
    iMod ((own_update (γ_b) (to_frac_agree 1 Bn)
                  (to_frac_agree 1 Bn')) with "[$Hb]") as "Hb".
    { apply cmra_update_exclusive.
      unfold valid, cmra_valid. simpl. unfold prod_valid.
      split; simpl; try done. }
    iEval (rewrite <-Qp_half_half) in "Hb".
    iEval (rewrite frac_agree_op) in "Hb".
    iDestruct "Hb" as "(H1_b & H2_b)".
    iMod ((own_update (γ_q) (to_frac_agree 1 Qn)
                  (to_frac_agree 1 Qn')) with "[$Hq]") as "Hq".
    { apply cmra_update_exclusive.
      unfold valid, cmra_valid. simpl. unfold prod_valid.
      split; simpl; try done. }
    iEval (rewrite <-Qp_half_half) in "Hq".
    iEval (rewrite frac_agree_op) in "Hq".
    iDestruct "Hq" as "(H1_q & H2_q)".
    iModIntro. iFrame.
  Qed.

  Lemma auth_agree γ xs ys :
    own γ (● (Excl' xs)) -∗ own γ (◯ (Excl' ys)) -∗ ⌜xs = ys⌝.
  Proof.
    iIntros "Hγ● Hγ◯". by iDestruct (own_valid_2 with "Hγ● Hγ◯")
      as %[<-%Excl_included%leibniz_equiv _]%auth_both_valid_discrete.
  Qed.

  Lemma auth_agree' (γ: gname) (xs ys: gset KT) :
    own γ (● (Excl' xs)) -∗ own γ (◯ (Excl' ys)) -∗ ⌜xs = ys⌝.
  Proof.
    iIntros "Hγ● Hγ◯". by iDestruct (own_valid_2 with "Hγ● Hγ◯")
      as %[<-%Excl_included%leibniz_equiv _]%auth_both_valid_discrete.
  Qed.

  Lemma set_of_map_member_ne (C: gmap K nat) k :
            C !! k = None →
              ∀ t, (k, t) ∉ set_of_map C.
  Proof.
    set (P := λ (s: gset KT) (m: gmap K nat),
                   m !! k = None → ∀ t, (k, t) ∉ s).
    apply (map_fold_ind P); try done.
    intros kx tx m r Hm HP. unfold P.
    unfold P in HP. destruct (decide (kx = k)).
    - subst kx. rewrite lookup_insert. try done.
    - rewrite lookup_insert_ne; try done.
      intros Hm'. pose proof HP Hm' as HP.
      intros t. intros Hnot.
      rewrite elem_of_union in Hnot*; intros Hnot.
      destruct Hnot as [Hnot | Hnot].
      + by apply HP in Hnot.
      + rewrite elem_of_singleton in Hnot*; intros Hnot.
        inversion Hnot. try done.
  Qed.

  Lemma set_of_map_member (C: gmap K nat) k t :
            C !! k = Some(t) →
              (k, t) ∈ set_of_map C.
  Proof.
    intros Hc. unfold set_of_map.
    set (P := λ (s: gset KT) (m: gmap K nat),
                  ∀ j x, m !! j = Some x → (j,x) ∈ s).
    apply (map_fold_ind P); try done.
    intros i x m s Hmi Hp. unfold P.
    intros j x'. destruct (decide (i = j)).
    - replace j. rewrite lookup_insert.
      intros H'; inversion H'. set_solver.
    - rewrite lookup_insert_ne; try done.
      pose proof Hp j x' as Hp'. set_solver.
  Qed.

  Lemma set_of_map_member_rev (C: gmap K nat) k t :
            (k, t) ∈ set_of_map C →
                C !! k = Some(t).
  Proof.
    set (P := λ (s: gset KT) (m: gmap K nat),
                  ∀ j x, (j,x) ∈ s → m !! j = Some x).
    apply (map_fold_ind P); try done.
    intros i x m r Hmi Hp. unfold P.
    intros j x'. destruct (decide (i = j)).
    - replace j. rewrite lookup_insert.
      rewrite elem_of_union. intros [Hr | Hr].
      unfold P in Hp. pose proof Hp i x' Hr as Hp.
      rewrite Hp in Hmi. inversion Hmi.
      assert (x = x') by set_solver. by replace x.
    - intros H'. assert ((j,x') ∈ r) as Hj by set_solver.
      pose proof Hp j x' Hj as Hp.
      rewrite lookup_insert_ne; try done.
  Qed.

  Lemma set_of_map_insert_subseteq (C: gmap K nat) k t :
         set_of_map (<[k := t]> C) ⊆ set_of_map C ∪ {[(k, t)]}.
  Proof.
    intros [k' t'] Hkt. destruct (decide (k' = k)).
    - replace k'. rewrite e in Hkt.
      apply set_of_map_member_rev in Hkt.
      rewrite lookup_insert in Hkt.
      inversion Hkt. set_solver.
    - apply set_of_map_member_rev in Hkt.
      rewrite lookup_insert_ne in Hkt; try done.
      apply set_of_map_member in Hkt.
      set_solver.
  Qed.

  Lemma map_of_set_lookup_cases H k:
        (∃ T, (k, T) ∈ H ∧ (∀ t, (k,t) ∈ H → t ≤ T) ∧ map_of_set H !! k = Some T)
      ∨ ((∀ t, (k,t) ∉ H) ∧ map_of_set H !! k = None).
  Proof.
    set (P := λ (m: gmap K nat) (X: gset KT),
                (∃ T, (k, T) ∈ X ∧ (∀ t, (k,t) ∈ X → t ≤ T)
                          ∧ m !! k = Some T)
              ∨ ((∀ t, (k,t) ∉ X) ∧ m !! k = None)).
    apply (set_fold_ind_L P); try done.
    - unfold P. right. split; try done.
    - intros [k' t'] X m Hnotin Hp.
      destruct (decide (k' = k)).
      + replace k'. unfold P. left. unfold P in Hp.
        destruct Hp as [Hp | Hp].
        * destruct Hp as [T Hp].
          destruct (decide (T < t')).
          ** exists t'. repeat split; first set_solver.
             intros t. rewrite elem_of_union.
             intros [Hv | Hv]. assert (t = t') by set_solver.
             lia. destruct Hp as [_ [Hp _]].
             pose proof Hp t Hv. lia. simpl.
             assert (m !!! k <= t') as Hm.
             { unfold lookup_total, finmap_lookup_total.
               destruct Hp as [_ [_ Hp]]. rewrite Hp.
               simpl. lia. }
             destruct (decide (m !!! k ≤ t')); try done.
             by rewrite lookup_insert.
          ** assert (t' = T ∨ t' < T) as Ht by lia. clear n.
             exists T. destruct Hp as [Hp1 [Hp2 Hp3]].
             repeat split; first set_solver.
             intros t. rewrite elem_of_union.
             intros [Hv | Hv]. assert (t = t') by set_solver.
             lia. pose proof Hp2 t Hv. lia. simpl.
             destruct Ht as [Ht | Ht].
             assert (m !!! k <= t') as Hm.
             { unfold lookup_total, finmap_lookup_total.
               rewrite Hp3. simpl. lia. }
             destruct (decide (m !!! k ≤ t')); try done.
             rewrite lookup_insert. by rewrite Ht.
             assert (m !!! k > t') as Hm.
             { unfold lookup_total, finmap_lookup_total.
               rewrite Hp3. simpl. lia. }
             destruct (decide (m !!! k ≤ t')); try done.
             exfalso. lia.
        * exists t'. simpl. repeat split; first set_solver.
          intros t. rewrite elem_of_union. intros [Hv | Hv].
          assert (t = t') by set_solver. lia.
          destruct Hp as [Hp _].
          pose proof Hp t as Hp. set_solver.
          assert (m !!! k ≤ t') as Hm.
          { unfold lookup_total, finmap_lookup_total.
            destruct Hp as [_ Hp]. rewrite Hp. simpl; lia. }
          destruct (decide (m !!! k ≤ t')); try done.
          by rewrite lookup_insert.
      + unfold P. unfold P in Hp.
        destruct Hp as [Hp | Hp].
        * destruct Hp as [T [Hp1 [Hp2 Hp3]]].
          left. exists T. repeat split; first set_solver.
          intros t Hkt. assert ((k,t) ∈ X) as Hx by set_solver.
          by pose proof Hp2 t Hx.
          simpl.
          destruct (decide (m !!! k' <= t')).
          rewrite lookup_insert_ne; try done. done.
        * destruct Hp as [Hp1 Hp2]. right.
          repeat split; first set_solver. simpl.
          destruct (decide (m !!! k' <= t')).
          rewrite lookup_insert_ne; try done. done.
  Qed.

  Lemma map_of_set_lookup H k T :
        (k, T) ∈ H → (∀ t, (k, t) ∈ H → t ≤ T) →
           map_of_set H !! k = Some T.
  Proof.
    intros Hkt Hmax.
    pose proof (map_of_set_lookup_cases H k) as Hp.
    destruct Hp as [Hp | Hp].
    - destruct Hp as [T' [Hp1 [Hp2 Hp3]]].
      pose proof Hmax T' Hp1 as Ht1.
      pose proof Hp2 T Hkt as Ht2.
      assert (T = T') as Ht by lia.
      by rewrite Ht.
    - destruct Hp as [Hp _].
      pose proof Hp T. set_solver.
  Qed.

  Lemma map_of_set_union_ne H k t k' :
          k' ≠ k → map_of_set (H ∪ {[(k, t)]}) !! k' = map_of_set H !! k'.
  Proof.
    intros Hk.
    pose proof (map_of_set_lookup_cases H k') as Hp.
    pose proof (map_of_set_lookup_cases (H ∪ {[(k,t)]}) k') as Hu.
    destruct Hp as [Hp | Hp].
    - destruct Hu as [Hu | Hu].
      + destruct Hp as [T [Hp1 [Hp2 Hp3]]].
        destruct Hu as [T' [Hu1 [Hu2 Hu3]]].
        assert (T ≤ T') as Ht1.
        { assert ((k', T) ∈ H ∪ {[k, t]}) as Ht by set_solver.
          by pose proof Hu2 T Ht. }
        assert (T' ≤ T) as Ht2.
        { assert ((k', T') ∈ H) as Ht by set_solver.
          by pose proof Hp2 T' Ht. }
        rewrite Hp3 Hu3. assert (T = T') as Ht by lia.
        by rewrite Ht.
      + destruct Hp as [T [Hp1 [Hp2 Hp3]]].
        destruct Hu as [Hu1 Hu2].
        pose proof Hu1 T as Hu1. set_solver.
    - destruct Hu as [Hu | Hu].
      + destruct Hp as [Hp1 Hp2].
        destruct Hu as [T' [Hu1 [Hu2 Hu3]]].
        pose proof Hp1 T' as Hp1. set_solver.
      + destruct Hp as [Hp1 Hp2].
        destruct Hu as [Hu1 Hu2].
        by rewrite Hp2 Hu2.
  Qed.

  Lemma map_of_set_insert_eq (C: gmap K nat) k T H :
        (∀ t, (k, t) ∈ H → t < T) →
                  C = map_of_set H →
                 <[k := T]> C = map_of_set (H ∪ {[(k, T)]}).
  Proof.
    intros Hmax Hc. apply map_eq. intros k'.
    destruct (decide (k' = k)).
    - replace k'. rewrite lookup_insert.
      rewrite (map_of_set_lookup _ _ T); try done.
      set_solver. intros t'. rewrite elem_of_union.
      intros [Hk | Hk]. pose proof Hmax t' Hk. lia.
      assert (t' = T) by set_solver. by replace t'.
    - rewrite map_of_set_union_ne; try done.
      rewrite lookup_insert_ne; try done.
      by rewrite Hc.
  Qed.

  Lemma flowint_update_result (γ: gname) (I I_n I_n': multiset_flowint_ur K) x :
    ⌜flowint_update_P (_) I I_n I_n' x⌝ ∗ own γ x -∗
    ∃ I', ⌜contextualLeq (_) I I'⌝
          ∗ ⌜∃ I_o, I = I_n ⋅ I_o ∧ I' = I_n' ⋅ I_o⌝
          ∗ own γ (● I' ⋅ ◯ I_n').
  Proof.
    unfold flowint_update_P.
    case_eq (view_auth_proj x); last first.
    - intros Hx. iIntros "(% & ?)". iExFalso. done.
    - intros [q a] Hx.
      iIntros "[HI' Hown]". iDestruct "HI'" as %HI'.
      destruct HI' as [I' HI'].
      destruct HI' as [Hagree [Hq [HIn [Hcontxl HIo]]]].
      iExists I'.
      iSplit. by iPureIntro.
      iSplit. by iPureIntro. destruct x.
      simpl in Hx. simpl in HIn.
      rewrite Hx. rewrite <-HIn.
      rewrite Hq Hagree.
      assert (● I' ⋅ ◯ I_n' = View (Some (1%Qp, to_agree I')) I_n') as H'.
      { rewrite /(● I' ⋅ ◯ I_n'). unfold cmra_op.
        simpl. unfold view_op. simpl.
        assert (ε ⋅ I_n' = I_n') as H'. by rewrite left_id.
        rewrite H'. unfold op, cmra_op. by simpl. }
      by iEval (rewrite H').
  Qed.

  Lemma flowint_update_result' (γ: gname) (I I_n I_n': multiset_flowint_ur KT) x :
    ⌜flowint_update_P (_) I I_n I_n' x⌝ ∗ own γ x -∗
    ∃ I', ⌜contextualLeq (_) I I'⌝
          ∗ ⌜∃ I_o, I = I_n ⋅ I_o ∧ I' = I_n' ⋅ I_o⌝
          ∗ own γ (● I' ⋅ ◯ I_n').
  Proof.
    unfold flowint_update_P.
    case_eq (view_auth_proj x); last first.
    - intros Hx. iIntros "(% & ?)". iExFalso. done.
    - intros [q a] Hx.
      iIntros "[HI' Hown]". iDestruct "HI'" as %HI'.
      destruct HI' as [I' HI'].
      destruct HI' as [Hagree [Hq [HIn [Hcontxl HIo]]]].
      iExists I'.
      iSplit. by iPureIntro.
      iSplit. by iPureIntro. destruct x.
      simpl in Hx. simpl in HIn.
      rewrite Hx. rewrite <-HIn.
      rewrite Hq Hagree.
      assert (● I' ⋅ ◯ I_n' = View (Some (1%Qp, to_agree I')) I_n') as H'.
      { rewrite /(● I' ⋅ ◯ I_n'). unfold cmra_op.
        simpl. unfold view_op. simpl.
        assert (ε ⋅ I_n' = I_n') as H'. by rewrite left_id.
        rewrite H'. unfold op, cmra_op. by simpl. }
      by iEval (rewrite H').
  Qed.

  Lemma dom_lookup (C: gmap K nat) k :
        C !! k ≠ None → k ∈ dom (gset K) C.
  Proof.
    intros Hcn. destruct (C !! k) eqn: Hcnk.
    rewrite elem_of_dom. rewrite Hcnk.
    by exists n. done.
  Qed.

  Definition map_subset (S: gset K) (C: gmap K nat) :=
              let f := λ a s', s' ∪ {[(a, C !!! a)]} in
                        set_fold f (∅: gset KT) S.

  Definition map_restriction (S: gset K) (C: gmap K nat) :=
              let f := λ a m, <[a := C !!! a ]> m in
                        set_fold f (∅: gmap K nat) S.

  Lemma lookup_map_restriction S (C: gmap K nat) (k: K):
              k ∈ S → map_restriction S C !! k = Some (C !!! k).
  Proof.
    set (P := λ (m: gmap K nat) (X: gset K),
                    ∀ x, x ∈ X → m !! x = Some (C !!! x)).
    apply (set_fold_ind_L P); try done.
    intros x X r Hx HP.
    unfold P in HP. unfold P.
    intros x' Hx'.
    destruct (decide (x' = x)).
    - subst x'. by rewrite lookup_insert.
    - assert (x' ∈ X) as x'_in_X. set_solver.
      rewrite lookup_insert_ne. apply HP.
      done. done.
  Qed.

  Lemma map_subset_member S C k t:
              (k, t) ∈ map_subset S C ↔ k ∈ S ∧ t = C !!! k.
  Proof.
    set (P := λ (m: gset KT) (X: gset K),
                    ∀ kx tx, (kx, tx) ∈ m ↔ kx ∈ X ∧ tx = C !!! kx).
    apply (set_fold_ind_L P); try done.
    - unfold P. intros kx tx. set_solver.
    - intros x X r Hx HP. unfold P.
      unfold P in HP. intros kx' tx'.
      split.
      + intros Hktx. rewrite elem_of_union in Hktx*; intros Hktx.
        destruct Hktx as [H' | H'].
        * apply HP in H'. destruct H' as [H' H''].
          split; try done. set_solver.
        * rewrite elem_of_singleton in H'*; intros H'.
          inversion H'. split; try done; set_solver.
      + intros [H' H'']. rewrite elem_of_union in H'*; intros H'.
        destruct H' as [H' | H'].
        rewrite elem_of_singleton in H'*; intros H'.
        rewrite H'. rewrite H''. set_solver.
        assert ((kx', tx') ∈ r) as Hkt.
        apply HP. split; try done.
        set_solver.
  Qed.

  Lemma map_restriction_dom S C :
              dom (gset K) (map_restriction S C) = S.
  Proof.
    set (P := λ (m: gmap K nat) (X: gset K), dom (gset K) m = X).
    apply (set_fold_ind_L P); try done.
    - unfold P; set_solver.
    - intros x X r Hx HP. unfold P. unfold P in HP.
      apply leibniz_equiv. rewrite dom_insert.
      rewrite HP. done.
  Qed.

  Lemma map_of_set_lookup_some_aux (H: gset KT) k :
          (∀ t, (k,t) ∉ H) ∨ (∃ T, (k, T) ∈ H ∧ (∀ t', (k,t') ∈ H → t' ≤ T)).
  Proof.
    set (P := λ (X: gset KT), (∀ t, (k,t) ∉ X) ∨
                  (∃ T, (k, T) ∈ X ∧ (∀ t', (k,t') ∈ X → t' ≤ T))).
    apply (set_ind_L P); try done.
    - unfold P. left. intros t. set_solver.
    - intros [k' t'] X Hkt HP. subst P.
      simpl in HP. simpl. destruct (decide (k' = k)).
      + subst k'. destruct HP as [H' | H'].
        * right. exists t'. split.
          set_solver. intros t. destruct (decide (t' = t)).
          subst t'. intros; done.
          intros H''. assert ((k,t) ∈ X).
          set_solver. pose proof H' t as H'.
          done.
        * right. destruct H' as [T H'].
          destruct (decide (t' < T)).
          ** exists T. split.
             destruct H' as [H' _].
             set_solver. intros t Hkt'.
             rewrite elem_of_union in Hkt'*; intros Hkt'.
             destruct Hkt' as [Hkt' | Hkt'].
             rewrite elem_of_singleton in Hkt'*; intros Hkt'.
             inversion Hkt'. lia.
             destruct H' as [_ H'']. apply H''; try done.
          ** exists t'. split. set_solver.
             intros t Hkt'. rewrite elem_of_union in Hkt'*; intros Hkt'.
             destruct Hkt' as [Hkt' | Hkt'].
             rewrite elem_of_singleton in Hkt'*; intros Hkt'.
             inversion Hkt'. lia.
             destruct H' as [_ H''].
             apply (Nat.le_trans _ T _); try lia.
             apply H''. try done.
      + destruct HP as [H' | H'].
        * left. intros t. set_solver.
        * right. destruct H' as [T H'].
          exists T. destruct H' as [H' H''].
          split. set_solver. intros t.
          intros Hkt'. rewrite elem_of_union in Hkt'*; intros Hkt'.
          destruct Hkt' as [Hkt' | Hkt'].
          rewrite elem_of_singleton in Hkt'*; intros Hkt'.
          inversion Hkt'. done. apply H''; try done.
  Qed.

  Lemma map_of_set_lookup_some (H: gset KT) k t :
              (k, t) ∈ H → is_Some(map_of_set H !! k).
  Proof.
    intros Hkt.
    pose proof map_of_set_lookup_some_aux H k as Hkt'.
    destruct Hkt' as [Hkt' | Hkt'].
    { pose proof Hkt' t as H'. set_solver. }
    pose proof (map_of_set_lookup_cases H k) as H'.
    destruct H' as [H' | H'].
    - destruct H' as [T' H'].
      destruct H' as [_ [_ H']].
      rewrite H'. by exists T'.
    - destruct Hkt' as [T Hkt'].
      destruct Hkt' as [Hkt' _].
      destruct H' as [H' _].
      pose proof H' T as H'.
      set_solver.
  Qed.

  Lemma map_of_set_lookup_lb H k t :
    (k,t) ∈ H → t ≤ map_of_set H !!! k.
  Proof.
    intros kt_in_H.
    pose proof map_of_set_lookup_cases H k as [H' | H'].
    - destruct H' as [T [kT_in_H [H' H_k]]].
      rewrite lookup_total_alt. rewrite H_k.
      simpl. apply H'; try done.
    - destruct H' as [H' _].
      pose proof H' t as H'.
      contradiction.
  Qed.

  (** Lock module **)

  Parameter getLockLoc_spec : ∀ (n: Node),
    ⊢ ({{{ True }}}
        general_multicopy.getLockLoc #n
       {{{ (l:loc), RET #l; ⌜general_multicopy.lockLoc n = l⌝ }}})%I.

  Lemma lockNode_spec (n: Node) (R: iProp):
    ⊢ <<< ∀ b, general_multicopy.lockR b n R >>>
      lockNode #n    @ ⊤
    <<< general_multicopy.lockR true n R ∗ R, RET #() >>>.
  Proof.
    iIntros (Φ) "AU". iLöb as "IH".
    wp_lam. wp_bind(general_multicopy.getLockLoc _)%E.
    wp_apply getLockLoc_spec; first done.
    iIntros (l) "#Hl". wp_let. wp_bind (CmpXchg _ _ _)%E.
    iMod "AU" as (b) "[Hb HAU]". iDestruct "Hl" as %Hl.
    unfold lockR.
    iEval (rewrite Hl) in "Hb". destruct b.
    iDestruct "Hb" as "(Hb & HR)".
    - wp_cmpxchg_fail. iDestruct "HAU" as "[HAU _]".
      iEval (rewrite Hl) in "HAU".
      iMod ("HAU" with "[Hb HR]") as "H".
      iFrame.
      iModIntro. wp_pures. iApply "IH".
      iEval (rewrite <-Hl) in "H". done.
    - iDestruct "Hb" as "(Hb & HR)".
      wp_cmpxchg_suc. iDestruct "HAU" as "[_ HAU]".
      iEval (rewrite Hl) in "HAU".
      iMod ("HAU" with "[Hb HR]") as "HΦ". iFrame; done.
      iModIntro. wp_pures. done.
  Qed.

  Lemma lockNode_spec_high N γ_te γ_he γ_s γ_t γ_I γ_J γ_f γ_gh γ_fr lc r n:
    ⊢ mcs_inv N γ_te γ_he γ_s γ_t γ_I γ_J γ_f γ_gh γ_fr lc r -∗
        inFP γ_f n -∗
              <<< True >>>
                lockNode #n    @ ⊤ ∖ ↑(mcsN N)
              <<< ∃ Cn Bn Qn, nodePred γ_gh γ_t γ_s lc r n Cn Bn Qn, RET #() >>>.
  Proof.
    iIntros "#mcsInv #FP_n".
    iIntros (Φ) "AU".
<<<<<<< Updated upstream
    awp_apply (lockNode_spec n (∃ Cn Bn Qn, nodePred γ_gh γ_t γ_s lc r n Cn Bn Qn)).
    iInv "mcsInv" as ">mcs". iDestruct "mcs" as (T H hγ I J) "(Hglob & Hstar)".
    iDestruct "Hglob" as "(MCS_auth & HH & Hist & HfrH & Ht & HI & Out_I & HJ
            & Out_J & Inf_J & Hf & Hγ & FP_r & Max_ts & domm_IJ & domm_Iγ)".
=======
    awp_apply (lockNode_spec n).
    iInv "mcsInv" as ">mcs".
    iDestruct "mcs" as (T H hγ I J) "(mcs_high & Hglob & Hstar)".
    iDestruct "mcs_high" as "(MCS_auth & HH & Hist & HfrH & MaxTS)".
    iDestruct "Hglob" as "(Ht & HI & Out_I & HJ
            & Out_J & Inf_J & Hf & Hγ & FP_r & domm_IJ & domm_Iγ)".
>>>>>>> Stashed changes
    iPoseProof (inFP_domm with "[$FP_n] [$]") as "%". rename H0 into n_in_I.
    iEval (rewrite (big_sepS_elem_of_acc (_) (domm I) n);
           last by eauto) in "Hstar".
    iDestruct "Hstar" as "(Hn & Hstar')".
    iDestruct "Hn" as (b Cn Bn Qn) "(Hlock & Hns)".
    iAaccIntro with "Hlock".
    { iIntros "Hlockn". iModIntro.
      iSplitR "AU".
      { iExists T, H, hγ, I, J. iFrame.
        iPoseProof ("Hstar'" with "[-]") as "Hstar".
        iExists b, Cn, Bn, Qn. iFrame.
        iNext. iFrame.
      }
      iFrame.
    }
    iIntros "Hlockn". iDestruct "Hlockn" as "(Hlockn & Hnp)".
    iDestruct "Hnp" as (Cn' Bn' Qn') "Hnp".
    iMod "AU" as "[_ [_ Hclose]]".
    iMod ("Hclose" with "[Hnp]") as "HΦ"; try done.
    iModIntro. iSplitR "HΦ".
    iNext. iExists T, H, hγ, I, J.
    iPoseProof ("Hstar'" with "[Hlockn Hns]") as "Hstar".
    iExists true, Cn, Bn, Qn. iFrame.
    iSplitL "MCS_auth HH Hist HfrH MaxTS". iFrame.
    iSplitR "Hstar". iFrame. iFrame. done.
  Qed.

  Lemma unlockNode_spec (n: Node) :
    ⊢ <<< general_multicopy.lockLoc n ↦ #true >>>
      unlockNode #n    @ ⊤
    <<< general_multicopy.lockLoc n ↦ #false, RET #() >>>.
  Proof.
    iIntros (Φ) "AU". wp_lam.
    wp_bind(general_multicopy.getLockLoc _)%E.
    wp_apply getLockLoc_spec; first done.
    iIntros (l) "#Hl". wp_let.
    iMod "AU" as "[Hy [_ Hclose]]".
    iDestruct "Hl" as %Hl.
    iEval (rewrite Hl) in "Hy".
    wp_store. iEval (rewrite Hl) in "Hclose".
    iMod ("Hclose" with "Hy") as "HΦ".
    iModIntro. done.
  Qed.
(*
  Lemma int_domm γ_te γ_he γ_s γ_t γ_I γ_J γ_f γ_gh r t H hγ I J n In :
    own γ_I (◯ In) -∗ ⌜domm In = {[n]}⌝
    -∗ global_state γ_te γ_he γ_s γ_t γ_I γ_J γ_f γ_gh r t H hγ I J
    -∗ ⌜n ∈ domm I⌝.
  Proof.
    iIntros "Hi Dom_In Hglob".
    iDestruct "Dom_In" as %Dom_In.
    iDestruct "Hglob" as "(MCS_auth & HH & Hist & Ht & HI & Out_I & HJ
            & Out_J & Inf_J & Hf & Hγ & FP_r & Max_ts & domm_IJ & domm_Iγ)".
    iPoseProof ((auth_own_incl γ_I (I) (In)) with "[$]") as "%".
    rename H0 into I_incl. destruct I_incl as [Io I_incl].
    iPoseProof (own_valid with "HI") as "%". rename H0 into Valid_I.
    iPureIntro. rewrite I_incl. rewrite flowint_comp_fp.
    rewrite Dom_In. set_solver. rewrite <- I_incl.
    by apply auth_auth_valid.
  Qed.
*)
  Lemma unlockNode_spec_high N γ_te γ_he γ_s γ_t γ_I γ_J γ_f γ_gh γ_fr lc r
                                                          n Cn Bn Qn:
    ⊢ mcs_inv N γ_te γ_he γ_s γ_t γ_I γ_J γ_f γ_gh γ_fr lc r -∗
        inFP γ_f n -∗ nodePred γ_gh γ_t γ_s lc r n Cn Bn Qn -∗
              <<< True >>>
                unlockNode #n    @ ⊤ ∖ ↑(mcsN N)
              <<< True, RET #() >>>.
  Proof.
    iIntros "#mcsInv #FP_n Hnp". iIntros (Φ) "AU".
    awp_apply (unlockNode_spec n).
    iInv "mcsInv" as ">mcs".
    iDestruct "mcs" as (T H hγ I J) "(mcs_high & Hglob & Hstar)".
    iDestruct "mcs_high" as "(MCS_auth & HH & Hist & HfrH & MaxTS)".
    iDestruct "Hglob" as "(Ht & HI & Out_I & HJ
            & Out_J & Inf_J & Hf & Hγ & FP_r & domm_IJ & domm_Iγ)".
    iPoseProof (inFP_domm with "[$FP_n] [$]") as "%". rename H0 into n_in_I.
    iEval (rewrite (big_sepS_elem_of_acc (_) (domm I) n);
           last by eauto) in "Hstar".
    iDestruct "Hstar" as "(Hn & Hstar')".
    iDestruct "Hn" as (b Cn' Bn' Qn') "(Hlock & Hns)".
    iAssert (general_multicopy.lockLoc n ↦ #true
              ∗ nodePred γ_gh γ_t γ_s lc r n Cn Bn Qn)%I
      with "[Hlock Hnp]" as "(Hlock & Hnp)".
    {
      destruct b.
    - (* Case n locked *)
      iDestruct "Hlock" as "(Hlock & _)".
      iFrame "∗".
    - (* Case n unlocked: impossible *)
    iDestruct "Hnp" as (? ? ? ? ? ? ?) "(n & _)".
    iDestruct "Hlock" as "(Hlock & Hnp')".
    iDestruct "Hnp'" as (Cn0 Bn0 Qn0) "Hnp'".
    iDestruct "Hnp'" as (? ? ? ? ? ? ?) "(n' & _)".
    iExFalso. iApply (node_sep_star r n). iFrame.
    }
    iAaccIntro with "Hlock".
    { iIntros "Hlock". iModIntro.
      iSplitR "Hnp AU".
      iExists T, H, hγ, I, J. iNext. iFrame.
      iPoseProof ("Hstar'" with "[Hlock Hns]") as "Hstar".
      iExists true, Cn', Bn', Qn'. iFrame.
      iFrame. iFrame.
    }
    iIntros "Hlock".
    iMod "AU" as "[_ [_ Hclose]]".
    iMod ("Hclose" with "[]") as "HΦ"; try done.
    iModIntro. iSplitR "HΦ".
    iNext. iExists T, H, hγ, I, J.
    iPoseProof ("Hstar'" with "[Hlock Hns Hnp]") as "Hstar".
    iExists false, Cn, Bn, Qn.
    iAssert (nodePred γ_gh γ_t γ_s lc r n Cn Bn Qn
                      ∗ nodeShared γ_I γ_J γ_f γ_gh r n Cn Bn Qn H T)%I
      with "[Hns Hnp]" as "(Hns & Hnp)".
    {
      iDestruct "Hnp" as (γ_en γ_cn γ_bn γ_qn γ_cirn esn T')
                             "(node_n & HnP_gh & HnP_frac & HnP_C & HnP_t)".
      iDestruct "Hns" as (γ_en' γ_cn' γ_bn' γ_qn' γ_cirn' es' In0 Jn0)
                           "(HnS_gh & HnS_frac & HnS_si & HnS_FP
                            & HnS_cl & HnS_oc & HnS_H & HnS_star & Hφ)".
      iPoseProof (ghost_heap_sync with "[$HnP_gh] [$HnS_gh]")
        as "(% & % & % & % & %)".
      subst γ_en'. subst γ_cn'. subst γ_bn'. subst γ_qn'. subst γ_cirn'.
      iPoseProof (frac_eq with "[$HnP_frac] [$HnS_frac]") as "%".
      destruct H0 as [Hes [Hc [Hb Hq]]].
      subst es'. subst Cn'. subst Bn'. subst Qn'.
      iSplitL "node_n HnP_gh HnP_frac HnP_C HnP_t".
      iExists γ_en, γ_cn, γ_bn, γ_qn, γ_cirn, esn, T'.
      iFrame.
      iExists γ_en, γ_cn, γ_bn, γ_qn, γ_cirn, esn, In0, Jn0.
      iFrame.
    }
    iFrame. iExists Cn, Bn, Qn. iFrame. iFrame. iFrame.
  Qed.

End util.


Require Import Category.Main.
Require Import Coq_Cats.Coq_Cat.

(*
**********************************************************
***************                          *****************
***************      Set Category        *****************
***************                          *****************
**********************************************************
*)

(** The category of types in Set universe (Coq's "Set")*)

Program Definition Set_Cat : Category := Coq_Cat Set.


Require Export Basics.

Require Export EnvListAux7.
Require Export EnvListAuxT1.

Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Lists.List.

Require Import TPipStaticM2.
Require Import TPipDynamicM2.

Module Weakening (IdT: IdModType) <: IdModType.
(* Export IdT. *)

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition Loc_PI := IdT.Loc_PI.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

Module DynamicC := Dynamic IdT.
Export DynamicC.

Lemma QValWeakening (env env': valEnv)
      (n1 n2: W)
      (q1 q2: QValue):
  QVStep env (Conf QValue n1 q1) (Conf QValue n2 q2) ->
  QVStep (overrideE env env') (Conf QValue n1 q1) (Conf QValue n2 q2).
Proof.
  intros.
  inversion X; subst.
  constructor.
  inversion X0; subst.
  eapply overrideRedux1 with (env2:=env') in H.
  constructor.
  rewrite H.
  inversion X0; subst.
  assumption.
Defined.

Lemma QFunWeakening (env env': funEnv)
      (n1 n2: W)
      (q1 q2: QFun):
  QFStep env (Conf QFun n1 q1) (Conf QFun n2 q2) ->
  QFStep (overrideE env env') (Conf QFun n1 q1) (Conf QFun n2 q2).
Proof.
  intros.
  inversion X; subst.
  constructor.
  inversion X0; subst.
  eapply overrideRedux1 with (env2:=env') in H.
  constructor.
  rewrite H.
  inversion X0; subst.
  assumption.
Defined.

Lemma weak
           (fenv fenv': funEnv) (env env': valEnv)
           (n1 n2: W) (e1 e2: Exp):
      EClosure fenv env (Conf Exp n1 e1) (Conf Exp n2 e2) ->
      EClosure (overrideE fenv fenv') (overrideE env env')
               (Conf Exp n1 e1) (Conf Exp n2 e2).
Proof.
  intros.
  dependent induction X.
  constructor.
  destruct p2 as [n0 e0].
  specialize (IHX n0 n2 e0 e2 eq_refl eq_refl).
  econstructor.
  Focus 2.
  eassumption.

  (***)

  clear IHX.
  clear X.
  rename e into H.
  clear n2 e2.
  revert fenv' env'.

  (***)

    eapply (EStep_mut (fun fenv env c1 c2
 (ExIH: EStep fenv env c1 c2) => forall fenv' env',
  EStep (overrideE fenv fenv') (overrideE env env')
        c1 c2)
  (fun fenv env c1 c2
  (PsIH: PrmsStep fenv env c1 c2) => forall fenv' env',
  PrmsStep (overrideE fenv fenv') (overrideE env env')
           c1 c2)).

  - intros.
    constructor.
  - intros.
    constructor.
    eapply QValWeakening.
    assumption.
  - intros.
    constructor.
  - intros.
    constructor.
    eapply QValWeakening.
    assumption.
  - intros.
    constructor.
  - intros.
    constructor.
    eapply X.
  - intros.
    constructor.
  - intros.
    constructor.
    eapply X.
  - intros.
    constructor.
  - intros.
    econstructor.
    + reflexivity.
    + reflexivity.
    + rewrite overrideAssoc.
      rewrite overrideAssoc.
      specialize (X fenv'0 env'0).
      rewrite e2 in X.
      rewrite e3 in X.
      eapply X.
  - intros.
    econstructor.
    auto.
    eassumption.
    assumption.
    assumption.
  - intros.
    econstructor.
    eassumption.
    assumption.
    assumption.
  - intros.
    econstructor.
    eapply X.
  - intros.
    econstructor.
    eapply QFunWeakening.
    assumption.
  - intros.
    constructor.
  - intros.
    constructor.
  - intros.
    constructor.
    eapply X.
  - intros.
    constructor.
    eapply X.
  - intros.
    constructor.
    eapply X.
  - assumption.
Defined.

End Weakening.


(** * Embedding IEL into IPC **)

Require Import forms nd List.
Section Embedding.
  Definition E := (VarI 0).
  Fixpoint e (f: form) : formIPC :=
    match f with
    | K x => (ImpI (ImpI (e x) E) (e x))
    | (ϕ ⊃ ψ) => (ImpI (e ϕ) (e ψ))
    | And ϕ ψ => (AndI (e ϕ) (e ψ))
    | Or ϕ ψ => (OrI (e ϕ) (e ψ))
    | Bot => BotI
    | Var x => (VarI x)
    end
  .
  Definition ℇ := map e.
  Notation "x 'el' A" := (In x A) (at level 70).
  Notation "A <<= B" := (incl A B) (at level 70).

  (** Define ND for IPC  **)
  Inductive ndI: list formIPC -> formIPC -> Prop :=
    ndiE A s: ndI A BotI -> ndI A s
  | ndiA A s: s el A -> ndI A s
  | ndiII A s t: ndI (s::A) t -> ndI A (ImpI s t)
  | ndiIE A s t: ndI A (ImpI s t) -> ndI A s -> ndI A t

  | ndiCI A s t: ndI A s -> ndI A t -> ndI A (AndI s t)
  | ndiCEL A s t: ndI A (AndI s t) -> ndI A s
  | ndiCER A s t: ndI A (AndI s t) -> ndI A t

  | ndiDIL A s t: ndI A s -> ndI A (OrI s t)
  | ndiDIR A s t: ndI A t -> ndI A (OrI s t)
  | ndiDE A s t v: ndI A (ImpI s v) -> ndI A (ImpI t v) -> ndI A (OrI s t) -> ndI A v.

  Hint Constructors ndI : core.
  Hint Constructors nd : core.

  Lemma ndiWeak Γ ϕ: (ndI Γ ϕ) -> forall Ω, Γ <<= Ω -> (ndI Ω ϕ).
  Proof.
    intro H.
    induction H;   eauto.
  Qed.
  Ltac iselement := try apply ndiA; firstorder eauto.
  Lemma embedding Γ {D: DerivationType}: forall ϕ, nd Γ ϕ -> (ndI (ℇ Γ) (e ϕ)).
  Proof.
    intros ϕ H.

  induction H; simpl e; firstorder eauto.
    - apply ndiA. unfold ℇ.    apply in_map_iff. eauto.
    - apply ndiII.  apply ndiII.
      remember (ImpI (e t) E :: ImpI (ImpI (e s) E) (e s) :: ℇ Γ) as Γ'.
      assert (ndI ((e s)::Γ') (ImpI (e (s ⊃ t)) E) ).
      {
        simpl e. apply ndiII.
        apply ndiIE with (s := (e t)).   rewrite HeqΓ'. iselement.
        apply ndiIE with (s := (e s)); rewrite HeqΓ'; iselement.
      }
      assert (ndI Γ' (e s)).
      {
        apply ndiIE with (s :=  (ImpI (e s) E)).
        - rewrite HeqΓ'. iselement.
        - apply ndiII.  apply ndiIE with (s := ((ImpI (e s) (e t)))).
          + apply ndiII. apply ndiIE with (s := (e t)). rewrite HeqΓ'. iselement.
            apply ndiIE with (s := (e s)); iselement.
          + simpl e in IHnd. apply ndiIE with (s := (ImpI (ImpI (e s) (e t)) E)).
            apply ndiWeak with (Γ := (ℇ Γ)). exact IHnd. rewrite HeqΓ'.  firstorder eauto.
            exact H0.
      }
      apply ndiIE with (s := (e s)).
      apply ndiIE with (s := (ImpI (ImpI (e s) (e t)) E)).
      simpl e in IHnd. apply ndiWeak with (Γ := (ℇ Γ)).  apply IHnd.   rewrite HeqΓ'. firstorder eauto.
      apply ndiII. apply ndiIE with (s := (e t)). rewrite HeqΓ'. iselement. apply ndiIE with (s := (e s)).
      iselement. apply ndiWeak with (Γ := Γ'); firstorder eauto. assumption.
    -
      simpl e in IHnd. apply ndiII.  apply ndiIE with (s := (e s)). apply ndiII. iselement.
      apply ndiWeak with (Γ := (ℇ Γ)). exact IHnd. intro; firstorder eauto.
    -
      simpl e in IHnd. apply ndiII.  apply ndiIE with (s := (e s)).  iselement.  apply ndiIE with (s := (ImpI (e s) E)).
      apply ndiWeak with (Γ := (ℇ Γ)). exact IHnd. intro; firstorder eauto.
      apply ndiII. apply ndiE. apply ndiIE with (s := (e s)); iselement.
  Qed.
End Embedding.


Require Import Reals.

Axiom y : R -> R.
Axiom d_y : derivable y.
Axiom n_y : forall x : R, y x <> 0%R.
Axiom dy_0 : derive_pt y 0 (d_y 0%R) = 1%R.

Lemma essai0 : continuity_pt (fun x : R => ((x + 2) / y x + x / y x)%R) 0.
assert (H := d_y).
assert (H0 := n_y).
reg.
Qed.

Lemma essai1 : derivable_pt (fun x : R => (/ 2 * sin x)%R) 1.
reg.
Qed.

Lemma essai2 : continuity (fun x : R => (Rsqr x * cos (x * x) + x)%R).
reg.
Qed.

Lemma essai3 : derivable_pt (fun x : R => (x * (Rsqr x + 3))%R) 0.
reg.
Qed.

Lemma essai4 : derivable (fun x : R => ((x + x) * sin x)%R).
reg.
Qed.

Lemma essai5 : derivable (fun x : R => (1 + sin (2 * x + 3) * cos (cos x))%R).
reg.
Qed.

Lemma essai6 : derivable (fun x : R => cos (x + 3)).
reg.
Qed.

Lemma essai7 :
 derivable_pt (fun x : R => (cos (/ sqrt x) * Rsqr (sin x + 1))%R) 1.
reg.
apply Rlt_0_1.
red in |- *; intro;  rewrite sqrt_1 in H; assert (H0 := R1_neq_R0); elim H0;
 assumption.
Qed.

Lemma essai8 : derivable_pt (fun x : R => sqrt (Rsqr x + sin x + 1)) 0.
reg.
 rewrite sin_0.
 rewrite Rsqr_0.
 replace (0 + 0 + 1)%R with 1%R; [ apply Rlt_0_1 |  ring ].
Qed.

Lemma essai9 : derivable_pt (id + sin) 1.
reg.
Qed.

Lemma essai10 : derivable_pt (fun x : R => (x + 2)%R) 0.
reg.
Qed.

Lemma essai11 : derive_pt (fun x : R => (x + 2)%R) 0 essai10 = 1%R.
reg.
Qed.

Lemma essai12 : derivable (fun x : R => (x + Rsqr (x + 2))%R).
reg.
Qed.

Lemma essai13 :
 derive_pt (fun x : R => (x + Rsqr (x + 2))%R) 0 (essai12 0%R) = 5%R.
reg.
Qed.

Lemma essai14 : derivable_pt (fun x : R => (2 * x + x)%R) 2.
reg.
Qed.

Lemma essai15 : derive_pt (fun x : R => (2 * x + x)%R) 2 essai14 = 3%R.
reg.
Qed.

Lemma essai16 : derivable_pt (fun x : R => (x + sin x)%R) 0.
reg.
Qed.

Lemma essai17 : derive_pt (fun x : R => (x + sin x)%R) 0 essai16 = 2%R.
reg.
 rewrite cos_0.
reflexivity.
Qed.

Lemma essai18 : derivable_pt (fun x : R => (x + y x)%R) 0.
assert (H := d_y).
reg.
Qed.

Lemma essai19 : derive_pt (fun x : R => (x + y x)%R) 0 essai18 = 2%R.
assert (H := dy_0).
assert (H0 := d_y).
reg.
Qed.

Axiom z : R -> R.
Axiom d_z : derivable z.

Lemma essai20 : derivable_pt (fun x : R => z (y x)) 0.
reg.
apply d_y.
apply d_z.
Qed.

Lemma essai21 : derive_pt (fun x : R => z (y x)) 0 essai20 = 1%R.
assert (H := dy_0).
reg.
Abort.

Lemma essai22 : derivable (fun x : R => (sin (z x) + Rsqr (z x) / y x)%R).
assert (H := d_y).
reg.
apply n_y.
apply d_z.
Qed.

(* Pour tester la continuite de sqrt en 0 *)
Lemma essai23 :
 continuity_pt
   (fun x : R => (sin (sqrt (x - 1)) + exp (Rsqr (sqrt x + 3)))%R) 1.
reg.
left; apply Rlt_0_1.
right; unfold Rminus in |- *;  rewrite Rplus_opp_r; reflexivity.
Qed.

Lemma essai24 :
 derivable (fun x : R => (sqrt (x * x + 2 * x + 2) + Rabs (x * x + 1))%R).
reg.
 replace (x * x + 2 * x + 2)%R with (Rsqr (x + 1) + 1)%R.
apply Rplus_le_lt_0_compat; [ apply Rle_0_sqr | apply Rlt_0_1 ].
unfold Rsqr in |- *;  ring.
red in |- *; intro; cut (0 < x * x + 1)%R.
intro;  rewrite H in H0; elim (Rlt_irrefl _ H0).
apply Rplus_le_lt_0_compat;
 [  replace (x * x)%R with (Rsqr x); [ apply Rle_0_sqr | reflexivity ]
 | apply Rlt_0_1 ].
Qed.


(* This Source Code Form is subject to the terms of the Mozilla Public
 * License, v. 2.0. If a copy of the MPL was not distributed with this
 * file, You can obtain one at https://mozilla.org/MPL/2.0/. *)

(* Copyright (C) 2018–2020 ANSSI *)

From ExtLib Require Import Functor Applicative Monad.
From FreeSpec.Core Require Import Interface Impure Contract.

(** To reason about impure computations, we introduce the “Hoare
    monad,” also called the “specification monad.” An instance of the
    specification monad is a couple of [pre] and [post] conditions,
    such that [pre p σ] means the program specified by [p] can be
    executed safely from a state [σ], and [post p σ x σ'] means the
    execution of [p] from [σ] may compute a result [x] and bring the
    system to a state [σ'].

    We equip this couple of predicate with a [bind] function to
    sequentially compose specifications. *)

(** * Definition *)

Record hoare (Σ : Type) (α : Type) : Type :=
  mk_hoare { pre : Σ -> Prop
           ; post : Σ -> α -> Σ -> Prop
           }.

Arguments mk_hoare {Σ α} (pre post).
Arguments pre {Σ α} (_ _).
Arguments post {Σ α} (_ _ _).

Definition hoare_pure {Σ α} (x : α) : hoare Σ α :=
  mk_hoare (fun _ => True) (fun s y s' => x = y /\ s = s').

Definition hoare_bind {Σ α β} (h : hoare Σ α) (k : α -> hoare Σ β) : hoare Σ β :=
  mk_hoare (fun s => pre h s /\ (forall x s', post h s x s' -> pre (k x) s'))
           (fun s x s'' => exists y s', post h s y s' /\ post (k y) s' x s'').

(** * Instances *)

(** ** Functor *)

Definition hoare_map {Σ α β} (f : α -> β) (h : hoare Σ α) : hoare Σ β :=
  hoare_bind h (fun x => hoare_pure (f x)).

Instance hoare_Functor Σ : Functor (hoare Σ) :=
  { fmap := fun _ _ => hoare_map }.

(** ** Applicative *)

Definition hoare_apply {Σ α β} (hf : hoare Σ (α -> β)) (h : hoare Σ α)
  : hoare Σ β :=
  hoare_bind hf (fun f => hoare_map f h).

Instance hoare_Applicative Σ : Applicative (hoare Σ) :=
  { ap := fun _ _ => hoare_apply
  ; pure := fun _ => hoare_pure
  }.

(** ** Monad *)

Instance hoare_Monad Σ : Monad (hoare Σ) :=
  { ret := @hoare_pure Σ; bind := @hoare_bind Σ }.

(** * Reasoning about Programs *)

Definition interface_to_hoare `{MayProvide ix i} `(c : contract i Ω) : ix ~> hoare Ω :=
  fun a e =>
    {| pre := fun ω => gen_caller_obligation c ω e
     ; post := fun ω x ω' => gen_callee_obligation c ω e x
                             /\ ω' = gen_witness_update c ω e x
    |}.

Definition to_hoare `{MayProvide ix i} `(c : contract i Ω)
  : impure ix ~> hoare Ω :=
  impure_lift (interface_to_hoare c).

Arguments to_hoare {ix i _ Ω} c {α} _.


Require Import Morphisms.
Import ProperNotations.
Require Import SetoidClass.
Require notation categories prods_pullbacks functors natural_transformations monads adjunctions.

Module Make(Import M: notation.T).
 Module Export kleisli_exp := adjunctions.Make(M).

Definition Kleisli_Category' (catC : Category)
                             (F    : obj catC -> obj catC)
                             (fmapT: forall (a b: obj catC) (f: arrow catC b a), (arrow catC (F b) (F a)))
                             (T    : Functor catC catC F fmapT)
                             (M    : @Monad' catC F fmapT T) : (Category).
Proof. destruct M. destruct nt3, nt4.
       refine (@mk_Category (obj catC)
                            (fun a b           => (@arrow catC (F b) a))
                            (fun a             => (@trans0 a))
                            (fun a b c f g     => (@trans1 c) o (fmapT _ _ g) o f)
                            _ _ _ ).
       - intros. simpl. destruct T, T3. simpl in *. unfold id in *. rewrite preserve_comp0.
         rewrite assoc. rewrite preserve_comp0. rewrite assoc. rewrite (comm_diagram1''0 a). do 2 rewrite assoc.
         specialize(@comm_diag1 b (F a) f0). (* rewrite comm_diag1. ?? *) apply rcancel. apply rcancel.
         rewrite <- assoc. rewrite <- assoc. rewrite comm_diag1. reflexivity.
       - intros. unfold id in *. destruct T, T3.  simpl in *. unfold id in *.
         specialize (@comm_diag0 b (F a) f0). rewrite <- assoc. rewrite comm_diag0. rewrite assoc.
         rewrite comm_diagram2_b2''0. rewrite identity_f. unfold idf. reflexivity.
       - intros. unfold id in *. destruct T, T3. simpl in *. unfold id in *.
          rewrite comm_diagram2''0, comm_diagram2_b2''0, identity_f. reflexivity.
Defined.
Check Kleisli_Category'.

Definition Kleisli_Category (catC : Category) (F: obj catC -> obj catC)
                            (fmapT: forall (a b: obj catC) (f: arrow catC b a), (arrow catC (F b) (F a)))
                            (Id   : (Functor catC catC id (fun a b f => (@idf catC a b f))))
                            (T    : (Functor catC catC F fmapT))
                            (T2   : (Functor catC catC (fun a: obj catC => F (F a)) (fun a b f => fmapT _ _ (fmapT _ _ f))))
                            (nt1  : @NaturalTransformation catC catC id F (fun a b f => (@idf catC a b f)) fmapT Id T)
                            (nt2  : @NaturalTransformation catC catC (fun a: obj catC => F (F a)) F
                                   (fun a b f => fmapT _ _ (fmapT _ _ f)) fmapT T2 T)
                            (M    : @Monad catC F fmapT Id T T2 nt1 nt2) : (Category).
Proof. refine (@mk_Category (obj catC)
                            (fun a b => (@arrow catC (F b) (id a)))
                            (fun a => (@trans _ _ _ _ _ _ _ _ nt1 a))
                            (fun a b c f g => ((@trans _ _ _ _ _ _ _ _ nt2 (id c))) o (fmapT _ _ g) o f)
                            _ _ _ ).
       - intros. simpl. destruct nt1, nt2, M, T, T2. simpl in *. unfold id in *. rewrite preserve_comp0.
         rewrite assoc. rewrite preserve_comp0. rewrite assoc. rewrite (comm_diagram3 a). do 2 rewrite assoc.
         specialize(@comm_diag1 b (F a) f0). (* rewrite comm_diag1. ?? *) apply rcancel. apply rcancel.
         rewrite <- assoc. rewrite <- assoc. rewrite comm_diag1. reflexivity.
       - intros. unfold id in *. destruct nt1, nt2, M, T, T2.  simpl in *. unfold id in *.
         specialize (@comm_diag0 b (F a) f0). rewrite <- assoc. rewrite comm_diag0. rewrite assoc.
         rewrite comm_diagram2_b4. rewrite identity_f. unfold idf. reflexivity.
       - intros. unfold id in *. destruct nt1, nt2, M, T, T2. simpl in *. unfold id in *.
          rewrite comm_diagram4, comm_diagram2_b4, identity_f. reflexivity.
Defined.
Check Kleisli_Category.

Definition Kleisli_Category2 (catC : Category) (F: obj catC -> obj catC)
                             (Id   : (Functor2 catC catC id))
                             (T    : (Functor2 catC catC F))
                             (T2   : (Functor2 catC catC (fun a: obj catC => F (F a))))
                             (nt1  : @NaturalTransformation2 catC catC id F Id T)
                             (nt2  : @NaturalTransformation2 catC catC (fun a: obj catC => F (F a)) F T2 T)
                             (M    : @Monad2 catC F Id T T2 nt1 nt2):
                             (forall a b f, (@fmap2 _ _ _ T2 a b f) = (@fmap2 _ _ _ T _ _ (@fmap2 _ _ _ T _ _ f))) ->
                             (forall a b f, (@fmap2 _ _ _ Id a b f) = (@idf catC a b f))
                             -> (Category).
Proof. intros. refine (@mk_Category (obj catC)
                            (fun a b       => (@arrow catC (F b) (id a)))
                            (fun a         => (@trans2 _ _ _ _ _ _ nt1 a))
                            (fun a b c f g => (@trans2 _ _ _ _ _ _ nt2 (id c)) o (@fmap2 _ _ _ T _ _ g) o f)
                            _
                            _
                            _
               ).
       - intros. simpl. destruct nt1, nt2, M, T, T2. simpl in *. unfold id in *. rewrite preserve_comp3.
         rewrite assoc. rewrite preserve_comp3. rewrite assoc. rewrite (comm_diagram1'0 a). do 2 rewrite assoc.
         apply rcancel. apply rcancel. specialize(@comm_diag4 b (F a) f0).
         (* rewrite comm_diag1. ?? *)
         rewrite <- assoc. rewrite <- assoc. rewrite comm_diag4.
         cut (fmap4 b (F a) f0 = fmap3 (F b) (F (F a)) (fmap3 b (F a) f0)).
           + intros. rewrite H. reflexivity.
           + apply H.
       - intros. unfold id in *. destruct nt1, nt2, M, T, T2.  simpl in *. unfold id in *.
         specialize (@comm_diag3 b (F a) f0). rewrite <- assoc. rewrite comm_diag3. rewrite assoc.
         rewrite comm_diagram2_b2'0. rewrite identity_f. destruct Id. unfold idf. rewrite H0.
         simpl; reflexivity.
       - intros. unfold id in *. destruct nt1, nt2, M, T, T2. simpl in *. unfold id in *.
          rewrite comm_diagram2'0, comm_diagram2_b2'0, identity_f. reflexivity.
Defined.
Check Kleisli_Category2.

Definition coKleisli_Category' (catC: Category) (F: obj catC -> obj catC)
                               (fmapD : forall (a b: obj catC) (f: arrow catC b a), (arrow catC (F b) (F a)))
                               (D   : (Functor catC catC F fmapD))
                               (CM  : coMonad' catC F fmapD D): Category.
Proof. destruct CM. destruct cnt3, cnt4.
       refine (@mk_Category (obj catC)
                            (fun a b => (@arrow catC (id b) (F a)))
                            (fun a => (@trans0 a))
                            (fun a b c f g => g o (fmapD _ _ f) o (@trans1 a))
                            _ _ _ ).
      - intros. simpl. destruct D, D3. simpl in *. unfold id in *. rewrite preserve_comp0.
         rewrite assoc. rewrite preserve_comp0. do 5 rewrite <- assoc. rewrite (cm_comm_diagram1''0 d).
         do 5 rewrite assoc.  apply rcancel. specialize(@comm_diag1 (F d) c h). rewrite <- assoc.
         rewrite <- comm_diag1. do 2 rewrite assoc. reflexivity.
      - intros. unfold id in *. destruct D, D3. simpl in *. unfold id in *. rewrite <- assoc.
         rewrite cm_comm_diagram2''0, cm_comm_diagram_b2''0, f_identity. reflexivity.
      - intros. unfold id in *. destruct D, D3. simpl in *. unfold id in *. rewrite <- comm_diag0.
         rewrite <- assoc. rewrite cm_comm_diagram_b2''0, f_identity. unfold idf; reflexivity.
Defined.
Check coKleisli_Category'.

Definition coKleisli_Category (catC: Category) (F: obj catC -> obj catC)
                              (fmapD : forall (a b: obj catC) (f: arrow catC b a), (arrow catC (F b) (F a)))
                              (Id  : (Functor catC catC id (fun a b f => (@idf catC a b f))))
                              (D   : (Functor catC catC F fmapD))
                              (D2  : (Functor catC catC (fun a: obj catC => F (F a)) (fun a b f => fmapD _ _ (fmapD _ _ f))))
                              (nt1 : NaturalTransformation catC catC F id fmapD (fun a b f => (@idf catC a b f)) D Id)
                              (nt2 : NaturalTransformation catC catC F (fun a: obj catC => F (F a))
                                     fmapD (fun a b f => fmapD _ _ (fmapD _ _ f)) D D2)
                              (CM  : coMonad catC F fmapD Id D D2 nt1 nt2): Category.
Proof. refine (@mk_Category (obj catC)
                            (fun a b => (@arrow catC (id b) (F a)))
                            (fun a => (@trans _ _ _ _ _ _ _ _ nt1 a))
                            (fun a b c f g => g o (fmapD _ _ f) o (@trans _ _ _ _ _ _ _ _ nt2 a))
                            _ _ _ ).
      - intros. simpl. destruct nt1, nt2, CM, D, D2. simpl in *. unfold id in *. rewrite preserve_comp0.
         rewrite assoc. rewrite preserve_comp0. do 5 rewrite <- assoc. rewrite (cm_comm_diagram3 d).
         do 5 rewrite assoc.  apply rcancel. specialize(@comm_diag1 (F d) c h). rewrite <- assoc.
         rewrite <- comm_diag1. do 2 rewrite assoc. reflexivity.
      - intros. unfold id in *. destruct nt1, nt2, CM, D, D2. simpl in *. unfold id in *. rewrite <- assoc.
         rewrite cm_comm_diagram4, cm_comm_diagram_b4, f_identity. reflexivity.
      - intros. unfold id in *. destruct nt1, nt2, CM, D, D2. simpl in *. unfold id in *. rewrite <- comm_diag0.
         rewrite <- assoc. rewrite cm_comm_diagram_b4, f_identity. unfold idf; reflexivity.
Defined.
Check coKleisli_Category.

Definition coKleisli_Category2 (catC: Category) (F: obj catC -> obj catC)
                               (Id  : (Functor2 catC catC id))
                               (D   : (Functor2 catC catC F))
                               (D2  : (Functor2 catC catC (fun a: obj catC => F (F a))))
                               (nt1 : NaturalTransformation2 catC catC F id D Id)
                               (nt2 : NaturalTransformation2 catC catC F (fun a: obj catC => F (F a)) D D2)
                               (CM  : coMonad2 catC F Id D D2 nt1 nt2) :
                              (forall a b f, (@fmap2 _ _ _ D2 a b f) = (@fmap2 _ _ _ D _ _ (@fmap2 _ _ _ D _ _ f))) ->
                              (forall a b f, (@fmap2 _ _ _ Id a b f) = (@idf catC a b f)) ->
                              (Category).
Proof. intros. refine (@mk_Category (obj catC)
                            (fun a b       => (@arrow catC (id b) (F a)))
                            (fun a         => (@trans2 _ _ _ _ _ _ nt1 a))
                            (fun a b c f g => g o (@fmap2 _ _ _ D _ _ f) o (@trans2 _ _ _ _ _ _  nt2 a))
                            _ _ _ ).
      - intros. simpl. destruct nt1, nt2, CM, D, D2. simpl in *. unfold id in *. rewrite preserve_comp3.
         rewrite assoc. rewrite preserve_comp3. do 5 rewrite <- assoc. rewrite (cm_comm_diagram1'0 d).
         do 5 rewrite assoc.  apply rcancel. specialize(@comm_diag4 (F d) c h). rewrite <- assoc.
         rewrite <- comm_diag4. do 2 rewrite assoc.
         rewrite H. reflexivity.
      - intros. unfold id in *. destruct nt1, nt2, CM, D, D2. simpl in *. unfold id in *. rewrite <- assoc.
         rewrite cm_comm_diagram2'0, cm_comm_diagram_b2'0, f_identity. reflexivity.
      - intros. unfold id in *. destruct nt1, nt2, CM, D, D2. simpl in *. unfold id in *. rewrite <- comm_diag3.
         rewrite <- assoc. rewrite cm_comm_diagram_b2'0, f_identity. rewrite H0; reflexivity.
Defined.
Check coKleisli_Category2.

End Make.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import RVIC2.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition need_ns_notify_spec (rec: Pointer) (target_rec: Pointer) (intid: Z64) (adt: RData) : option Z :=
    match intid with
    | VZ64 intid =>
      rely is_int64 intid;
      rely (peq (base rec) buffer_loc);
      rely (peq (base target_rec) buffer_loc);
      rely prop_dec (0 <= offset target_rec < 16);
      when rec_gidx == ((buffer (priv adt)) @ (offset rec));
      when target_gidx == ((buffer (priv adt)) @ (offset target_rec));
      let gn_rec := (gs (share adt)) @ rec_gidx in
      let gn_target := (gs (share adt)) @ target_gidx in
      rely (gtype gn_rec) =? GRANULE_STATE_REC;
      rely (gtype gn_target) =? GRANULE_STATE_REC;
      rely (g_inited (gro gn_rec));
      rely (g_inited (gro gn_target));
      let idx1 := (g_rec_idx (gro gn_target)) in
      let idx2 := (g_rec_idx (gro gn_rec)) in
      rely is_int64 idx1; rely is_int64 idx2;
      if idx1 =? idx2 then
        Some 0
      else
        rely (g_tag (ginfo gn_target)) =? GRANULE_STATE_REC;
        rely prop_dec (glock gn_target = Some CPU_ID);
        let enabled := (r_rvic_enabled (g_rvic (gnorm gn_target))) in
        rely is_int enabled;
        if enabled =? 0 then
          Some 0
        else
          let idx := (intid / 64) in
          let bit := (intid mod 64) in
          rely prop_dec (0 <= idx < 512);
          let bits := (r_pending_bits (g_rvic (gnorm gn_target))) @ idx in
          if Z.land bits (Z.shiftl 1 bit) =? 0 then
            Some 0
          else
            let bits := (r_mask_bits (g_rvic (gnorm gn_target))) @ idx in
            if Z.land bits (Z.shiftl 1 bit) =? 0 then
              Some 1
            else
              Some 0
    end.

End Spec.


Require Import HoTT.Basics.Overture.
Require Export HoTT.Classes.implementations.list.

Import ListNotations.

(** Extensions to [list] *)

Section operations.
  Context {A: Type}.

  (* Copy pasted from the Coq library. *)
  Definition tl (l:list A) :=
    match l with
      | [] => nil
      | a :: m => m
    end.

  (* Modified copy from the Coq library. *)
  (** The [In] predicate *)
  Fixpoint InList (a:A) (l:list A) : Type0 :=
    match l with
      | [] => False
      | b :: m => b = a |_| InList a m
    end.

  Fixpoint fold_right {B: Type} (f: B -> A -> A) (a0: A) (l: list B) : A :=
    match l with
      | nil => a0
      | cons b t => f b (fold_right f a0 t)
    end.
End operations.


Require Import compcert.common.AST.

(*THREADS*)
Module Type ThreadID.
  Parameter tid: Set.
  Axiom eq_tid_dec: forall (i j: tid), {i=j} + {i<>j}.
End ThreadID.

Module NatTID <: ThreadID.
  Definition tid:= nat.
  Lemma eq_tid_dec: forall (i j: tid), {i=j} + {i<>j}.
  Proof. intros; apply Peano_dec.eq_nat_dec. Qed.
End NatTID.

(*SCHEDULERS*)
Module Type Scheduler.
  Declare Module TID: ThreadID.
  Import TID.
  Parameter schedule : Type.
  Parameter empty : schedule.
  Parameter Empty : schedule -> bool.
  Parameter schedPeek: schedule -> option tid.
  Parameter schedSkip: schedule -> schedule.
  Parameter buildSched: list tid -> schedule.
  Parameter sch_dec: forall (sch sch': schedule), {sch = sch'} + {sch <> sch'}.
  Parameter end_of_sch: forall U, U = schedSkip U <-> schedPeek U = None.
End Scheduler.

Module ListScheduler (TID:ThreadID) <: Scheduler with Module TID:= TID.
  Module TID:= TID.
  Import TID.
  Definition schedule:= list tid.
  Definition empty : schedule := nil.
  Definition schedPeek (sc:schedule):= @List.hd_error tid sc.
  Definition Empty : schedule -> bool := fun sch => if schedPeek sch then false else true.
  Definition schedSkip (sc:schedule): schedule:= @List.tl tid sc.
  Definition buildSched (ls : list tid) : schedule := ls.
  Lemma sch_dec: forall (sch sch': schedule), {sch = sch'} + {sch <> sch'}.
  Proof.
    induction sch.
    - intro sch'; destruct sch'; [left | right]; auto; apply List.nil_cons.
    - intro sch'; destruct sch'; [right|].
      + intros HH. apply (@List.nil_cons _ a sch); symmetry; assumption.
      + destruct (TID.eq_tid_dec a t).
        destruct (IHsch sch').
        * subst; left; auto.
        * subst; right. intros HH; apply n. inversion HH; auto.
        * right. intros HH; apply n. inversion HH; auto.
  Qed.
  Lemma end_of_sch: forall U, U = schedSkip U <-> schedPeek U = None.
  Proof.
    unfold schedPeek, schedSkip.
    split; simpl; intros HH; destruct U; inversion HH; try reflexivity.
    simpl in HH.
    contradict HH.
    generalize t; clear; induction U.
    - intros t HH. apply (@List.nil_cons _ t nil). symmetry; assumption.
    - intros t HH. inversion HH. apply (IHU a); assumption.
  Qed.
End ListScheduler.


Require Import Rsequence_def Rsequence_sums_facts.
Require Import Rpser.
Require Import Rfunction_facts Rextensionality.
Require Import Rfunction_classes.
Require Import Nth_derivative_def Nth_derivative_facts.
Require Import Dequa_def.
Require Import List.
Require Import Max.
Require Import Ass_handling.
Require Import Option.

Local Open Scope R_scope.

Lemma map_nth_error_None_iff : forall {A B : Type} (l : list A) (f : A -> B) (n : nat),
  nth_error l n = None <-> nth_error (map f l) n = None.
Proof.
intros A B l f n ; revert l ; induction n ; intro l.
 destruct l ; simpl ; split ; auto ; intro H ; inversion H.
 destruct l ; simpl ; [split ; auto ; intro H ; inversion H | apply IHn].
Qed.

Lemma map_nth_error_None : forall {A B : Type} (l : list A) (f : A -> B) (n : nat),
  nth_error l n = None -> nth_error (map f l) n = None.
Proof.
intros ; apply map_nth_error_None_iff ; assumption.
Qed.

Definition App {A B : Type} f (a : A) : option B := Bind f (fun g => g a).

Lemma interp_side_equa_in_N_R : forall s l Un f,
  interp_side_equa_in_N s (map (@projT1 _ infinite_cv_radius) l) = Some Un ->
  interp_side_equa_in_R s l = Some f ->
  {pr : infinite_cv_radius Un | sum Un pr == f}.
Proof.
intro s ; induction s ; simpl ; intros l Un f HN HR3.

 inversion HN ; inversion HR3 ; subst ; exists (constant_infinite_cv_radius r) ;
  apply constant_is_cst.

 destruct_eq (interp_side_equa_in_N s (map (@projT1 _ infinite_cv_radius) l)).
  destruct_eq (interp_side_equa_in_R s l).
   symmetry in Heqb ; symmetry in Heqb0 ; specify5 IHs l r0 r1 Heqb Heqb0.
   inversion HR3 as [Hrew] ; destruct Hrew.
   inversion HN as [Hrew] ; destruct Hrew.
   destruct IHs as [rho Hrho].
   assert (pr : infinite_cv_radius (r * r0)).
    destruct (Req_dec r 0) as [Heq | Hneq].
     rewrite Heq ; simpl ; rewrite <- (infinite_cv_radius_ext (Rseq_constant 0)) ;
      [apply zero_infinite_cv_radius | intro n ; unfold Rseq_mult ;
      rewrite Rmult_0_l ; reflexivity].
     rewrite <- infinite_cv_radius_scal_compat ; assumption.
   exists pr ; intro x ; unfold mult_fct ; rewrite <- Hrho.
   apply sum_scal_compat.
  inversion HR3.
 inversion HN.

 assert (Hrew := map_nth_error (@projT1 _ infinite_cv_radius) p l) ;
  unfold Bind in * ; destruct (nth_error l p).
  specify2 Hrew s (eq_refl (Some s)) ; destruct s as [An rAn] ;
  rewrite Hrew in HN ; inversion HN as [HN0] ; destruct HN0 ;
   inversion HR3 as [HR30] ; destruct HR30.
   assert (ppr: infinite_cv_radius (An_nth_deriv An k)).
    rewrite <- infinite_cv_radius_nth_derivable_compat ; assumption.
   assert (pr : infinite_cv_radius (An_expand (An_nth_deriv An k) a)).
    apply infinite_cv_radius_expand_compat ; assumption.
   exists pr ; intro x ; symmetry ; rewrite (sum_expand_compat _ ppr).
   erewrite <- nth_derive_sum_explicit ; reflexivity.
  inversion HR3.

 destruct_eq (interp_side_equa_in_N s (map (@projT1 _ infinite_cv_radius) l)).
  destruct_eq (interp_side_equa_in_R s l).
   symmetry in Heqb ; symmetry in Heqb0 ; specify5 IHs l r r0 Heqb Heqb0.
   inversion HR3 as [Hrew] ; destruct Hrew.
   inversion HN as [Hrew] ; destruct Hrew.
   destruct IHs as [rho Hrho].
   assert (pr : infinite_cv_radius (- r)) by
    (rewrite <- infinite_cv_radius_opp_compat ; assumption).
   exists pr ; intro x ; unfold opp_fct ; rewrite <- Hrho ;
   apply sum_opp_compat.
  inversion HR3.
 inversion HN.

 destruct_eq (interp_side_equa_in_N s1 (map (@projT1 _ infinite_cv_radius) l)).
  destruct_eq (interp_side_equa_in_N s2 (map (@projT1 _ infinite_cv_radius) l)).
   destruct_eq (interp_side_equa_in_R s1 l).
    destruct_eq (interp_side_equa_in_R s2 l).
     inversion HN as [Hrew] ; destruct Hrew ;
     inversion HR3 as [Hrew] ; destruct Hrew.
     symmetry in Heqb, Heqb0, Heqb1, Heqb2.
     specify5 IHs1 l r r1 Heqb Heqb1 ;
     specify5 IHs2 l r0 r2 Heqb0 Heqb2.
     destruct IHs1 as [rho1 Hrho1] ;
     destruct IHs2 as [rho2 Hrho2].
     assert (pr : infinite_cv_radius (r - r0)).
      apply infinite_cv_radius_minus_compat ; assumption.
     exists pr.
     intro x ; unfold minus_fct ; rewrite <- Hrho1, <- Hrho2 ;
     apply sum_minus_compat.
    inversion HR3.
   inversion HR3.
  inversion HN.
 inversion HN.

 destruct_eq (interp_side_equa_in_N s1 (map (@projT1 _ infinite_cv_radius) l)).
  destruct_eq (interp_side_equa_in_N s2 (map (@projT1 _ infinite_cv_radius) l)).
   destruct_eq (interp_side_equa_in_R s1 l).
    destruct_eq (interp_side_equa_in_R s2 l).
     inversion HN as [Hrew] ; destruct Hrew ;
     inversion HR3 as [Hrew] ; destruct Hrew.
     symmetry in Heqb, Heqb0, Heqb1, Heqb2.
     specify5 IHs1 l r r1 Heqb Heqb1 ;
     specify5 IHs2 l r0 r2 Heqb0 Heqb2.
     destruct IHs1 as [rho1 Hrho1] ;
     destruct IHs2 as [rho2 Hrho2].
     assert (pr : infinite_cv_radius (r + r0)).
      apply infinite_cv_radius_plus_compat ; assumption.
     exists pr.
     intro x ; unfold plus_fct ; rewrite <- Hrho1, <- Hrho2 ;
     apply sum_plus_compat.
    inversion HR3.
   inversion HR3.
  inversion HN.
 inversion HN.

 destruct_eq (interp_side_equa_in_N s1 (map (@projT1 _ infinite_cv_radius) l)).
  destruct_eq (interp_side_equa_in_N s2 (map (@projT1 _ infinite_cv_radius) l)).
   destruct_eq (interp_side_equa_in_R s1 l).
    destruct_eq (interp_side_equa_in_R s2 l).
     inversion HN as [Hrew] ; destruct Hrew ;
     inversion HR3 as [Hrew] ; destruct Hrew.
     symmetry in Heqb, Heqb0, Heqb1, Heqb2.
     specify5 IHs1 l r r1 Heqb Heqb1 ;
     specify5 IHs2 l r0 r2 Heqb0 Heqb2.
     destruct IHs1 as [rho1 Hrho1] ;
     destruct IHs2 as [rho2 Hrho2].
     assert (pr : infinite_cv_radius (r # r0)).
      apply infinite_cv_radius_prod_compat ; assumption.
     exists pr.
     intro x ; unfold mult_fct ; rewrite <- Hrho1, <- Hrho2 ;
     apply sum_mult_compat.
    inversion HR3.
   inversion HR3.
  inversion HN.
 inversion HN.
Qed.

Lemma map_nth_error2 {A B : Type} : forall f l p,
  nth_error l p = @None A -> nth_error (map f l) p = @None B.
Proof.
intros f l p ; revert l ; induction p ; intro l ; destruct l.
 trivial.
 intro Hf ; inversion Hf.
 trivial.
 simpl ; apply IHp.
Qed.

Lemma interp_side_equa_in_N_R_compat : forall s l un,
  interp_side_equa_in_N s (map (@projT1 _ infinite_cv_radius) l) = Some un ->
  {f | interp_side_equa_in_R s l = Some f}.
Proof.
intro s ; induction s ; intros l un H.
 exists (fun _ => r) ; reflexivity.

 simpl in * ; destruct_eq (interp_side_equa_in_N s (map
 (@projT1 _ infinite_cv_radius) l)) ; symmetry in Heqb.
  specify3 IHs l r0 Heqb ; destruct IHs as [f Hf] ;
  exists ((fun _ => r) * f)%F ; rewrite Hf ; reflexivity.
 inversion H.

 assert (Hrew := map_nth_error (@projT1 _ infinite_cv_radius) p l) ;
 destruct_eq (nth_error l p).
  specify2 Hrew s (eq_refl (Some s)).
  destruct s as [An rAn] ; simpl in H, Hrew ; rewrite Hrew in H ;
   simpl in H ; exists (fun x => nth_derive (sum An rAn) (D_infty_Rpser An rAn k) (a * x)) ;
   simpl ; rewrite <- Heqb ; reflexivity.
  symmetry in Heqb ; simpl in H.
 assert (T := map_nth_error2 (@projT1 _ infinite_cv_radius) _ _ Heqb).
 rewrite T in H ; inversion H.

 simpl in * ;
  destruct_eq (interp_side_equa_in_N s (map (@projT1 _ infinite_cv_radius) l)) ;
  symmetry in Heqb.
   specify3 IHs l r Heqb ; destruct IHs as [f Hf].
   exists (- f)%F ; rewrite Hf ; reflexivity.
 inversion H.

 simpl in *.
  destruct_eq (interp_side_equa_in_N s1 (map (@projT1 _ infinite_cv_radius) l)) ;
  symmetry in Heqb.
   destruct_eq (interp_side_equa_in_N s2 (map (@projT1 _ infinite_cv_radius) l)) ;
   symmetry in Heqb0.
    specify3 IHs1 l r Heqb ; destruct IHs1 as [f Hf] ;
    specify3 IHs2 l r0 Heqb0 ; destruct IHs2 as [g Hg].
    exists (f - g)%F ; rewrite Hf, Hg ; reflexivity.
   inversion H.
  inversion H.

 simpl in *.
  destruct_eq (interp_side_equa_in_N s1 (map (@projT1 _ infinite_cv_radius) l)) ;
  symmetry in Heqb.
   destruct_eq (interp_side_equa_in_N s2 (map (@projT1 _ infinite_cv_radius) l)) ;
   symmetry in Heqb0.
    specify3 IHs1 l r Heqb ; destruct IHs1 as [f Hf] ;
    specify3 IHs2 l r0 Heqb0 ; destruct IHs2 as [g Hg].
    exists (f + g)%F ; rewrite Hf, Hg ; reflexivity.
   inversion H.
  inversion H.

 simpl in *.
  destruct_eq (interp_side_equa_in_N s1 (map (@projT1 _ infinite_cv_radius) l)) ;
  symmetry in Heqb.
   destruct_eq (interp_side_equa_in_N s2 (map (@projT1 _ infinite_cv_radius) l)) ;
   symmetry in Heqb0.
    specify3 IHs1 l r Heqb ; destruct IHs1 as [f Hf] ;
    specify3 IHs2 l r0 Heqb0 ; destruct IHs2 as [g Hg].
    exists (f * g)%F ; rewrite Hf, Hg ; reflexivity.
   inversion H.
  inversion H.
Qed.

Lemma interp_equa_in_N_R : forall (e : diff_equa)
  (l : list (sigT infinite_cv_radius)),
  [| e |]N (map (@projT1 _ infinite_cv_radius) l) -> [| e |]R l.
Proof.
intros [s1 s2] l H ; simpl in *.
 destruct_eq (interp_side_equa_in_N s1 (map (@projT1 _ infinite_cv_radius) l)).
  destruct_eq (interp_side_equa_in_N s2 (map (@projT1 _ infinite_cv_radius) l)).
   destruct_eq (interp_side_equa_in_R s1 l).
    destruct_eq (interp_side_equa_in_R s2 l).
     symmetry in Heqb, Heqb0, Heqb1, Heqb2.
     destruct (interp_side_equa_in_N_R s1 l r r1 Heqb Heqb1) as [rho1 Hrho1].
     destruct (interp_side_equa_in_N_R s2 l r0 r2 Heqb0 Heqb2) as [rho2 Hrho2].
     rewrite <- Hrho1, <- Hrho2 ; apply sum_ext ; assumption.
    symmetry in Heqb0 ;
    destruct (interp_side_equa_in_N_R_compat _ _ _ Heqb0) as [f Hf] ;
    rewrite Hf in Heqb2 ; inversion Heqb2.
   symmetry in Heqb ;
   destruct (interp_side_equa_in_N_R_compat _ _ _ Heqb) as [f Hf] ;
   rewrite Hf in Heqb1 ; inversion Heqb1.
  inversion H.
 inversion H.
Qed.


Require Import Equations.

Inductive foo : Set :=
| c0 : nat -> foo
| c1 : bar -> bar -> foo
(* | c3 : bar -> foo *)
| c2 : foo -> foo
with bar : Set :=
| d0 : nat -> bar
| d1 : foo -> bar.

(* Inductive foo_foo_subterm : foo -> foo -> Prop := *)
(* | c1_sub0 b f g : *)
(*     foo_bar_subterm f b -> foo_foo_subterm f (c1 b g) *)
(* | c1_sub1 b f g : foo_bar_subterm b g -> foo_foo_subterm b (c1 f g) *)
(* | c2_sub x : foo_foo_subterm x (c2 x) *)
(* with foo_bar_subterm : foo -> bar -> Prop := *)
(* | d1_sub f : foo_bar_subterm f (d1 f) *)

(* with bar_bar_subterm : bar -> bar -> Prop := *)
(* | d1b b f : bar_foo_subterm b f -> bar_bar_subterm b (d1 f) *)

(* with bar_foo_subterm : bar -> foo -> Prop := *)
(* | c1b b q : bar_foo_subterm b (c1 b q) *)
(* | c2b b q :bar_foo_subterm b (c1 q b). *)

(* Scheme foo_foo_s := Induction for foo_foo_subterm Sort Prop *)
(* with foo_bar_s := Induction for foo_bar_subterm Sort Prop *)
(* with bar_bar_s := Induction for bar_bar_subterm Sort Prop *)
(* with bar_foo_s := Induction for bar_foo_subterm Sort Prop. *)

(* Combined Scheme foo_bar_subterm from foo_foo_s, foo_bar_s, bar_bar_s, bar_foo_s. *)

Scheme foo_bar_mut := Induction for foo Sort Set
with foo_bar_mut' := Induction for bar Sort Set.

Equations fn (x : foo) : nat :=
fn (c0 x) := x;
fn (c2 f) := fn f;
(* fn (c3 b) := fnb b; *)
fn (c1 b b') := fnb b + fnb b'
where fnb (x : bar) : nat :=
  fnb (d0 x) := x;
  fnb (d1 f) := fn f.
Next Obligation.
  revert x. fix f 1.
  destruct x. constructor. Transparent fn. unfold fn.
  assert(forall x: bar, fn_ind_1 b b0 x (fn_obligation_1 fn b b0 x)).
  fix g 1. destruct x. simpl. constructor. constructor. apply f.
  constructor. apply H. apply H.
  simpl. constructor. apply f.
Defined.

Eval compute in fn.
(* Combined Scheme foo_bar from foo_bar_mut, foo_bar_mut'. *)

Section mutrec.
  Variables foo_bar_rec : foo -> nat.
  Variables foo_bar_rec' : bar -> nat.

  Equations foo_bar_fn (x : foo) : nat :=
  foo_bar_fn (c0 x) := x;
  foo_bar_fn (c1 b b') := foo_bar_rec' b + foo_bar_rec' b';
  foo_bar_fn (c2 f) := foo_bar_rec f.

  Equations foo_bar_fn' (x : bar) : nat :=
  foo_bar_fn' (d0 x) := x;
  foo_bar_fn' (d1 b) := foo_bar_fn b.
End mutrec.

Definition foobarknot :=
  fix F (x : foo) := foo_bar_fn F G x
  with G (x : bar) := foo_bar_fn' F G x for F.


Require Import POCS.

(** * Logging API *)

(** This file defines the desired API for an append-only durable log.
    A log like the one defined here is widely used in storage systems,
    such as a file system or a database, to make atomic crash-safe
    updates.  In this lab, you will implement and prove correct the
    log itself, though the lab does not involve building anything on
    top of this log (like a file system).
  *)

(** Logically, the state of the log is a list of blocks: *)
Definition State : Type := list block.

(** The log provides three operations: [get], [append], and [reset].
    The [get] retrieves all of the blocks currently in the log: *)
Definition get_spec : Specification unit (list block) unit State :=
  fun (_ : unit) state => {|
    pre := True;
    post := fun r state' => r = state /\ state' = state;
    recovered := fun _ state' => state' = state
  |}.

(** [append] adds blocks to the log.  The [append] is the most interesting
    part of the log, because [append] must be atomic with respect to crashes.
    That means that, if the system crashes in the middle of an [append],
    either all of the blocks should be present (i.e., returned by [get]),
    or none of them should be present.

    [append] returns a boolean to indicate whether it succeeded
    or not.  The intent is that [append] might fail if the log
    has grown too big on disk, and there's no room for the new
    blocks. *)
Definition append_spec v : Specification unit bool unit State :=
  fun (_ : unit) state => {|
    pre := True;
    post := fun r state' => r = true /\ state' = state ++ v \/
                            r = false /\ state' = state;
    recovered := fun _ state' => state' = state \/ state' = state ++ v
  |}.

(** Finally, [reset] logically clears the log, removing all entries.  This
    also must be crash-safe: if the system crashes in the middle of clearing
    the log, either the log contents should still be there, or the log should
    appear to be empty (according to [get]).
  *)
Definition reset_spec : Specification unit unit unit State :=
  fun (_ : unit) state => {|
    pre := True;
    post := fun r state' => r = tt /\ state' = nil;
    recovered := fun _ state' => state' = state \/ state' = nil
  |}.

Module Type LogAPI.

  Axiom init : proc InitResult.
  Axiom get : proc (list block).
  Axiom append : list block -> proc bool.
  Axiom reset : proc unit.
  Axiom recover : proc unit.

  Axiom abstr : Abstraction State.

  Axiom init_ok : init_abstraction init recover abstr inited_any.
  Axiom get_ok : proc_spec get_spec get recover abstr.
  Axiom append_ok : forall v, proc_spec (append_spec v) (append v) recover abstr.
  Axiom reset_ok : proc_spec reset_spec reset recover abstr.
  Axiom recover_wipe : rec_wipe recover abstr no_wipe.

  Hint Resolve init_ok : core.
  Hint Resolve get_ok : core.
  Hint Resolve append_ok : core.
  Hint Resolve reset_ok : core.
  Hint Resolve recover_wipe : core.

End LogAPI.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^206 - 5
Base: 22 + 8/9
***)

Definition curve : CurveParameters :=
  {|
    sz := 9%nat;
    base := 22 + 8/9;
    bitwidth := 32;
    s := 2^206;
    c := [(1, 5)];
    carry_chains := Some [seq 0 (pred 9); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.