(**
  This is Keccak-256 and SHA3-256 ported from Go's
    golang.org/x/crypto/sha3
 *)

From Coq Require Import List.
From Coq Require HexString.
From Coq Require Import String.
From Coq Require Import NArith ZArith Lia.

From Vyper Require UInt64 Tuplevector.
From Vyper Require Import Nibble.

Local Open Scope string_scope.

Local Definition rc_hex: list string
:= "0x0000000000000001"
:: "0x0000000000008082"
:: "0x800000000000808A"
:: "0x8000000080008000"
:: "0x000000000000808B"
:: "0x0000000080000001"
:: "0x8000000080008081"
:: "0x8000000000008009"
:: "0x000000000000008A"
:: "0x0000000000000088"
:: "0x0000000080008009"
:: "0x000000008000000A"
:: "0x000000008000808B"
:: "0x800000000000008B"
:: "0x8000000000008089"
:: "0x8000000000008003"
:: "0x8000000000008002"
:: "0x8000000000000080"
:: "0x000000000000800A"
:: "0x800000008000000A"
:: "0x8000000080008081"
:: "0x8000000000008080"
:: "0x0000000080000001"
:: "0x8000000080008008"
:: nil.

Local Definition rc := map UInt64.uint64_of_Z_mod (map HexString.to_Z rc_hex).
Local Lemma rc_ok:
  map UInt64.Z_of_uint64 rc = map HexString.to_Z rc_hex.
Proof. trivial. Qed.

Local Definition rc_quads_backwards := Tuplevector.gather rc 6 4 eq_refl.

Inductive vec25 (T: Type)
:= Vec25 (a0  a1  a2  a3  a4
          a5  a6  a7  a8  a9
          a10 a11 a12 a13 a14
          a15 a16 a17 a18 a19
          a20 a21 a22 a23 a24: T).
Arguments Vec25 {_}.

Definition vec25_fill {T: Type} (x: T)
:= Vec25 x x x x x
         x x x x x
         x x x x x
         x x x x x
         x x x x x.

Local Definition uint64 := UInt64.uint64.

Definition vec25_zeros := vec25_fill (UInt64.uint64_0).

Section Permutation.

Local Notation "x ^ y"  := (UInt64.bitwise_xor x y).

Local Definition vec25_xor_tuple17_backwards (a: vec25 uint64) (b: Tuplevector.t uint64 17)
:= match a with
   | Vec25 a0  a1  a2  a3  a4
           a5  a6  a7  a8  a9
          a10 a11 a12 a13 a14
          a15 a16 a17 a18 a19
          a20 a21 a22 a23 a24 =>
      match b with
      | (b16, b15, b14, b13, b12, b11, b10, b9, b8, b7, b6, b5, b4, b3, b2, b1, b0) =>
             Vec25 ( a0 ^  b0)  (a1 ^  b1)  (a2 ^  b2)  (a3 ^  b3)  (a4 ^  b4)
                   ( a5 ^  b5)  (a6 ^  b6)  (a7 ^  b7)  (a8 ^  b8)  (a9 ^  b9)
                   (a10 ^ b10) (a11 ^ b11) (a12 ^ b12) (a13 ^ b13) (a14 ^ b14)
                   (a15 ^ b15) (a16 ^ b16)  a17         a18         a19
                    a20         a21         a22         a23         a24
      end
   end.

Local Notation "x << y" := (UInt64.shl x y) (at level 30, no associativity).
Local Notation "x >> y" := (UInt64.shr x y) (at level 30, no associativity).
Local Notation "x | y"  := (UInt64.bitwise_or x y)  (at level 30). (* dangerous! messes up match! *)
Local Notation "x & y"  := (UInt64.bitwise_and x y) (at level 30).
Local Notation "~ x"  := (UInt64.bitwise_not x).

(* here a - b = a + ~b + 1 *)
Local Definition rot x k := ((x << k) | (x >> (UInt64.add (UInt64.uint64_of_Z_mod 65) (UInt64.bitwise_not k)))).

Local Definition round (rc: uint64) (a: vec25 uint64) (b: vec25 uint64)
: vec25 uint64
:= match a, b with
   | Vec25 a0  a1  a2  a3  a4
           a5  a6  a7  a8  a9
           a10 a11 a12 a13 a14
           a15 a16 a17 a18 a19
           a20 a21 a22 a23 a24,
     Vec25 b0  b1  b2  b3  b4
           b5  b6  b7  b8  b9
           b10 b11 b12 b13 b14
           b15 b16 b17 b18 b19
           b20 b21 b22 b23 b24 =>

      let bc0 := a0 ^ a5 ^ a10 ^ a15 ^ a20 in
      let bc1 := a1 ^ a6 ^ a11 ^ a16 ^ a21 in
      let bc2 := a2 ^ a7 ^ a12 ^ a17 ^ a22 in
      let bc3 := a3 ^ a8 ^ a13 ^ a18 ^ a23 in
      let bc4 := a4 ^ a9 ^ a14 ^ a19 ^ a24 in

      let d0 := bc4 ^ rot bc1 UInt64.uint64_1 in
      let d1 := bc0 ^ rot bc2 UInt64.uint64_1 in
      let d2 := bc1 ^ rot bc3 UInt64.uint64_1 in
      let d3 := bc2 ^ rot bc4 UInt64.uint64_1 in
      let d4 := bc3 ^ rot bc0 UInt64.uint64_1 in

      let p0 := b0 ^ d0 in
      let p1 := rot (b1 ^ d1) (UInt64.uint64_of_Z_mod 44) in
      let p2 := rot (b2 ^ d2) (UInt64.uint64_of_Z_mod 43) in
      let p3 := rot (b3 ^ d3) (UInt64.uint64_of_Z_mod 21) in
      let p4 := rot (b4 ^ d4) (UInt64.uint64_of_Z_mod 14) in

      let z0  := p0 ^ (p2 & ~ p1) ^ rc in
      let z1  := p1 ^ (p3 & ~ p2) in
      let z2  := p2 ^ (p4 & ~ p3) in
      let z3  := p3 ^ (p0 & ~ p4) in
      let z4  := p4 ^ (p1 & ~ p0) in

      let q2 := rot (b5 ^ d0) (UInt64.uint64_of_Z_mod 3) in
      let q3 := rot (b6 ^ d1) (UInt64.uint64_of_Z_mod 45) in
      let q4 := rot (b7 ^ d2) (UInt64.uint64_of_Z_mod 61) in
      let q0 := rot (b8 ^ d3) (UInt64.uint64_of_Z_mod 28) in
      let q1 := rot (b9 ^ d4) (UInt64.uint64_of_Z_mod 20) in

      let z5  := q0 ^ (q2 & ~ q1) in
      let z6  := q1 ^ (q3 & ~ q2) in
      let z7  := q2 ^ (q4 & ~ q3) in
      let z8  := q3 ^ (q0 & ~ q4) in
      let z9  := q4 ^ (q1 & ~ q0) in

      let r4 := rot (b10 ^ d0) (UInt64.uint64_of_Z_mod 18) in
      let r0 := rot (b11 ^ d1) UInt64.uint64_1 in
      let r1 := rot (b12 ^ d2) (UInt64.uint64_of_Z_mod 6) in
      let r2 := rot (b13 ^ d3) (UInt64.uint64_of_Z_mod 25) in
      let r3 := rot (b14 ^ d4) UInt64.uint64_8 in

      let z10 := r0 ^ (r2 & ~ r1) in
      let z11 := r1 ^ (r3 & ~ r2) in
      let z12 := r2 ^ (r4 & ~ r3) in
      let z13 := r3 ^ (r0 & ~ r4) in
      let z14 := r4 ^ (r1 & ~ r0) in

      let s1 := rot (b15 ^ d0) (UInt64.uint64_of_Z_mod 36) in
      let s2 := rot (b16 ^ d1) (UInt64.uint64_of_Z_mod 10) in
      let s3 := rot (b17 ^ d2) (UInt64.uint64_of_Z_mod 15) in
      let s4 := rot (b18 ^ d3) UInt64.uint64_56 in
      let s0 := rot (b19 ^ d4) (UInt64.uint64_of_Z_mod 27) in

      let z15 := s0 ^ (s2 & ~ s1) in
      let z16 := s1 ^ (s3 & ~ s2) in
      let z17 := s2 ^ (s4 & ~ s3) in
      let z18 := s3 ^ (s0 & ~ s4) in
      let z19 := s4 ^ (s1 & ~ s0) in

      let t3 := rot (b20 ^ d0) (UInt64.uint64_of_Z_mod 41) in
      let t4 := rot (b21 ^ d1) UInt64.uint64_2 in
      let t0 := rot (b22 ^ d2) (UInt64.uint64_of_Z_mod 62) in
      let t1 := rot (b23 ^ d3) (UInt64.uint64_of_Z_mod 55) in
      let t2 := rot (b24 ^ d4) (UInt64.uint64_of_Z_mod 39) in

      let z20 := t0 ^ (t2 & ~ t1) in
      let z21 := t1 ^ (t3 & ~ t2) in
      let z22 := t2 ^ (t4 & ~ t3) in
      let z23 := t3 ^ (t0 & ~ t4) in
      let z24 := t4 ^ (t1 & ~ t0) in

      Vec25 z0  z1  z2  z3  z4
            z5  z6  z7  z8  z9
            z10 z11 z12 z13 z14
            z15 z16 z17 z18 z19
            z20 z21 z22 z23 z24
   end.

Local Definition permute1 {T} (a: vec25 T)
:= match a with
   | Vec25 a0  a1  a2  a3  a4
           a5  a6  a7  a8  a9
           a10 a11 a12 a13 a14
           a15 a16 a17 a18 a19
           a20 a21 a22 a23 a24 =>
     Vec25 a0  a11 a22 a8  a19
           a15 a1  a12 a23 a9
           a5  a16 a2  a13 a24
           a20 a6  a17 a3  a14
           a10 a21 a7  a18 a4
   end.
Local Definition permute2 {T} (a: vec25 T)
:= match a with
   | Vec25 a0  a1  a2  a3  a4
           a5  a6  a7  a8  a9
           a10 a11 a12 a13 a14
           a15 a16 a17 a18 a19
           a20 a21 a22 a23 a24 =>
     Vec25 a0  a16 a7  a23 a14
           a20 a11 a2  a18 a9
           a15 a6  a22 a13 a4
           a10 a1  a17 a8  a24
           a5  a21 a12 a3  a19
   end.
Local Definition permute3 {T} (a: vec25 T)
:= match a with
   | Vec25 a0  a1  a2  a3  a4
           a5  a6  a7  a8  a9
           a10 a11 a12 a13 a14
           a15 a16 a17 a18 a19
           a20 a21 a22 a23 a24 =>
     Vec25 a0  a6  a12 a18 a24
           a10 a16 a22 a3  a9
           a20 a1  a7  a13 a19
           a5  a11 a17 a23 a4
           a15 a21 a2  a8  a14
   end.
Local Lemma permute1_of_permute3 {T} (a: vec25 T):
  permute1 (permute3 a) = a.
Proof. now destruct a. Qed.
Local Lemma permute3_of_permute1 {T} (a: vec25 T):
  permute3 (permute1 a) = a.
Proof. now destruct a. Qed.
Local Lemma permute2_of_permute2 {T} (a: vec25 T):
  permute2 (permute2 a) = a.
Proof. now destruct a. Qed.

Local Definition quad_round (a: vec25 uint64) (rcs: Tuplevector.t uint64 4)
: vec25 uint64
:= match rcs with
   | (rc4, rc3, rc2, rc1) =>
        let a1 := permute1 (round rc1 a  (permute3 a))  in
        let a2 := permute2 (round rc2 a1 (permute2 a1)) in
        let a3 := permute3 (round rc3 a2 (permute1 a2)) in
        round rc4 a3 a3
   end.

Local Definition F1600 := fold_left quad_round rc_quads_backwards.

End Permutation.

(* Create padding of the given length (of the padding, not of the data). *)
Local Definition padding (len: positive) (start: uint64) (* start is 1 for Ethereum's Keccak, otherwise 6 *)
: list byte
:= match len with
   | 1%positive => UInt64.byte_of_uint64 (UInt64.bitwise_or UInt64.uint64_128 start) :: nil
   | _ => (UInt64.byte_of_uint64 start) ::
             repeat (UInt64.byte_of_uint64 UInt64.uint64_0) (N.to_nat (N.pos len - 2)) ++
                UInt64.byte_of_uint64 UInt64.uint64_128 :: nil
   end.

(* The padding has the requested length *)
Local Lemma padding_ok (len: positive) (start: uint64):
  List.length (padding len start) = Pos.to_nat len.
Proof.
unfold padding.
remember (UInt64.byte_of_uint64 start ::
          repeat (UInt64.byte_of_uint64 UInt64.uint64_0) (N.to_nat (N.pos len - 2)) ++
          UInt64.byte_of_uint64 UInt64.uint64_128 ::
          nil) as l.
assert (cons_length: forall {T} h (t: list T), List.length (h :: t) = S (List.length t)) by easy.
destruct len; cbn; subst;
  repeat (rewrite List.app_length || rewrite List.repeat_length || rewrite cons_length);
  replace (List.length (@nil byte)) with 0 by trivial; lia.
Qed.

(** Calculate the padding length given the data length. *)
Definition padding_length (data_length: N) (rate: positive)
: positive
:= match (data_length mod N.pos rate)%N with
   | 0%N => rate
   | Npos p => rate - p
   end.

Local Lemma padding_length_ok (data_length: N) (rate: positive):
  ((data_length + N.pos (padding_length data_length rate)) mod N.pos rate = 0)%N.
Proof.
unfold padding_length.
remember (data_length mod N.pos rate)%N as m.
destruct m; rewrite N.add_mod by discriminate; rewrite<- Heqm.
{ rewrite N.add_0_l. rewrite N.mod_same by discriminate. apply N.mod_0_l. discriminate. }
assert(L: (N.pos p < N.pos rate)%N).
{ rewrite Heqm. apply N.mod_upper_bound. discriminate. }
replace (N.pos (rate - p) mod N.pos rate)%N with (N.pos (rate - p)).
2:{ symmetry. apply N.mod_small. lia. }
replace (N.pos p + N.pos (rate - p))%N with (N.pos rate) by lia.
apply N.mod_same. discriminate.
Qed.

Local Definition pad (unpadded_data: list byte) (rate: positive) (start: uint64)
: list byte
:= (unpadded_data ++ padding (padding_length (N.of_nat (List.length unpadded_data)) rate) start)%list.

Local Lemma pad_ok_mod (data: list byte) (rate: positive) (start: uint64):
  (N.of_nat (List.length (pad data rate start)) mod N.pos rate = 0)%N.
Proof.
unfold pad. rewrite List.app_length. rewrite Nat2N.inj_add.
remember (List.length data) as n. rewrite padding_ok.
rewrite positive_nat_N. rewrite padding_length_ok.
trivial.
Qed.

Local Lemma pad_ok (data: list byte) (rate: positive) (start: uint64):
  let d := List.length (pad data rate start) / Pos.to_nat rate in
    List.length (pad data rate start) = d * Pos.to_nat rate.
Proof.
apply Nat2N.inj.
assert (M := pad_ok_mod data rate start).
remember (List.length  _) as len. clear Heqlen.
match goal with |- ?lhs = ?rhs => rewrite<- (N.add_0_r rhs) end.
rewrite<- M.
rewrite Nat.mul_comm.
rewrite Nat2N.inj_mul.
rewrite Arith2.Nat2N_inj_div.
remember (Pos.to_nat rate) as r.
assert (R: N.pos rate = N.of_nat r).
{ subst. symmetry. apply positive_nat_N. }
rewrite R. rewrite R in M.
apply N.div_mod.
subst. assert(P := Pos2Nat.is_pos rate).
destruct (Pos.to_nat rate).
{ now apply Nat.lt_irrefl in P. }
discriminate.
Qed.

Local Lemma can_gather_by_8 (n: nat):
  n = n / 136 * 136  ->  n = (n / 136 * 17) * 8.
Proof.
now rewrite<- Nat.mul_assoc.
Qed.

Local Definition pad_by_136_and_gather_into_uint64s (data: list byte) (padding_start: uint64)
:= let padded := pad data 136%positive padding_start in
   let PadOk  := pad_ok data 136%positive padding_start in
   List.map UInt64.uint64_of_be_bytes
            (Tuplevector.gather padded _ 8 (can_gather_by_8 _ PadOk)).

Local Lemma pad_by_136_and_gather_into_uint64s_length (data: list byte) (s: uint64):
  List.length (pad_by_136_and_gather_into_uint64s data s)
   =
  (List.length (pad data 136 s)) / 136 * 17.
Proof.
unfold pad_by_136_and_gather_into_uint64s.
rewrite List.map_length.
apply (Tuplevector.gather_length (pad data 136 s)
             (Datatypes.length (pad data 136 s) / 136 * 17) 8
             (can_gather_by_8 (Datatypes.length (pad data 136 s)) (pad_ok data 136 s))).
Qed.

Local Definition blocks (data: list byte) (padding_start: uint64)
:= Tuplevector.gather (pad_by_136_and_gather_into_uint64s data padding_start)
                      _ 17
                      (pad_by_136_and_gather_into_uint64s_length data padding_start).

Local Definition absorb (data: list byte) (padding_start: uint64)
:= fold_left (fun state block => F1600 (vec25_xor_tuple17_backwards state block))
             (blocks data padding_start)
             vec25_zeros.

Local Definition squeeze_256 (a: vec25 uint64)
:= match a with
   | Vec25 a0  a1  a2  a3  _
           _   _   _   _   _
           _   _   _   _   _
           _   _   _   _   _
           _   _   _   _   _ =>
      let eights: list (Tuplevector.t byte 8)
                := map UInt64.uint64_to_le_bytes (a0 :: a1 :: a2 :: a3 :: nil)
      in fold_right Tuplevector.app_to_list nil eights
   end.

Local Lemma squeeze_256_length a:
  List.length (squeeze_256 a) = 32.
Proof.
now destruct a.
Qed.

Definition keccak_256 (data: list byte): list byte := squeeze_256 (absorb data UInt64.uint64_1).
Definition sha3_256   (data: list byte): list byte := squeeze_256 (absorb data (UInt64.uint64_of_Z_mod 6)).

Lemma keccak_256_length (data: list byte):
  List.length (keccak_256 data) = 32.
Proof.
unfold keccak_256. apply squeeze_256_length.
Qed.
Lemma sha3_256_length (data: list byte):
  List.length (sha3_256 data) = 32.
Proof.
unfold sha3_256. apply squeeze_256_length.
Qed.

Definition keccak_256_of_string (s: String.string)
:= keccak_256 (bytes_of_string s).
Definition sha3_256_of_string (s: String.string)
:= sha3_256 (bytes_of_string s).

Lemma keccak_256_of_string_length (s: String.string):
  List.length (keccak_256_of_string s) = 32.
Proof.
unfold keccak_256_of_string. apply keccak_256_length.
Qed.
Lemma sha3_256_of_string_length (s: String.string):
  List.length (sha3_256_of_string s) = 32.
Proof.
unfold sha3_256_of_string. apply sha3_256_length.
Qed.

Local Fixpoint N_of_bytes_rec (start: N) (bytes: list byte)
:= match bytes with
   | nil => start
   | (h :: t)%list => N_of_bytes_rec (N.shiftl start 8 + N_of_byte h) t
   end.
Definition N_of_bytes := N_of_bytes_rec 0.

Definition keccak_256_N (data: list byte): N
:= N_of_bytes (keccak_256 data).

Definition keccak_256_N_of_string (s: String.string): N
:= N_of_bytes (keccak_256_of_string s).

Definition keccak_256_hex (data: list byte)
: String.string
:= hex_of_bytes (keccak_256 data) true.
Definition sha3_256_hex (data: list byte)
: String.string
:= hex_of_bytes (sha3_256 data) true.

Definition keccak_256_hex_of_string (s: String.string)
: String.string
:= hex_of_bytes (keccak_256_of_string s) true.
Definition sha3_256_hex_of_string (s: String.string)
: String.string
:= hex_of_bytes (sha3_256_of_string s) true.

(* This test is from Go's sha3_test.go. *)
Local Example keccak_256_smoke_test:
  keccak_256_hex_of_string "abc"
   =
  "4e03657aea45a94fc7d47ba826c8d667c0d1e6e33a64a036ec44f58fa12d6c45".
Proof. trivial. Qed.

(* A byte-long test from XKCP's ShortMsgKAT_SHA3-256.txt. *)
Local Example sha3_256_test_CC:
  sha3_256_hex (byte_of_N (HexString.to_N "0xCC") :: nil)
   =
  "677035391cd3701293d385f037ba32796252bb7ce180b00b582dd9b20aaad7f0".
Proof. trivial. Qed.

(* We won't prove this for everything. *)
Example keccak_256_N_smoke_test:
  HexString.to_N ("0x" ++ keccak_256_hex_of_string "foo") = keccak_256_N_of_string "foo".
Proof. trivial. Qed.


From Coq.Relations Require Import Relation_Operators.
From Coq.Wellfounded Require Import Lexicographic_Product.

From TLA.examples.mutex Require Import nodup automation safety.

Section example.

Implicit Types (σ: State) (s: Config) (t: Tid) (tp: gmap Tid pc.t).
Implicit Types (l: bool) (q: list Tid).

Lemma fair_step (tid: nat) :
  fair ⊢ weak_fairness (step tid).
Proof.
  unfold fair.
  (* apply doesn't work due to the wrong unification heuristics *)
  refine (forall_apply _ _).
Qed.

(* specialized wf1 rule that handles some common manipulation for this state
machine *)
Lemma mutex_wf1 (t: Tid) (P Q: Config → Prop) :
  (∀ t' σ tp pc σ' pc',
     let s := {| state := σ; tp := tp|} in
     let s' := {| state := σ'; tp := <[t' := pc']> tp |} in
     ∀ (Hpre: P s)
       (Hinv: all_invs s)
       (Hinv': all_invs s')
       (Hneq: t ≠ t')
       (Hlookup: tp !! t' = Some pc)
       (Hstep: thread_step t' (σ, pc) (σ', pc')),
       P s' ∨ Q s'
  ) →
  (∀ σ tp pc σ' pc',
     let s := {| state := σ; tp := tp|} in
     let s' := {| state := σ'; tp := <[t := pc']> tp |} in
     ∀ (Hpre: P s)
       (Hinv: all_invs s)
       (Hlookup: tp !! t = Some pc)
       (Hstep: thread_step t (σ, pc) (σ', pc')),
     Q s'
  ) →
  (∀ l q tp,
     let s := {| state := {| lock := l; queue := q |}; tp := tp |} in
     P s →
     ∃ pc, tp !! t = Some pc ∧
           (pc = pc.kernel_wait → t ∉ q) ∧
           pc ≠ pc.finished
  ) →
  spec ⊢ ⌜P⌝ ~~> ⌜Q⌝.
Proof.
  simpl.
  intros H1 H2 H3.
  apply (add_safety all_invs_ok).
  tla_apply (wf1 (step t)).
  { rewrite /spec.
    tla_split; [ tla_assumption | tla_apply fair_step ]. }
  - intros [σ tp] [σ' tp'].
    intros Hp Hnext.
    destruct Hnext as [Hnext [Hinvs Hinvs']].
    apply next_inv in Hnext as
        [[[=] ?] |
          (t' & pc & pc' & Hlookup & Hstep & ?)]; subst; eauto.
    (* in one branch we use the proof that P ∨ Q is preserved, in the other we
    use the proof that [step t] leads to Q *)
    destruct (decide (t = t')); subst; eauto.
  - intros [σ tp] [σ' tp'].
    intros Hp [_ [Hinvs Hinvs']] Hstep.
    destruct Hstep as [pc'' [Hlookup [ρ' [Hstep Heq]]]].
    invc Heq.
    destruct ρ' as [σ' tp']; simpl in *.
    eauto.
  - intros [[l q] tp] HP.
    rewrite step_enabled /=.
    eauto.
Qed.

Definition measure (s: Config) : gset Tid * gset Tid * gset Tid :=
  (wait_set s.(tp), pc_set pc.unlock_store s.(tp), pc_set pc.unlock_wake s.(tp)).

Definition h_lt : relation (gset Tid * gset Tid * gset Tid) :=
  slexprod _ _ (slexprod _ _ (⊂) (⊂)) (⊂).

Infix "≺" := h_lt (at level 70).

Definition h_le : relation (gset Tid * gset Tid * gset Tid) :=
  λ ss ss', ss = ss' ∨ ss ≺ ss'.

Infix "⪯" := h_le (at level 70).

Lemma unlock_set_lock_inv s :
  all_invs s →
  s.(state).(lock) = true →
  ∃ t, pc_set pc.unlock_store s.(tp) = {[t]} ∧
       s.(tp) !! t = Some pc.unlock_store.
Proof.
  destruct 1; intros Hlock.
  apply Hlocked in Hlock as [t Hlock].
  rewrite /lock_held in Hlock.
  exists t; intuition idtac.
  cut ({[t]} ⊆ pc_set pc.unlock_store s.(tp) ⊆ {[t]}); [ set_solver | ].
  split.
  - apply singleton_subseteq_l.
    auto.
  - apply elem_of_subseteq => t'.
    rewrite elem_pc_set => Hlock'.
    assert (t = t') by (apply Hexcl; eauto); set_solver.
Qed.

Lemma unlock_set_unlocked_inv s :
  all_invs s →
  pc_set pc.unlock_store s.(tp) = ∅ →
  s.(state).(lock) = false.
Proof.
  intros Hinv Hempty.
  destruct s.(state).(lock) eqn:Hlock; [ exfalso | done ].
  apply unlock_set_lock_inv in Hlock as [t Hlock]; intuition idtac.
  set_solver.
Qed.

Hint Constructors slexprod : core.

Lemma measure_lt_unfold Sₗ Sᵤ S__w Sₗ' Sᵤ' S__w' :
  (Sₗ', Sᵤ', S__w') ≺ (Sₗ, Sᵤ, S__w) ↔
  Sₗ' ⊂ Sₗ ∨
  (Sₗ' = Sₗ ∧ Sᵤ' ⊂ Sᵤ) ∨
  (Sₗ' = Sₗ ∧ Sᵤ' = Sᵤ ∧ S__w' ⊂ S__w).
Proof.
  split.
  - intros H; invc H; eauto.
    invc H1; eauto.
  - rewrite /h_lt. intuition (subst; eauto).
Qed.

Lemma tuple_eq_unfold (S1 S2 S3 S1' S2' S3': gset Tid) :
  (S1, S2, S3) = (S1', S2', S3') ↔
  S1 = S1' ∧ S2 = S2' ∧ S3 = S3'.
Proof. naive_solver. Qed.

Hint Rewrite tuple_eq_unfold measure_lt_unfold : pc.

Lemma eventually_wake_progress Sₗ Sᵤ S__w :
  S__w ≠ ∅ →
  spec ⊢ ⌜λ s, measure s = (Sₗ, Sᵤ, S__w)⌝ ~~>
         ⌜λ s, measure s ≺ (Sₗ, Sᵤ, S__w)⌝.
Proof.
  intros [t Hel]%set_choose_L.
  rewrite /measure.
  apply (mutex_wf1 t); simpl; intros.
  - destruct_step; stm.
  - assert (pc = pc.unlock_wake); [ | by stm ].
    { stm.
      apply elem_pc_set in Hel; congruence. }
  - assert (tp !! t = Some pc.unlock_wake); [ | naive_solver ].
    stm.
    apply elem_pc_set in Hel; congruence.
Qed.

Lemma eventually_unlock_progress Sₗ Sᵤ S__w :
  Sᵤ ≠ ∅ →
  spec ⊢ ⌜λ s, measure s = (Sₗ, Sᵤ, S__w)⌝ ~~>
         ⌜λ s, measure s ≺ (Sₗ, Sᵤ, S__w)⌝.
Proof.
  intros [t Hel]%set_choose_L.
  rewrite /measure.
  apply (mutex_wf1 t); simpl; intros.
  - destruct_step; stm.
  - assert (pc = pc.unlock_store); [ | by stm ].
    { stm.
      apply elem_pc_set in Hel; congruence. }
  - assert (tp !! t = Some pc.unlock_store); [ | naive_solver ].
    stm.
    apply elem_pc_set in Hel; congruence.
Qed.

Lemma eventually_atomic_cas_progress Sₗ t :
  spec ⊢ ⌜λ s, measure s = (Sₗ, ∅, ∅) ∧
               s.(tp) !! t = Some pc.lock_cas ⌝ ~~>
         ⌜λ s, measure s ≺ (Sₗ, ∅, ∅)⌝.
Proof.
  rewrite /measure.
  apply (mutex_wf1 t); simpl; intros.
  - destruct_step; stm.
  - stm.
    destruct l0; stm.
    exfalso.
    apply unlock_set_lock_inv in Hinv as [t' ?]; intuition.
    simpl in *.
    set_solver.
  - naive_solver.
Qed.

Lemma eventually_futex_wait_progress Sₗ t :
  spec ⊢ ⌜λ s, measure s = (Sₗ, ∅, ∅) ∧
               s.(tp) !! t = Some pc.futex_wait ⌝ ~~>
         ⌜λ s, measure s ≺ (Sₗ, ∅, ∅)⌝.
Proof.
  eapply leads_to_detour; [ | apply (eventually_atomic_cas_progress _ t); eauto ].
  lt_simp.
  rewrite /measure.
  apply (mutex_wf1 t); simpl; intros.
  - destruct_step; stm.
  - stm.
    destruct l0; stm.
    exfalso.
    apply unlock_set_lock_inv in Hinv as [t' ?]; intuition.
    simpl in *.
    set_solver.
  - naive_solver.
Qed.

Lemma eventually_kernel_wait_progress Sₗ t :
  spec ⊢ ⌜λ s, measure s = (Sₗ, ∅, ∅) ∧
               s.(tp) !! t = Some pc.kernel_wait ⌝ ~~>
         ⌜λ s, measure s ≺ (Sₗ, ∅, ∅)⌝.
Proof.
  lt_simp.
  leads_to_trans (∃ t', ⌜λ s, measure s = (Sₗ, ∅, ∅) ∧
                              (s.(tp) !! t' = Some pc.kernel_wait ∧ t' ∉ s.(state).(queue) ∨
                                s.(tp) !! t' = Some pc.lock_cas)⌝)%L.
  { apply (leads_to_assume _ all_invs_ok).
    lt_unfold.
    intros [ [Hmeasure Hlookup] Hinv ].
    destruct s.(state).(queue) eqn:Hq.
    - exists t; intuition.
      rewrite /thread_can_signal.
      left. intuition.
      set_solver.
    - rewrite /measure in Hmeasure |- *; stm.
      pose proof Hinv as Hinv'.
      apply unlock_set_unlocked_inv in Hinv'; eauto. stm_simp.
      destruct Hinv.
      rewrite /lock_free_queue_inv /= in Hcan_lock.
      edestruct Hcan_lock; eauto.
      destruct H; stm.
  }

  lt_intro t'.
  rewrite -combine_state_preds -combine_or_preds. rewrite ?tla_and_distr_l.
  lt_split_or; lt_simp.
  - eapply leads_to_detour; [ | apply (eventually_atomic_cas_progress _ t'); eauto ].
    rewrite /measure /thread_can_signal.
    lt_simp.
    apply (mutex_wf1 t'); simpl; intros.
    + destruct_step; stm.
      simp_props.
      left; set_solver.
    + stm.
    + naive_solver.
  - lt_apply eventually_atomic_cas_progress.
Qed.

Lemma eventually_lock_progress Sₗ t :
  t ∈ Sₗ →
  spec ⊢ ⌜λ s, measure s = (Sₗ, ∅, ∅) ⌝ ~~>
         ⌜λ s, measure s ≺ (Sₗ, ∅, ∅)⌝.
Proof.
  intros Hel.
  leads_to_trans
    (⌜λ s, measure s = (Sₗ, ∅, ∅)⌝ ∧
    (⌜λ s, s.(tp) !! t = Some pc.lock_cas⌝ ∨
     ⌜λ s, s.(tp) !! t = Some pc.futex_wait⌝ ∨
     ⌜λ s, s.(tp) !! t = Some pc.kernel_wait⌝))%L.
  { lt_unfold.
    intros Hmeasure.
    split; auto.
    rewrite /measure in Hmeasure; stm_simp.
    apply elem_of_wait_set in Hel as [pc [Hlookup H]].
    rewrite /wait_pc in H; naive_solver. }
  lt_split_or; [ | lt_split_or ]; lt_simp.
  - apply eventually_atomic_cas_progress.
  - apply eventually_futex_wait_progress.
  - apply eventually_kernel_wait_progress.
Qed.

Lemma eventually_progress Sₗ Sᵤ S__w :
  (Sₗ, Sᵤ, S__w) ≠ (∅, ∅, ∅) →
  spec ⊢ ⌜λ s, measure s = (Sₗ, Sᵤ, S__w) ⌝ ~~>
         ⌜λ s, measure s ≺ (Sₗ, Sᵤ, S__w)⌝.
Proof.
  intros.
  assert (S__w ≠ ∅ ∨ Sᵤ ≠ ∅ ∨ (S__w = ∅ ∧ Sᵤ = ∅ ∧ Sₗ ≠ ∅)).
  { destruct (decide (S__w = ∅)); subst; auto.
    destruct (decide (Sᵤ = ∅)); subst; auto.
    destruct (decide (Sₗ = ∅)); subst; auto.
  }
  intuition subst.
  - apply eventually_wake_progress; auto.
  - apply eventually_unlock_progress; auto.
  - apply set_choose_L in H3 as [t Hel].
    eapply eventually_lock_progress; eauto.
Qed.

Lemma h_lt_wf :
  well_founded (h_lt).
Proof.
  apply wf_slexprod; [ apply wf_slexprod | ]; apply set_wf.
Qed.

Theorem eventually_terminated :
  spec ⊢ ◇⌜terminated⌝.
Proof.
  apply (leads_to_apply ⌜λ s, True⌝).
  { unseal. }

  set (h := λ ss s, measure s = ss).
  lt_apply (lattice_leads_to_ex h_lt_wf h (∅, ∅, ∅)).

  - lt_unfold; intros _.
    rewrite /h. eauto.
  - intros [[Sₗ Sᵤ] S__w] Hnotempty.
    rewrite /h.
    lt_apply eventually_progress; auto.
    lt_auto.
  - rewrite /h /terminated /measure.
    lt_unfold; stm.
    destruct pc; trivial; exfalso; eauto.
    + assert (tid ∈ wait_set tp) by eauto; set_solver.
    + assert (tid ∈ wait_set tp) by eauto; set_solver.
    + assert (tid ∈ wait_set tp) by eauto; set_solver.
Qed.

End example.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(* This contribution was updated for Coq V5.10 by the COQ workgroup.        *)
(* January 1995                                                             *)
(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*  valid.v                                                                 *)
(*                                                                          *)
(*  This file contains definitions of valid environments and                *)
(*  configurations, and also a related property.                            *)
(*                                                                          *)
(*                                                                          *)
(*  Jill Seaman                                                             *)
(*  Coq V5.8                                                                *)
(*  November 1993                                                           *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                                 valid.v                                  *)
(****************************************************************************)

Require Import syntax.
Require Import List.
Require Import utils.
Require Import environments.

Require Import typecheck.

(****************************************************************)
(*							      	*)
(*  Validity functions for OS environments and configurations 	*)
(*							      	*)
(*                   Domt(A)|- e:t  VAL(A) 			*)
(*  valid_env     : -----------------------			*)
(*                     VAL ([v:t->e]*A)				*)
(*							      	*)
(*                   Domt(A)|- e:t  VAL(A)			*)
(* valid_config   : -----------------------			*)
(*                       VAL<<e,A>> 				*)
(*							      	*)
(****************************************************************)

Inductive valid_env : OS_env -> Prop :=
  | valid_nil : valid_env nil
  | valid_cons :
      forall (v : vari) (t : ty) (e : tm) (A : OS_env),
      TC (OS_Dom_ty A) e t -> valid_env A -> valid_env ((v, t, e) :: A).

Inductive valid_config (c : config) : Prop :=
    valid_cfg :
      valid_env (cfgenv c) ->
      forall t : ty, TC (OS_Dom_ty (cfgenv c)) (cfgexp c) t -> valid_config c.

(****************************************)
(*  inv_valid_cons		 	*)
(*	Val([v:t->e]A) --->		*)
(*         Val(A) /\ Domt(A)|-e:t	*)
(****************************************)
Definition valid_c (A : OS_env) :=
  match A return Prop with
  | nil =>
      (* nil *)  True
      (* cons *)
  | vtt :: A' => valid_env A' /\ TC (OS_Dom_ty A') (snd vtt) (snd (fst vtt))
  end.

Goal
forall (v : vari) (t : ty) (e : tm) (A : OS_env),
valid_env ((v, t, e) :: A) -> valid_env A /\ TC (OS_Dom_ty A) e t.

intros v t e A H.
change (valid_c ((v, t, e) :: A)) in |- *.
elim H; simpl in |- *; exact I || intros; split; assumption.
Save inv_valid_cons.


(** * Axiom of choice *)

Require Export UniMath.MoreFoundations.DecidablePropositions.
Require Export UniMath.MoreFoundations.Sets.

(** ** Preliminaries  *)

Lemma pr1_issurjective {X : UU} {P : X -> UU} :
  (∏ x : X, ∥ P x ∥) -> issurjective (pr1 : (∑ x, P x) -> X).
(* move upstream later *)
Proof.
  intros ne x. simple refine (hinhuniv _ (ne x)).
  intros p. apply hinhpr.
  exact ((x,,p),,idpath _).
Defined.

(** ** Characterize equivalence relations on [bool] *)

Definition eqrel_on_bool (P:hProp) : eqrel boolset.
(* an equivalence relation on bool amounts to a single proposition *)
Proof.
  set (ifb := bool_rect (λ _:bool, hProp)).
  exists (λ x y, ifb (ifb htrue P y) (ifb P htrue y) x).
  repeat split.
  { intros x y z a b.
    induction x.
    - induction z.
      + exact tt.
      + induction y.
        * exact b.
        * exact a.
    - induction z.
      + induction y.
        * exact a.
        * exact b.
      + exact tt. }
  { intros x. induction x; exact tt. }
  { intros x y a. induction x; induction y; exact a. }
Defined.

Lemma eqrel_on_bool_iff (P:hProp) (E := eqrel_on_bool P) (f := setquotpr E) : f true = f false <-> P.
Proof.
  split.
  { intro q. change (E true false). apply (invmap (weqpathsinsetquot _ _ _)).
    change (f true = f false). exact q. }
  { intro p. apply iscompsetquotpr. exact p. }
Defined.

(** ** Statements of Axiom of Choice *)

Local Open Scope logic.

(** We write these axioms as types rather than as axioms, which would assert them to be true, to
    force them to be mentioned as explicit hypotheses whenever they are used. *)

Definition AxiomOfChoice : hProp := ∀ (X:hSet), ischoicebase X.

Definition AxiomOfChoice_surj : hProp :=
  ∀ (X:hSet) (Y:UU) (f:Y→X), issurjective f ⇒ ∃ g, ∀ x, f (g x) = x.
(** Notice that the equation above is a proposition only because X is a set, which is not required
    in the previous formulation.  The notation for "=" currently in effect uses [eqset] instead of
    [paths].  *)

(** ** Implications between forms of the Axiom of Choice *)

Lemma AC_impl2 : AxiomOfChoice <-> AxiomOfChoice_surj.
Proof.
  split.
  - intros AC X Y f surj.
    use (squash_to_prop (AC _ _ surj) (propproperty _)).
    intro s.
    use hinhpr.
    use tpair.
    + exact (λ y, hfiberpr1 f y (s y)).
    + exact (λ y, hfiberpr2 f y (s y)).
  - intros AC X P ne.
    use (hinhuniv _ (AC X _ _ (pr1_issurjective ne))).
    intros sec. use hinhpr. intros x.
    induction (pr2 sec x). exact (pr2 (pr1 sec x)).
Defined.

(** ** The Axiom of Choice implies a type receives a surjective map from a set *)

Theorem SetCovering (X:Type) : AxiomOfChoice -> ∃ (S:hSet) (f:S->X), issurjective f.
Proof.
  (** We use the axiom of choice to find a splitting f of the projection map g from X
     onto its set [pi0 X] of connected components.  Since the image of f contains one
     point in every component of X, f is surjective.
   *)
  intros ac.
  assert (ac' := pr1 AC_impl2 ac); clear ac; unfold AxiomOfChoice_surj in ac'.
  set (S := pi0 X : hSet).
  set (g := pi0pr X : X -> S).
  assert (f := ac' _ _ g (issurjsetquotpr _)); clear ac'.
  apply (squash_to_prop f).
  { apply propproperty. }
  clear f; intros [f eqn].
  apply hinhpr.
  exists S.
  exists f.
  intros x.
  use (@squash_to_prop (f (g x) = x)%type).
  { apply (invmap (weqpathsinsetquot (pathseqrel X) _ _)).
    change (g (f (g x)) = g x)%type.
    exact (eqn (g x)). }
  { apply propproperty. }
  intros e.
  apply hinhpr.
  exists (g x).
  exact e.
Defined.

(** ** The Axiom of Choice implies the Law of the Excluded Middle  *)

(** This result is covered in the HoTT book, is due to Radu Diaconescu, "Axiom of choice and
    complementation", Proceedings of the American Mathematical Society, 51 (1975) 176–178, and was
    first mentioned on page 4 in F. W. Lawvere, "Toposes, algebraic geometry and logic (Conf.,
    Dalhousie Univ., Halifax, N.S., 1971)", pp. 1–12, Lecture Notes in Math., Vol. 274, Springer,
    Berlin, 1972.

    The idea is to define an equivalence relation E on bool by setting [E true false := P], to use
    AC to split the surjection f from bool to its quotient Y by E with a function g, and to observe
    bool has decidable equality, and thus so does Y, because then Y is a retract of bool, to use
    that to decide whether [f true = f false], and thus to decide P. *)

Theorem AC_to_LEM : AxiomOfChoice -> LEM.
Proof.
  intros AC P.
  set (f := setquotpr _ : bool -> setquotinset (eqrel_on_bool P)).
  assert (q := pr1 AC_impl2 AC _ _ f (issurjsetquotpr _)).
  apply (squash_to_prop q).
  { apply isapropdec, propproperty. }
  intro sec. induction sec as [g h].
  (* reduce decidability of P to decidability of [f true = f false] *)
  apply (logeq_dec (eqrel_on_bool_iff P)).
  (* a retract of a type with decidable equality has decidable equality *)
  apply (retract_dec f g h isdeceqbool).
Defined.

(** A weaker Axiom of Choice *)

(** Having proved above that the Axiom of Choice implies the Law of the Excluded Middle, we would
    like to formulate a weaker axiom of choice that would be usable in formalization, but without
    implying the Law of the Excluded Middle, thus making it a more acceptable omniscience principle.
    Our idea here is to add the hypothesis that the base set have decidable equality.  Classically,
    there is no difference between the two axioms.  Recall from [isasetifdeceq] that a type with
    decidable equality is a set, so we don't include being a set explicitly in the statement of the
    axiom. *)

Definition AxiomOfDecidableChoice : hProp := ∀ (X:UU), isdeceq X ⇒ ischoicebase X.

Theorem AC_iff_ADC_and_LEM : AxiomOfChoice ⇔ AxiomOfDecidableChoice ∧ LEM.
Proof.
  split.
  - intros AC. split.
    + intros X i. exact (AC (make_hSet X (isasetifdeceq X i))).
    + exact (AC_to_LEM AC).
  - intros [adc lem] X. refine (adc X _). intros x y. exact (lem (x = y)).
Defined.


From HoTT Require Import Basics.
From HoTT Require Import HSet.
From HoTT Require Import Categories.
From HoTT Require Import Spaces.Finite.
Require Import Misc.
Require Import Limits.Graph.
Require Import Limits.Product.
Require Import Limits.Terminal.
Require Import Limits.Equalizer.
Require Import Limits.GraphOfFunctors.

Local Open Scope morphism_scope.

Section Pullback.
  Context {C : PreCategory}.

  Let f1 : Fin 3 := inr tt.
  Let f2 : Fin 3 := inl (inr tt).
  Let f3 : Fin 3 := inl (inl (inr tt)).

  Context {a b c : object C}.
  Context {f : morphism C a c} {g : morphism C b c}.

  Definition PullbackGr : Graph C (Fin 3) (Fin 2).
  Proof.
    simple refine {| gr_vertex := fun f =>
                                    match f with
                                    | inr tt => a
                                    | inl (inr tt) => b
                                    | _ => c
                                    end
                  ;  gr_edges := _
                  |}.
    intro x. destruct x.
    - exists f1. exists f3. exact f.
    - exists f2. exists f3. exact g.
  Defined.
  Definition Pullback := Limit PullbackGr.
  Definition fprod_obj : Pullback -> object C :=
    fun lim => cn_top (lim_cone lim).
  Definition fpi1 (fprod : Pullback) : morphism C (fprod_obj fprod) a :=
    cn_side (lim_cone fprod) f1.
  Definition fpi2 (fprod : Pullback) : morphism C (fprod_obj fprod) b :=
    cn_side (lim_cone fprod) f2.
  Lemma fpi_comm (fprod : Pullback) : f o fpi1 fprod = g o fpi2 fprod.
  Proof.
    rewrite (cn_comm (lim_cone fprod) fin1).
    rewrite (cn_comm (lim_cone fprod) fin2).
    reflexivity.
  Qed.

  Definition fprod_cone (fprod : Pullback) {d : object C} :
    forall(c1 : morphism C d a) (c2 : morphism C d b),
      f o c1 = g o c2 -> Cone PullbackGr.
  Proof.
    intros c1 c2 Hcomm. srapply mkCone; [ exact d | idtac | idtac ].
    - intro n. destruct n as [ n | u ]; [ destruct n | destruct u; exact c1 ].
      + destruct f0 as [ f0 | u ]; [ empty_ind | destruct u ]. exact (f o c1).
      + destruct u. exact c2.
    - intro n; destruct n as [ n | u ];
        [ destruct n as [ n | u ]; [ empty_ind | idtac ] | idtac ];
        destruct u; simpl; try reflexivity.
      rewrite Hcomm. reflexivity.
  Defined.
  Lemma fprod_ex (fprod : Pullback) {d : object C} :
    forall(c1 : morphism C d a) (c2 : morphism C d b),
      f o c1 = g o c2 ->
      exists(m : morphism C d (fprod_obj fprod)),
        fpi1 fprod o m = c1 /\ fpi2 fprod o m = c2.
  Proof.
    intros c1 c2 Hcomm. pose (cn := fprod_cone fprod c1 c2 Hcomm).
    pose (mph := lim_ex fprod cn). exists(cnmph_mph mph). split.
    - apply (cnmph_comm mph f1).
    - apply (cnmph_comm mph f2).
  Qed.

  Definition fprod_mph (fprod : Pullback) {d : object C} :
    forall(m : morphism C d (fprod_obj fprod)),
    forall(c1 : morphism C d a) (c2 : morphism C d b),
    forall(Hcomm : f o c1 = g o c2),
      fpi1 fprod o m = c1 ->
      fpi2 fprod o m = c2 ->
      ConeMorphism (fprod_cone fprod c1 c2 Hcomm) (lim_cone fprod).
  Proof.
    intros m c1 c2 Hcomm Hc1 Hc2. srapply mkCnMph; [ exact m | idtac ].
    intro n; destruct n as [ [ [ e | [ ] ] | [ ] ] | [ ] ];
      [ empty_ind | idtac | idtac | idtac ];
      [ idtac | apply Hc2 | apply Hc1 ]; simpl.
    rewrite <- (cn_comm (lim_cone fprod) fin1). rewrite associativity.
    rewrite Hc2. rewrite Hcomm. reflexivity.
  Defined.
  Lemma fprod_uniq (fprod : Pullback) {d : object C} :
    forall(m1 m2 : morphism C d (fprod_obj fprod)),
      fpi1 fprod o m1 = fpi1 fprod o m2 ->
      fpi2 fprod o m1 = fpi2 fprod o m2 ->
      m1 = m2.
  Proof.
    intros m1 m2 Hpi1 Hpi2.
    assert (f o (fpi1 fprod o m2) = g o (fpi2 fprod o m2)) as Hcomm.
    { rewrite <- associativity. rewrite <- associativity. f_ap. apply fpi_comm. }
    pose (mph1 := fprod_mph fprod m1 (fpi1 fprod o m2) (fpi2 fprod o m2) Hcomm Hpi1 Hpi2).
    pose (mph2 := fprod_mph fprod m2 (fpi1 fprod o m2) (fpi2 fprod o m2) Hcomm 1 1).
    apply (lim_uniq fprod _ mph1 mph2).
  Qed.

End Pullback.

Arguments PullbackGr {C a b c} f g.
Arguments Pullback {C a b c} f g.

Definition AllPullbacks (C : PreCategory) :=
  forall(a b c : object C), forall(f : morphism C a c), forall(g : morphism C b c), Pullback f g.

Section pointwisePullback.
  Context `{Funext}.
  Context {C D : PreCategory}.
  Context {F G L : Functor C D}.
  Context (theta : NaturalTransformation F L).
  Context (tau   : NaturalTransformation G L).
  Context (x : C).
  Let Gr := pointwiseGraph (@PullbackGr (functor_category C D) F G L theta tau) x.

  Definition pwPbCone : Cone (PullbackGr (theta x) (tau x)) -> Cone Gr.
  Proof.
    intro cn. srapply mkCone; [ exact (cn_top cn) | | ].
    - intro n; pose (m := n); destruct3 n; exact (cn_side cn m).
    - intro n; pose (m := n); destruct2 n; exact (cn_comm cn m).
  Defined.
  Definition pwPbCone' : Cone Gr -> Cone (PullbackGr (theta x) (tau x)).
  Proof.
    intro cn. srapply mkCone; [ exact (cn_top cn) | | ].
    - intro n; pose (m := n); destruct3 n; exact (cn_side cn m).
    - intro n; pose (m := n); destruct2 n; exact (cn_comm cn m).
  Defined.

  Definition pwPbConeMorphismLToR (c1 : Cone Gr) (c2 : Cone (PullbackGr (theta x) (tau x))) :
    ConeMorphism (pwPbCone' c1) c2 ->
    ConeMorphism c1 (pwPbCone c2).
  Proof.
    intro mph. srapply mkCnMph; [ exact (cnmph_mph mph) | ].
    intro n; pose (m := n); destruct3 n; exact (cnmph_comm mph m).
  Defined.
  Definition pwPbConeMorphismRToL (c1 : Cone Gr) (c2 : Cone (PullbackGr (theta x) (tau x))) :
    ConeMorphism c1 (pwPbCone c2) ->
    ConeMorphism (pwPbCone' c1) c2.
  Proof.
    intro mph. srapply mkCnMph; [ exact (cnmph_mph mph) | ].
    intro n; pose (m := n); destruct3 n; exact (cnmph_comm mph m).
  Defined.

  Theorem pointwisePullback :
      Limit (PullbackGr (theta x) (tau x)) ->
      Limit (pointwiseGraph (@PullbackGr (functor_category C D) F G L theta tau) x).
  Proof.
    intro P. srapply mkLim.
    - apply pwPbCone. exact (lim_cone P).
    - intro c. apply pwPbConeMorphismLToR. apply lim_ex.
    - intros c m1 m2.
      pose (mph1 := pwPbConeMorphismRToL _ _ m1). pose (mph2 := pwPbConeMorphismRToL _ _ m2).
      apply (lim_uniq P _ mph1 mph2).
  Defined.
End pointwisePullback.

Section PullbackEqualizer.
  Context {C : PreCategory}.
  Context {a b : object C}.
  Context (f g : morphism C a b).
  Context (P : Product b b).
  Let d : morphism C b (prod_obj P) :=
        proj1 (product_ex P b (identity b) (identity b)).
  Let pack : morphism C a (prod_obj P) := proj1 (product_ex P a f g).
  Let FPEqGr := PullbackGr pack d.

  Definition PullbackConeFromEqualizer : Cone (EqualizerGr f g) -> Cone FPEqGr.
  Proof.
    intro cn. srapply mkCone; [ exact (cn_top cn) | idtac | idtac ].
    - intro n. destruct3 n; [ idtac | exact (cn_side cn fin2) | exact (cn_side cn fin1) ].
      apply (product_ex P _ (cn_side cn fin2) (cn_side cn fin2)).
    - intro n. destruct2 n; unfold gr_edge; simpl.
      + destruct (product_ex P _ (cn_side cn fin2) (cn_side cn fin2)) as [ dup [ Hpi1 Hpi2 ] ].
        unfold pack. destruct (product_ex P _ f g) as [ pk [ Hpk1 Hpk2 ] ].
        apply (product_uniq P); rewrite <- associativity; simpl;
          [ rewrite <- Hpi1; rewrite <- Hpk1
          | rewrite <- Hpi2; rewrite <- Hpk2 ].
        * apply (cn_comm cn fin2).
        * apply (cn_comm cn fin1).
      + destruct (product_ex P _ (cn_side cn fin2) (cn_side cn fin2)) as [ dup [ Hpi1 Hpi2 ] ].
        unfold d. destruct (product_ex P _ (identity b) (identity b)) as [ id [ Hid1 Hid2 ] ].
        apply (product_uniq P); rewrite <- associativity; simpl.
        * rewrite <- Hpi1. rewrite <- Hid1. apply left_identity.
        * rewrite <- Hpi2. rewrite <- Hid2. apply left_identity.
  Defined.
  Definition EqualizerConeFromPullback : Cone FPEqGr -> Cone (EqualizerGr f g).
  Proof.
    intro cn. srapply mkCone; [ exact (cn_top cn) | idtac | idtac ].
    - intro n. destruct2 n; [ exact (cn_side cn f2) | exact (cn_side cn f1) ].
    - pose (Hcomm := (cn_comm cn fin1) @ (cn_comm cn fin2)^); unfold gr_edge in Hcomm;
        unfold gr_src in Hcomm; unfold gr_dst in Hcomm; simpl in Hcomm.
      unfold d. destruct (product_ex P _ (identity b) (identity b)) as [ id [ Hid1 Hid2 ] ].
        unfold pack. destruct (product_ex P _ f g) as [ pk [ Hpk1 Hpk2 ] ].
      intro n; destruct2 n; unfold gr_edge; simpl;
        rewrite <- (left_identity C _ _ (cn_side cn f2));
        [ rewrite Hpk1; rewrite Hid1
        | rewrite Hpk2; rewrite Hid2 ];
        rewrite associativity; rewrite associativity;
        f_ap; symmetry; exact Hcomm.
  Defined.
  Definition PullbackCnMphFromEqualizer (c1 : Cone (EqualizerGr f g)) (c2 : Cone FPEqGr) :
    ConeMorphism (PullbackConeFromEqualizer c1) c2 ->
    ConeMorphism c1 (EqualizerConeFromPullback c2).
  Proof.
    intro mph. srapply mkCnMph; [ exact (cnmph_mph mph) | idtac ].
    intro n; destruct2 n.
    - apply (cnmph_comm mph f2).
    - apply (cnmph_comm mph f1).
  Defined.
  Definition EqualizerCnMphFromPullback (c1 : Cone (EqualizerGr f g)) (c2 : Cone FPEqGr) :
    ConeMorphism c1 (EqualizerConeFromPullback c2) ->
    ConeMorphism (PullbackConeFromEqualizer c1) c2.
  Proof.
    intro mph. srapply mkCnMph; [ exact (cnmph_mph mph) | idtac ].
    intro n; destruct3 n; [ idtac | apply (cnmph_comm mph fin2) | apply (cnmph_comm mph fin1) ].
    destruct (product_ex P _ (cn_side c1 fin2) (cn_side c1 fin2)) as [ dup [ Hpi1 Hpi2 ] ].
    destruct (product_ex P _ f g).2 as [ Hpk1 Hpk2 ].
    apply (product_uniq P); simpl;
      [ rewrite <- Hpi1 | rewrite <- Hpi2 ];
      rewrite <- associativity; rewrite <- (cn_comm c2 fin2); rewrite <- associativity;
      [ rewrite <- Hpk1 | rewrite <- Hpk2 ]; rewrite associativity;
      unfold gr_src; simpl; rewrite (cnmph_comm mph fin1).
    - apply (cn_comm c1 fin2).
    - apply (cn_comm c1 fin1).
  Defined.
  Theorem EqualizerFromPullback : Pullback pack d -> Equalizer f g.
  Proof.
    intro E. srapply mkLim.
    - exact (EqualizerConeFromPullback (lim_cone E)).
    - intro c. apply PullbackCnMphFromEqualizer. apply (lim_ex E).
    - intros c m1 m2.
      pose (mph1 := EqualizerCnMphFromPullback _ _ m1).
      pose (mph2 := EqualizerCnMphFromPullback _ _ m2).
      apply (lim_uniq E _ mph1 mph2).
  Qed.

End PullbackEqualizer.

Section Pullback.
  Context {C : PreCategory}.
  Context (T : Terminal C).
  Context (a b : object C).
  Let _a := terminal_ex a T.
  Let _b := terminal_ex b T.
  Let FPProdGr := PullbackGr _a _b.

  Definition PullbackConeFromProduct : Cone (ProductGr a b) -> Cone FPProdGr.
  Proof.
    intro cn. srapply mkCone; [ exact (cn_top cn) | idtac | idtac ].
    - intro n; destruct3 n; [ apply (terminal_ex _ T)
                            | apply (cn_side cn fin2)
                            | apply (cn_side cn fin1) ].
    - intro n; destruct2 n; apply (terminal_uniq _ T).
  Defined.
  Definition ProductConeFromPullback : Cone FPProdGr -> Cone (ProductGr a b).
  Proof.
    intro cn. srapply mkCone; [ exact (cn_top cn) | idtac | empty_ind' ].
    intro n; destruct2 n; [ apply (cn_side cn f2) | apply (cn_side cn f1) ].
  Defined.
  Definition ProductCnMphFromPullback (c1 : Cone (ProductGr a b)) (c2 : Cone FPProdGr) :
    ConeMorphism (PullbackConeFromProduct c1) c2 ->
    ConeMorphism c1 (ProductConeFromPullback c2).
  Proof.
    intro mph. srapply mkCnMph; [ exact (cnmph_mph mph) | idtac ].
    intro n; destruct2 n.
    - apply (cnmph_comm mph f2).
    - apply (cnmph_comm mph f1).
  Defined.
  Definition PullbackCnMphFromProduct (c1 : Cone (ProductGr a b)) (c2 : Cone FPProdGr) :
    ConeMorphism c1 (ProductConeFromPullback c2) ->
    ConeMorphism (PullbackConeFromProduct c1) c2.
  Proof.
    intro mph. srapply mkCnMph; [ exact (cnmph_mph mph) | idtac ].
    intro n; destruct3 n.
    - apply (terminal_uniq _ T).
    - apply (cnmph_comm mph fin2).
    - apply (cnmph_comm mph fin1).
  Defined.
  Theorem ProductFromPullback : Pullback _a _b -> Product a b.
  Proof.
    intro E. srapply mkLim.
    - exact (ProductConeFromPullback (lim_cone E)).
    - intro c. apply ProductCnMphFromPullback. apply (lim_ex E).
    - intros c m1 m2.
      pose (mph1 := PullbackCnMphFromProduct _ _ m1).
      pose (mph2 := PullbackCnMphFromProduct _ _ m2).
      apply (lim_uniq E _ mph1 mph2).
  Qed.

End Pullback.


From iris.algebra Require Import excl auth cmra gmap agree gset numbers.
From iris.algebra.lib Require Import frac_agree.
From iris.proofmode Require Import tactics.
Set Default Proof Using "All".
Require Export multicopy.

Section multicopy_util.
  Context {Σ} `{!multicopyG Σ}.
  Notation iProp := (iProp Σ).

  Lemma MCS_agree γ_te γ_he t H t' H':
    MCS_auth γ_te γ_he t H -∗ MCS γ_te γ_he t' H' -∗ ⌜t = t'⌝ ∗ ⌜H = H'⌝.
  Proof.
    iIntros "(Ht● & HH●) (Ht'◯ & HH'◯ & _)".
    iDestruct (own_valid_2 with "Ht● Ht'◯")
      as %[<-%Excl_included%leibniz_equiv _]%auth_both_valid_discrete.
    iDestruct (own_valid_2 with "HH● HH'◯")
      as %[<-%Excl_included%leibniz_equiv _]%auth_both_valid_discrete.
    by iPureIntro.
  Qed.

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

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

  Lemma map_of_set_lookup_some_aux (H: gset KVT) k :
        HUnique H →
          (∀ v t, (k, (v, t)) ∉ H) ∨
            (∃ v t, (k, (v, t)) ∈ H
              ∧ (∀ v' t', (k, (v', t')) ∈ H → t' ≤ t)).
  Proof.
    intros Uniq.
    set (P := λ (X: gset KVT), (∀ v t, (k, (v, t)) ∉ X) ∨
                  (∃ v T, (k, (v, T)) ∈ X ∧ (∀ v' t', (k, (v', t')) ∈ X → t' ≤ T))).
    apply (set_ind_L P); try done.
    - unfold P. left. intros v t. set_solver.
    - intros [k' [v' t']] X Hkt HP. subst P.
      simpl in HP. simpl. destruct (decide (k' = k)).
      + subst k'. destruct HP as [H' | H'].
        * right. exists v', t'. split.
          set_solver. intros v t. destruct (decide (t' = t)).
          subst t'. intros; done.
          intros H''. assert ((k, (v, t)) ∈ X).
          set_solver. pose proof H' v t as H'.
          done.
        * right. destruct H' as [v [T H']].
          destruct (decide (t' < T)).
          ** exists v, T. split.
             destruct H' as [H' _].
             set_solver. intros v'' 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'' v''); try done.
          ** exists v', t'. split. set_solver.
             intros v'' 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'' v''). try done.
      + destruct HP as [H' | H'].
        * left. intros v t. set_solver.
        * right. destruct H' as [v [T H']].
          exists v, T. destruct H' as [H' H''].
          split. set_solver. intros v'' 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'' v''); try done.
  Qed.

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

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

  Lemma set_of_map_member_ne (C: gmap K (V*T)) k :
            C !! k = None →
              ∀ v t, (k, (v, t)) ∉ set_of_map C.
  Proof.
    set (P := λ (s: gset KVT) (m: gmap K (V*T)),
                   m !! k = None → ∀ v t, (k, (v, 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 v 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 map_of_set_union_ne H k v t k' :
          HUnique H → k' ≠ k →
            map_of_set (H ∪ {[(k, (v, t))]}) !! k' = map_of_set H !! k'.
  Proof.
    intros HUniq Hk.
    pose proof (map_of_set_lookup_cases H k') as Hp.
    pose proof (map_of_set_lookup_cases (H ∪ {[(k, (v, t))]}) k') as Hu.
    destruct Hp as [Hp | Hp].
    - destruct Hu as [Hu | Hu].
      + destruct Hp as [v0 [T [Hp1 [Hp2 Hp3]]]].
        destruct Hu as [v0' [T' [Hu1 [Hu2 Hu3]]]].
        assert (T ≤ T') as Ht1.
        { assert ((k', (v0, T)) ∈ H ∪ {[(k, (v, t))]}) as Ht by set_solver.
          by pose proof Hu2 v0 T Ht. }
        assert (T' ≤ T) as Ht2.
        { assert ((k', (v0', T')) ∈ H) as Ht by set_solver.
          by pose proof Hp2 v0' T' Ht. }
        rewrite Hp3 Hu3. assert (T = T') as Ht by lia.
        subst T'. assert ((k', (v0', T)) ∈ H) as H'.
        { clear -Hu1 Hk; set_solver. }
        pose proof HUniq k' T v0 v0' Hp1 H' as HUniq.
        by rewrite HUniq.
      + destruct Hp as [v0 [T [Hp1 [Hp2 Hp3]]]].
        destruct Hu as [Hu1 Hu2].
        pose proof Hu1 v0 T as Hu1. set_solver.
    - destruct Hu as [Hu | Hu].
      + destruct Hp as [Hp1 Hp2].
        destruct Hu as [v0 [T' [Hu1 [Hu2 Hu3]]]].
        pose proof Hp1 v0 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 k v t H1 :
        HUnique H1 →
          HClock t H1 →
              <[k := (v, t)]> (map_of_set H1)
                          = map_of_set (H1 ∪ {[(k, (v, t))]}).
  Proof.
    intros HUniq HClock. apply map_eq. intros k'.
    destruct (decide (k' = k)).
    - replace k'. rewrite lookup_insert.
      rewrite (map_of_set_lookup _ _ v t); try done.
      { intros k0 t0 v0 v0'. rewrite !elem_of_union.
        intros [Hkvt0 | Hkvt0]; intros [Hkvt0' | Hkvt0'].
        - by pose proof HUniq k0 t0 v0 v0' Hkvt0 Hkvt0'.
        - assert ((k0, v0', t0) = (k, v, t)) as H' by set_solver.
          inversion H'. subst k0 v0' t0.
          pose proof HClock k v0 t Hkvt0 as HClock. lia.
        - assert ((k0, v0, t0) = (k, v, t)) as H' by set_solver.
          inversion H'. subst k0 v0 t0.
          pose proof HClock k v0' t Hkvt0' as Hmax. lia.
        - assert ((k0, v0, t0) = (k0, v0', t0)) as H' by set_solver.
          by inversion H'. }
      set_solver. intros v' t'. rewrite elem_of_union.
      intros [Hk | Hk]. pose proof HClock k v' 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.
  Qed.

  Lemma set_of_map_member (C: gmap K (V*T)) k v t :
            C !! k = Some((v, t)) →
              (k, (v, t)) ∈ set_of_map C.
  Proof.
    intros Hc. unfold set_of_map.
    set (P := λ (s: gset KVT) (m: gmap K (V*T)),
                  ∀ j v x, m !! j = Some (v, x) → (j, (v, x)) ∈ s).
    apply (map_fold_ind P); try done.
    intros i x m s Hmi Hp. unfold P.
    intros j v' 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 v' x' as Hp'. set_solver.
  Qed.

  Lemma set_of_map_member_rev (C: gmap K (V*T)) k v t :
            (k, (v, t)) ∈ set_of_map C →
                C !! k = Some((v, t)).
  Proof.
    set (P := λ (s: gset KVT) (m: gmap K (V*T)),
                  ∀ k v t, (k, (v, t)) ∈ s → m !! k = Some (v, t)).
    apply (map_fold_ind P); try done.
    intros k' vt m r Hmi Hp. unfold P.
    intros k0 v0 t0 Hkvt0. destruct (decide (k0 = k')).
    - subst k0. rewrite lookup_insert.
      rewrite elem_of_union in Hkvt0*; intros Hkvt0.
      destruct Hkvt0 as [Hkvt0 | Hkvt0].
      unfold P in Hp. pose proof Hp k' v0 t0 Hkvt0 as Hp.
      rewrite Hp in Hmi. inversion Hmi.
      assert ((v0, t0) = (vt.1, vt.2)) as H' by set_solver.
      inversion H'. destruct vt as [v' t']; by simpl.
    - assert ((k0, (v0, t0)) ∈ r) as Hj by set_solver.
      pose proof Hp k0 v0 t0 Hj as Hp.
      rewrite lookup_insert_ne; try done.
  Qed.

  Lemma set_of_map_insert_subseteq (C: gmap K (V*T)) k v t :
    set_of_map (<[k := (v, t)]> C) ⊆ set_of_map C ∪ {[(k, (v, t))]}.
  Proof.
    intros [k' [v' t']] Hkt. destruct (decide (k' = k)).
    - subst k'.
      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 chop_ts_lookup_total M k :
      chop_ts M !!! k = (M !!! k).1.
  Proof.
    set (P := λ (m': gmap K V) (m: gmap K (V*T)),
                   ∀ k, m' !!! k = (m !!! k).1).
    apply (map_fold_ind P _ _); try done.
    intros k0 vt m m' Hm HP. subst P.
    intros k1. destruct (decide (k1 = k0)).
    - subst k1. by rewrite !lookup_total_insert.
    - rewrite !lookup_total_insert_ne; try done.
  Qed.

  Lemma chop_ts_dom M :
    dom (gset K) (chop_ts M) = dom (gset K) M.
  Proof.
    set (P := λ (m': gmap K V) (m: gmap K (V*T)),
                   dom (gset K) m' = dom (gset K) m).
    apply (map_fold_ind P _ _); try done.
    - unfold P. set_solver.
    - intros k [v t] m m' Hmk HP.
      unfold P. simpl. apply leibniz_equiv.
      repeat rewrite dom_insert. unfold P in HP.
      by rewrite HP.
  Qed.

  Lemma chop_ts_insert M k v t :
        chop_ts (<[k := (v, t)]> M) = <[k := v]> (chop_ts M).
  Proof.
    apply map_eq; intros k'.
    pose proof chop_ts_dom (<[k:=(v, t)]> M) as Hdom.
    assert (dom (gset K) (<[k:=(v, t)]> M) = {[k]} ∪ dom (gset K) M) as Hdom'.
    { apply leibniz_equiv. by rewrite dom_insert. }
    destruct (decide (k' = k)); last first.
    - destruct (decide (k' ∈ dom (gset K) M)).
      + assert (k' ∈ dom (gset K) (chop_ts (<[k:=(v, t)]> M))) as Hk.
        { rewrite Hdom Hdom'. set_solver. }
        apply lookup_lookup_total_dom in Hk.
        rewrite Hk. rewrite chop_ts_lookup_total.
        rewrite lookup_insert_ne; try done.
        rewrite lookup_total_insert_ne; try done.
        pose proof chop_ts_lookup_total M k' as Hchop.
        assert (k' ∈ dom (gset K) (chop_ts M)) as Hdom''.
        { by rewrite chop_ts_dom. }
        apply lookup_lookup_total_dom in Hdom''.
        rewrite Hdom''. apply f_equal.
        by rewrite chop_ts_lookup_total.
      + rewrite lookup_insert_ne; try done.
        assert (k' ∉ dom (gset K) (chop_ts (<[k:=(v, t)]> M))) as Hdom''.
        { rewrite Hdom Hdom'. set_solver. }
        assert (k' ∉ dom (gset K) (chop_ts M)) as Hdom'''.
        { by rewrite chop_ts_dom. }
        rewrite not_elem_of_dom in Hdom''*; intros Hdom''.
        rewrite not_elem_of_dom in Hdom'''*; intros Hdom'''.
        by rewrite Hdom'' Hdom'''.
    - subst k'. rewrite lookup_insert.
      assert (k ∈ dom (gset K) (chop_ts (<[k:=(v, t)]> M))) as Hk.
      { rewrite Hdom Hdom'. set_solver. }
      apply lookup_lookup_total_dom in Hk.
      rewrite Hk. rewrite chop_ts_lookup_total.
      rewrite lookup_total_insert. by simpl.
  Qed.

End multicopy_util.


(* Do not edit this file, it was generated automatically *)
Require Import VST.floyd.proofauto.
Require Import VST.progs64.revarray.
Require Import VST.zlist.sublist.

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

Definition reverse_spec :=
 DECLARE _reverse
  WITH a0: val, sh : share, contents : list int, size: Z
  PRE [ tptr tint, tint ]
          PROP (0 <= size <= Int.max_signed; writable_share sh)
          PARAMS (a0; Vint (Int.repr size))
          SEP (data_at sh (tarray tint size) (map Vint contents) a0)
  POST [ tvoid ]
     PROP() RETURN()
     SEP(data_at sh (tarray tint size) (map Vint (rev contents)) a0).

Definition main_spec :=
  DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog tt gv
  POST [ tint ] main_post prog gv.

Definition Gprog : funspecs :=   ltac:(with_library prog [reverse_spec; main_spec]).

Definition flip_ends {A} lo hi (contents: list A) :=
  sublist 0 lo (rev contents)
  ++ sublist lo hi contents
  ++ sublist hi (Zlength contents) (rev contents).

Definition reverse_Inv a0 sh contents size :=
 (EX j:Z,
  (PROP  (0 <= j; j <= size-j)
   LOCAL  (temp _a a0; temp _lo (Vint (Int.repr j)); temp _hi (Vint (Int.repr (size-j))))
   SEP (data_at sh (tarray tint size) (flip_ends j (size-j) contents) a0)))%assert.

Lemma Zlength_flip_ends:
 forall A i j (al: list A),
 0 <= i  -> i<=j -> j <= Zlength al ->
 Zlength (flip_ends i j al) = Zlength al.
Proof.
intros.
unfold flip_ends.
autorewrite with sublist. lia.
Qed.
#[export] Hint Rewrite @Zlength_flip_ends using (autorewrite with sublist; lia) : sublist.

Lemma flip_fact_1: forall A {d: Inhabitant A} size (contents: list A) j,
  Zlength contents = size ->
  0 <= j ->
  size - j - 1 <= j <= size - j ->
  flip_ends j (size - j) contents = rev contents.
Proof.
  intros.
  unfold flip_ends.
  rewrite <- (Zlen_le_1_rev (sublist j (size-j) contents))
      by list_solve.
  rewrite !sublist_rev by list_solve.
 rewrite <- !rev_app_distr.
 f_equal.
 list_solve.
Qed.

Lemma flip_fact_3:
 forall A {d: Inhabitant A} (al: list A) j size,
  size = Zlength al ->
  0 <= j < size - j - 1 ->
sublist 0 j (flip_ends j (size - j) al) ++
sublist (size - j - 1) (size - j) al ++
sublist (j + 1) size
  (sublist 0 (size - j - 1) (flip_ends j (size - j) al) ++
   sublist j (j + 1) (flip_ends j (size - j) al) ++
   sublist (size - j) size (flip_ends j (size - j) al)) =
flip_ends (j + 1) (size - (j + 1)) al.
Proof.
intros.
unfold flip_ends.
pose proof (Zlength_rev _ al).
list_simplify.
+ rewrite Znth_rev by list_solve.
     list_solve.
+ rewrite Znth_rev by list_solve.
     list_solve.
Qed.

Lemma flip_ends_map:
  forall A B (F: A -> B) lo hi (al: list A),
  flip_ends lo hi (map F al) = map F (flip_ends lo hi al).
Proof.
intros.
unfold flip_ends.
rewrite !map_app.
rewrite !map_sublist, !map_rev, Zlength_map.
auto.
Qed.

Lemma flip_fact_2:
  forall {A}{d: Inhabitant A} (al: list A) size j,
 Zlength al = size ->
  j < size - j - 1 ->
   0 <= j ->
  Znth (size - j - 1) al =
  Znth (size - j - 1) (flip_ends j (size - j) al).
Proof.
intros.
unfold flip_ends.
pose proof (Zlength_rev _ al).
list_solve.
Qed.

Lemma body_reverse: semax_body Vprog Gprog f_reverse reverse_spec.
Proof.
start_function.
forward.  (* lo = 0; *)
forward. (* hi = n; *)

assert_PROP (Zlength (map Vint contents) = size)
    as ZL by entailer!.
forward_while (reverse_Inv a0 sh (map Vint contents) size).
* (* Prove that current precondition implies loop invariant *)
Exists 0.
entailer!!.
unfold flip_ends; autorewrite with sublist; auto.
* (* Prove that loop invariant implies typechecking condition *)
entailer!.
* (* Prove that loop body preserves invariant *)
forward. (* t = a[lo]; *)
{
  entailer!!.
  clear - H0 HRE.
  autorewrite with sublist in *|-*.
  rewrite flip_ends_map.
  rewrite Znth_map by (autorewrite with sublist; list_solve).
  apply I.
}
forward.  (* s = a[hi-1]; *)
{
  entailer!!.
  clear - H H0 HRE.
  autorewrite with sublist in *|-*.
  rewrite flip_ends_map.
  rewrite Znth_map by (autorewrite with sublist; list_solve).
  apply I.
}
rewrite <- flip_fact_2 by (rewrite ?Zlength_flip_ends; lia).
forward. (*  a[hi-1] = t; *)
forward. (* a[lo] = s; *)
forward. (* lo++; *)
forward. (* hi--; *)
(* Prove postcondition of loop body implies loop invariant *)
 Exists (Z.succ j).
 entailer!.
 f_equal; f_equal; lia.
 simpl.
 apply derives_refl'.
 unfold data_at.    f_equal.
 clear - H0 HRE H1.
 unfold Z.succ.
 rewrite <- flip_fact_3 by auto with typeclass_instances.
 pose proof (Zlength_flip_ends _ j (Zlength (map Vint contents) - j) (map Vint contents)
    ltac:(lia) ltac:(lia)  ltac:(lia)).
 list_solve.
* (* after the loop *)
forward. (* return; *)
entailer!!.
rewrite map_rev. rewrite flip_fact_1; try lia; auto.
cancel.
Qed.

Definition four_contents := [Int.repr 1; Int.repr 2; Int.repr 3; Int.repr 4].

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof. finish. Qed.

#[export] Existing Instance NullExtension.Espec.

Lemma prog_correct:
  semax_prog prog tt Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons body_reverse.
semax_func_cons body_main.
Qed.

Module Alternate.

(* Lemma calc_Zlength_rev : forall A (l : list A) len,
  Zlength l = len ->
  Zlength (rev l) = len.
Proof.
  intros.
  rewrite Zlength_rev.
  auto.
Qed.

Ltac calc_Zlength_extra l ::=
  lazymatch l with
  | @rev ?A ?l =>
    calc_Zlength l;
    let H := get_Zlength l in
    add_Zlength_res (calc_Zlength_rev A l _ H)
  end. *)

#[export] Hint Rewrite Zlength_rev : Zlength.
#[export] Hint Rewrite @Znth_rev using Zlength_solve : Znth.
#[export] Hint Unfold flip_ends : list_solve_unfold.

Lemma body_reverse: semax_body Vprog Gprog f_reverse reverse_spec.
Proof.
start_function.
fastforward.

assert_PROP (Zlength (map Vint contents) = size)
    as ZL by entailer!.
forward_while (reverse_Inv a0 sh (map Vint contents) size).
* (* Prove that current precondition implies loop invariant *)
simpl (data_at _ _ _).
Time finish.
* (* Prove that loop invariant implies typechecking condition *)
Time finish.
* (* Prove that loop body preserves invariant *)
(* unfold flip_ends. *) (* seems good to do this, but it makes step VERY slow *)
Time finish.
(* Finished transaction in 14.318 secs (14.043u,0.165s) (successful) *)
(* solved in step! *)
* (* after the loop *)
Time finish.
(* Finished transaction in 2.409 secs (2.379u,0.014s) (successful) *)
Time Qed.
(* Finished transaction in 0.718 secs (0.714u,0.002s) (successful) *)

Definition four_contents := [Int.repr 1; Int.repr 2; Int.repr 3; Int.repr 4].

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof. finish. Qed.

End Alternate.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj20synthconj1 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (Succ (plus lv0 (plus lv1 lv2))) (plus (mult lv2 (Succ (plus Zero lv1))) (Succ (plus Zero lv1)))).
Admitted.
QuickChick conj20synthconj1.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj30synthconj4 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus (mult lv0 lv1) lv1) lv2) (plus (mult lv0 (plus (Succ Zero) lv1)) (plus (Succ Zero) lv1))).
Admitted.
QuickChick conj30synthconj4.


Require Import IL List.

Inductive block_rel (stn : settings) (prog : program) : state' -> state' -> Prop :=
  | run_block : forall st st', step stn prog st = Some st' -> block_rel stn prog st st'.
Lemma block_deterministic : forall stn prog st st1 st2,
  block_rel stn prog st st1 -> block_rel stn prog st st2 -> st1 = st2.
Proof.
intros. destruct H. destruct H0. congruence.
Qed.

Inductive inst_state : Set :=
  | start_block : state' -> inst_state
  | inside_block : block -> state -> inst_state
  .

Definition inst_step (stn : settings) (prog : program) (st : inst_state) : option inst_state :=
  match st with
  | start_block st' =>
    match prog (fst st') with
      | None => None
      | Some b => Some (inside_block b (snd st'))
    end
  | inside_block (nil, j) st =>
    match evalJmp stn st j with
      | Some w => Some (start_block (w,st))
      | None => None
    end
  | inside_block (i :: is, j) st =>
    match evalInstr stn st i with
      | Some st' => Some (inside_block (is,j) st')
      | None => None
    end
  end.

Inductive inst_rel (stn : settings) (prog : program) (st st' : inst_state) : Prop :=
  | run_inst : inst_step stn prog st = Some st' -> inst_rel stn prog st st'.

Lemma inst_det : forall stn prog st st1 st2,
   inst_rel stn prog st st1 -> inst_rel stn prog st st2 -> st1 = st2.
Proof.
destruct 1;destruct 1;congruence.
Qed.

Inductive inside_steps stn prog (st : inst_state) (st' : state') : Prop :=
  | finish : inst_rel stn prog st (start_block st') -> inside_steps stn prog st st'
  | inside_step : forall b mid,
      inst_rel stn prog st (inside_block b mid) ->
      inside_steps stn prog (inside_block b mid) st' ->
      inside_steps stn prog st st'
  .

Inductive star {A} (R : A -> A -> Prop) : A -> A -> Prop :=
  | empty : forall a, star R a a
  | step : forall a b, R a b -> forall c, star R b c -> star R a c.

Lemma inside_star stn prog st st' :
  inside_steps stn prog st st' -> star (inst_rel stn prog) st (start_block st').
Proof.
induction 1.
destruct H. eapply step;[|eapply empty]. constructor;eassumption.
eapply step;eassumption.
Qed.

Lemma refine_fwd : forall stn prog st st',
  block_rel stn prog st st' -> inside_steps stn prog (start_block st) st'.
Proof.
intros.
destruct H.
unfold IL.step in H.
destruct (prog (fst st)) eqn:?;[|discriminate].
apply inside_step with b (snd st).
  constructor. simpl. rewrite Heqo. reflexivity.
destruct st.
simpl in * |- *.
clear Heqo w.
destruct b.
revert s st' H.
induction l.
(* *)
simpl. intros.
destruct (evalJmp stn s j) eqn:?;[|discriminate].
apply finish. constructor. simpl. rewrite Heqo. congruence.
(* *)
intros. simpl in H.
destruct (evalInstr stn s a) eqn:?;[|discriminate].
specialize (IHl s0 st' H).
apply inside_step with (l, j) s0.
constructor. simpl. rewrite Heqo. reflexivity.
assumption.
Qed.

Lemma refine_rev : forall stn prog st st',
  inside_steps stn prog (start_block st) st' -> block_rel stn prog st st'.
destruct 1. destruct H.  simpl in H. destruct (prog (fst st)); discriminate.
constructor. simpl.
unfold IL.step.
destruct H. simpl in H. destruct (prog (fst st));[|discriminate].
injection H;intros;subst;clear H.
revert H0.
destruct st. simpl. clear.
destruct b.
revert s. induction l.
destruct 1. destruct H. simpl in H. simpl.
destruct (evalJmp stn s j);[apply f_equal|];congruence.
destruct H. simpl in H. destruct (evalJmp stn s j);discriminate.
destruct 1. destruct H. simpl in H. destruct (evalInstr stn s a);discriminate.
destruct H. simpl in H. simpl. destruct (evalInstr stn s a);[|discriminate].
apply IHl. congruence.
Qed.

Lemma refine : forall stn prog st st',
  block_rel stn prog st st' <-> inside_steps stn prog (start_block st) st'.
Proof.
split; auto using refine_fwd, refine_rev.
Qed.


(******************************************************************************)
(*       Copyright (C) 2019-2021 Florent Hivert <florent.hivert@lri.fr>       *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of          *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU       *)
(*    General Public License for more details.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp Require Import boolp classical_sets.
From mathcomp Require Import order.

Require Import natbar.

Import Order.Syntax.
Import Order.Theory.
Open Scope order_scope.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Definition directed (T : Type) (R : T -> T -> bool) :=
  forall x y : T, { z | R x z & R y z }.

Module Directed.
Section ClassDef.

Record mixin_of (disp : unit)
       (T : porderType disp) := Mixin { _ : directed (@Order.le disp T) }.
Record class_of (T : Type) := Class {
  base  : Order.POrder.class_of T;
  mixin_disp : unit;
  mixin : mixin_of (Order.POrder.Pack mixin_disp base)
}.

Local Coercion base : class_of >-> Order.POrder.class_of.

Structure type (disp : unit) := Pack { sort; _ : class_of sort }.

Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (disp : unit) (cT : type disp).

Definition class := let: Pack _ c as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack disp T c.
Definition clone_with disp' c of phant_id class c := @Pack disp' T c.
Let xT := let: Pack T _ := cT in T.
Notation xclass := (class : class_of xT).

Definition pack d0 b0 (m0 : mixin_of (@Order.POrder.Pack d0 T b0)) :=
  fun bT b & phant_id (@Order.POrder.class disp bT) b =>
  fun m & phant_id m0 m => Pack disp (@Class T b d0 m).

Definition eqType := @Equality.Pack cT xclass.
Definition choiceType := @Choice.Pack cT xclass.
Definition porderType := @Order.POrder.Pack disp cT xclass.
End ClassDef.

Module Exports.
Coercion base : class_of >-> Order.POrder.class_of.
Coercion mixin : class_of >-> mixin_of.
Coercion sort : type >-> Sortclass.
Coercion eqType : type >-> Equality.type.
Coercion choiceType : type >-> Choice.type.
Coercion porderType : type >-> Order.POrder.type.
Canonical eqType.
Canonical choiceType.
Canonical porderType.
Notation dirType  := type.
Notation dirMixin := mixin_of.
Notation DirMixin := Mixin.
Notation DirType T m := (@pack T _ _ _ m _ _ id _ id).
Notation "[ 'dirType' 'of' T 'for' cT ]" := (@clone T _ cT _ id)
  (at level 0, format "[ 'dirType'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'dirType' 'of' T 'for' cT 'with' disp ]" :=
  (@clone_with T _ cT disp _ id)
  (at level 0, format "[ 'dirType'  'of'  T  'for'  cT  'with'  disp ]") :
  form_scope.
Notation "[ 'dirType' 'of' T ]" := [dirType of T for _]
  (at level 0, format "[ 'dirType'  'of'  T ]") : form_scope.
Notation "[ 'dirType' 'of' T 'with' disp ]" :=
  [dirType of T for _ with disp]
  (at level 0, format "[ 'dirType'  'of'  T  'with' disp ]") : form_scope.
End Exports.

End Directed.
Export Directed.Exports.

Lemma directedP (disp : unit) (T : dirType disp) : directed (T := T) <=%O.
Proof. by case: T => sort [/= bs mx []]. Qed.

Section Generic.
Variables (disp : unit) (T : latticeType disp).

Fact lattice_directed : directed (T := T) <=%O.
Proof. by move=> x y; exists (x `|` y); [apply: leUl |apply: leUr]. Qed.
Definition lattice_dirMixin := DirMixin lattice_directed.
Canonical lattice_dirType := DirType T lattice_dirMixin.

End Generic.

Canonical nat_dirType := DirType nat (@lattice_dirMixin _ _).
Canonical natdvd_dirType := DirType natdvd (@lattice_dirMixin _ _).

Section UpSets.

Variables (disp : unit) (I : dirType disp).
Implicit Types (i j k : I).
Implicit Types (s t : set I).

Definition up_set (S : set I) :=
  nonempty S /\ forall i j, i <= j -> S i -> S j.

Lemma up_setI S T : up_set S -> up_set T -> up_set (S `&` T).
Proof.
move=> [[x Sx upS]] [[y Sy upT]]; split.
- have [z le_xz le_yz] := directedP x y; exists z.
  by split; [apply: upS; first exact: le_xz | apply: upT; first exact: le_yz].
by move=> i j le_ij [/(upS _ _ le_ij) Si /(upT _ _ le_ij) Sj].
Qed.
Lemma up_setU S T : up_set S -> up_set T -> up_set (S `|` T).
Proof.
move=> [[x Sx upS]] [[y Sy upT]]; split; first by exists x; left.
by move=> i j le_ij [/(upS _ _ le_ij) Si | /(upT _ _ le_ij) Sj]; [left|right].
Qed.

Variables (T : Type) (P : set T) (F : T -> set I).

Lemma up_set_bigcup :
  nonempty P ->
  (forall t : T, P t -> up_set (F t)) ->
  up_set (\bigcup_(t in P) F t).
Proof.
move=> [t Pt] H; split.
  by have [[i Fti] _] := H t Pt; exists i; exists t.
move=> {t Pt} i j le_ij [t Pt Fti]; exists t => //.
by have [_ ] := (H t Pt); apply; first apply: le_ij.
Qed.

End UpSets.


Require Import TLC.LibList.
Require Import TLC.LibFset.
Require Import CpdtTactics.
Set Implicit Arguments.

Lemma from_list_spec A : forall (x : A) L, mem x (from_list L) = LibList.mem x L.
Proof using.
  unfold from_list. induction L; rew_listx.
  rewrite in_empty. auto.
  rewrite in_union, in_singleton. congruence.
Qed.