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 Qprime Cprime P Q Aprime C A : Universe, ((wd_ Qprime Cprime /\ (wd_ Cprime P /\ (wd_ P Q /\ (wd_ Qprime Q /\ (wd_ Qprime P /\ (wd_ Cprime Q /\ (wd_ Aprime P /\ (wd_ Q Aprime /\ (wd_ Aprime A /\ (wd_ Cprime C /\ (wd_ P A /\ (wd_ P C /\ (wd_ Cprime Aprime /\ (col_ P C A /\ (col_ Aprime P A /\ col_ Cprime P C))))))))))))))) -> col_ P Cprime Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*          Sandrine Blazy, ENSIIE and INRIA Paris-Rocquencourt        *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** In-memory representation of values. *)

Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.

(** * Properties of memory chunks *)

(** Memory reads and writes are performed by quantities called memory chunks,
  encoding the type, size and signedness of the chunk being addressed.
  The following functions extract the size information from a chunk. *)

Definition size_chunk (chunk: memory_chunk) : Z :=
  match chunk with
  | Mint8signed => 1
  | Mint8unsigned => 1
  | Mint16signed => 2
  | Mint16unsigned => 2
  | Mint32 => 4
  | Mfloat32 => 4
  | Mfloat64 => 8
  | Mfloat64al32 => 8
  end.

Lemma size_chunk_pos:
  forall chunk, size_chunk chunk > 0.
Proof.
  intros. destruct chunk; simpl; omega.
Qed.

Definition size_chunk_nat (chunk: memory_chunk) : nat :=
  nat_of_Z(size_chunk chunk).

Lemma size_chunk_conv:
  forall chunk, size_chunk chunk = Z_of_nat (size_chunk_nat chunk).
Proof.
  intros. destruct chunk; reflexivity.
Qed.

Lemma size_chunk_nat_pos:
  forall chunk, exists n, size_chunk_nat chunk = S n.
Proof.
  intros.
  generalize (size_chunk_pos chunk). rewrite size_chunk_conv.
  destruct (size_chunk_nat chunk).
  simpl; intros; omegaContradiction.
  intros; exists n; auto.
Qed.

(** Memory reads and writes must respect alignment constraints:
  the byte offset of the location being addressed should be an exact
  multiple of the natural alignment for the chunk being addressed.
  This natural alignment is defined by the following
  [align_chunk] function.  Some target architectures
  (e.g. PowerPC and x86) have no alignment constraints, which we could
  reflect by taking [align_chunk chunk = 1].  However, other architectures
  have stronger alignment requirements.  The following definition is
  appropriate for PowerPC, ARM and x86. *)

Definition align_chunk (chunk: memory_chunk) : Z :=
  match chunk with
  | Mint8signed => 1
  | Mint8unsigned => 1
  | Mint16signed => 2
  | Mint16unsigned => 2
  | Mint32 => 4
  | Mfloat32 => 4
  | Mfloat64 => 8
  | Mfloat64al32 => 4
  end.

Lemma align_chunk_pos:
  forall chunk, align_chunk chunk > 0.
Proof.
  intro. destruct chunk; simpl; omega.
Qed.

Lemma align_size_chunk_divides:
  forall chunk, (align_chunk chunk | size_chunk chunk).
Proof.
  intros. destruct chunk; simpl; try apply Zdivide_refl. exists 2; auto.
Qed.

Lemma align_le_divides:
  forall chunk1 chunk2,
  align_chunk chunk1 <= align_chunk chunk2 -> (align_chunk chunk1 | align_chunk chunk2).
Proof.
  intros. destruct chunk1; destruct chunk2; simpl in *;
  solve [ omegaContradiction
        | apply Zdivide_refl
        | exists 2; reflexivity
        | exists 4; reflexivity
        | exists 8; reflexivity ].
Qed.

(** * Memory values *)

(** A ``memory value'' is a byte-sized quantity that describes the current
  content of a memory cell.  It can be either:
- a concrete 8-bit integer;
- a byte-sized fragment of an opaque pointer;
- the special constant [Undef] that represents uninitialized memory.
*)

(** Values stored in memory cells. *)

Inductive memval: Type :=
  | Undef: memval
  | Byte: byte -> memval
  | Pointer: block -> int -> nat -> memval.

(** * Encoding and decoding integers *)

(** We define functions to convert between integers and lists of bytes
  of a given length *)

Fixpoint bytes_of_int (n: nat) (x: Z) {struct n}: list byte :=
  match n with
  | O => nil
  | S m => Byte.repr x :: bytes_of_int m (x / 256)
  end.

Fixpoint int_of_bytes (l: list byte): Z :=
  match l with
  | nil => 0
  | b :: l' => Byte.unsigned b + int_of_bytes l' * 256
  end.

Parameter big_endian: bool.

Definition rev_if_be (l: list byte) : list byte :=
  if big_endian then List.rev l else l.

Definition encode_int (sz: nat) (x: Z) : list byte :=
  rev_if_be (bytes_of_int sz x).

Definition decode_int (b: list byte) : Z :=
  int_of_bytes (rev_if_be b).

(** Length properties *)

Lemma length_bytes_of_int:
  forall n x, length (bytes_of_int n x) = n.
Proof.
  induction n; simpl; intros. auto. decEq. auto.
Qed.

Lemma rev_if_be_length:
  forall l, length (rev_if_be l) = length l.
Proof.
  intros; unfold rev_if_be; destruct big_endian.
  apply List.rev_length.
  auto.
Qed.

Lemma encode_int_length:
  forall sz x, length(encode_int sz x) = sz.
Proof.
  intros. unfold encode_int. rewrite rev_if_be_length. apply length_bytes_of_int.
Qed.

(** Decoding after encoding *)

Lemma int_of_bytes_of_int:
  forall n x,
  int_of_bytes (bytes_of_int n x) = x mod (two_p (Z_of_nat n * 8)).
Proof.
  induction n; intros.
  simpl. rewrite Zmod_1_r. auto.
Opaque Byte.wordsize.
  rewrite inj_S. simpl.
  replace (Zsucc (Z_of_nat n) * 8) with (Z_of_nat n * 8 + 8) by omega.
  rewrite two_p_is_exp; try omega.
  rewrite Zmod_recombine. rewrite IHn. rewrite Zplus_comm. reflexivity.
  apply two_p_gt_ZERO. omega. apply two_p_gt_ZERO. omega.
Qed.

Lemma rev_if_be_involutive:
  forall l, rev_if_be (rev_if_be l) = l.
Proof.
  intros; unfold rev_if_be; destruct big_endian.
  apply List.rev_involutive.
  auto.
Qed.

Lemma decode_encode_int:
  forall n x, decode_int (encode_int n x) = x mod (two_p (Z_of_nat n * 8)).
Proof.
  unfold decode_int, encode_int; intros. rewrite rev_if_be_involutive.
  apply int_of_bytes_of_int.
Qed.

Lemma decode_encode_int_1:
  forall x, Int.repr (decode_int (encode_int 1 (Int.unsigned x))) = Int.zero_ext 8 x.
Proof.
  intros. rewrite decode_encode_int.
  rewrite <- (Int.repr_unsigned (Int.zero_ext 8 x)).
  decEq. symmetry. apply Int.zero_ext_mod. compute; auto.
Qed.

Lemma decode_encode_int_2:
  forall x, Int.repr (decode_int (encode_int 2 (Int.unsigned x))) = Int.zero_ext 16 x.
Proof.
  intros. rewrite decode_encode_int.
  rewrite <- (Int.repr_unsigned (Int.zero_ext 16 x)).
  decEq. symmetry. apply Int.zero_ext_mod. compute; auto.
Qed.

Lemma decode_encode_int_4:
  forall x, Int.repr (decode_int (encode_int 4 (Int.unsigned x))) = x.
Proof.
  intros. rewrite decode_encode_int. transitivity (Int.repr (Int.unsigned x)).
  decEq. apply Zmod_small. apply Int.unsigned_range. apply Int.repr_unsigned.
Qed.

Lemma decode_encode_int_8:
  forall x, Int64.repr (decode_int (encode_int 8 (Int64.unsigned x))) = x.
Proof.
  intros. rewrite decode_encode_int. transitivity (Int64.repr (Int64.unsigned x)).
  decEq. apply Zmod_small. apply Int64.unsigned_range. apply Int64.repr_unsigned.
Qed.

(** A length-[n] encoding depends only on the low [8*n] bits of the integer. *)

Lemma bytes_of_int_mod:
  forall n x y,
  Int.eqmod (two_p (Z_of_nat n * 8)) x y ->
  bytes_of_int n x = bytes_of_int n y.
Proof.
  induction n.
  intros; simpl; auto.
  intros until y.
  rewrite inj_S.
  replace (Zsucc (Z_of_nat n) * 8) with (Z_of_nat n * 8 + 8) by omega.
  rewrite two_p_is_exp; try omega.
  intro EQM.
  simpl; decEq.
  apply Byte.eqm_samerepr. red.
  eapply Int.eqmod_divides; eauto. apply Zdivide_factor_l.
  apply IHn.
  destruct EQM as [k EQ]. exists k. rewrite EQ.
  rewrite <- Z_div_plus_full_l. decEq. change (two_p 8) with 256. ring. omega.
Qed.

Lemma encode_int_8_mod:
  forall x y,
  Int.eqmod (two_p 8) x y ->
  encode_int 1%nat x = encode_int 1%nat y.
Proof.
  intros. unfold encode_int. decEq. apply bytes_of_int_mod. auto.
Qed.

Lemma encode_int_16_mod:
  forall x y,
  Int.eqmod (two_p 16) x y ->
  encode_int 2%nat x = encode_int 2%nat y.
Proof.
  intros. unfold encode_int. decEq. apply bytes_of_int_mod. auto.
Qed.

(** * Encoding and decoding values *)

Definition inj_bytes (bl: list byte) : list memval :=
  List.map Byte bl.

Fixpoint proj_bytes (vl: list memval) : option (list byte) :=
  match vl with
  | nil => Some nil
  | Byte b :: vl' =>
      match proj_bytes vl' with None => None | Some bl => Some(b :: bl) end
  | _ => None
  end.

Remark length_inj_bytes:
  forall bl, length (inj_bytes bl) = length bl.
Proof.
  intros. apply List.map_length.
Qed.

Remark proj_inj_bytes:
  forall bl, proj_bytes (inj_bytes bl) = Some bl.
Proof.
  induction bl; simpl. auto. rewrite IHbl. auto.
Qed.

Lemma inj_proj_bytes:
  forall cl bl, proj_bytes cl = Some bl -> cl = inj_bytes bl.
Proof.
  induction cl; simpl; intros.
  inv H; auto.
  destruct a; try congruence. destruct (proj_bytes cl); inv H.
  simpl. decEq. auto.
Qed.

Fixpoint inj_pointer (n: nat) (b: block) (ofs: int) {struct n}: list memval :=
  match n with
  | O => nil
  | S m => Pointer b ofs m :: inj_pointer m b ofs
  end.

Fixpoint check_pointer (n: nat) (b: block) (ofs: int) (vl: list memval)
                       {struct n} : bool :=
  match n, vl with
  | O, nil => true
  | S m, Pointer b' ofs' m' :: vl' =>
      eq_block b b' && Int.eq_dec ofs ofs' && beq_nat m m' && check_pointer m b ofs vl'
  | _, _ => false
  end.

Definition proj_pointer (vl: list memval) : val :=
  match vl with
  | Pointer b ofs n :: vl' =>
      if check_pointer 4%nat b ofs vl then Vptr b ofs else Vundef
  | _ => Vundef
  end.

Definition encode_val (chunk: memory_chunk) (v: val) : list memval :=
  match v, chunk with
  | Vint n, (Mint8signed | Mint8unsigned) => inj_bytes (encode_int 1%nat (Int.unsigned n))
  | Vint n, (Mint16signed | Mint16unsigned) => inj_bytes (encode_int 2%nat (Int.unsigned n))
  | Vint n, Mint32 => inj_bytes (encode_int 4%nat (Int.unsigned n))
  | Vptr b ofs, Mint32 => inj_pointer 4%nat b ofs
  | Vfloat n, Mfloat32 => inj_bytes (encode_int 4%nat (Int.unsigned (Float.bits_of_single n)))
  | Vfloat n, (Mfloat64 | Mfloat64al32) => inj_bytes (encode_int 8%nat (Int64.unsigned (Float.bits_of_double n)))
  | _, _ => list_repeat (size_chunk_nat chunk) Undef
  end.

Definition decode_val (chunk: memory_chunk) (vl: list memval) : val :=
  match proj_bytes vl with
  | Some bl =>
      match chunk with
      | Mint8signed => Vint(Int.sign_ext 8 (Int.repr (decode_int bl)))
      | Mint8unsigned => Vint(Int.zero_ext 8 (Int.repr (decode_int bl)))
      | Mint16signed => Vint(Int.sign_ext 16 (Int.repr (decode_int bl)))
      | Mint16unsigned => Vint(Int.zero_ext 16 (Int.repr (decode_int bl)))
      | Mint32 => Vint(Int.repr(decode_int bl))
      | Mfloat32 => Vfloat(Float.single_of_bits (Int.repr (decode_int bl)))
      | Mfloat64 | Mfloat64al32 => Vfloat(Float.double_of_bits (Int64.repr (decode_int bl)))
      end
  | None =>
      match chunk with
      | Mint32 => proj_pointer vl
      | _ => Vundef
      end
  end.

Lemma encode_val_length:
  forall chunk v, length(encode_val chunk v) = size_chunk_nat chunk.
Proof.
  intros. destruct v; simpl; destruct chunk;
  solve [ reflexivity
        | apply length_list_repeat
        | rewrite length_inj_bytes; apply encode_int_length ].
Qed.

Lemma check_inj_pointer:
  forall b ofs n, check_pointer n b ofs (inj_pointer n b ofs) = true.
Proof.
  induction n; simpl. auto.
  unfold proj_sumbool. rewrite dec_eq_true. rewrite dec_eq_true.
  rewrite <- beq_nat_refl. simpl; auto.
Qed.

Definition decode_encode_val (v1: val) (chunk1 chunk2: memory_chunk) (v2: val) : Prop :=
  match v1, chunk1, chunk2 with
  | Vundef, _, _ => v2 = Vundef
  | Vint n, Mint8signed, Mint8signed => v2 = Vint(Int.sign_ext 8 n)
  | Vint n, Mint8unsigned, Mint8signed => v2 = Vint(Int.sign_ext 8 n)
  | Vint n, Mint8signed, Mint8unsigned => v2 = Vint(Int.zero_ext 8 n)
  | Vint n, Mint8unsigned, Mint8unsigned => v2 = Vint(Int.zero_ext 8 n)
  | Vint n, Mint16signed, Mint16signed => v2 = Vint(Int.sign_ext 16 n)
  | Vint n, Mint16unsigned, Mint16signed => v2 = Vint(Int.sign_ext 16 n)
  | Vint n, Mint16signed, Mint16unsigned => v2 = Vint(Int.zero_ext 16 n)
  | Vint n, Mint16unsigned, Mint16unsigned => v2 = Vint(Int.zero_ext 16 n)
  | Vint n, Mint32, Mint32 => v2 = Vint n
  | Vint n, Mint32, Mfloat32 => v2 = Vfloat(Float.single_of_bits n)
  | Vint n, (Mfloat32 | Mfloat64 | Mfloat64al32), _ => v2 = Vundef
  | Vint n, _, _ => True (**r nothing meaningful to say about v2 *)
  | Vptr b ofs, Mint32, Mint32 => v2 = Vptr b ofs
  | Vptr b ofs, _, _ => v2 = Vundef
  | Vfloat f, Mfloat32, Mfloat32 => v2 = Vfloat(Float.singleoffloat f)
  | Vfloat f, Mfloat32, Mint32 => v2 = Vint(Float.bits_of_single f)
  | Vfloat f, (Mfloat64 | Mfloat64al32), (Mfloat64 | Mfloat64al32) => v2 = Vfloat f
  | Vfloat f, (Mint8signed|Mint8unsigned|Mint16signed|Mint16unsigned|Mint32), _ => v2 = Vundef
  | Vfloat f, _, _ => True   (* nothing interesting to say about v2 *)
  end.

Remark decode_val_undef:
  forall bl chunk, decode_val chunk (Undef :: bl) = Vundef.
Proof.
  intros. unfold decode_val. simpl. destruct chunk; auto.
Qed.

Lemma decode_encode_val_general:
  forall v chunk1 chunk2,
  decode_encode_val v chunk1 chunk2 (decode_val chunk2 (encode_val chunk1 v)).
Proof.
Opaque inj_pointer.
  intros.
  destruct v; destruct chunk1; simpl; try (apply decode_val_undef);
  destruct chunk2; unfold decode_val; auto; try (rewrite proj_inj_bytes).
  (* int-int *)
  rewrite decode_encode_int_1. decEq. apply Int.sign_ext_zero_ext. compute; auto.
  rewrite decode_encode_int_1. decEq. apply Int.zero_ext_idem. compute; auto.
  rewrite decode_encode_int_1. decEq. apply Int.sign_ext_zero_ext. compute; auto.
  rewrite decode_encode_int_1. decEq. apply Int.zero_ext_idem. compute; auto.
  rewrite decode_encode_int_2. decEq. apply Int.sign_ext_zero_ext. compute; auto.
  rewrite decode_encode_int_2. decEq. apply Int.zero_ext_idem. compute; auto.
  rewrite decode_encode_int_2. decEq. apply Int.sign_ext_zero_ext. compute; auto.
  rewrite decode_encode_int_2. decEq. apply Int.zero_ext_idem. compute; auto.
  rewrite decode_encode_int_4. auto.
  rewrite decode_encode_int_4. auto.
  rewrite decode_encode_int_4. auto.
  rewrite decode_encode_int_4. decEq. apply Float.single_of_bits_of_single.
  rewrite decode_encode_int_8. decEq. apply Float.double_of_bits_of_double.
  rewrite decode_encode_int_8. decEq. apply Float.double_of_bits_of_double.
  rewrite decode_encode_int_8. decEq. apply Float.double_of_bits_of_double.
  rewrite decode_encode_int_8. decEq. apply Float.double_of_bits_of_double.
  change (proj_bytes (inj_pointer 4 b i)) with (@None (list byte)). simpl.
  unfold proj_pointer. generalize (check_inj_pointer b i 4%nat).
Transparent inj_pointer.
  simpl. intros EQ; rewrite EQ; auto.
Qed.

Lemma decode_encode_val_similar:
  forall v1 chunk1 chunk2 v2,
  type_of_chunk chunk1 = type_of_chunk chunk2 ->
  size_chunk chunk1 = size_chunk chunk2 ->
  decode_encode_val v1 chunk1 chunk2 v2 ->
  v2 = Val.load_result chunk2 v1.
Proof.
  intros until v2; intros TY SZ DE.
  destruct chunk1; destruct chunk2; simpl in TY; try discriminate; simpl in SZ; try omegaContradiction;
  destruct v1; auto.
Qed.

Lemma decode_val_type:
  forall chunk cl,
  Val.has_type (decode_val chunk cl) (type_of_chunk chunk).
Proof.
  intros. unfold decode_val.
  destruct (proj_bytes cl).
  destruct chunk; simpl; auto.
  destruct chunk; simpl; auto.
  unfold proj_pointer. destruct cl; try (exact I).
  destruct m; try (exact I).
  destruct (check_pointer 4%nat b i (Pointer b i n :: cl));
  exact I.
Qed.

Lemma encode_val_int8_signed_unsigned:
  forall v, encode_val Mint8signed v = encode_val Mint8unsigned v.
Proof.
  intros. destruct v; simpl; auto.
Qed.

Lemma encode_val_int16_signed_unsigned:
  forall v, encode_val Mint16signed v = encode_val Mint16unsigned v.
Proof.
  intros. destruct v; simpl; auto.
Qed.

Lemma encode_val_int8_zero_ext:
  forall n, encode_val Mint8unsigned (Vint (Int.zero_ext 8 n)) = encode_val Mint8unsigned (Vint n).
Proof.
  intros; unfold encode_val. decEq. apply encode_int_8_mod. apply Int.eqmod_zero_ext. compute; auto.
Qed.

Lemma encode_val_int8_sign_ext:
  forall n, encode_val Mint8signed (Vint (Int.sign_ext 8 n)) = encode_val Mint8signed (Vint n).
Proof.
  intros; unfold encode_val. decEq. apply encode_int_8_mod. apply Int.eqmod_sign_ext'. compute; auto.
Qed.

Lemma encode_val_int16_zero_ext:
  forall n, encode_val Mint16unsigned (Vint (Int.zero_ext 16 n)) = encode_val Mint16unsigned (Vint n).
Proof.
  intros; unfold encode_val. decEq. apply encode_int_16_mod. apply Int.eqmod_zero_ext. compute; auto.
Qed.

Lemma encode_val_int16_sign_ext:
  forall n, encode_val Mint16signed (Vint (Int.sign_ext 16 n)) = encode_val Mint16signed (Vint n).
Proof.
  intros; unfold encode_val. decEq. apply encode_int_16_mod. apply Int.eqmod_sign_ext'. compute; auto.
Qed.

Lemma decode_val_cast:
  forall chunk l,
  let v := decode_val chunk l in
  match chunk with
  | Mint8signed => v = Val.sign_ext 8 v
  | Mint8unsigned => v = Val.zero_ext 8 v
  | Mint16signed => v = Val.sign_ext 16 v
  | Mint16unsigned => v = Val.zero_ext 16 v
  | Mfloat32 => v = Val.singleoffloat v
  | _ => True
  end.
Proof.
  unfold decode_val; intros; destruct chunk; auto; destruct (proj_bytes l); auto.
  unfold Val.sign_ext. rewrite Int.sign_ext_idem; auto. compute; auto.
  unfold Val.zero_ext. rewrite Int.zero_ext_idem; auto. compute; auto.
  unfold Val.sign_ext. rewrite Int.sign_ext_idem; auto. compute; auto.
  unfold Val.zero_ext. rewrite Int.zero_ext_idem; auto. compute; auto.
  simpl. rewrite Float.singleoffloat_of_bits. auto.
Qed.

(** Pointers cannot be forged. *)

Definition memval_valid_first (mv: memval) : Prop :=
  match mv with
  | Pointer b ofs n => n = 3%nat
  | _ => True
  end.

Definition memval_valid_cont (mv: memval) : Prop :=
  match mv with
  | Pointer b ofs n => n <> 3%nat
  | _ => True
  end.

Inductive encoding_shape: list memval -> Prop :=
  | encoding_shape_intro: forall mv1 mvl,
      memval_valid_first mv1 ->
      (forall mv, In mv mvl -> memval_valid_cont mv) ->
      encoding_shape (mv1 :: mvl).

Lemma encode_val_shape:
  forall chunk v, encoding_shape (encode_val chunk v).
Proof.
  intros.
  destruct (size_chunk_nat_pos chunk) as [sz1 EQ].
  assert (A: encoding_shape (list_repeat (size_chunk_nat chunk) Undef)).
    rewrite EQ; simpl; constructor. exact I.
    intros. replace mv with Undef. exact I. symmetry; eapply in_list_repeat; eauto.
  assert (B: forall bl, length bl = size_chunk_nat chunk ->
          encoding_shape (inj_bytes bl)).
    intros. destruct bl; simpl in *. congruence.
    constructor. exact I. unfold inj_bytes. intros.
    exploit list_in_map_inv; eauto. intros [x [C D]]. subst mv. exact I.
  destruct v; auto; destruct chunk; simpl; auto; try (apply B; apply encode_int_length).
  constructor. red. auto.
  simpl; intros. intuition; subst mv; red; simpl; congruence.
Qed.

Lemma check_pointer_inv:
  forall b ofs n mv,
  check_pointer n b ofs mv = true -> mv = inj_pointer n b ofs.
Proof.
  induction n; destruct mv; simpl.
  auto.
  congruence.
  congruence.
  destruct m; try congruence. intro.
  destruct (andb_prop _ _ H). destruct (andb_prop _ _ H0).
  destruct (andb_prop _ _ H2).
  decEq. decEq. symmetry; eapply proj_sumbool_true; eauto.
  symmetry; eapply proj_sumbool_true; eauto.
  symmetry; apply beq_nat_true; auto.
  auto.
Qed.

Inductive decoding_shape: list memval -> Prop :=
  | decoding_shape_intro: forall mv1 mvl,
      memval_valid_first mv1 -> mv1 <> Undef ->
      (forall mv, In mv mvl -> memval_valid_cont mv /\ mv <> Undef) ->
      decoding_shape (mv1 :: mvl).

Lemma decode_val_shape:
  forall chunk mvl,
  List.length mvl = size_chunk_nat chunk ->
  decode_val chunk mvl = Vundef \/ decoding_shape mvl.
Proof.
  intros. destruct (size_chunk_nat_pos chunk) as [sz EQ].
  unfold decode_val.
  caseEq (proj_bytes mvl).
  intros bl PROJ. right. exploit inj_proj_bytes; eauto. intros. subst mvl.
  destruct bl; simpl in H. congruence. simpl. constructor.
  red; auto. congruence.
  unfold inj_bytes; intros. exploit list_in_map_inv; eauto. intros [b [A B]].
  subst mv. split. red; auto. congruence.
  intros. destruct chunk; auto. unfold proj_pointer.
  destruct mvl; auto. destruct m; auto.
  caseEq (check_pointer 4%nat b i (Pointer b i n :: mvl)); auto.
  intros. right. exploit check_pointer_inv; eauto. simpl; intros; inv H2.
  constructor. red. auto. congruence.
  simpl; intros. intuition; subst mv; simpl; congruence.
Qed.

Lemma encode_val_pointer_inv:
  forall chunk v b ofs n mvl,
  encode_val chunk v = Pointer b ofs n :: mvl ->
  chunk = Mint32 /\ v = Vptr b ofs /\ mvl = inj_pointer 3%nat b ofs.
Proof.
  intros until mvl.
  assert (A: list_repeat (size_chunk_nat chunk) Undef = Pointer b ofs n :: mvl ->
            chunk = Mint32 /\ v = Vptr b ofs /\ mvl = inj_pointer 3 b ofs).
    intros. destruct (size_chunk_nat_pos chunk) as [sz SZ]. rewrite SZ in H. simpl in H. discriminate.
  assert (B: forall bl, length bl <> 0%nat -> inj_bytes bl = Pointer b ofs n :: mvl ->
            chunk = Mint32 /\ v = Vptr b ofs /\ mvl = inj_pointer 3 b ofs).
    intros. destruct bl; simpl in *; congruence.
  unfold encode_val; destruct v; destruct chunk;
  (apply A; assumption) ||
  (apply B; rewrite encode_int_length; congruence) || idtac.
  simpl. intros EQ; inv EQ; auto.
Qed.

Lemma decode_val_pointer_inv:
  forall chunk mvl b ofs,
  decode_val chunk mvl = Vptr b ofs ->
  chunk = Mint32 /\ mvl = inj_pointer 4%nat b ofs.
Proof.
  intros until ofs; unfold decode_val.
  destruct (proj_bytes mvl).
  destruct chunk; congruence.
  destruct chunk; try congruence.
  unfold proj_pointer. destruct mvl. congruence. destruct m; try congruence.
  case_eq (check_pointer 4%nat b0 i (Pointer b0 i n :: mvl)); intros.
  inv H0. split; auto. apply check_pointer_inv; auto.
  congruence.
Qed.

Inductive pointer_encoding_shape: list memval -> Prop :=
  | pointer_encoding_shape_intro: forall mv1 mvl,
      ~memval_valid_cont mv1 ->
      (forall mv, In mv mvl -> ~memval_valid_first mv) ->
      pointer_encoding_shape (mv1 :: mvl).

Lemma encode_pointer_shape:
  forall b ofs, pointer_encoding_shape (encode_val Mint32 (Vptr b ofs)).
Proof.
  intros. simpl. constructor.
  unfold memval_valid_cont. red; intro. elim H. auto.
  unfold memval_valid_first. simpl; intros; intuition; subst mv; congruence.
Qed.

Lemma decode_pointer_shape:
  forall chunk mvl b ofs,
  decode_val chunk mvl = Vptr b ofs ->
  chunk = Mint32 /\ pointer_encoding_shape mvl.
Proof.
  intros. exploit decode_val_pointer_inv; eauto. intros [A B].
  split; auto. subst mvl. apply encode_pointer_shape.
Qed.

(** * Compatibility with memory injections *)

(** Relating two memory values according to a memory injection. *)

Inductive memval_inject (f: meminj): memval -> memval -> Prop :=
  | memval_inject_byte:
      forall n, memval_inject f (Byte n) (Byte n)
  | memval_inject_ptr:
      forall b1 ofs1 b2 ofs2 delta n,
      f b1 = Some (b2, delta) ->
      ofs2 = Int.add ofs1 (Int.repr delta) ->
      memval_inject f (Pointer b1 ofs1 n) (Pointer b2 ofs2 n)
  | memval_inject_undef:
      forall mv, memval_inject f Undef mv.

Lemma memval_inject_incr:
  forall f f' v1 v2, memval_inject f v1 v2 -> inject_incr f f' -> memval_inject f' v1 v2.
Proof.
  intros. inv H; econstructor. rewrite (H0 _ _ _ H1). reflexivity. auto.
Qed.

(** [decode_val], applied to lists of memory values that are pairwise
  related by [memval_inject], returns values that are related by [val_inject]. *)

Lemma proj_bytes_inject:
  forall f vl vl',
  list_forall2 (memval_inject f) vl vl' ->
  forall bl,
  proj_bytes vl = Some bl ->
  proj_bytes vl' = Some bl.
Proof.
  induction 1; simpl. congruence.
  inv H; try congruence.
  destruct (proj_bytes al); intros.
  inv H. rewrite (IHlist_forall2 l); auto.
  congruence.
Qed.

Lemma check_pointer_inject:
  forall f vl vl',
  list_forall2 (memval_inject f) vl vl' ->
  forall n b ofs b' delta,
  check_pointer n b ofs vl = true ->
  f b = Some(b', delta) ->
  check_pointer n b' (Int.add ofs (Int.repr delta)) vl' = true.
Proof.
  induction 1; intros; destruct n; simpl in *; auto.
  inv H; auto.
  destruct (andb_prop _ _ H1). destruct (andb_prop _ _ H).
  destruct (andb_prop _ _ H5).
  assert (n = n0) by (apply beq_nat_true; auto).
  assert (b = b0) by (eapply proj_sumbool_true; eauto).
  assert (ofs = ofs1) by (eapply proj_sumbool_true; eauto).
  subst. rewrite H3 in H2; inv H2.
  unfold proj_sumbool. rewrite dec_eq_true. rewrite dec_eq_true.
  rewrite <- beq_nat_refl. simpl. eauto.
  congruence.
Qed.

Lemma proj_pointer_inject:
  forall f vl1 vl2,
  list_forall2 (memval_inject f) vl1 vl2 ->
  val_inject f (proj_pointer vl1) (proj_pointer vl2).
Proof.
  intros. unfold proj_pointer.
  inversion H; subst. auto. inversion H0; subst; auto.
  case_eq (check_pointer 4%nat b0 ofs1 (Pointer b0 ofs1 n :: al)); intros.
  exploit check_pointer_inject. eexact H. eauto. eauto.
  intro. rewrite H4. econstructor; eauto.
  constructor.
Qed.

Lemma proj_bytes_not_inject:
  forall f vl vl',
  list_forall2 (memval_inject f) vl vl' ->
  proj_bytes vl = None -> proj_bytes vl' <> None -> In Undef vl.
Proof.
  induction 1; simpl; intros.
  congruence.
  inv H; try congruence.
  right. apply IHlist_forall2.
  destruct (proj_bytes al); congruence.
  destruct (proj_bytes bl); congruence.
  auto.
Qed.

Lemma check_pointer_undef:
  forall n b ofs vl,
  In Undef vl -> check_pointer n b ofs vl = false.
Proof.
  induction n; intros; simpl.
  destruct vl. elim H. auto.
  destruct vl. auto.
  destruct m; auto. simpl in H; destruct H. congruence.
  rewrite IHn; auto. apply andb_false_r.
Qed.

Lemma proj_pointer_undef:
  forall vl, In Undef vl -> proj_pointer vl = Vundef.
Proof.
  intros; unfold proj_pointer.
  destruct vl; auto. destruct m; auto.
  rewrite check_pointer_undef. auto. auto.
Qed.

Theorem decode_val_inject:
  forall f vl1 vl2 chunk,
  list_forall2 (memval_inject f) vl1 vl2 ->
  val_inject f (decode_val chunk vl1) (decode_val chunk vl2).
Proof.
  intros. unfold decode_val.
  case_eq (proj_bytes vl1); intros.
  exploit proj_bytes_inject; eauto. intros. rewrite H1.
  destruct chunk; constructor.
  destruct chunk; auto.
  case_eq (proj_bytes vl2); intros.
  rewrite proj_pointer_undef. auto. eapply proj_bytes_not_inject; eauto. congruence.
  apply proj_pointer_inject; auto.
Qed.

(** Symmetrically, [encode_val], applied to values related by [val_inject],
  returns lists of memory values that are pairwise
  related by [memval_inject]. *)

Lemma inj_bytes_inject:
  forall f bl, list_forall2 (memval_inject f) (inj_bytes bl) (inj_bytes bl).
Proof.
  induction bl; constructor; auto. constructor.
Qed.

Lemma repeat_Undef_inject_any:
  forall f vl,
  list_forall2 (memval_inject f) (list_repeat (length vl) Undef) vl.
Proof.
  induction vl; simpl; constructor; auto. constructor.
Qed.

Lemma repeat_Undef_inject_self:
  forall f n,
  list_forall2 (memval_inject f) (list_repeat n Undef) (list_repeat n Undef).
Proof.
  induction n; simpl; constructor; auto. constructor.
Qed.

Theorem encode_val_inject:
  forall f v1 v2 chunk,
  val_inject f v1 v2 ->
  list_forall2 (memval_inject f) (encode_val chunk v1) (encode_val chunk v2).
Proof.
  intros. inv H; simpl.
  destruct chunk; apply inj_bytes_inject || apply repeat_Undef_inject_self.
  destruct chunk; apply inj_bytes_inject || apply repeat_Undef_inject_self.
  destruct chunk; try (apply repeat_Undef_inject_self).
  repeat econstructor; eauto.
  replace (size_chunk_nat chunk) with (length (encode_val chunk v2)).
  apply repeat_Undef_inject_any. apply encode_val_length.
Qed.

Definition memval_lessdef: memval -> memval -> Prop := memval_inject inject_id.

Lemma memval_lessdef_refl:
  forall mv, memval_lessdef mv mv.
Proof.
  red. destruct mv; econstructor.
  unfold inject_id; reflexivity. rewrite Int.add_zero; auto.
Qed.

(** [memval_inject] and compositions *)

Lemma memval_inject_compose:
  forall f f' v1 v2 v3,
  memval_inject f v1 v2 -> memval_inject f' v2 v3 ->
  memval_inject (compose_meminj f f') v1 v3.
Proof.
  intros. inv H.
  inv H0. constructor.
  inv H0. econstructor.
  unfold compose_meminj; rewrite H1; rewrite H5; eauto.
  rewrite Int.add_assoc. decEq. unfold Int.add. apply Int.eqm_samerepr. auto with ints.
  constructor.
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool ssrint eqtype ssrnat seq choice fintype rat finfun.
From mathcomp Require Import bigop ssralg div ssrnum ssrint finmap.

Require Import Meas Aux PIOA Ascii String CompPIOA SSRString FastEnum Action Refinement StateSim Compute PIOAOps.

Require Import Coq.Strings.String.
Local Open Scope string_scope.

Require Import Lens.Lens Lens.TC.

Require Import Derive.

Set Primitive Projections.

Lemma ctx_is_empty_l_spec {C D : ctx} (H : C ~~ emptyCtx) :
  ctxbij_spec D (C :+: D) (fun x => inr x) (fun x => match x with | inl a => match (lr H a) with end | inr a => a end).
  constructor.
 done.
 case => a; rewrite //=.
 generalize (H *c a).
 case.
 move => x; simpl.
 done.
Qed.

Definition ctx_is_empty_l {C D : ctx} (H : C ~~ emptyCtx) : D ~~ (C :+: D).
  econstructor; apply (ctx_is_empty_l_spec H).
Defined.

Lemma ctx_is_empty_l_appc {C D : ctx} (H : C ~~ emptyCtx) c :
  (@ctx_is_empty_l C D H) *c c =
  inr c.
  done.
Qed.

Inductive RPSContextM :=
  choose | committed | reveal | commit | open | winner.

Definition rps_context_enc (a : RPSContextM) :=
  match a with
  | choose => (None, false)
  | committed => (None, true)
  | reveal => (Some false, false)
  | commit => (Some false, true)
  | open => (Some true, false)
  | winner => (Some true, true) end .

Definition rps_context_dec x :=
  match (x) with
    | (None, false) => choose
    | (None, true) => committed
    | (Some false, false) => reveal
    | (Some false, true) => commit
    | (Some true, false) => open
    | (Some true, true) => winner
  end.

Lemma rps_context_can : cancel rps_context_enc rps_context_dec.
  by case.
Qed.

Canonical rps_eq := EqType RPSContextM (CanEqMixin rps_context_can).
Canonical rps_choice := ChoiceType RPSContextM (CanChoiceMixin rps_context_can).
Canonical rps_count := CountType RPSContextM (CanCountMixin rps_context_can).
Canonical rps_fin := FinType RPSContextM (CanFinMixin rps_context_can).

Instance rps_fe : FastEnum [finType of RPSContextM] := { fastEnum := [:: choose; committed; reveal; commit; open; winner]}.
apply uniq_perm_eq; rewrite ?enum_uniq //= => x; case x; rewrite mem_enum //=.
Defined.

Inductive play := rock | paper | scissors.

Definition play_eq m1 m2 :=
  match m1,m2 with
    | rock,rock => true | paper,paper => true | scissors,scissors => true | _,_ => false end.

Definition play_obool m :=
  match m with
    | rock => None | paper => Some false | scissors => Some true end.

Definition obool_play m :=
  match m with
    | None => rock | Some false => paper | Some true => scissors end.

Lemma play_obool_can : cancel play_obool obool_play.
  by case.
Qed.

Canonical play_eqType := EqType play (CanEqMixin play_obool_can).
Canonical play_choiceType := ChoiceType play (CanChoiceMixin play_obool_can).
Canonical play_countType := CountType play (CanCountMixin play_obool_can).
Canonical play_finType := FinType play (CanFinMixin play_obool_can).

Instance play_fe : FastEnum [finType of play] := {fastEnum := [:: rock; paper; scissors]}.
  apply uniq_perm_eq; rewrite ?enum_uniq //= => x; case x; rewrite mem_enum //=.
Defined.

Definition rps_win_a (va vb : option play) :=
  match va, vb with
    | Some x, Some y => ((x == rock) && (y == scissors)) || ((x == paper) && (y == rock)) || ((x == scissors) && (y == paper))
    | _, _ => false
                end.

Definition rps_win_b (va vb : option play) :=
  match va, vb with
    | Some x, Some y => ((x == rock) && (y == paper)) || ((x == paper) && (y == scissors)) || ((x == scissors) && (y == rock))
    | _, _ => false
                end.

Definition rps_win_tie (va vb : option play) :=
  match va, vb with
  | Some x, Some y => x == y
  | _, _ => false
              end.

Lemma rpsP (va vb : play) : [|| rps_win_a (Some va) (Some vb), rps_win_b (Some va) (Some vb) | rps_win_tie (Some va) (Some vb)].
  destruct va; destruct vb; simpl; done.
Qed.

Definition RPSContext_f (x : RPSContextM * bool) : finType  :=
  match x.1 with
    | (choose) => [finType of play]
    | (committed) => [finType of unit]
    | (reveal) => [finType of play]
    | (commit) => [finType of play]
    | (open) => [finType of unit]
    | (winner) => [finType of option bool]
                            end.

Definition RPSContext :=
  mkCon ([finType of RPSContextM * bool])%type RPSContext_f.

Instance rpscontext_fe (x : cdom RPSContext) : FastEnum (RPSContext x).
case x; case; case; simpl; rewrite /RPSContext_f //=; apply _.
Defined.

Record playerSt :=
  PlayerSt {
      val1 : option play;
      val2 : option play;
      com1 : bool;
      com2 : bool }.

Run TemplateProgram (deriveFinRecord playerSt "f" "g" "playerSt_cancel1" "playerSt_cancel2").
Next Obligation.
  by case.
Defined.
Next Obligation.
  by case => x; case => y; case => z w.
Defined.

Run TemplateProgram (genLens playerSt).

Instance playerSt_fe : FastEnum [finType of playerSt] := fastEnum_bij playerSt_cancel2 playerSt_cancel1.

Definition player_trans (wh : bool) (s : playerSt) (a : action emptyCtx + action RPSContext) : option {meas playerSt}:=
  match a with
  | inr (existT (choose, b) msg) =>
        if (wh == b) then
        if (val1 s) == None then Some (ret (set _val1 (Some msg) s)) else Some (ret s)
        else None
  | inr (existT (commit, b) msg) =>
        if (wh == b) && (val1 s == Some msg) then
        Some (ret set _com1 true s)
        else None
  | inr (existT (committed, b) msg) =>
        if (wh != b) then
        Some (ret set _com2 true s)
        else None
  | inr (existT (open, b) msg) =>
        if (wh == b) && com1 s && com2 s then
        Some (ret s)
        else None
  | inr (existT (reveal, b) msg) =>
        if (wh != b) then
          if (val2 s == None) then
            Some (ret set _val2 (Some msg) s)
          else Some (ret s)
        else None
  | inr (existT (winner, b) msg) =>
    multiIf [::
        ([&& wh == b, msg == Some true & rps_win_a (val1 s) (val2 s)], (ret s)) ;
        ([&& wh == b, msg == Some false & rps_win_b (val1 s) (val2 s)], (ret s)) ;
        ([&& wh == b, msg == None & rps_win_tie (val1 s) (val2 s)], (ret s)) ]
  | _ => None
      end.

Definition player_data (wh : bool) : PIOA_data RPSContext emptyCtx.
econstructor.
apply (PlayerSt None None false false).
apply ([:: (choose, wh); (committed, ~~ wh); (reveal, ~~ wh)]).
apply ([:: (commit, wh); (open, wh); (winner, wh)]).
apply (player_trans wh).
Defined.

Lemma if_eq_irrel {A} (b : bool) (c e d : A) (p : Prop) :
  (c = d -> p) -> (e = d -> p) -> (if b then c else e) = d -> p.
  intros ; destruct b.
  apply H; done.
  apply H0; done.
Qed.

Lemma player_spec wh : PIOA_spec (player_data wh).
econstructor.
done.
done.
  intros; apply (decide_ad_vP RPSContext emptyCtx _ [finType of playerSt] (player_trans wh) [:: (commit, wh); (open, wh); (winner, wh)] s).
  done.
  done.
  done.
  case wh; vm_compute; done.

  intros; apply (decide_i_aP RPSContext emptyCtx _ [finType of playerSt] _  [:: (choose, wh); (committed, ~~ wh); (reveal, ~~ wh)] ).
  done.
  case wh; vm_compute; done.
  move => s a mu; destruct a.
  done.

  destruct a; simpl.
  destruct x as [r b]; simpl; destruct r; pioa_dist_tac.
Qed.

Definition playerA := mkPIOA _ _ (player_data false) (player_spec false).
Definition playerB := mkPIOA _ _ (player_data true) (player_spec true).

Definition Ftrans (s : playerSt) (a : action emptyCtx + action RPSContext) : option {meas playerSt} :=
  match a with
  | inr (existT (commit, false) msg) =>
    Some (ret set _val1 (if view _val1 s == None then Some msg else view _val1 s) s)
  | inr (existT (commit, true) msg) =>
    Some (ret set _val2 (if view _val2 s == None then Some msg else view _val2 s) s)
  | inr (existT (committed, false) _) =>
    if (val1 s) != None then Some (ret s) else None
  | inr (existT (committed, true) _) =>
    if (val2 s) != None then Some (ret s) else None
  | inr (existT (open, false) _) =>
    Some (ret (set _com1 true s))
  | inr (existT (open, true) _) =>
    Some (ret (set _com2 true s))
  | inr (existT (reveal, false) x) =>
    if ((com1 s) && ((val1 s) == Some x)) then Some (ret s) else None
  | inr (existT (reveal, true) x) =>
    if ((com2 s) && ((val2 s) == Some x)) then Some (ret s) else None
  | _ => None end.

Definition funct_data : PIOA_data RPSContext emptyCtx.
econstructor.
apply (PlayerSt None None false false).
    apply [:: (commit, true); (commit, false); (open, true); (open,false)].
apply    [:: (committed, true); (committed, false); (reveal, true); (reveal, false)].
apply Ftrans.
Defined.

Lemma funct_spec : PIOA_spec funct_data.
econstructor.
done.
done.
  intros; eapply (decide_ad_vP RPSContext emptyCtx _ [finType of playerSt] _ _ s).
  apply H.
  apply H0.
  done.
  vm_compute; done.

  intros; eapply decide_i_aP.
  apply H.
  vm_compute; done.
  move => s a mu; destruct a.
  done.
  destruct a as [r b]; simpl; destruct r.
  destruct r; pioa_dist_tac.
  destruct b0; pioa_dist_tac.
  destruct b0; pioa_dist_tac.
  destruct b0; pioa_dist_tac.
  destruct b0; pioa_dist_tac.
Qed.

Definition Funct := mkPIOA _ _ funct_data funct_spec.

Lemma compatAB : compatible playerA playerB.
  done.
Qed.

Lemma compatABF : compatible (playerA ||| playerB) Funct.
  done.
Qed.

Definition rpshide : seq (cdom RPSContext) :=
  [:: (commit, true); (commit, false);
      (committed, true); (committed, false);
      (open, true); (open, false);
      (reveal, true); (reveal, false)].

Definition IRPS : PIOA RPSContext (RPSContext |c_ rpshide).
  eapply changeH.
  apply (hidePIOA (playerA ||| playerB ||| Funct) rpshide).
  done.
  apply ctx_is_empty_l.
  apply ctx_symm.
  apply ctx_is_empty_l.
  apply ctx_symm; apply empty_plus_r.
Defined.

Definition FReal (wh : bool) (s : option play * bool) (a : action emptyCtx + action RPSContext) :=
  match a with
  | inr (existT (commit, b) m) =>
    if wh == b then Some (ret (set _1 (if s.1 == None then Some m else s.1) s)) else None
  | inr (existT (committed, b) m) =>
    if (wh == b) && (s.1 != None) then Some (ret s) else None
  | inr (existT (open, b) m) =>
    if (wh == b) then Some (ret set _2 true s) else None
  | inr (existT (reveal, b) m) =>
    if (wh == b) && (s.2) && (s.1 == Some m) then Some (ret s) else None
  | _ => None
                                                                      end.

Definition FAB_data (wh : bool) : PIOA_data RPSContext emptyCtx.
econstructor.
apply ((None, false)  : option play * bool).
    apply [:: (commit, wh); (open, wh)].
apply    [:: (committed, wh); (reveal, wh)].
apply (FReal wh).
Defined.

Definition FAB_spec (wh : bool) : PIOA_spec (FAB_data wh).
  constructor.
  done.
  done.
  intros; eapply (decide_ad_vP RPSContext emptyCtx _ [finType of option play * bool] _ _ s).
  apply H.
  apply H0.
  done.
  case wh; vm_compute; done.

  intros; eapply decide_i_aP.
  apply H.
  case wh; vm_compute; done.
  intros; simpl.
  move: H; simpl; rewrite /FReal.
  destruct a; rewrite //=; destruct a; destruct x; destruct r; pioa_dist_tac.
Qed.

Definition FA := mkPIOA _ _ (FAB_data false) (FAB_spec false).
Definition FB := mkPIOA _ _ (FAB_data true) (FAB_spec true).

Definition RRPS : PIOA RPSContext (RPSContext |c_ rpshide).
  eapply changeH.
  apply (hidePIOA (playerA ||| playerB ||| FA ||| FB) rpshide).
  done.

  apply ctx_is_empty_l.
  apply ctx_symm; apply ctx_is_empty_l.
  apply ctx_symm; apply ctx_is_empty_l.
  apply ctx_symm; apply empty_plus_r.
Defined.

Definition R_RPS (x : St RRPS) : St IRPS :=
  (x.1.1.1, x.1.1.2, PlayerSt x.1.2.1 x.2.1 x.1.2.2 x.2.2).

Ltac app_v_comp_l_ext_tac :=
  rewrite app_v_comp_l_ext; [ idtac | done | done | done].

Ltac app_v_comp_r_ext_tac :=
  rewrite app_v_comp_r_ext; [ idtac | done | done | done].

Ltac app_v_comp_l_int_tac :=
  rewrite app_v_comp_l_int; [ idtac | done | done | done].

Ltac app_v_comp_r_int_tac :=
  rewrite app_v_comp_r_int; [ idtac | done | done | done].

Ltac caseof_tac b t1 t2 :=
  match (eval cbv in b) with
  | true => t1
  | false => t2
               end.

Ltac app_v_comp_tac :=
  match goal with
  | [ |- context[app_v (?P ||| ?Q) ?c ?x]] =>
    match (eval cbv in (c \in outputs P))  with
        | true =>
          match (eval cbv in (c \in inputs Q)) with
            | true => app_v_comp_l_int_tac
            | false => app_v_comp_l_ext_tac
                         end
        | false =>
          match (eval cbv in (c \in inputs P)) with
            | true => app_v_comp_r_int_tac
            | false => app_v_comp_r_ext_tac
                         end
  end
    end.

Lemma rps_sim : SimpleStateInj RRPS IRPS R_RPS.
  constructor.
  done.
  simpl => x c Hc.
  rewrite /RRPS /IRPS; simpl.
  rewrite !appv_changeh.
  rewrite !appv_hide.
  move: Hc.
  move/inP.
  split_In.
  repeat app_v_comp_tac; rewrite !measE; apply mbind_eqP => y Hy; rewrite !measE //=.
  repeat app_v_comp_tac; rewrite !measE; apply mbind_eqP => y Hy; rewrite !measE //=.

  move => x h.
  rewrite /RRPS /IRPS.
  rewrite apph_changeh.
  rewrite apph_changeh.
  simpl.
  rewrite app_h_hidden.
  rewrite app_h_hidden.

  destruct h as [h H]; simpl; move: H.
  rewrite /rpshide; move/inP; split_In; repeat app_v_comp_tac; rewrite !measE //=.

  elim: (app_vP playerB (commit, true) x.1.1.2); last by done.
  move => m mu Heq ->; rewrite !measE; munder (rewrite !measE /R_RPS //=). done.
  move => _ ->; rewrite !measE //=.

  elim: (app_vP playerA (commit, false) x.1.1.1); last by done.
  move => m mu Heq ->; rewrite !measE; munder (rewrite !measE /R_RPS //=). done.
  move => _ ->; rewrite !measE //=.

  apply (app_v_equienabledP FB Funct); [done | done | idtac | idtac | idtac].
  rewrite /v_chan_equienabled /v_chan_enabled /enabled //=.
  by (exunder (rewrite if_neq_None)).

    simpl => m m' mu mu'; move/eqP; rewrite if_eq_Some => /andP [h1 /eqP h2] /eqP; rewrite if_eq_Some => /andP [h3 /eqP h4]; rewrite -h2 -h4 !measE //= /R_RPS //=.

    move => H; rewrite !measE //=.

  apply (app_v_equienabledP FA Funct); [done | done | idtac | idtac | idtac].
  rewrite /v_chan_equienabled /v_chan_enabled /enabled //=.
  by (exunder (rewrite if_neq_None)).

    simpl => m m' mu mu'; move/eqP; rewrite if_eq_Some => /andP [h1 /eqP h2] /eqP; rewrite if_eq_Some => /andP [h3 /eqP h4]; rewrite -h2 -h4 !measE //= /R_RPS //=.

    move => H; rewrite !measE //=.

  elim: (app_vP playerB (open, true) x.1.1.2); last by done.
  move => m mu Heq ->; rewrite !measE; munder (rewrite !measE /R_RPS //=). done.
  move => _ ->; rewrite !measE //=.

  elim: (app_vP playerA (open, false) x.1.1.1); last by done.
  move => m mu Heq ->; rewrite !measE; munder (rewrite !measE /R_RPS //=). done.
  move => _ ->; rewrite !measE //=.

  apply (app_v_equienabledP FB Funct); [done | done | idtac | idtac | idtac].
  rewrite /v_chan_equienabled /v_chan_enabled /enabled //=.
  by (exunder (rewrite if_neq_None)).

    simpl => m m' mu mu'; move/eqP; rewrite if_eq_Some => /andP [h1 /eqP h2] /eqP; rewrite if_eq_Some => /andP [h3 /eqP h4]; rewrite -h2 -h4 !measE //= /R_RPS //=.

 rewrite /app_i //=.
 remember (val2 x.1.1.1) as v2; destruct v2; rewrite -Heqv2 //=.
 rewrite !measE //=.
 rewrite !measE //=.
 move/andP: h1 => [h11 h12].
 move/andP: h3 => [h31 h32].
 rewrite -(eqP h12) -(eqP h32) //=.
 rewrite !measE //=.

  apply (app_v_equienabledP FA Funct); [done | done | idtac | idtac | idtac].
  rewrite /v_chan_equienabled /v_chan_enabled /enabled //=.
  by (exunder (rewrite if_neq_None)).

    simpl => m m' mu mu'; move/eqP; rewrite if_eq_Some => /andP [h1 /eqP h2] /eqP; rewrite if_eq_Some => /andP [h3 /eqP h4]; rewrite -h2 -h4 !measE //= /R_RPS //=.
    rewrite /app_i //=.
 remember (val2 x.1.1.2) as v2; destruct v2; rewrite -Heqv2 //=.
 rewrite !measE //=.
 rewrite !measE //=.
 move/andP: h1 => [h11 h12].
 move/andP: h3 => [h31 h32].
 rewrite -(eqP h12) -(eqP h32) //=.

 rewrite !measE //=.

  (* for app_i, we may simply compute on the transition function since we know the action. *)
  move => x.
  elim; simpl => c m Hc.
  move: Hc m.
  move/inP.
  split_In; simpl; rewrite /app_i //= => m.
  remember (val1 x.1.1.1) as v1; destruct v1; rewrite -Heqv1 //=;
  rewrite !measE /R_RPS //=.
  remember (val1 x.1.1.2) as v1; destruct v1; rewrite -Heqv1 //=;
  rewrite !measE /R_RPS //=.

Qed.


(** The second layer of the construction of the bicategory of pseudofunctors consists of three parts.
    First part: we add an action of 1-cells.
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Base.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.

Local Open Scope cat.

Section Map2Cells.
  Variable (C D : bicat).

  Definition map2cells_disp_cat_data
    : disp_cat_ob_mor (map1cells C D).
  Proof.
    use tpair.
    - exact (λ F, ∏ (X Y : C) (f g : X --> Y), f ==> g → Fmor F f ==> Fmor F g).
    - exact (λ F G F₂ G₂ η, ∏ (X Y : C) (f g : X --> Y) (α : f ==> g),
             (ηobj η X ◃ G₂ X Y f g α) • ηmor η g
             =
             ηmor η f • (F₂ X Y f g α ▹ ηobj η Y)) ; cbn in *.
  Defined.

  Definition map2cells_disp_cat_id_comp
    : disp_cat_id_comp (map1cells C D) map2cells_disp_cat_data.
  Proof.
    split.
    - intros F F₂ X Y f g α ; cbn in *.
      rewrite !vassocr.
      rewrite vcomp_lunitor.
      rewrite !vassocl.
      rewrite rinvunitor_natural.
      rewrite <- rwhisker_hcomp.
      reflexivity.
    - intros F G H η ε F₂ G₂ H₂ η₂ ε₂ X Y f g α ; cbn in *.
      rewrite !vassocr.
      rewrite <- lwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite ε₂.
      rewrite <- lwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_lwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite η₂.
      rewrite <- rwhisker_vcomp.
      rewrite !vassocl.
      rewrite rwhisker_rwhisker_alt.
      reflexivity.
  Qed.

  Definition map2cells_disp_cat
    : disp_bicat (map1cells C D).
  Proof.
    use disp_cell_unit_bicat.
    use tpair.
    - exact map2cells_disp_cat_data.
    - exact map2cells_disp_cat_id_comp.
  Defined.

  Definition map2cells_is_disp_univalent_2_1
    : disp_univalent_2_1 map2cells_disp_cat.
  Proof.
    apply disp_cell_unit_bicat_univalent_2_1.
    intros F G η F₂ G₂ ; simpl in *.
    repeat (apply impred ; intro).
    apply D.
  Defined.

  Definition map2cells_is_disp_univalent_2_0
             (HD_2_1 : is_univalent_2_1 D)
    : disp_univalent_2_0 map2cells_disp_cat.
  Proof.
    use disp_cell_unit_bicat_univalent_2_0.
    - apply map1cells_is_univalent_2_1.
      exact HD_2_1.
    - intros ; simpl.
      repeat (apply impred ; intro).
      apply D.
    - intro ; cbn.
      repeat (apply impred_isaset ; intro).
      apply D.
    - intros F F₂ F₂' η ; cbn in *.
      induction η as [η₁ η₂].
      apply funextsec ; intro X.
      apply funextsec ; intro Y.
      apply funextsec ; intro f.
      apply funextsec ; intro g.
      apply funextsec ; intro α.
      specialize (η₁ X Y f g α).
      specialize (η₂ X Y f g α).
      rewrite !vassocr in η₁.
      rewrite vcomp_lunitor in η₁.
      rewrite !vassocl in η₁.
      rewrite rinvunitor_natural in η₁.
      rewrite <- rwhisker_hcomp in η₁.
      rewrite !vassocr in η₁.
      apply rwhisker_id_inj.
      use (vcomp_lcancel (lunitor _ • rinvunitor _)).
      { is_iso. }
      exact (!η₁).
  Defined.

  Definition map2cells_is_disp_univalent_2
             (HD_2_1 : is_univalent_2_1 D)
    : disp_univalent_2 map2cells_disp_cat.
  Proof.
    split.
    - apply map2cells_is_disp_univalent_2_0; assumption.
    - exact map2cells_is_disp_univalent_2_1.
  Defined.

  Definition map2cells_disp_left_adjequiv_over_id
             {F : map1cells C D}
             {F₂ G₂ : map2cells_disp_cat F}
             (η₂ : F₂ -->[ internal_adjoint_equivalence_identity _ ] G₂)
    : disp_left_adjoint_equivalence (internal_adjoint_equivalence_identity _) η₂.
  Proof.
    apply disp_cell_unit_bicat_left_adjoint_equivalence_weq.
    intros x y f g α.
    cbn.
    pose (η₂ x y f g α) as p.
    cbn in p.
    rewrite !vassocr.
    rewrite vcomp_lunitor.
    rewrite !vassocl.
    rewrite rinvunitor_natural.
    rewrite <- rwhisker_hcomp.
    rewrite !vassocr.
    refine (!p @ _).
    rewrite !vassocr.
    rewrite vcomp_lunitor.
    rewrite !vassocl.
    rewrite rinvunitor_natural.
    rewrite <- rwhisker_hcomp.
    apply idpath.
  Qed.

  Definition map2cells_disp_left_adjequiv
             {HD : is_univalent_2 D}
             {F G : map1cells C D}
             (η : adjoint_equivalence F G)
             {F₂ : map2cells_disp_cat F}
             {G₂ : map2cells_disp_cat G}
             (η₂ : F₂ -->[ η ] G₂)
    : disp_left_adjoint_equivalence η η₂.
  Proof.
    revert F G η F₂ G₂ η₂.
    use J_2_0.
    - apply map1cells_is_univalent_2_0.
      exact HD.
    - intros F F₂ G₂ η₂.
      apply map2cells_disp_left_adjequiv_over_id.
  Defined.
End Map2Cells.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

(** This module provides support for bags (or multisets). *)

Require Import Arith.
Require Import Min.
Require Import Max.
Require Import ZArith.
Require Import Lia.
Require Import Permutation.
Require Import Equivalence.
Require Import Morphisms.
Require Import Setoid.
Require Import EquivDec.
Require Import List.
Require Import CoqLibAdd.
Require Import ListAdd.
Require Import Sublist.
Require Import Assoc.

Section Bag.

  Context {A:Type}.
  Context {eqdec:EqDec A eq}.

  Definition rbag := list A.

  Definition bunion := (@app A).

  Declare Scope rbag_scope.
  Delimit Scope rbag_scope with rbag.
  Bind Scope rbag_scope with rbag.
  Open Scope rbag_scope.

  Notation "X ≅ Y" := (ldeqA X Y) (at level 70) : rbag_scope.                              (* ≅ = \cong *)
  Notation "b1 ⊎ b2" := (bunion b1 b2) (right associativity, at level 70) : rbag_scope.    (* ⊎ = \uplus *)

  Global Instance bunion_proper : Proper (ldeqA ==> ldeqA ==> ldeqA) bunion.
  Proof.
    unfold Proper, respectful.
    intros. unfold bunion.
    apply Permutation_app; assumption.
  Qed.

  Lemma bunion_nil_r:
    forall (l:list A),
      (l ⊎ nil) = l.
  Proof.
    intros; unfold bunion; rewrite app_nil_r; reflexivity.
  Qed.

  Lemma bunion_nil_l:
    forall (l:list A),
      (nil ⊎ l) = l.
  Proof. reflexivity. Qed.

  Lemma bunion_assoc:
    forall (l1 l2 l3:list A),
      ((l1 ⊎ l2) ⊎ l3) = (l1 ⊎ (l2 ⊎ l3)).
  Proof.
    intros; unfold bunion; rewrite app_assoc; reflexivity.
  Qed.

  Lemma bunion_comm (l1 l2: list A) :
    (l1 ⊎ l2) ≅ (l2 ⊎ l1).
  Proof.
    intros.
    unfold bunion.
    apply Permutation_app_comm; try assumption.
  Qed.

  Lemma bunion_Forall P (l1 l2 : list A) :
    Forall P l1 -> Forall P l2 -> Forall P (bunion l1 l2).
  Proof.
    unfold bunion; intros.
    apply Forall_app; trivial.
  Qed.

  Fixpoint remove_one (x : A) (l : list A) : list A :=
    match l with
      | nil => nil
      | y::tl => if (x == y) then tl else y::(remove_one x tl)
    end.

  Hint Unfold ldeqA : qcert.

  Ltac tac
    := repeat progress (intros; simpl in *; try autorewrite with bag in *; try match goal with
         | [H: ?a = ?a |- _ ] => clear H
         | [H: ?a = ?a -> False |- _ ] => elim H; reflexivity
         | [H: ?a <> ?a |- _ ] => elim H; reflexivity
         | [H: {_ | _ } |- _ ] => destruct H
         | [H: ?a ≅ ?b |- _ ] => rewrite H in *

         | [H: context [@equiv_dec ?A ?eqA ?eqvA ?eqdecA ?x ?x ] |- _] =>
           let HH:=(fresh "eqH") in
           destruct (@equiv_dec A eqA eqvA eqdecA x x) as [eqH|eqH];
                                                         [|elim eqH; reflexivity]
         | [|- context [@equiv_dec ?A ?eqA ?eqvA ?eqdecA ?x ?x ]] =>
           let HH:=(fresh "eqH") in
           destruct (@equiv_dec A eqA eqvA eqdecA x x) as [eqH|eqH];
                                                         [|elim eqH; reflexivity]
         | [|- ?x :: ?l ≅ ?x :: ?l' ] => apply perm_skip; fold ldeqA
         | [|- ?x :: ?y :: ?l ≅ ?y :: ?x :: ?l' ] => apply perm_swap; fold ldeqA

        | [H: ?a + {?b} |- _ ] => destruct H
        | [H: {?a} + {?b} |- _ ] => destruct H
         | [H: context [@equiv_dec ?A ?eqA ?eqvA ?eqdecA ?x ?y ] |- _] =>
           destruct (@equiv_dec A eqA eqvA eqdecA x y)
         | [|- context [@equiv_dec ?A ?eqA ?eqvA ?eqdecA ?x ?y ]] =>
           destruct (@equiv_dec A eqA eqvA eqdecA x y)
       end;
                        unfold complement, Equivalence.equiv in *;
                          try subst; try reflexivity; eauto with qcert).

  Global Instance remove_one_proper : Proper (eq ==> ldeqA ==> ldeqA) remove_one.
  Proof.
    unfold Proper, respectful.
    intros; subst.
    elim H0; tac.
  Qed.

  (** Bag minus
   * Remove elements of d from x.
   * Note the order of arguments: (bminus d x) is "x ⊖ d" *)
  Fixpoint bminus (d x:list A) {struct d} : list A :=
    match d with
      | nil => x
      | d1 :: d' => bminus d' (remove_one d1 x)
    end.

  Notation "b1 ⊖ b2" := (bminus b2 b1) (right associativity, at level 70) : rbag_scope.    (* ⊖ = \ominus *)

  Lemma bminus_over_app_delta :
    forall (d1 d2:list A), forall (s:list A),
      ((s ⊖ d1) ⊖ d2) = (s ⊖ (d1 ++ d2)).
  Proof.
    induction d1; tac.
  Qed.

  Lemma bminus_to_nil:
    forall (d:list A), (nil ⊖ d) = nil.
  Proof.
    induction d; tac.
  Qed.

  Lemma bminus_nil_to_self:
    forall (x:list A), (x ⊖ nil) = x.
  Proof.
    induction x; tac.
  Qed.

  Global Instance bminus_proper_lem : Proper (eq ==> ldeqA ==> ldeqA) bminus.
  Proof.
    unfold Proper, respectful.
    intros x y H; subst.
    induction y; tac.
    eapply IHy; rewrite H; reflexivity.
  Qed.

  Lemma remove_one_comm:
    forall (x1 x2:A), forall x:list A,
      (remove_one x1 (remove_one x2 x)) = (remove_one x2 (remove_one x1 x)).
  Proof.
    intros.
    induction x; tac.
    congruence.
  Qed.

  Lemma remove_one_not_first:
    forall (x1 x2:A), forall s:list A,
      x1 <> x2 -> (remove_one x1 (x2 :: s)) = x2 :: (remove_one x1 s).
  Proof.
    intros.
    simpl.
    elim (equiv_dec x1 x2); intros; [contradiction|reflexivity].
  Qed.

  Global Instance bminus_proper : Proper (ldeqA ==> ldeqA ==> ldeqA) bminus.
  Proof.
    unfold Proper, respectful.
    intros x y H.
    elim H; tac.
    - rewrite remove_one_comm; eauto with qcert.
    - rewrite H1; eauto.
      symmetry; eauto.
  Qed.

  (* some useful properties *)

  Lemma bminus_self : forall (x:list A), (x ⊖ x) = nil.
  Proof.
    intros; induction x; tac.
  Qed.

  Lemma bminus_naught : forall (x:list A), (x ⊖ nil) = x.
  Proof.
    reflexivity.
  Qed.

  Hint Rewrite bminus_nil_to_self bminus_to_nil bminus_self bminus_naught : bag.

  Lemma bminus_cons :
    forall (a:A) (x y:list A), ((a :: x) ⊖ (a :: y)) = (x ⊖ y).
  Proof.
    tac.
  Qed.

  Hint Rewrite bminus_cons : bag.
  Hint Rewrite app_nil_r : bag.

  Lemma bunion_bminus :
    forall (x y: list A), ((y ⊎ x) ⊖ y) = x.
  Proof.
    intros.
    induction x; unfold bunion in *; tac.
    induction y; tac.
  Qed.

  Lemma remove_one_consed:
    forall (x:list A), forall (a:A),
      (remove_one a (a :: x)) = x.
  Proof.
    tac.
  Qed.

  Lemma remove_one_In (a x:A) (l1 l2:list A) :
    In x (bminus l1 (remove_one a l2)) -> In x (bminus l1 l2).
  Proof.
    revert l2 a x.
    induction l1; intros; simpl in *.
    - induction l2; intros; simpl in *.
      assumption.
      destruct (equiv_dec a a0).
      rewrite e in *; clear e.
      right; assumption.
      simpl in H.
      elim H; clear H; intros.
      left; assumption.
      right; apply (IHl2 H).
    - apply (IHl1 (remove_one a l2) a0 x).
      rewrite remove_one_comm.
      assumption.
  Qed.

  Lemma remove_one_sublist l a : sublist (remove_one a l) l.
  Proof.
    induction l; simpl.
    - constructor.
    - match_destr.
      + constructor; reflexivity.
      + constructor.
         trivial.
  Qed.

  Lemma bminus_sublist (l1 l2:list A) :
    sublist (bminus l1 l2) l2.
  Proof.
    revert l2.
    induction l1; simpl; intros.
    - reflexivity.
    - rewrite IHl1.
      apply remove_one_sublist.
  Qed.

  Lemma bminus_Forall (l1 l2:list A) p :
    Forall p l2 -> Forall p (bminus l1 l2).
  Proof.
    intros.
    rewrite bminus_sublist.
    trivial.
  Qed.

  Lemma bminus_NoDup  (l1 l2:list A) : NoDup l2 -> NoDup (bminus l1 l2).
  Proof.
    intros.
    rewrite bminus_sublist.
    trivial.
  Qed.

  Hint Rewrite bunion_bminus remove_one_consed : bag.

  (* not used, unfollowed thought from now... *)
  Lemma pick_an_a:
    forall (l:list A) (a:A),
      ({l':list A | a::l' ≅ l}) + {remove_one a l ≅ l}.
  Proof.
    intros; induction l; tac.
    left; exists (a0::x).
    rewrite perm_swap, l0; eauto with qcert.
  Qed.

  (* It seems some properties are easier to check on a different representation with
     the multiplicity explicit. Some conversion operations. *)

  Global Instance filter_proper : forall (p:A -> bool), Proper (ldeqA ==> ldeqA) (filter p).
  Proof.
    unfold Proper, respectful.
    intros.
    elim H; tac;
    repeat match goal with
        [|- context [if ?a then _ else _ ] ] => case_eq a
    end; tac.
  Qed.

  Section MBag.

    Fixpoint mult (l:list A) (a:A) : nat :=
      match l with
        | nil => O
        | b :: l' => if (equiv_dec a b) then S (mult l' a) else (mult l' a)
      end.

    Definition mult_equiv l l' := (forall a, mult l a = mult l' a).

    Notation "X ≅# Y" := (mult_equiv X Y) (at level 70) : rbag_scope.                              (* ≅ = \cong *)

    Hint Unfold mult_equiv : qcert.

    Global Instance mult_proper : Proper (ldeqA ==> eq ==> eq) mult.
    Proof.
      unfold Proper, respectful; intros.
      elim H; intros; simpl.
      - reflexivity.
      - rewrite H0 in *.
        destruct (equiv_dec y0 x1).
        rewrite H2; reflexivity.
        assumption.
      - rewrite H0 in *.
        destruct (equiv_dec y0 y1).
        rewrite e in *.
        destruct (equiv_dec y1 x1); reflexivity.
        destruct (equiv_dec y0 x1); reflexivity.
      - rewrite H0 in *; rewrite H2; assumption.
    Qed.

    Lemma bags_equal_same_mult1:
      forall (l1 l2:list A),
        l1 ≅ l2 -> l1 ≅# l2.
    Proof.
      unfold mult_equiv.
      intros.
      induction H; tac.
      congruence.
    Qed.

    Fixpoint groupby (l:list A) : list (A*nat)
      := match l with
           | nil => nil
           | (a::ls) => let rest := groupby ls in
                        match lookup equiv_dec rest a with
                          | None => (a,1)::rest
                          | Some x => update_first equiv_dec rest a (S x)
                        end
         end.

    Lemma groupby_noDup l : NoDup (domain (groupby l)).
    Proof.
      Hint Constructors NoDup : qcert.
      induction l; simpl; trivial with qcert.
      case_eq (lookup equiv_dec (groupby l) a); [intros ? ?| intros neq].
      - rewrite domain_update_first; trivial.
      - simpl; constructor; auto. apply lookup_none_nin in neq; trivial.
    Qed.

    Fixpoint rep (a:A) n : list A :=
      match n with
        | 0 => nil
        | S m => a::(rep a m)
      end.

    Fixpoint smush (l:list (A*nat)) : list A
      := match l with
           | nil => nil
           | ((d,n)::ls) => rep d n ++ smush ls
         end.

    Global Instance smush_perm_proper : Proper ((@Permutation (A*nat)) ==> ldeqA) smush.
    Proof.
      unfold respectful, Proper.
      apply Permutation_ind_bis; intros; try reflexivity; simpl.
      - destruct x. rewrite H0. reflexivity.
      - destruct x; destruct y. rewrite H0. repeat rewrite app_assoc. apply Permutation_app_tail.
        apply Permutation_app_comm.
      - transitivity (smush l'); auto.
    Qed.

    Lemma smush1 a n x : smush ((a,S n)::x) = a::(smush ((a,n)::x)).
    Proof.
      trivial.
    Qed.

    Hint Resolve groupby_noDup : qcert.

    Lemma smush_groupby l : Permutation (smush (groupby l)) l.
    Proof.
      induction l; simpl; trivial.
      case_eq (lookup equiv_dec (groupby l) a); [intros n eqn | intros neq].
      - destruct (lookup_to_front equiv_dec eqn).
        assert (perm1:Permutation (update_first equiv_dec (groupby l) a (S n)) (update_first equiv_dec ((a, n) :: x) a (S n))) by (apply update_first_NoDup_perm_proper; auto with qcert).
        rewrite perm1.
        simpl. destruct (equiv_dec a a); try congruence.
        rewrite smush1.
        apply perm_skip.
        rewrite <- H, IHl.
        trivial.
      - simpl. apply perm_skip; trivial.
    Qed.

(* {mult l a = 0} + {{l':list A | a::l' ≅ l}}. *)
    Lemma pick_an_a_or_absent:
      forall (l:list A) (a:A),
        (mult l a = 0) \/ (exists l':list A, a::l' ≅ l).
    Proof.
      induction l; intros; simpl.
      left; reflexivity.
      elim (equiv_dec a a0); intros.
      rewrite a1 in *; clear a1.
      elim (equiv_dec a0 a0); intros.
      - right.
        generalize (IHl a0); intros; clear IHl.
        elim H; intros; clear H.
        exists l; reflexivity.
        exists l; reflexivity.
      - generalize (IHl a0); intros; clear IHl.
        elim H; intros; clear H.
        left; assumption.
        right.
        exists l; reflexivity.
      - elim (equiv_dec a0 a); intros.
        rewrite a1 in *; congruence.
        generalize (IHl a0); intros; clear IHl.
        elim H; intros; clear H.
        left; assumption.
        right.
        elim H0; intros.
        exists (a::x).
        rewrite <- H.
        apply perm_swap.
    Qed.

    Lemma lookup_none_mult0 l d : lookup equiv_dec (groupby l) d = None -> mult l d = 0.
    Proof.
      revert d.
      induction l; simpl; trivial; intros.
      case_eq (lookup equiv_dec (groupby l) a); intros; rewrite H0 in H; destruct (equiv_dec d a); subst.
      - apply lookup_none_nin in H. elim H.
        rewrite domain_update_first.
        rewrite e in *.
        eapply in_dom; eapply lookup_in; eauto.
      - apply IHl.
        apply lookup_none_nin in H.
        rewrite domain_update_first in H.
        case_eq (lookup equiv_dec (groupby l) d); try congruence; intros.
        apply lookup_in in H1. apply in_dom in H1. congruence.
      - simpl in H. rewrite e in *; destruct (equiv_dec a a); try congruence.
      - simpl in H. destruct (equiv_dec d a); try congruence.
        auto.
    Qed.

    Lemma lookup_update_eq {B:Type }{l a} {n n':B} : lookup equiv_dec (update_first equiv_dec l a n') a = Some n -> n = n'.
    Proof.
      revert a n n'.
      induction l; simpl; try congruence.
      intros. destruct a.
      destruct (equiv_dec a0 a); simpl in *; subst.
      - rewrite e in*; destruct (equiv_dec a a); try congruence.
      - destruct (equiv_dec a0 a); try congruence.
        eauto.
    Qed.

    Lemma domain_groupby {l a} : In a (domain (groupby l)) <-> In a l.
    Proof.
      revert a.
      induction l; simpl; intuition; subst.
      - case_eq (lookup equiv_dec (groupby l) a); intros; rewrite H0 in H; simpl in *.
        + rewrite domain_update_first in H. right; apply IHl; auto.
        + intuition. right; apply IHl; auto.
      - case_eq (lookup equiv_dec (groupby l) a0); intros; simpl in *.
        + rewrite domain_update_first. eapply in_dom; eapply lookup_in; eauto.
        + intuition.
      - case_eq (lookup equiv_dec (groupby l) a); intros; simpl in *.
        + rewrite domain_update_first. apply IHl; eauto.
        + right; eapply IHl; eauto.
    Qed.

    Lemma groupby_mult_in {l d n} : In (d, n) (groupby l) -> mult l d = n.
    Proof.
      revert n. induction l; simpl; intuition.
      case_eq (lookup equiv_dec (groupby l) a); intros; rewrite H0 in H.
      - apply (in_lookup_nodup equiv_dec) in H; [|rewrite domain_update_first; apply groupby_noDup].
        case_eq (equiv_dec d a); trivial; intros; try rewrite e in * ; subst.
        + apply lookup_update_eq in H. rewrite (IHl n0); auto.
          eapply lookup_in; eauto.
        + apply IHl. rewrite lookup_update_neq in H; try congruence. eapply lookup_in; eauto.
      - destruct H.
        + inversion H; subst. case_eq (equiv_dec d d); try congruence; intros.
          rewrite lookup_none_mult0; auto.
        + rewrite (IHl _ H). case_eq (equiv_dec d a); trivial; intros; subst.
          apply lookup_none_nin in H0.
          apply in_dom in H. congruence.
    Qed.

    Lemma groupby_mult_in_pos {l d n} : In (d, n) (groupby l) -> n <> 0.
    Proof.
      revert n. induction l; simpl; intuition; subst.
      case_eq (lookup equiv_dec (groupby l) a); intros; rewrite H0 in H.
      - apply (in_lookup_nodup equiv_dec) in H; [|rewrite domain_update_first; apply groupby_noDup].
        case_eq (equiv_dec d a); trivial; intros; subst; try rewrite e in *.
        + apply lookup_update_eq in H; discriminate.
        + rewrite lookup_update_neq in H; auto. apply (IHl 0); trivial.
          eapply lookup_in; eauto.
      - destruct H.
        + inversion H; congruence.
        + eauto.
    Qed.

    Lemma mult_in_groupby {l d n} : mult l d = S n -> In (d, S n) (groupby l).
    Proof.
      revert d n. induction l; simpl; try congruence; intros.
      case_eq (lookup equiv_dec (groupby l) a); intros;
      case_eq (equiv_dec d a); intros; rewrite H1 in H; subst; simpl; try rewrite e in *.
      - inversion H.
        rewrite H3.
        assert (mn0:mult l a = n0).
        + apply groupby_mult_in. apply (lookup_in equiv_dec); auto.
        + rewrite H3 in mn0. subst n0.
          apply (lookup_in equiv_dec).
          apply lookup_update_eq_in. apply lookup_in, in_dom in H0. trivial.
      - apply (lookup_in equiv_dec). rewrite lookup_update_neq; auto.
        apply in_lookup_nodup; try apply groupby_noDup; auto.
      - destruct n; intuition. apply lookup_none_nin in H0.
        inversion H. specialize (IHl _ _ H3).
        apply in_dom in IHl. intuition.
      - auto.
    Qed.

    Lemma mult_nin_groupby {l d} : mult l d = 0 -> ~ In d (domain (groupby l)).
    Proof.
      intros mu ind.
      destruct (in_domain_in ind).
      rewrite (groupby_mult_in H) in mu.
      generalize (groupby_mult_in_pos H); intuition.
    Qed.

    Lemma bags_same_mult_has_equal :
      forall (l1 l2:list A),
        (forall (a:A), (mult l1 a) = (mult l2 a)) ->  (l1 ≅ l2).
    Proof.
      red. intros.
      rewrite <- (smush_groupby l1), <- (smush_groupby l2).
      apply smush_perm_proper.
      apply NoDup_Permutation.
      - apply NoDup_domain_NoDup; apply groupby_noDup.
      - apply NoDup_domain_NoDup; apply groupby_noDup.
      - intros. destruct x. destruct n.
        + split; intros HH; elim (groupby_mult_in_pos HH); trivial.
        + split; intros HH; apply groupby_mult_in in HH; apply mult_in_groupby.
          * congruence.
          * congruence.
    Qed.

  End MBag.

  (* Formally defined with 'min' over arity in the [GL95] paper *)
  Definition bmin (l1 l2:list A) :=
    l1 ⊖ (l1 ⊖ l2).
  Notation "b1 min-b b2" := (bmin b1 b2) (right associativity, at level 70) : rbag_scope.

  (* Formally defined with 'max' over arity in the [GL95] paper *)
  Definition bmax (l1 l2:list A) :=
    l1 ⊎ (l2 ⊖ l1).
  Notation "b1 max-b b2" := (bmax b1 b2) (right associativity, at level 70) : rbag_scope.

  (* counting *)

  Definition bcount {A} (l:list A) := length l.

  Lemma bcount_map_id {B} (f:A -> B) (l:list A) :
    @bcount A l = @bcount B (map f l).
  Proof.
    induction l; [reflexivity|].
    simpl.
    auto.
  Qed.

  (* Formally defined with 'max' over arity in the [GL95] paper *)
  Fixpoint bdistinct (l:list A) :=
    match l with
      | nil => nil
      | x :: l' =>
        let dl' := bdistinct l' in
        match mult dl' x with
          | O => x :: dl'
          | _ => dl'
        end
    end.

  Lemma bdistinct_sublist l : sublist (bdistinct l) l.
  Proof.
    induction l; simpl.
    - reflexivity.
    - match_destr.
      + apply sublist_cons; trivial.
      + apply sublist_skip; trivial.
  Qed.

  Lemma bdistinct_Forall {P} {l} :
      Forall P l -> Forall P (bdistinct l).
  Proof.
    intros.
    apply (Forall_sublist _ _ (bdistinct_sublist l)) in H.
    trivial.
  Qed.

  Lemma bdistinct_at_most_one:
    forall (l:list A), forall (x:A),
      (mult (bdistinct l) x) = 0 \/ (mult (bdistinct l) x) = 1.
  Proof.
    induction l; simpl; intros.
    left; reflexivity.
    generalize (IHl x); generalize (IHl a); intros; clear IHl.
    elim H0; intro; clear H0; elim H; intro; clear H;
    try rewrite H0; simpl; elim (equiv_dec x a); intro aH.
    - right; auto.
    - left; assumption.
    - rewrite aH in *; auto.
    - left; assumption.
    - rewrite aH in *; auto.
    - right; assumption.
    - right; assumption.
    - right; assumption.
  Qed.

  (* I am going too brute-force here... wondering if that's a good sign... -JS *)

  Global Instance bdistinct_proper : Proper (ldeqA ==> ldeqA) bdistinct.
  Proof.
    unfold Proper, respectful.
    intros.
    generalize bags_equal_same_mult1; intros.
    elim H; simpl; intros.
    - reflexivity.
    - apply bags_same_mult_has_equal; intros.
      assert ((mult (bdistinct l) x0) = (mult (bdistinct l') x0)).
      apply H0; assumption.
      apply H0; rewrite H3.
      generalize bdistinct_at_most_one; intros.
      elim (H4 l' x0); intros; clear H4; rewrite H5.
      rewrite H2; reflexivity.
      assumption.
    - apply bags_same_mult_has_equal; intros.
      assert (((mult (bdistinct l) x0) = 0) \/ ((mult (bdistinct l) x0) = 1)).
      apply bdistinct_at_most_one.
      assert (((mult (bdistinct l) y0) = 0) \/ ((mult (bdistinct l) y0) = 1)).
      apply bdistinct_at_most_one.
      elim H1; intros; clear H1; elim H2; intros; clear H2; rewrite H3; rewrite H1.
      simpl.
      + elim (equiv_dec y0 x0); intros.
        rewrite a0 in *; clear a0; simpl.
        elim (equiv_dec a x0); intros.
        elim (equiv_dec x0 x0); intros; simpl.
        elim (equiv_dec a x0); intros; try reflexivity; try contradiction; try congruence.
        elim (equiv_dec x0 x0); intros; simpl.
        elim (equiv_dec a x0); intros; try reflexivity; try contradiction; try congruence.
        rewrite H3; congruence.
        elim (equiv_dec x0 x0); intros; simpl.
        elim (equiv_dec a x0); intros; try reflexivity; try contradiction; try congruence.
        rewrite H3.
        congruence.
        rewrite H1.
        elim (equiv_dec x0 y0); intros; simpl.
        congruence.
        rewrite H3.
        elim (equiv_dec a y0); intros; simpl.
        elim (equiv_dec a x0); intros; simpl.
        elim (equiv_dec a y0); intros; try reflexivity; try contradiction; try congruence.
        elim (equiv_dec a y0); intros; try reflexivity; try contradiction; try congruence.
        elim (equiv_dec a x0); intros; try reflexivity; try contradiction; try congruence.
        elim (equiv_dec a y0); intros; try reflexivity; try contradiction; try congruence.
        elim (equiv_dec a y0); intros; try reflexivity; try contradiction; try congruence.
      + simpl; rewrite H3.
        elim (equiv_dec y0 x0); intros; simpl; try reflexivity; try contradiction; try congruence.
        rewrite H1.
        elim (equiv_dec a y0); intros; try reflexivity; try contradiction; try congruence.
      + simpl.
        elim (equiv_dec a y0); intros; try reflexivity; try contradiction; try congruence.
        elim (equiv_dec x0 y0); intros; simpl; try reflexivity; try contradiction; try congruence.
        rewrite H3; simpl.
        elim (equiv_dec a y0); intros; try reflexivity; try contradiction; try congruence.
        elim (equiv_dec x0 y0); intros; simpl; try reflexivity; try contradiction; try congruence.
        rewrite H3.
        simpl.
        elim (equiv_dec a y0); intros; try reflexivity; try contradiction; try congruence.
      + rewrite H3.
        reflexivity.
    - apply perm_trans with (l' := bdistinct l'); assumption.
  Qed.

  Lemma bdistinct_exactly_zero:
    forall (l:list A), forall (x:A),
      (mult l x) = 0 -> (mult (bdistinct l) x) = 0.
  Proof.
    induction l.
    intros; simpl; reflexivity.
    simpl.
    intro.
    elim (equiv_dec x a); intros.
    - congruence.
    - assert (((mult (bdistinct l) a) = 0) \/ ((mult (bdistinct l) a) = 1)).
      apply bdistinct_at_most_one.
      elim H0; intros; rewrite H1.
      simpl.
      elim (equiv_dec x a); intros.
      + contradiction.
      + apply IHl; assumption.
      + apply IHl; assumption.
  Qed.

  Lemma bdistinct_exactly_zero_back:
    forall (l:list A), forall (x:A),
      (mult (bdistinct l) x) = 0 -> (mult l x) = 0.
  Proof.
    intros.
    generalize (pick_an_a_or_absent l x); intros.
    elim H0; intros.
    - assumption.
    - elim H1; intros.
      assert ((mult (bdistinct (x :: x0)) x) = 0).
      rewrite <- H.
      apply bags_equal_same_mult1.
      rewrite H2; reflexivity.
      simpl in H3.
      assert (((mult (bdistinct x0) x) = 0) \/ ((mult (bdistinct x0) x) = 1)).
      apply bdistinct_at_most_one.
      elim H4; intros; clear H4.
      rewrite H5 in H3.
      simpl in H3.
      revert H3.
      elim (equiv_dec x x); intros.
      congruence.
      congruence.
      rewrite H5 in H3.
      congruence.
  Qed.

  Lemma bdistinct_exactly_one:
    forall (l:list A), forall (x:A),
      (mult l x) <> 0 -> (mult (bdistinct l) x) = 1.
  Proof.
    intros.
    generalize (bdistinct_at_most_one l x).
    intros.
    elim H0; intro.
    assert False.
    apply H.
    apply bdistinct_exactly_zero_back; assumption.
    contradiction.
    assumption.
  Qed.

  Lemma bdistinct_exactly_one_back:
    forall (l:list A), forall (x:A),
      (mult (bdistinct l) x) = 1 -> (mult l x) <> 0.
  Proof.
    induction l; simpl; intros.
    congruence.
    assert (((mult (bdistinct l) a) = 0) \/ ((mult (bdistinct l) a) = 1)).
    apply bdistinct_at_most_one.
    revert H.
    elim H0; intro; clear H0; rewrite H; simpl.
    elim (equiv_dec x a); intros.
    rewrite a0 in *; clear a0.
    auto.
    apply IHl; assumption.
    intros.
    elim (equiv_dec x a); intros.
    rewrite a0 in *; clear a0.
    auto.
    apply IHl; assumption.
  Qed.

  Lemma bdistinct_exactly_one_back_diff:
    forall (l:list A), forall (x:A),
      (mult (bdistinct l) x) = 1 -> (mult l x) >= 1.
  Proof.
    intros.
    assert ((mult l x) <> 0).
    apply bdistinct_exactly_one_back; assumption.
    lia.
  Qed.

  Lemma exist_or_zero:
    forall (s:list A), forall (x:A),
      (exists (rs:list A), (x::rs) ≅ s) \/ (mult s x) = 0.
  Proof.
    induction s.
    intros.
    - right; simpl; reflexivity.
    - intros. destruct (equiv_dec x a).
      left; elim (IHs a); intro; elim H; intros; rewrite e in *; exists s; reflexivity.
      elim (IHs x); intro; elim H; intros.
      + left.
        exists (a::x0).
        rewrite <- H0.
        rewrite perm_swap; reflexivity.
      + right.
        simpl.
        destruct (equiv_dec x a).
        contradiction.
        reflexivity.
  Qed.

  Lemma bdistinct_mult:
    forall (l:list A), forall (x:A),
      mult (bdistinct l) x = min (mult l x) 1.
  Proof.
    induction l; simpl; intros.
    reflexivity.
    elim (equiv_dec x a); intro.
    rewrite a0 in *; clear a0.
    generalize (IHl a); intro; rewrite H; clear H.
    generalize (exist_or_zero l a); intro.
    elim H; intro.
    elim H0; intros.
    assert (min (mult l a) 1 = 1).
    rewrite <- H1; simpl.
    elim (equiv_dec a a); intro; try congruence.
    generalize (mult x0 a); intro; auto with arith.
    rewrite H2.
    rewrite IHl; rewrite H2.
    generalize (mult l a); intro; rewrite <- succ_min_distr; auto with arith.
    rewrite H0; rewrite min_0_l; simpl.
    elim (equiv_dec a a); intro; try congruence.
    rewrite IHl; rewrite H0; auto with arith.
    rewrite IHl.
    generalize (min_against_one (mult l a)); intro.
    elim H; intro; clear H; rewrite H0.
    simpl; elim (equiv_dec x a); intro; try congruence.
    rewrite IHl; reflexivity.
  Qed.

  Lemma mult_pos_equiv_in:
    forall l,
    forall x,
      mult l x > 0 <-> In x l.
  Proof.
    split.
    - (* Case "->" *)
      induction l; simpl; try lia.
      case (equiv_dec x a).
      + intros Hx.
        rewrite Hx in *; clear Hx.
        left.
        reflexivity.
      + intros Hx Hl.
        right.
        apply IHl.
        assumption.
    - (* Case "<-" *)
      induction l; simpl; try contradiction.
      intros Hx.
      destruct Hx.
      + rewrite H in *; clear H.
        case (equiv_dec x x); try congruence.
        intros.
        apply gt_Sn_O.
      + case (equiv_dec x a).
        * intros.
          apply gt_Sn_O.
        * intros.
          apply IHl.
          assumption.
  Qed.

  Lemma bdistinct_same_elemts:
    forall l,
    forall x,
      In x l -> In x (bdistinct l).
  Proof.
    intros l x Hx.
    apply mult_pos_equiv_in.
    apply mult_pos_equiv_in in Hx.
    rewrite bdistinct_mult.
    apply min_case; auto.
  Qed.

  Lemma bdistinct_nil {l:list A} :
    bdistinct l = nil -> l = nil.
  Proof.
    induction l; simpl; trivial.
    destruct (bdistinct l); simpl.
    - discriminate.
    - match_destr.
  Qed.

  Lemma bdistinct_NoDup (l : list A) :
    NoDup (bdistinct l).
  Proof.
    induction l; simpl; [constructor | ].
    match_case; intros.
    constructor; trivial.
    rewrite <- mult_pos_equiv_in.
    lia.
  Qed.

  Lemma NoDup_bdistinct {l:list A} :
    NoDup l -> bdistinct l = l.
  Proof.
    induction l; simpl; trivial.
    inversion 1; subst.
    rewrite IHl by trivial.
    rewrite <- mult_pos_equiv_in in H2.
    match_case.
    intros; lia.
  Qed.

  Lemma bdistinct_idem {l:list A} :
    bdistinct (bdistinct l) = bdistinct l.
  Proof.
    apply (@NoDup_bdistinct (bdistinct l)); trivial.
    apply bdistinct_NoDup.
  Qed.

  Lemma bdistinct_equivlist  (l : list A) :
    equivlist l (bdistinct l).
  Proof.
    intros.
    apply equivlist_incls.
    split.
    - intros ? inn.
      apply bdistinct_same_elemts; trivial.
    - rewrite bdistinct_sublist; reflexivity.
  Qed.

  Lemma fold_right_bdistinct (f : A -> A -> A)
        (assoc:forall x y z : A, f x (f y z) = f (f x y) z)
        (comm:forall x y : A, f x y = f y x)
        (idem:forall x  : A, f x x = x) (l:list A) (unit:A) :
    fold_right f unit l = fold_right f unit (bdistinct l).
  Proof.
    induction l; simpl; trivial.
    match_case; simpl; rewrite IHl; trivial; intros.
    assert (inn:In a (bdistinct l))
      by (apply mult_pos_equiv_in; lia).
    destruct (in_split _ _ inn) as [t1 [t2 teq]].
    rewrite teq.
    assert (perm:Permutation (t1 ++ a :: t2) (a::t1++ t2))
      by (rewrite Permutation_middle; reflexivity).
    rewrite (fold_right_perm _ assoc comm (t1 ++ a :: t2) (a :: t1 ++ t2))
      by trivial.
    simpl.
    rewrite assoc, idem.
    trivial.
  Qed.

  Lemma fold_right_equivlist (f : A -> A -> A)
  (assoc:forall x y z : A, f x (f y z) = f (f x y) z)
  (comm:forall x y : A, f x y = f y x)
  (idem:forall x  : A, f x x = x) (l1 l2:list A) (unit:A) :
    equivlist l1 l2 ->
    fold_right f unit l1 = fold_right f unit l2.
  Proof.
    intros.
    rewrite (fold_right_bdistinct _ assoc comm idem l1);
      rewrite (fold_right_bdistinct _ assoc comm idem l2).
    apply fold_right_perm; trivial.
    apply NoDup_Permutation'; trivial.
    - apply bdistinct_NoDup.
    - apply bdistinct_NoDup.
    - repeat rewrite <- bdistinct_equivlist.
      trivial.
  Qed.

  Lemma bunion_mult:
    forall (s t:list A), forall (x:A), mult (s ⊎ t) x = (mult s x) + (mult t x).
  Proof.
    intros.
    induction s.
    - unfold bunion; rewrite app_nil_l; simpl; reflexivity.
    - unfold bunion in *; simpl.
      destruct (equiv_dec x a).
      + rewrite IHs; auto.
      + assumption.
  Qed.

  Lemma remove_one_mult:
    forall (s:list A), forall (x:A), mult (remove_one x s) x = pred (mult s x).
  Proof.
    intros.
    induction s; simpl.
    - reflexivity.
    - destruct (equiv_dec x a).
      + auto.
      + simpl.
        destruct (equiv_dec x a).
        contradiction.
        assumption.
  Qed.

  Lemma mult_on_remove:
    forall (s:list A), forall (a x:A),
      x <> a -> mult (remove_one a s) x = mult s x.
  Proof.
    intros; induction s.
    simpl; reflexivity.
    simpl.
    elim (equiv_dec a a0); intro; simpl.
    - rewrite a1 in *; clear a1.
      elim (equiv_dec x a0); intro.
      rewrite a1 in *; clear a1; congruence.
      elim (equiv_dec a a); intro; [reflexivity|congruence].
    - elim (equiv_dec x a0); intro; auto; assumption.
  Qed.

  Lemma bminus_mult:
    forall (s t:list A), forall (x:A), mult (s ⊖ t) x = (mult s x) - (mult t x).
  Proof.
    intros; revert s.
    induction t; simpl.
    intro. rewrite <- minus_n_O; reflexivity.
    intros; rewrite IHt.
    destruct (equiv_dec x a).
    rewrite e in *; clear e.
    rewrite remove_one_mult.
    generalize (exist_or_zero s a); intros.
    elim H; intros; clear H.
    elim H0; intros; clear H0.
    rewrite <- H in *; simpl.
    elim (equiv_dec a a); intro; try congruence; auto.
    rewrite H0; auto.
    generalize (mult_on_remove s a x); intro.
    unfold complement,equiv in c.
    auto.
  Qed.

  Lemma bmin_on_nil_r:
    forall (s:list A), (s min-b nil) = nil.
  Proof.
    intros.
    induction s; unfold bmin.
    rewrite bminus_naught; reflexivity.
    simpl; destruct (equiv_dec a a).
    rewrite bminus_self; reflexivity.
    congruence.
  Qed.

  Lemma bmin_on_nil_l:
    forall (s:list A), (nil min-b s) = nil.
  Proof.
    intros.
    induction s; unfold bmin; rewrite bminus_to_nil; reflexivity.
  Qed.

  Lemma bmax_on_nil_r:
    forall (s:list A), (s max-b nil) = s.
  Proof.
    intros.
    induction s; unfold bmax.
    rewrite bminus_naught; reflexivity.
    simpl; destruct (equiv_dec a a); rewrite bminus_to_nil; rewrite bunion_nil_r; reflexivity.
  Qed.

  Lemma bmax_on_nil_l:
    forall (s:list A), (nil max-b s) = s.
  Proof.
    intros; unfold bmax; reflexivity.
  Qed.

    Lemma bmin_Forall P (l1 l2 : list A) :
    Forall P l1 -> Forall P l2 -> Forall P (bmin l1 l2).
  Proof.
    unfold bmin.
    intros.
    repeat apply bminus_Forall; trivial.
  Qed.

  Lemma bmax_Forall P (l1 l2 : list A) :
    Forall P l1 -> Forall P l2 -> Forall P (bmax l1 l2).
  Proof.
    unfold bmax.
    intros.
    apply bunion_Forall; trivial.
    apply bminus_Forall; trivial.
  Qed.

  Lemma minus_min:
    forall (n n0:nat), n0 - (n0 - n) = min n0 n.
  Proof.
    induction n.
    intros; rewrite min_0_r; rewrite <- minus_n_O; rewrite minus_diag; reflexivity.
    intros.
    generalize eq_nat_dec; intro.
    elim (H n n0); intro; clear H.
    rewrite a in *; clear a.
    assert (n0 <= (S n0)); auto.
    rewrite (min_l n0 (S n0) H); lia.
    generalize (compare_either n0 (S n)); intro.
    elim H; intro; clear H.
    - rewrite min_l; try assumption; lia.
    - rewrite min_r; try assumption; lia.
  Qed.

  Lemma minus_max:
    forall (n n0:nat), n0 + (n - n0) = max n0 n.
  Proof.
    induction n; intros.
    rewrite max_0_r; auto with arith.
    generalize eq_nat_dec; intro.
    elim (H n n0); intro; clear H.
    rewrite a in *; clear a.
    assert (n0 <= (S n0)); auto.
    rewrite (max_r n0 (S n0) H); lia.
    generalize (compare_either n0 (S n)); intro.
    elim H; intro; clear H.
    - rewrite max_r; try assumption; lia.
    - rewrite max_l; try assumption; lia.
  Qed.

  Lemma bmin_mult:
    forall (s t:list A), forall (x:A), (mult (s min-b t) x) = min (mult s x) (mult t x).
  Proof.
    intros.
    unfold bmin.
    repeat rewrite bminus_mult; induction s; simpl.
    - reflexivity.
    - elim (equiv_dec x a); intro.
      + rewrite a0 in *; clear a0.
        revert IHs; generalize (mult s a); generalize (mult t a); intros.
        rewrite minus_min; reflexivity.
      + generalize (mult s x); generalize (mult t x); intros.
        rewrite minus_min; reflexivity.
  Qed.

  Lemma bmax_mult:
    forall (s t:list A), forall (x:A), (mult (s max-b t) x) = max (mult s x) (mult t x).
  Proof.
    intros.
    unfold bmax.
    rewrite bunion_mult; rewrite bminus_mult; induction s; simpl.
    - auto with arith.
    - elim (equiv_dec x a); intro.
      + rewrite a0 in *; clear a0.
        revert IHs; generalize (mult s a); generalize (mult t a); intros.
        rewrite minus_max; reflexivity.
      + generalize (mult s x); generalize (mult t x); intros.
        rewrite minus_max; reflexivity.
  Qed.

  (* This is a first proof that relies on Avi's nice mult-based lemma *)
  Lemma bmin_comm:
    forall (s t:list A), (s min-b t) ≅ (t min-b s).
  Proof.
    intros.
    apply bags_same_mult_has_equal.
    intro.
    rewrite (bmin_mult s t a).
    rewrite (bmin_mult t s a).
    rewrite min_comm.
    reflexivity.
  Qed.

  Lemma bmax_comm:
    forall (s t:list A), (s max-b t) ≅ (t max-b s).
  Proof.
    intros.
    apply bags_same_mult_has_equal.
    intro.
    rewrite (bmax_mult s t a).
    rewrite (bmax_mult t s a).
    rewrite max_comm.
    reflexivity.
  Qed.

  (* Some other lemmas... *)

  Lemma select_not_select:
    forall (p:A -> bool), forall (s:list A),
      ((filter p s) ⊎ (filter (fun x => negb (p x)) s)) ≅ s.
  Proof.
    intros.
    induction s.
    simpl; reflexivity.
    simpl.
    generalize (two_cases p a); intro.
    elim H; intro; rewrite H0; simpl;
    rewrite bunion_comm in *; unfold bunion in *;
    try rewrite <- app_comm_cons; rewrite IHs; reflexivity.
  Qed.

  Lemma bdistinct_over_bunion_empty_r:
    forall (l1 l2:list A), forall (x:A),
      (mult (bdistinct (l1 ⊎ l2)) x = 0) -> (mult (bdistinct l2) x = 0).
  Proof.
    unfold bunion in *.
    induction l1; intros; simpl in *; try assumption.
    elim (equiv_dec x a); intro.
    rewrite a0 in *; clear a0.
    assert (((mult (bdistinct (l1++l2)) a) = 0) \/ ((mult (bdistinct (l1++l2)) a) = 1)).
    apply bdistinct_at_most_one.
    elim H0; intros; clear H0.
    apply (IHl1 l2 a); try assumption.
    rewrite H1 in H.
    congruence.
    apply (IHl1 l2 x); simpl in H.
    assert (((mult (bdistinct (l1++l2)) a) = 0) \/ ((mult (bdistinct (l1++l2)) a) = 1)).
    apply bdistinct_at_most_one.
    elim H0; intros; clear H0.
    rewrite H1 in H.
    simpl in H.
    revert H.
    elim (equiv_dec x a); intro.
    rewrite a0 in *; clear a0.
    congruence.
    intro; assumption.
    rewrite H1 in H.
    assumption.
  Qed.

  Lemma bdistinct_over_bunion_empty_l:
    forall (l1 l2:list A), forall (x:A),
      (mult (bdistinct (l1 ⊎ l2)) x = 0) -> (mult (bdistinct l1) x = 0).
  Proof.
    intros; rewrite bdistinct_mult in *; rewrite bunion_mult in *.
    induction l1; simpl in *; try reflexivity.
    revert H; elim (equiv_dec x a); intros.
    rewrite a0 in *; clear a0; simpl in *.
    - congruence.
    - apply IHl1; assumption.
  Qed.

  Lemma bdistinct_over_bunion_singleton2:
    forall (l1 l2:list A), forall (x:A),
      (mult (bdistinct l2) x = 0) -> (mult (bdistinct l1) x = 1) -> (mult (bdistinct (l1 ⊎ l2)) x = 1).
  Proof.
    intros; rewrite bdistinct_mult in *; rewrite bunion_mult in *.
    induction l1; simpl in *; try congruence.
    revert H0; elim (equiv_dec x a); intros.
    - rewrite a0 in *; clear a0; simpl in *.
      revert H IHl1 H0; generalize (mult l1 a); generalize (mult l2 a); intros.
      assert (n = 0).
      + apply min_zero with (n2 := 0); assumption.
      + clear H; rewrite H1 in *; rewrite plus_0_r in *; assumption.
    - apply IHl1; assumption.
  Qed.

  Lemma bdistinct_over_bunion:
    forall (l1 l2:list A),
      (bdistinct (l1 ⊎ l2)) ≅ ((bdistinct l1) max-b (bdistinct l2)).
  Proof.
    intros.
    apply bags_same_mult_has_equal; intros.
    rewrite bmax_mult.
    repeat rewrite bdistinct_mult.
    rewrite bunion_mult.
    generalize (mult l1 a); generalize (mult l2 a); intros.
    generalize (min_against_one n); generalize (min_against_one n0); intros.
    elim H; elim H0; intros; clear H H0; rewrite H1; rewrite H2; simpl.
    - assert (n = 0).
      apply min_zero with (n2 := 0); assumption.
      assert (n0 = 0).
      apply min_zero with (n2 := 0); assumption.
      rewrite H; rewrite H0; reflexivity.
    - assert (n0 = 0).
      apply min_zero with (n2 := 0); assumption.
      rewrite H; assumption.
    - assert (n = 0).
      apply min_zero with (n2 := 0); assumption.
      rewrite H; rewrite plus_0_r; assumption.
    - assert (1 <= n).
      apply min_one_yields_one; assumption.
      assert (1 <= n0).
      apply min_one_yields_one; assumption.
      generalize (compare_either (n+n0) 1); intro; elim H; intros; clear H.
      rewrite min_r; try reflexivity.
      lia.
      rewrite <- plus_n_Sm.
      simpl.
      rewrite min_r.
      reflexivity.
      auto with arith.
  Qed.

  Lemma bmin_zero:
    forall (l1 l2:list A), forall (x:A),
      mult (l1 min-b l2) x = 0 -> (mult l1 x = 0) \/ (mult l2 x = 0).
  Proof.
    induction l2; simpl; intros.
    right; reflexivity.
    rewrite bmin_mult in H.
    simpl in H.
    revert H; elim (equiv_dec x a); intro.
    rewrite a0 in *; clear a0.
    intro; left; apply (min_zero (mult l1 a) (mult l2 a)); assumption.
    intro.
    rewrite <- bmin_mult in H.
    apply (IHl2 x); assumption.
  Qed.

  Lemma bmin_zero_back:
    forall (l1 l2:list A), forall (x:A),
      (mult l1 x = 0) \/ (mult l2 x = 0) -> mult (l1 min-b l2) x = 0.
  Proof.
    induction l2; simpl; intros; rewrite bmin_mult; simpl.
    rewrite min_0_r; reflexivity.
    revert H; elim (equiv_dec x a); intros.
    rewrite a0 in *; clear a0.
    elim H; intro; clear H.
    rewrite H0 in *.
    generalize (mult l2 a); auto.
    rewrite H0 in *.
    generalize (mult l1 a); intro; rewrite min_0_r; reflexivity.
    elim H; intro; clear H; rewrite H0.
    generalize (mult l1 a); auto.
    generalize (mult l1 a); intro; rewrite min_0_r; reflexivity.
  Qed.

  Lemma bdistinct_over_bmin:
    forall (l2 l1:list A),
      (bdistinct (l1 min-b l2)) ≅ ((bdistinct l1) min-b (bdistinct l2)).
  Proof.
    intros.
    apply bags_same_mult_has_equal; intro.
    rewrite bdistinct_mult.
    repeat rewrite bmin_mult.
    repeat rewrite bdistinct_mult.
    generalize (mult l1 a); intro.
    generalize (mult l2 a); intro.
    generalize (min_against_one n); intro.
    generalize (min_against_one n0); intro.
    elim H; intro; clear H; elim H0; intro; clear H0; rewrite H; rewrite H1.
    assert (n = 0); try (apply (min_zero n 0); assumption).
    assert (n0 = 0); try (apply (min_zero n0 0); assumption).
    rewrite H0; rewrite H2; auto with arith.
    assert (n = 0); try (apply (min_zero n 0); assumption).
    rewrite H0; auto with arith.
    assert (n0 = 0); try (apply (min_zero n0 0); assumption).
    rewrite H0; rewrite min_0_r; auto with arith.
    simpl; generalize (compare_either n n0); intro.
    elim H0; intro; clear H0.
    assert (min n n0 = n). try (rewrite min_l; [reflexivity|assumption]).
    rewrite H0; assumption.
    assert (min n n0 = n0). try (rewrite min_r; [reflexivity|assumption]).
    rewrite H0; assumption.
  Qed.

  Lemma split_select:
    forall (p:A -> bool), forall (s:list A),
      exists (sp nsp:list A),
        (sp ⊎ nsp) ≅ s /\
        (filter p sp) = sp /\
        (filter p nsp) = nil.
  Proof.
    intros.
    assert (s ≅ ((filter p s) ⊎ (filter (fun x => negb (p x)) s))).
    rewrite (select_not_select p) with (s := s); reflexivity.
    exists (filter p s).
    exists (filter (fun x : A => negb (p x)) s).
    split;[rewrite <- H; reflexivity|split].
    - rewrite filter_filter; reflexivity.
    - rewrite filter_not_filter; reflexivity.
  Qed.

  Lemma mult_filter_true l {p a} :
    p a = true ->
    mult (filter p l) a = mult l a.
  Proof.
    intros eqf.
    induction l; simpl; trivial.
    case_eq (equiv_dec a a0); intros; try rewrite e in *; subst.
    - rewrite eqf; simpl. rewrite H; auto.
    - destruct (p a0); auto; simpl. rewrite H; auto.
  Qed.

  Lemma mult_filter_false l {p a} :
    p a = false ->
    mult (filter p l) a = 0.
  Proof.
    intros eqf.
    induction l; simpl; trivial.
    case_eq (p a0); auto; simpl; intros.
    case_eq (equiv_dec a a0); intros; subst; intuition; congruence.
  Qed.

  (* Minimal solution support *)

  Definition bminus_delta2 (Q dQm dQp:list A) :=
    (Q min-b dQm) ⊖ dQp.

  Definition bplus_delta2 (Q dQm dQp:list A) :=
    dQp ⊖ (Q min-b dQm).

  Definition apply_deltas (Q dQm dQp: list A) :=
    (Q ⊖ dQm) ⊎ dQp.

  Lemma theorem2_a:
    forall (Q dQm dQp: list A),
      (apply_deltas Q dQm dQp) ≅
      (apply_deltas Q (bminus_delta2 Q dQm dQp) (bplus_delta2 Q dQm dQp)).
  Proof.
    intros.
    apply bags_same_mult_has_equal; intro.
    unfold apply_deltas.
    unfold bminus_delta2; unfold bplus_delta2.
    repeat rewrite bunion_mult.
    repeat rewrite bminus_mult.
    repeat rewrite bmin_mult.
    generalize (mult Q a) as nQ; intro.
    generalize (mult dQm a) as ndQm; intro.
    generalize (mult dQp a) as ndQp; intro.
    generalize (compare_either nQ ndQm); intro.
    elim H; intro; clear H.
    - rewrite min_l; try assumption; lia.
    - rewrite min_r; try assumption; lia.
  Qed.

  Lemma theorem2_b:
    forall (Q dQm dQp: list A),
      ((bminus_delta2 Q dQm dQp) ⊖ Q) ≅ nil.
  Proof.
    intros.
    apply bags_same_mult_has_equal; intro; simpl.
    unfold bminus_delta2.
    repeat rewrite bminus_mult.
    rewrite bmin_mult.
    generalize (mult Q a) as nQ; intro.
    generalize (mult dQm a) as ndQm; intro.
    generalize (mult dQp a) as ndQp; intro.
    generalize (compare_either nQ ndQm); intro.
    elim H; intro; clear H.
    - rewrite min_l; try assumption; lia.
    - rewrite min_r; try assumption; lia.
  Qed.

  Lemma theorem2_c:
    forall (Q dQm dQp: list A),
      ((bminus_delta2 Q dQm dQp) min-b (bplus_delta2 Q dQm dQp)) ≅ nil.
  Proof.
    intros.
    apply bags_same_mult_has_equal; intro; simpl.
    unfold bminus_delta2; unfold bplus_delta2.
    rewrite bmin_mult.
    repeat rewrite bminus_mult.
    repeat rewrite bmin_mult.
    generalize (mult Q a) as nQ; intro.
    generalize (mult dQm a) as ndQm; intro.
    generalize (mult dQp a) as ndQp; intro.
    generalize (compare_either nQ ndQm); intro.
    elim H; intros; clear H.
    - assert (min nQ ndQm = nQ).
      rewrite min_l; [reflexivity|assumption].
      rewrite H.
      generalize (compare_either nQ ndQp); intro.
      elim H1; intros; clear H1.
      + rewrite min_l; lia.
      + rewrite min_r; lia.
    - assert (min nQ ndQm = ndQm).
      rewrite min_r; [reflexivity|assumption].
      rewrite H.
      generalize (compare_either ndQm ndQp); intro.
      elim H1; intros; clear H1.
      + rewrite min_l; lia.
      + rewrite min_r; lia.
  Qed.

  Lemma remove_one_bminus r s a:
    ((remove_one a s) ⊖ r) = (s ⊖ (a :: r)).
  Proof.
    revert s r. induction r; intros; reflexivity.
  Qed.

  Lemma remove_bminus_comm r s a:
    ((remove_one a s) ⊖ r) = (remove_one a (s ⊖ r)).
  Proof.
    revert r s.
    induction r; intros; simpl.
    - reflexivity.
    - rewrite remove_one_comm.
      rewrite (IHr (remove_one a0 s)).
      reflexivity.
  Qed.

  Lemma filter_remove_one_false s {p a} : p a = false ->
      (filter p (remove_one a s)) = filter p s.
  Proof.
    intros eqf.
    induction s; simpl; trivial.
    case_eq (equiv_dec a a0); intros; subst; simpl.
    rewrite e in *.
    - rewrite eqf; auto.
    - case_eq (p a0); intros eqf0; rewrite IHs; reflexivity.
  Qed.

  Lemma filter_remove_one s {p a} :
      (filter p (remove_one a s)) = remove_one a (filter p s).
  Proof.
    induction s; simpl; trivial.
    case_eq (equiv_dec a a0); intros; subst; simpl.
    - red in e; subst.
      case_eq (p a0); intros eqf0; simpl.
      elim (equiv_dec a0 a0); intro.
      reflexivity.
      congruence.
      rewrite filter_remove_one_false in IHs; auto.
    - case_eq (p a0); intros eqf0; simpl.
      elim (EquivDec.equiv_dec a a0); intro.
      congruence.
      rewrite IHs; reflexivity.
      assumption.
  Qed.

  Lemma bunion_filter (s:list A) (ds:list A) (p:A -> bool):
      (filter p (s ⊎ ds)) = ((filter p s) ⊎ (filter p ds)).
  Proof.
    intros; unfold bunion.
    induction s; simpl.
    - reflexivity.
    - generalize (two_cases p a); intro.
      elim H; intro; rewrite H0; try rewrite <- app_comm_cons; rewrite IHs; reflexivity.
  Qed.

  Lemma bminus_filter (p:A -> bool) (s ds:list A) : (filter p (s ⊖ ds)) = ((filter p s) ⊖ (filter p ds)).
  Proof.
    revert s.
    induction ds; simpl; auto; intros.
    rewrite IHds.
    case_eq (p a); intros eqf; simpl.
    - rewrite filter_remove_one; auto.
    - rewrite filter_remove_one_false; trivial.
  Qed.

End Bag.

Section NumMinMax.
  Open Scope Z_scope.

  Definition bnummin (l:list Z) :=
    match l with
    | nil => 0
    | x0 :: l' =>
      fold_right (fun x y => Z.min x y) x0 l'
    end.

  Definition bnummax (l:list Z) :=
    match l with
    | nil => 0
    | x0 :: l' =>
      fold_right (fun x y => Z.max x y) x0 l'
    end.

End NumMinMax.

(* Post section rewrites and notations *)
Hint Rewrite
     bminus_nil_to_self
     bminus_to_nil
     bminus_self
     bminus_naught
     bminus_cons
     app_nil_r
     bunion_bminus
     remove_one_consed : bag.

Global Hint Unfold ldeqA : qcert.
Global Hint Unfold mult_equiv : qcert.