Require Export Monotonicity.
Require Import KLR.

(** ** The [transport] tactic *)

(** Often, we know that a number of terms are related, and need to
  transport hypotheses built out the the left-hand sides into ones
  with similar shapes, but built out of the right-hand sides. For
  instance, in cirumstances where [rauto] can establish
  [option_rel R x y], we will want to turn a hypothesis of the form
  [x = Some a] into one of the form [y = Some b], and remember that
  [R a b]. This is the role of the [transport] tactic. *)

(** *** Transportable hypotheses *)

(* To make the tactic extensible, we use the following typeclass to
  declare patterns of relations and hypothesis shapes that can be
  handled in this way. *)

Class Transport {A B} (R: rel A B) (a: A) (b: B) (PA: Prop) (PB: Prop) :=
  transport: R a b -> PA -> PB.

(** One stereotypical example is [option_le]: the [Transport] instance
  defined in the [OptionRel] library allows us to transport hypothese
  of the form [x = Some a] into hypotheses of the form [y = Some b],
  with [a] and [b] related by [R] whenever [x] and [y] are related by
  [option_le R], and similarly for [None] and [option_rel].

  Other instances are declared below. *)

Global Instance prod_rel_transport_eq_pair {A1 B1 A2 B2} (R1: rel A1 B1) (R2: rel A2 B2) x y a1 a2:
  Transport (prod_rel R1 R2) x y (x = (a1, a2)) (exists b1 b2, y = (b1, b2) /\ R1 a1 b1 /\ R2 a2 b2).
Proof.
  intros [Hxy1 Hxy2] Hx.
  destruct y.
  subst.
  simpl in *.
  eauto.
Qed.

(** For [set_le] the situation is slightly more involved, for two
  reasons. First, a regular [eapply set_le_transport] fails to unify
  the parameter [B] of [Transport] against the [_ -> Prop] provied by
  the instance below. This can be worked around by pre-unifying that
  specific parameter. Second, because [set_le_transport] is
  potentially applicable to virtually any hypothesis (since there is
  no strongly distinguishing syntactic format in our target
  hypotheses), it makes [transport_hyps] very slow.

  To address this, we explicitely register hints based on the
  [set_le_transport] tactic, which looks for "keywords" before doing
  anything, then applies the lemma with the required unification
  preparation. For example, [set_le_transport] is used in the
  following way in the [SimClight] library:
<<
    Hint Extern 1 (Transport _ _ _ _ _) =>
      set_le_transport @assign_loc : typeclass_instances.
>>
  Note that it's necessary to use [@] because [assign_loc] is
  parametrized by typeclasses, and we want to avoid undue
  specialization at hint registration time. *)

Lemma set_le_transport {A B} (R: rel A B) sA sB a:
  Transport (set_le R) sA sB (sA a) (exists b, sB b /\ R a b).
Proof.
  intros HsAB Ha.
  edestruct HsAB; eauto.
Qed.

Ltac set_le_transport keyword :=
  lazymatch goal with
    | |- @Transport ?A ?B ?R ?a ?b ?PA ?PB =>
      lazymatch PA with
        | context [keyword] =>
          let Xv := fresh "X" in evar (Xv: Type);
          let X := eval red in Xv in clear Xv;
          unify B (X -> Prop);
          eapply set_le_transport
      end
  end.

(** We defined a few more relation patterns based on [set_le] and
  [rel_curry], with a similar strategy. *)

Lemma rel_curry_set_le_transport {A1 A2 B1 B2} R sA sB (a1: A1) (a2: A2):
  Transport (% set_le R) sA sB
    (sA a1 a2)
    (exists (b1: B1) (b2: B2), sB b1 b2 /\ R (a1, a2) (b1, b2)).
Proof.
  intros HsAB Ha.
  destruct (HsAB (a1, a2)) as ([b1 b2] & Hb & Hab); eauto.
Qed.

Ltac rel_curry_set_le_transport keyword :=
  lazymatch goal with
    | |- @Transport ?A ?B ?R ?a ?b ?PA ?PB =>
      lazymatch PA with
        | context [keyword] =>
          let Xv := fresh "X" in evar (Xv: Type);
          let X := eval red in Xv in clear Xv;
          let Yv := fresh "Y" in evar (Yv: Type);
          let Y := eval red in Yv in clear Yv;
          unify B (X -> Y -> Prop);
          eapply rel_curry_set_le_transport
      end
  end.

Lemma rel_curry2_set_le_transport {A1 A2 A3 B1 B2 B3} R sA sB (a1: A1) (a2: A2) (a3: A3):
  Transport (% % set_le R) sA sB
    (sA a1 a2 a3)
    (exists (b1: B1) (b2: B2) (b3: B3), sB b1 b2 b3 /\ R (a1, a2, a3) (b1, b2, b3)).
Proof.
  intros HsAB Ha.
  destruct (HsAB (a1, a2, a3)) as ([[b1 b2] b3] & Hb & Hab); eauto.
Qed.

Ltac rel_curry2_set_le_transport keyword :=
  lazymatch goal with
    | |- @Transport ?A ?B ?R ?a ?b ?PA ?PB =>
      lazymatch PA with
        | context [keyword] =>
          let Xv := fresh "X" in evar (Xv: Type);
          let X := eval red in Xv in clear Xv;
          let Yv := fresh "Y" in evar (Yv: Type);
          let Y := eval red in Yv in clear Yv;
          let Zv := fresh "Y" in evar (Yv: Type);
          let Z := eval red in Yv in clear Yv;
          unify B (X -> Y -> Z -> Prop);
          eapply rel_curry2_set_le_transport
      end
  end.

(** The situation for [impl] is similar: since this transport instance
  can apply to pretty much anything, we need to register it on a
  case-by-case basis. Here is an example used in the CertiKOS proof
  for hypotheses of the form [writable_block ge b]:
<<
    Hint Extern 10 (Transport _ _ _ (writable_block _ _) _) =>
      eapply impl_transport : typeclass_instances.
>> *)

Lemma impl_transport P Q:
  Transport impl P Q P Q.
Proof.
  firstorder.
Qed.

(*** *** The actual tactic *)

(** Often, the target hypotheses declared using the [Transport] class
  have existential quantifiers, and need to be broken up to get to the
  actual relational hypotheses we're interested in. The [split_hyp]
  tactic does that. We also use that opportunity to split up
  [prod_rel] and [rel_incr] when appropriate. For [prod_rel] this is
  especially useful when [rel_curry] is involved. Likewise we
  generally want to split up [rel_incr] as soon as possible, so that
  the existentially quantified world therein can be used to
  instantiate evars that have been spawned from that point on.

  As a generally useful complement, the [split_hyps] tactic applies
  the same process to all hypotheses. *)

Ltac split_hyp H :=
  lazymatch type of H with
    | ex _ =>
      destruct H as [? H];
      split_hyp H
    | _ /\ _ =>
      let H1 := fresh in
      let H2 := fresh in
      destruct H as [H1 H2];
      split_hyp H1;
      split_hyp H2
    | prod_rel ?Rx ?Ry (?x1, ?y1) (?x2, ?y2) =>
      change (Rx x1 x2 /\ Ry y1 y2) in H;
      split_hyp H
    | rel_incr ?acc ?R ?w ?x ?y =>
      let w' := fresh w "'" in
      let Hw' := fresh "H" w' in
      destruct H as (w' & Hw' & H);
      split_hyp H
    | klr_diam ?l ?R ?w ?x ?y =>
      let w' := fresh w "'" in
      let Hw' := fresh "H" w' in
      destruct H as (w' & Hw' & H);
      split_hyp H
    | prod_klr ?Rx ?Ry ?w (?x1, ?y1) (?x2, ?y2) =>
      change (Rx w x1 x2 /\ Ry w y1 y2) in H;
      split_hyp H
    | _ =>
      idtac
  end.

Ltac split_hyps :=
  repeat
    lazymatch goal with
      | H: ex _ |- _ =>
        destruct H
      | H: _ /\ _ |- _ =>
        destruct H
      | H: prod_rel ?Rx ?Ry (?x1, ?y1) (?x2, ?y2) |- _ =>
        change (Rx x1 x2 /\ Ry y1 y2) in H
      | H: klr_diam ?R ?w ?x ?y |- _ =>
        let w' := fresh w "'" in
        let Hw' := fresh "H" w' in
        destruct H as (w' & Hw' & H)
      | H: prod_klr ?Rx ?Ry ?w (?x1, ?y1) (?x2, ?y2) |- _ =>
        change (Rx w x1 x2 /\ Ry w y1 y2) in H
    end.

(** We're now ready to defined the [transport] tactic, which
  essentially looks up a [Transport] instance and applies it the the
  hypothesis to be transported, using [RAuto] to solve the relational
  subgoal. Note that the relation and right-hand side will usually
  contain existential variables, but the proof search can hopefully
  proceed by following the structure of the left-hand side. Once the
  [Transport] instance has been applied, we use [split_hyp] on the
  modified hypothesis as post-processing.

  Because we have many open-ended evars involved, it is easy for
  trivial relations such as [eq] to kick in and sabotage us,
  overriding the more interesting properties that we actually want to
  use and preventing any progress from actually being made. In order
  to attenuate this issue, we require that [RAuto] yield unconvertible
  related elements.

  Another pitfall we want to avoid is illustrated by the [option_rel]
  case. When we have a hypothesis of the form [H: m = Some a], but no
  interesting way to relate [m] to something else, then the search for
  [(option_rel ?R) m ?n] can end up using [H] itself (because
  [option_rel eq] is reflexive, hence [subrel_eq] applies). To prevent
  such cases we need to make sure that the hypothesis being
  transported is not used to discharge the relational premise, and so
  we revert it into the conclusing before we proceed, and use the
  following lemma to work on a goal of that form directly. *)

Lemma transport_in_goal `{Transport} `{!RAuto (R a b)} `{!Unconvertible a b}:
  forall (Q: Prop), (PB -> Q) -> (PA -> Q).
Proof.
  firstorder.
Qed.

Ltac transport H :=
  revert H;
  lazymatch goal with
    | |- ?PA -> ?Q =>
      apply (transport_in_goal (PA:=PA) Q)
  end;
  intro H;
  split_hyp H.

(** Again we provide a tactic which attempts to transport all
  hypotheses. Notice that earlier transportations may provide new
  hypotheses making later transportations possible. Hence it would be
  hard to provide a much more effective tactic, even though this one
  may retry failing transportations many times. *)

Ltac transport_hyps :=
  repeat
    match goal with
      | H: _ |- _ => transport H
    end.


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.