(** printing wi $w_i$ #wi#  *)
(** printing wi16 $w_{i+16}$ #wi+16#  *)
(** printing wi14 $w_{i+14}$ #wi+14#  *)
(** printing wi9 $w_{i+9}$ #wi+9#  *)
(** printing wi1 $w_{i+1}$ #wi+1#  *)

Require Import Nat.
(** * The Verse EDSL.
Implementing cryptographic primitives in a High level language is
problematic for two reasons.

- The resulting code is not fast (enough), but more importantly

- The safety of the resulting program can be compromised due to side
  channel leaks.

Due to this unfortunate situation, cryptographic libraries, even for a
high level language like Haskell, has in it a lots of hand written C
and assembly code fragment. This is not a nice situation to be in.  As
a solution to this problem, we propose Verse, an embedded domain
specific language designed for writing cryptographic primitives. This
module serves as a short tutorial for Verse.

 *)

(** ** Getting started.

You will need a recent enough version of Coq. Refer to our continuous
build at
https://github.com/raaz-crypto/verse-coq/actions/workflows/ci.yml for
which all versions are supported. We recommend the use of emacs and
the proof general mode for editing.

 *)

(** ** A quick tour.

Cryptographic primitives come in two variety: bulk primitives and
fixed input ones. Primitives like ciphers, cryptographic hash
functions etc takes input as a stream of fixed sized chunks (called
blocks) and processes it and are examples for the former.  On the
other hand, the operations needed for asymmetric key primitives like
point multiplication in an elliptic curve are examples for the
latter. Being designed specifically for crypto-primitives, verse only
supports two kinds of functions.

- An iterator which can be thought of as a particular transformation,
  applied individually on each block of data in a stream of blocks, or

- Straight line programs which are a sequence of assembly language
  statements.

In particular, there are no facilities for performing any kind of
control flow except the implicit ones when the iterator loops over the
blocks. Not only are these two forms general enough to write
cryptographic primitives, restricting to such functions means that we
would not inadvertently use a secret information to execute a branch
thereby leaking information about secrets through the branch
predication.

Programming in Verse is carried out in two stages. In the first stage,
the Verse programmer writes a generic program which can potentially be
targeted at multiple architectures and in the second stage code
generation is done for specific targets. For the latter part the
programmer needs to tell the code generator which of the variables are
the parameters of the resulting C/assembly function, which of them are
to be spilled on stack and which are to be allocated in explicitly
given register list. While many of the mundane details are taken care
of by verse, there are two important considerations that the user
should worry about.

- In the first stage when writing generic code, care should be taken
  to avoid instructions that may not be available on the eventual
  target architecture. For example, if the target architecture is X86,
  a program that uses the instruction [X ::= Y [+] Z] will fail during
  code generation because of the lack of support for this 3-operand
  instruction in X86.

- During actual code generation verse takes care of using the
  appropriate calling convention for parameter passing and offset
  calculation on stack. However the register allocation is left to the
  user. The user should take care to avoid special registers that are
  reserved by the calling convention for otherwise code generation
  phase would fail.

We start by importing the verse module and setting up notations for
lists and vectors.

 *)

From Verse Require Import Verse.

(** *** Straight line functions

Let us give an example of a message scheduling for a sha2 like hash,
deliberately simplified to illustrate some of the constructs of the
language. The message is an array of 16x64-bit unsigned integers that
is expanded using the rule [wi16 = wi + wi14 + wi9 + wi1]. We will
wrap this code inside a module to preserve namespaces.

*)

Section Schedule.

  (** The standard idiom for writing a Verse program is to define a
      Coq [Section] which contains definitions of the program
      variables, Verse code, and other auxiliary information.
   *)

  (** The message schedule of SHA512 and SHA256 involves the same
      message indices. In our simplified variant, the only
      difference between the two is that the former uses words of
      64-bit whereas the latter uses words of 32-bit. By making the
      [word] a [Variable] of this section, our code effectively
      becomes polymorphic on the [word] type.  *)

  Variable word : type direct.

  (** The [type direct] in the above definition is the type of all
      direct types, i.e. types that fit into machine registers, which
      includes the word and multi-word types. See
      Section%~\ref{sec-type-system}% for more details on types
      and kinds in Verse.

   *)
  (** A SHA2 block is a 16 length array of this word type encoded
      in big endian.

     *)
  Definition SIZE  := 16.
  Definition BLOCK := Array SIZE bigE word.

  (**

Generic variants of code are _parameterised_ over the program
variables which will eventually be instantiated from the
architecture specific register set during code generation. In
Verse the type [VariableT] is the universe of all possible program
variable types.

   *)

  Variable progvar     : VariableT.
  (* begin hide *)
  (* end hide *)

  (** What follows is the Verse program for message scheduling. First we
      "declare" the program variables, the variable [W], [S], and [T] followed
      by the actual message schedule.
   *)

  Section Params.

    Variable W       : progvar of type BLOCK.

    Section Locals.

      Variable S T     : progvar of type word.

      (**

     We can index the [i]-th elements of the array [W] by using the
     notation [W[i]].  However, for safety verse does not allow
     such indexing without an accompanying proof of the fact that
     [i] is less than the bound. Instead of using the notation
     directly, we instead use a tactic also called `verse` whos
     joub is to complete such bounds. In the Definition below
     notice its use.

       *)

      Section Schedule.
        Context (i : nat)(pf : i < SIZE).
        Definition WordSchedule  :  Repeat (statement progvar).
          verse ([code|
                   S  :=  W[ i ] ;
                   T  :=  W[ (i + 14) mod SIZE ] ;
                   S  +=  T;
                   T  :=  W[ (i + 9) mod SIZE  ] ;
                   S  +=  T;
                   T  :=  W[ (i + 1) mod SIZE ];
                   S  +=  T;
                   W[ i ] := S
                 |]).
        Defined.
      End Schedule.

      (** Having defined the code segment for scheduling a single word
      in the message, we use the [foreach] function to generate an
      unrolled loop performing the [WordSchedule] for every index of
      [W].
       *)

      Definition Schedule := iterate WordSchedule.

    End Locals.

    Definition Scheduled := do Schedule end.

  End Params.

End Schedule.

From Verse Require Import Verse.Target.C.
From Verse Require Import Verse.Print.

Inductive name := schedule64bit.

Definition Schedule64bit
  : CodeGen.Config.programLine + {Error.TranslationError}.
  Function schedule64bit
           (Scheduled Word64).
Defined.

Goal to_print (recover Schedule64bit).
  print.
Abort.

(** ** Legal

Copyright 2018, Piyush P Kurur

Licensed under the Apache License, Version 2.0 (the "License"); you
may not use this software 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.

SPDX-License-Identifier: Apache-2.0

 *)


(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2015 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

From Coq Require Import Reals Psatz ssreflect.

From Coquelicot Require Import Hierarchy PSeries Rbar Lim_seq.

(** This file describes an experiment: most 18-year old French
students pass an exam called Baccalaureate which ends the high school
and is required for attending the university. We took the 2013
mathematics test of the scientific Baccalaureate at the same time as
the students. The pdf of the test is available #here#. This file is dedicated
to the mathematics specialty exercise, done after the exam. *)

Open Scope R_scope.

(** * Bac 2013 - Exercice 4 spécialité *)

(** 1. Exprimer v (S n) et c (S n) en fonction de v n et c n *)

Fixpoint v (n : nat) : R :=
  match n with
  | O => 7 / 10 * 250000
  | S n => 95 / 100 * v n + 1 / 100 * c n
  end
with c (n : nat) : R :=
  match n with
  | O => 3 / 10 * 250000
  | S n => 5 / 100 * v n + 99 / 100 * c n
  end.

(** 2. Définition de la matrice A *)

Definition A : matrix 2 2 :=
  [[95/100, 1/100 ] ,
    [ 5/100, 99/100]].

Definition X (n : nat) : matrix 2 1 :=
  [[v n],[c n]].

Lemma Q2 : forall n, X (S n) = scal A (X n).
Proof.
  intros n.
  rewrite /scal /= /Mmult.
  apply (coeff_mat_ext 0).
  case ; [ | case => //].
  case ; [ | case => //] ;
  rewrite coeff_mat_bij /= ; (try lia) ;
  rewrite sum_Sn sum_O /plus /mult //=.
  case ; [ | case => //] ;
  rewrite coeff_mat_bij /= ; (try lia) ;
  rewrite sum_Sn sum_O /plus /mult //=.
Qed.

(** 3. Diagonalisation *)

Definition P : matrix 2 2 :=
  [[1,-1], [5,1]].
Definition Q : matrix 2 2 :=
  [[1,1],[-5,1]].

Goal mult P Q = [[6,0],[0,6]].
apply (coeff_mat_ext_aux 0 0) => i j Hi Hj.
rewrite coeff_mat_bij => //.
rewrite /coeff_mat /= /mult /plus /=.
(destruct i as [ | i] ; destruct j as [ | j] ; rewrite /zero /= ; try ring) ;
(try (destruct i as [ | i]) ; try (destruct j as [ | j]) ; rewrite /zero /= ; try ring) ;
rewrite sum_Sn sum_O /= /plus /= ; ring.
Qed.

Goal mult Q P = [[6,0],[0,6]].
apply (coeff_mat_ext_aux 0 0) => i j Hi Hj.
rewrite coeff_mat_bij => //.
rewrite /coeff_mat /= /mult /plus /=.
(destruct i as [ | i] ; destruct j as [ | j] ; rewrite /zero /= ; try ring) ;
(try (destruct i as [ | i]) ; try (destruct j as [ | j]) ; rewrite /zero /= ; try ring) ;
rewrite sum_Sn sum_O /= /plus /= ; ring.
Qed.

Definition P' : matrix 2 2 :=
  [[1 / 6,1 / 6],[-5 / 6,1 / 6]].

Lemma Q3a : mult P P' = Mone /\ mult P' P = Mone.
Proof.
  split.
  apply (coeff_mat_ext_aux 0 0) => i j Hi Hj.
  rewrite coeff_mat_bij => //.
  rewrite /coeff_mat /= /mult /plus /=.
  (destruct i as [ | i] ; destruct j as [ | j] ; rewrite /zero /= ; try field) ;
  (try (destruct i as [ | i]) ; try (destruct j as [ | j]) ; rewrite /zero /one /= ; try field) ;
  rewrite sum_Sn sum_O /= /plus /= ; field.
  apply (coeff_mat_ext_aux 0 0) => i j Hi Hj.
  rewrite coeff_mat_bij => //.
  rewrite /coeff_mat /= /mult /plus /=.
  (destruct i as [ | i] ; destruct j as [ | j] ; rewrite /zero /= ; try field) ;
  (try (destruct i as [ | i]) ; try (destruct j as [ | j]) ; rewrite /zero /one /= ; try field) ;
  rewrite sum_Sn sum_O /= /plus /= ; field.
Qed.

Definition D : matrix 2 2 := [[1,0],[0,94 / 100]].

Lemma Q3b : mult P' (mult A P) = D.
Proof.
  apply (coeff_mat_ext_aux 0 0) => i j Hi Hj.
  rewrite coeff_mat_bij => //.
  rewrite /coeff_mat /= /mult /plus /=.
  (destruct i as [ | i] ; destruct j as [ | j] ; rewrite /zero /= ; try field) ;
  (try (destruct i as [ | i]) ; try (destruct j as [ | j]) ; rewrite /zero /one /= ; try field) ;
  rewrite sum_Sn sum_O /= /plus /= ; (try field) ;
  rewrite !sum_Sn !sum_O /= /plus /coeff_mat /= ; field.
Qed.

Lemma Q3c : forall n, pow_n A n = mult P (mult (pow_n D n) P').
Proof.
  elim => /= [ | n IH].
  rewrite mult_one_l.
  apply sym_eq, Q3a.
  by rewrite -{1}Q3b !mult_assoc (proj1 Q3a) mult_one_l -!mult_assoc IH.
Qed.

(** 4. Terme général et limite de la suite v n *)

Lemma Q4 : forall n, v n = 1 / 6 * (1 + 5 * (94 / 100) ^ n) * v 0
                         + 1 / 6 * (1 - (94 / 100) ^ n) * c 0.
Proof.
  intros n.
  assert (X n = scal (pow_n A n) (X 0)).
    elim: n => [ | n IH] /=.
    by rewrite scal_one.
    rewrite -scal_assoc -IH.
    by apply Q2.
  assert (pow_n D n = [[1,0], [0,(94 / 100)^n]]).
    elim: (n) => [ | m IH] //=.
    rewrite IH.
    apply (coeff_mat_ext_aux 0 0) => i j Hi Hj.
    rewrite coeff_mat_bij => //=.
    rewrite /plus /mult /= /coeff_mat /=.
    (destruct i as [ | i] ; destruct j as [ | j] ; rewrite /zero /one /=) ;
    (try (destruct i as [ | i]) ; try (destruct j as [ | j]) ; rewrite /zero /one /= ; try field) ;
    rewrite sum_Sn sum_O /= /plus /= ; field.
  rewrite Q3c H0 in H.
  apply (proj1 (coeff_mat_ext 0 _ _)) with (i := O) (j := O) in H.
  rewrite {1}/coeff_mat /= in H.
  rewrite H ; repeat (rewrite !/coeff_mat /=).
  rewrite !sum_Sn !sum_O /= /plus /mult /= ; field.
Qed.

Lemma lim_v : is_lim_seq v (41666 + 2 / 3).
Proof.
  eapply is_lim_seq_ext.
  intros n ; apply sym_eq, Q4.
  eapply is_lim_seq_plus.
  eapply is_lim_seq_mult.
  eapply is_lim_seq_mult.
  apply is_lim_seq_const.
  eapply is_lim_seq_plus.
  apply is_lim_seq_const.
  eapply is_lim_seq_mult.
  apply is_lim_seq_const.
  apply is_lim_seq_geom.
  rewrite Rabs_pos_eq ; lra.
  by [].
  by [].
  by [].
  apply is_lim_seq_const.
  by [].
  eapply is_lim_seq_mult.
  eapply is_lim_seq_mult.
  apply is_lim_seq_const.
  eapply is_lim_seq_minus.
  apply is_lim_seq_const.
  apply is_lim_seq_geom.
  rewrite Rabs_pos_eq ; lra.
  by [].
  by [].
  apply is_lim_seq_const.
  by [].
  apply (f_equal (fun x => Some (Finite x))) ;
  simpl ; field.
Qed.

Lemma lim_c : is_lim_seq c (208333 + 1 / 3).
Proof.
  assert (forall n, c n = 250000 - v n).
    elim => [ | n /= ->] /= ; field.
  eapply is_lim_seq_ext.
  intros n ; apply sym_eq, H.
  eapply is_lim_seq_minus.
  apply is_lim_seq_const.
  by apply lim_v.
  apply (f_equal (fun x => Some (Finite x))) ;
  simpl ; field.
Qed.


Require Export k_inf.

Reserved Notation "'kcont' ty" (at level 75).

Fixpoint ktype ty :=
  match ty with
  | t_int => t_int
  | t_arr t1 t2 => t_arr t1 (t_arr (kcont t2) t_void)
  | t_void => t_void
  end

where "'kcont' ty" := (t_arr (ktype ty) t_void).

Inductive kexp : e -> e -> e -> Prop :=
| exp_var : forall y ty k,
    kexp (e_ann (u_var_f y) ty) k
         (e_ann (u_app k (e_ann (u_var_f y)
                                (ktype ty)))
                t_void)
| exp_int : forall n ty k,
    kexp (e_ann (u_int n) ty) k
         (e_ann (u_app k (e_ann (u_int n)
                                (ktype ty)))
                t_void)
| exp_lam : forall ut t1 e2 u2 t2 e' ty k,
    ut = u_lam t1 e2 ->
    e2 = (e_ann u2 t2) ->
    (forall x1 c1, x1 `notin` (fv_u ut) ->
    c1 `notin` (fv_u ut) ->
        let xt := u_var_f x1 in
        let ct := u_var_f c1 in
        kexp (open_e_wrt_u e2 xt) (e_ann ct (kcont t2)) (open_e_wrt_u (open_e_wrt_u e' xt) ct)) ->
    (forall xt ct,
       lc_u xt ->
       lc_u ct ->
       lc_e (open_e_wrt_u (open_e_wrt_u e' xt) ct)) ->
    kexp (e_ann ut ty) k
         (e_ann (u_app k
                       (e_ann
                          (u_lam (ktype t1)
                                 (e_ann (u_lam (kcont t2)
                                               e')
                                        (t_arr (kcont t2) t_void)))
                          (kcont ty)))
                t_void)
| exp_app : forall e1 e1' u1 t1 e2 e2' u2 t2 ty k,
    e1 = e_ann u1 t1 ->
    e2 = e_ann u2 t2 ->
    (forall c1, c1 `notin` (fv_e e1) ->
    let ct := u_var_f c1 in
    kexp e1 (e_ann ct (kcont t1)) (open_e_wrt_u e1' ct)) ->
    (forall c2, c2 `notin` (fv_e e2) ->
    let ct := u_var_f c2 in
    kexp e2 (e_ann ct (kcont t2)) (open_e_wrt_u e2' ct)) ->
    (forall ct,
       lc_u ct ->
       lc_e (open_e_wrt_u e1' ct)) ->
    (forall ct,
       lc_u ct ->
       lc_e (open_e_wrt_u e2' ct)) ->
    kexp (e_ann (u_app e1 e2) ty) k
         (open_e_wrt_u e1'
                       (u_lam (ktype t1)
                              (open_e_wrt_u e2'
                                            (u_lam (ktype t2)
                                                   (e_ann (u_app (e_ann (u_app (e_ann (u_var_b 1)
                                                                                (ktype t1))
                                                                               (e_ann (u_var_b 0)
                                                                                (ktype t2)))
                                                                        (t_arr (kcont t2) t_void)) k)
                                                          t_void)))))
| exp_prim : forall e1 e1' e2 e2' p ty k,
    (forall c1, c1 `notin` (fv_e e1) ->
    let ct := u_var_f c1 in
    kexp e1 (e_ann ct (kcont t_int)) (open_e_wrt_u e1' ct)) ->
    (forall c2, c2 `notin` (fv_e e2) ->
    let ct := u_var_f c2 in
    kexp e2 (e_ann ct (kcont t_int)) (open_e_wrt_u e2' ct)) ->
    (forall ct,
       lc_u ct ->
       lc_e (open_e_wrt_u e1' ct)) ->
    (forall ct,
       lc_u ct ->
       lc_e (open_e_wrt_u e2' ct)) ->
    kexp (e_ann (u_prim e1 p e2) ty) k
         (open_e_wrt_u e1'
                       (u_lam t_int
                              (open_e_wrt_u e2'
                                            (u_lam t_int
                                                   (e_ann (u_let (e_ann (u_prim (e_ann (u_var_b 2) t_int) p
                                                                                (e_ann (u_var_b 1) t_int))
                                                                        t_int)
                                                                 (u_app k (e_ann (u_var_b 0) t_int)))
                                                          t_void)))))
| exp_if0 : forall e1 e1' e2 e2' e3 e3' ty k,
    (forall c1, c1 `notin` (fv_e e1) ->
    let ct := u_var_f c1 in
    kexp e1 (e_ann ct (kcont t_int)) (open_e_wrt_u e1' ct)) ->
    kexp e2 k e2' ->
    kexp e3 k e3' ->
    (forall ct,
       lc_u ct ->
       lc_e (open_e_wrt_u e1' ct)) ->
    lc_e e2' ->
    lc_e e3' ->
    kexp (e_ann (u_if0 e1 e2 e3) ty) k
         (open_e_wrt_u e1'
                       (u_lam t_int
                              (e_ann (u_if0 (e_ann (u_var_b 0) t_int)
                                            e2'
                                            e3')
                                     t_void)))
.

Inductive kprog : e -> e -> Prop :=
| prog_halt:
    forall e1 u1 ty e',
    e1 = e_ann u1 ty ->
    (forall c1,
        c1 `notin` (fv_e e1) ->
        let ct := u_var_f c1 in
        kexp e1 (e_ann ct (kcont ty)) (open_e_wrt_u e' ct)) ->
    kprog e1
          (open_e_wrt_u e'
                        (u_lam (ktype ty)
                               (e_ann (u_halt (e_ann (u_var_b 0) (ktype ty)))
                                      t_void))).

Fixpoint ke e k :=
  match e with
  | e_ann u t =>
    match u with
    | u_var_f x =>
      e_ann (u_app k (e_ann (u_var_f x)
                            (ktype t)))
            t_void
    | u_int i =>
      e_ann (u_app k (e_ann (u_int i)
                            (ktype t)))
            t_void
    | u_lam t1 e2 =>
      match e2 with
      | e_ann u2 t2 =>
        e_ann (u_app k (e_ann (u_lam (kcont t1)
                                     (e_ann (u_lam (kcont t2)
                                                   (ke e2 (e_ann (u_var_b 0)
                                                                 (kcont t2))))
                                            (t_arr (kcont t2) t_void)))
                              (ktype t)))
              t_void
      end
    | u_app e1 e2 =>
      match e1,e2 with
      | e_ann u1 t1, e_ann u2 t2 =>
        ke e1 (e_ann (u_lam (ktype t1)
                            (ke e2 (e_ann (u_lam (ktype t2)
                                                 (e_ann (u_app (e_ann (u_app (e_ann (u_var_b 1) (ktype t1))
                                                                             (e_ann (u_var_b 0) (ktype t2)))
                                                                      (t_arr (kcont t) t_void))
                                                               k)
                                                        t_void))
                                          (kcont t2))))
                     (kcont t1))
      end
    | u_prim e1 p e2 =>
      ke e1 (e_ann (u_lam t_int
                          (ke e2 (e_ann (u_lam t_int
                                               (e_ann (u_let (e_ann (u_prim (e_ann (u_var_b 1) t_int) p
                                                                            (e_ann (u_var_b 0) t_int))
                                                                    t_int)
                                                             (u_app k (e_ann (u_var_b 0) t_int)))
                                                      t_void))
                                        (kcont t_int))))
                   (kcont t_int))
    | u_if0 e1 e2 e3 =>
      ke e1 (e_ann (u_lam t_int
                          (e_ann (u_if0 (e_ann (u_var_b 0) t_int)
                                        (ke e2 k)
                                        (ke e3 k))
                                 t_void))
                   (kcont t_int))
    | _ => e
    end
  end.

Definition kp e1 :=
  match e1 with
  | e_ann u1 t1 =>
    ke e1 (e_ann (u_lam (ktype t1)
                        (e_ann (u_halt (e_ann (u_var_b 0)
                                              (ktype t1)))
                               t_void))
                 (kcont t1))
  end.


(** Equality.v *)

From Babel Require Import TerminalDogma.

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

Lemma refl_iff_True (T : Type) (a : T) :
    a = a <-> True.
Proof. by []. Qed.


Require Import Coq.Program.Basics.
Require Import Coq.Strings.String.
Require Import Setoid.
Require Import ZArith.
Require Import Coq.Program.Equality.
Require Import Lia.

Require Import FinProof.All.
Require Import UMLang.All.
Require Import UrsusStdLib.Solidity.All.
Require Import UrsusTVM.Solidity.All.

Require Import UrsusDefinitions.

Import UrsusNotations.
Local Open Scope xlist_scope.
Local Open Scope record.
Local Open Scope program_scope.
Local Open Scope glist_scope.
Local Open Scope ursus_scope.
Local Open Scope usolidity_scope.

Interfaces.

MakeInterface Class IOnPoolActivated :=
{
    onPoolActivated : external PhantomType false
}.
EndInterfaces.


(******************************************************************************)
(** * Definitions of the RC11 axiomatic memory model *)
(******************************************************************************)
Require Import Classical List Relations Peano_dec.
Require Import Hahn.
Require Import Basic RC11_Events.

Set Implicit Arguments.
Remove Hints plus_n_O.

Record execution :=
  { acts : list event ;
    lab  : event -> label ;
    sb   : relation event ;
    rmw  : relation event ;
    rf   : relation event ;
    mo   : relation event ;
    data : relation event ;
    addr : relation event ;
    ctrl : relation event ;
  }.

Section Consistency.

Variable G : execution.

Notation "'acts'" := G.(acts).
Notation "'lab'" := G.(lab).
Notation "'sb'" := G.(sb).
Notation "'rmw'" := G.(rmw).
Notation "'rf'" := G.(rf).
Notation "'mo'" := G.(mo).
Notation "'data'" := G.(data).
Notation "'addr'" := G.(addr).
Notation "'ctrl'" := G.(ctrl).

Notation "'R'" := (R lab).
Notation "'W'" := (W lab).
Notation "'F'" := (F lab).
Notation "'RMW'" := (RMW lab).

Notation "'RW'" := (RW lab).
Notation "'FR'" := (FR lab).
Notation "'FW'" := (FW lab).

Notation "'Na'" := (Only_Na lab).
Notation "'Rlx'" := (Rlx lab).
Notation "'Rel'" := (Rel lab).
Notation "'Acq'" := (Acq lab).
Notation "'Acqrel'" := (Acqrel lab).
Notation "'Sc'" := (Sc lab).

Definition E a := In a acts.
Definition same_loc := (fun x y => loc lab x <> None /\ loc lab x = loc lab y).
Notation "rel |loc" := (rel ∩ same_loc) (at level 1).

(******************************************************************************)
(** ** Derived relations  *)
(******************************************************************************)

Definition useq := (rf ⨾ (rmw ∪ ⦗RMW⦘))⁺.

(* release sequence *)
Definition rs := ⦗E⦘ ⨾ ⦗W⦘ ⨾ (sb|loc)^? ⨾ ⦗W∩₁Rlx⦘ ⨾ useq^?.

Definition release := (⦗W∩₁Rel⦘ ∪ ⦗F∩₁Rel⦘ ⨾ sb) ⨾ rs.

(* synchronizes with *)
Definition sw := release ⨾ rf ⨾ (⦗R∩₁Acq⦘ ∪ ⦗R∩₁Rlx⦘ ⨾ sb ⨾ ⦗F∩₁Acq⦘).

(* happens-before *)
Definition hb := (sb ∪ sw)⁺.

(* reads-before *)
Definition rb := (rf⁻¹ ⨾ mo) \ ⦗E⦘.

(* extended coherence order *)
Definition eco := rf ∪ mo ⨾ rf^? ∪ rb ⨾ rf^?.

Definition sb_neq_loc := sb \ sb|loc.

Definition scb := sb ∪ sb_neq_loc ⨾ hb ⨾ sb_neq_loc ∪ hb|loc ∪ mo ∪ rb.

Definition psc_base := (⦗Sc⦘ ∪ ⦗F∩₁Sc⦘ ⨾ hb) ⨾ scb ⨾ (⦗Sc⦘ ∪ hb ⨾ ⦗F∩₁Sc⦘).

Definition psc_f := ⦗F∩₁Sc⦘ ⨾ (hb ∪ hb ⨾ eco ⨾ hb) ⨾ ⦗F∩₁Sc⦘.

Definition psc := psc_base ∪ psc_f.

Definition deps := data ∪ addr ∪ ctrl.

(******************************************************************************)
(** ** Basic properties *)
(******************************************************************************)

Lemma sb_in_hb : sb ⊆ hb.
Proof. vauto. Qed.

Lemma sw_in_hb : sw ⊆ hb.
Proof. vauto. Qed.

Lemma hb_trans : transitive hb.
Proof. vauto. Qed.

Lemma hb_hb : hb ⨾ hb ⊆ hb.
Proof. unfold seq, inclusion; ins; desf; vauto. Qed.

Lemma cr_hb_hb : hb^? ⨾ hb ⊆ hb.
Proof. unfold hb; rels. Qed.

Lemma sb_neq_loc_in_sb : sb_neq_loc ⊆ sb.
Proof. by unfold sb_neq_loc; basic_solver. Qed.

Lemma sb_neq_loc_in_hb : sb_neq_loc ⊆ hb.
Proof. by rewrite sb_neq_loc_in_sb, sb_in_hb. Qed.

Lemma hb_loc_in_hb : hb|loc ⊆ hb.
Proof. basic_solver. Qed.

(******************************************************************************)
(** ** Well-formed relations *)
(******************************************************************************)
Definition WfACTS :=
  ⟪ ACTS_INIT : forall l, In (Init l) acts ⟫ /\
  ⟪ LAB_INIT  : forall l, lab (Init l) = init_label l⟫.

Definition WfSB :=
  ⟪ SB_ACT  : sb ⊆ ⦗E⦘ ⨾ sb ⨾ ⦗E⦘ ⟫ /\
  ⟪ SB_INIT : init_pair ⨾ ⦗E⦘ ⊆ sb ⟫ /\
  ⟪ SB_IRR  : irreflexive sb ⟫ /\
  ⟪ SB_T    : transitive sb ⟫ /\
  ⟪ SB_TID  : sb ⊆ sb∙ ∪ init_pair ⟫ /\
  ⟪ SB_TOT  : forall i, is_total (E ∩₁ (fun a => tid a = Some i)) sb ⟫.

Definition WfRF :=
  ⟪ RF_ACT: rf ⊆ ⦗E⦘ ⨾ rf ⨾ ⦗E⦘ ⟫ /\
  ⟪ RF_IRR  : irreflexive rf ⟫ /\
  ⟪ RF_DOM: rf ⊆ ⦗W⦘ ⨾ rf ⨾ ⦗R⦘ ⟫ /\
  ⟪ RF_LOC: funeq (loc lab) rf ⟫ /\
  ⟪ RF_VAL: forall a b, rf a b -> (valw lab) a = (valr lab) b ⟫ /\
  ⟪ RF_FUN: functional rf⁻¹ ⟫ /\
  ⟪ RF_TOT: forall b (IN: E b) (READ: R b), exists a, rf a b ⟫.

Definition WfMO :=
  ⟪ MO_ACT: mo ⊆ ⦗E⦘ ⨾ mo ⨾ ⦗E⦘ ⟫ /\
  ⟪ MO_DOM: mo ⊆ ⦗W⦘ ⨾ mo ⨾ ⦗W⦘ ⟫ /\
  ⟪ MO_LOC: funeq (loc lab) mo ⟫ /\
  ⟪ MO_IRR: irreflexive mo ⟫ /\
  ⟪ MO_T  :   transitive mo ⟫ /\
  ⟪ MO_TOT: forall l, is_total (E ∩₁ W ∩₁ (fun a => loc lab a = Some l)) mo ⟫.

Definition WfRMW :=
  ⟪ RMW_DOM: rmw ⊆ ⦗R⦘ ⨾ rmw ⨾ ⦗W⦘ ⟫ /\
  ⟪ RMW_LOC: funeq (loc lab) rmw ⟫ /\
  ⟪ RMW_MOD: forall a b (RMW_AB: rmw a b),
      (Rlx a /\ Rlx b) \/ (Acq a /\ Rlx b) \/ (Rlx a /\ Rel b) \/ (Acq a /\ Rel b) \/ (Sc a /\ Sc b) ⟫ /\
  ⟪ RMW_IMM: rmw ⊆ sb|imm ⟫.

Definition WfDEPS :=
  ⟪ DATA        : data ⊆ ⦗R⦘ ⨾ data ⨾ ⦗W⦘⟫ /\
  ⟪ ADDR        : addr ⊆ ⦗R⦘ ⨾ addr ⨾ ⦗RW⦘⟫ /\
  ⟪ CTRL_RE     : ctrl ⊆ ⦗R⦘ ⨾ ctrl ⟫ /\
  ⟪ DATA_IN_SB  : data ⊆ sb ⟫ /\
  ⟪ ADDR_IN_SB  : addr ⊆ sb ⟫ /\
  ⟪ CTRL_SB     : ctrl ⨾ sb ⊆ ctrl ⟫ /\
  ⟪ CTRL_IN_SB  : ctrl ⊆ sb ⟫ /\
  ⟪ RMW_DEPS    : rmw ⊆ deps ⟫.

Definition Wf :=
  ⟪ WF_ACTS   : WfACTS ⟫ /\
  ⟪ WF_SB     : WfSB ⟫ /\
  ⟪ WF_RMW    : WfRMW ⟫ /\
  ⟪ WF_RF     : WfRF ⟫ /\
  ⟪ WF_MO     : WfMO ⟫ /\
  ⟪ WF_DEPS   : WfDEPS ⟫.

Implicit Type WF : Wf.

Lemma wf_sb WF : WfSB.
Proof. cdes WF; done. Qed.
Lemma wf_rmw WF : WfRMW.
Proof. cdes WF; done. Qed.
Lemma wf_rf WF : WfRF.
Proof. cdes WF; done. Qed.
Lemma wf_mo WF : WfMO.
Proof. cdes WF; done. Qed.
Lemma wf_deps WF : WfDEPS.
Proof. cdes WF; done. Qed.

Hint Resolve wf_sb wf_rmw wf_rf wf_mo.

(******************************************************************************)
(** ** Coherence *)
(******************************************************************************)

Definition Coherent := irreflexive (hb ⨾ eco^?).
Definition Atomic := irreflexive (rb ⨾ mo ⨾ rmw⁻¹).
Definition Atomic2 := irreflexive (mo ⨾ mo ⨾ rf⁻¹).
Definition PSC := acyclic psc.
Definition NoThinAir := acyclic (sb ∪ rf).

Definition consistent :=
  ⟪ WF  : Wf ⟫ /\
  ⟪ COH : Coherent ⟫ /\
  ⟪ AT  : Atomic ⟫ /\
  ⟪ AT2 : Atomic2 ⟫ /\
  ⟪ SC  : PSC ⟫ /\
  ⟪ NTA : NoThinAir ⟫.

Definition wconsistent :=
  ⟪ WF   : Wf ⟫ /\
  ⟪ COH  : Coherent ⟫ /\
  ⟪ AT   : Atomic ⟫ /\
  ⟪ AT2  : Atomic2 ⟫ /\
  ⟪ SC   : PSC ⟫.

Lemma con_wf  (CON: consistent) : Wf.
Proof. cdes CON; done. Qed.

Lemma wcon_wf  (CON: wconsistent) : Wf.
Proof. cdes CON; done. Qed.

Hint Resolve con_wf.

Lemma atomicity_equiv : rmw ∩ (rb ⨾ mo) ⊆ ∅₂ <-> irreflexive (rb ⨾ mo ⨾ rmw⁻¹).
Proof.  split; basic_solver 8. Qed.

Lemma atomicity_equiv2 : rf ∩ (mo ⨾ mo) ⊆ ∅₂ <-> irreflexive (mo ⨾ mo ⨾ rf⁻¹).
Proof.  split; basic_solver 8. Qed.

Implicit Type CON : consistent.
Implicit Type WCON : wconsistent.
Implicit Type COH: irreflexive (hb ⨾ eco^?).

(******************************************************************************)
(** ** Outcomes  *)
(******************************************************************************)
Definition conflicting :=
  (⦗E⦘ ⨾ ⦗W⦘ ⨾ same_loc ⨾ ⦗E⦘ ∪ ⦗E⦘ ⨾ same_loc ⨾ ⦗W⦘ ⨾ ⦗E⦘) \ ⦗fun x => True⦘.

Definition race := conflicting \ (hb ∪ hb⁻¹).

Definition racy := ⦗Na⦘ ⨾ race ∪ race ⨾ ⦗Na⦘.

Definition outcome (O: location -> value) :=
  forall l, exists w,
    W w /\
    loc lab w = Some l /\
    val lab w = Some (O l) /\
    max_elt mo w.

(******************************************************************************)
(** ** Same Location relations  *)
(******************************************************************************)

Lemma restr_eq_rel_same_loc r : ⦗RW⦘ ⨾ restr_eq_rel (loc lab) r ⨾ ⦗RW⦘ ≡ r ∩ same_loc.
Proof.
unfold same_loc; unfolder.
unfold RC11_Events.loc.
solve_type_mismatch 42.
Qed.

Lemma loceq_useq WF : funeq (loc lab) useq.
Proof.
cdes WF; cdes WF_RMW; cdes WF_RF.
unfold useq; eauto 10 with rel.
Qed.

Lemma loceq_rs WF : funeq (loc lab) rs.
Proof.
unfold rs; eauto 10 using loceq_useq with rel.
Qed.

Lemma loceq_hb_loc WF : funeq (loc lab) hb|loc.
Proof.
  unfold funeq, same_loc; basic_solver.
Qed.

(******************************************************************************)
(** ** Actions in graph *)
(******************************************************************************)

Local Notation "'acta' r" := (doma r (fun x => In x acts)) (at level 2).
Local Notation "'actb' r" := (domb r (fun x => In x acts)) (at level 2).

Lemma act_helper r :
    r ⊆ ⦗fun a => In a acts⦘ ⨾ r ⨾ ⦗fun a => In a acts⦘ <->
    acta r /\ actb r.
Proof. apply domab_helper. Qed.

Lemma sb_acta (WF: WfSB) : acta sb.
Proof. apply act_helper, WF. Qed.
Lemma sb_actb (WF: WfSB) : actb sb.
Proof. apply act_helper, WF. Qed.
Hint Resolve sb_acta sb_actb : rel.
Lemma sbloc_acta (WF: WfSB) : acta sb|loc.
Proof. arewrite (sb|loc ⊆ sb). eauto with rel. Qed.
Lemma sbloc_actb (WF: WfSB) : actb sb|loc.
Proof. arewrite (sb|loc ⊆ sb). eauto with rel. Qed.
Lemma rmw_acta (WF_SB: WfSB) (WF_RMW: WfRMW) : acta rmw.
Proof.
  by cdes WF_RMW; rewrite RMW_IMM; arewrite (sb|imm ⊆ sb); apply sb_acta.
Qed.
Lemma rmw_actb (WF_SB: WfSB) (WF_RMW: WfRMW) : actb rmw.
Proof.
  by cdes WF_RMW; rewrite RMW_IMM; arewrite (sb|imm ⊆ sb); apply sb_actb.
Qed.
Lemma rf_acta (WF: WfRF) : acta rf.
Proof. apply act_helper, WF. Qed.
Lemma rf_actb (WF: WfRF) : actb rf.
Proof. apply act_helper, WF. Qed.
Lemma mo_acta (WF: WfMO) : acta mo.
Proof. apply act_helper, WF. Qed.
Lemma mo_actb (WF: WfMO) : actb mo.
Proof. apply act_helper, WF. Qed.
Lemma rb_acta (WF: WfRF) : acta rb.
Proof.
  unfold rb; arewrite (rf⁻¹ ⨾ mo \ ⦗E⦘ ⊆ rf⁻¹ ⨾ mo).
  eauto using rf_actb with rel.
Qed.
Lemma rb_actb (WF: WfMO) : actb rb.
Proof.
  unfold rb; arewrite (rf⁻¹ ⨾ mo \ ⦗E⦘ ⊆ rf⁻¹ ⨾ mo).
  eauto using mo_actb with rel.
Qed.
Lemma rb_act WF : rb ⊆ ⦗fun a => In a acts⦘ ⨾ rb ⨾ ⦗fun a => In a acts⦘.
Proof. eapply domab_helper; splits; [apply rb_acta|apply rb_actb]; auto. Qed.

Hint Resolve
  sbloc_acta rmw_acta rf_acta mo_acta rb_acta
  sbloc_actb rmw_actb rf_actb mo_actb rb_actb
: rel.

Lemma eco_act WF :
  eco ⊆ ⦗fun a => In a acts⦘ ⨾ eco ⨾ ⦗fun a => In a acts⦘.
Proof.
unfold eco; cdes WF; cdes WF_RF; cdes WF_MO.
rewrite RF_ACT at 1 2 3; rewrite MO_ACT at 1; rewrite rb_act at 1; try done.
apply inclusion_union_l; solve_type_mismatch 15.
Qed.
Lemma eco_acta WF : acta eco.
Proof. by apply act_helper, eco_act. Qed.
Lemma eco_actb WF : actb eco.
Proof. by apply act_helper, eco_act. Qed.
Lemma useq_acta WF : acta useq. Proof. eauto with rel. Qed.
Lemma useq_actb WF : actb useq.
Proof. unfold useq; rewrite seq_union_r; eauto 10 with rel. Qed.
Hint Resolve useq_acta useq_actb : rel.
Lemma rs_acta WF : acta rs. Proof. eauto with rel. Qed.
Lemma rs_actb WF : actb rs.
Proof. unfold rs; rewrite <- !seqA; eauto 10 with rel. Qed.
Hint Resolve rs_acta rs_actb : rel.
Lemma rel_acta WF : acta release.
Proof. unfold release; relsf; eauto 10 with rel. Qed.
Lemma rel_actb WF : actb release. Proof. eauto with rel. Qed.
Hint Resolve rel_acta rel_actb : rel.
Lemma sw_acta WF : acta sw. Proof. eauto with rel. Qed.
Lemma sw_actb WF : actb sw.
Proof. unfold sw; relsf; rewrite inclusion_seq_eqv_r; auto 12 with rel. Qed.
Hint Resolve sw_acta sw_actb : rel.
Lemma hb_acta WF : acta hb. Proof. eauto 10 with rel. Qed.
Lemma hb_actb WF : actb hb. Proof. eauto 10 with rel. Qed.
Hint Resolve hb_acta hb_actb : rel.

(******************************************************************************)
(** ** Domains and Codomains of relations  *)
(******************************************************************************)
Lemma sb_domb (WF: WfSB) : domb sb (fun x => ~ is_init x).
Proof.
  cdes WF.
  rewrite SB_TID.
  apply domb_helper.
  unionL.
  - rewrite seq_union_l; unionR left.
    unfolder; ins; desf; splits; auto.
    unfold same_thread, tid, is_init in *; desf.
  - rewrite seq_union_l; unionR right.
    unfolder; ins; desf; splits; auto.
    red in H; desf.
Qed.
Lemma rmw_doma (WF: WfRMW) : doma rmw R.
Proof.
eapply doma_helper; cdes WF; rewrite RMW_DOM at 1.
solve_type_mismatch.
Qed.
Lemma rmw_domb (WF: WfRMW) : domb rmw W.
Proof.
eapply domb_helper; cdes WF; rewrite RMW_DOM at 1.
solve_type_mismatch.
Qed.
Lemma rf_doma (WF: WfRF) : doma rf W.
Proof.
eapply doma_helper; cdes WF; rewrite RF_DOM at 1.
solve_type_mismatch.
Qed.
Lemma rf_domb (WF: WfRF) : domb rf R.
Proof.
eapply domb_helper; cdes WF; rewrite RF_DOM at 1.
solve_type_mismatch.
Qed.
Lemma mo_doma (WF: WfMO) : doma mo W.
Proof.
eapply doma_helper; cdes WF; rewrite MO_DOM at 1.
solve_type_mismatch.
Qed.
Lemma mo_domb (WF: WfMO) : domb mo W.
Proof.
eapply domb_helper; cdes WF; rewrite MO_DOM at 1.
solve_type_mismatch.
Qed.
Lemma rb_doma WF : doma rb R.
Proof.
  unfold rb; arewrite (rf⁻¹ ⨾ mo \ ⦗E⦘ ⊆ rf⁻¹ ⨾ mo).
  eauto using rf_domb with rel.
Qed.
Lemma rb_domb WF : domb rb W.
Proof.
  unfold rb; arewrite (rf⁻¹ ⨾ mo \ ⦗E⦘ ⊆ rf⁻¹ ⨾ mo).
  eauto using mo_domb with rel.
Qed.

Lemma sb_dom (WF: WfSB) : sb ⊆ ⦗fun _ => True⦘ ⨾ sb ⨾ ⦗fun x => ~ is_init x⦘.
Proof. rewrite domb_fold; [rels | eapply sb_domb; eauto | ins; eauto]. Qed.
Lemma rmw_dom (WF: WfRMW) : rmw ⊆ ⦗R⦘ ⨾ rmw ⨾ ⦗W⦘.
Proof. apply WF. Qed.
Lemma rf_dom (WF: WfRF) : rf ⊆ ⦗W⦘ ⨾ rf ⨾ ⦗R⦘.
Proof. apply WF. Qed.
Lemma mo_dom (WF: WfMO) : mo ⊆ ⦗W⦘ ⨾ mo ⨾ ⦗W⦘.
Proof. apply WF. Qed.
Lemma rb_dom WF : rb ⊆ ⦗R⦘ ⨾ rb ⨾ ⦗W⦘.
Proof. apply domab_helper; split; [apply rb_doma | apply rb_domb]; done. Qed.

Lemma eco_doma WF : doma eco RW.
Proof.
unfold eco; rewrite rf_dom, mo_dom, rb_dom; auto.
unfold doma; solve_type_mismatch.
Qed.

Lemma eco_domb WF : domb eco RW.
Proof.
unfold eco; rewrite rf_dom, mo_dom, rb_dom; auto.
unfold domb; solve_type_mismatch.
Qed.

Lemma eco_dom WF : eco ⊆ ⦗RW⦘ ⨾ eco ⨾ ⦗RW⦘.
Proof. apply domab_helper; split; [apply eco_doma | apply eco_domb]; done. Qed.

Lemma useq_doma WF : doma useq W.
Proof. unfold useq; eauto using rf_doma with rel. Qed.

Lemma RMW_in_W : RMW ⊆₁ W.
Proof. solve_type_mismatch. Qed.

Lemma useq_domb WF : domb useq W.
Proof.
  unfold useq; rewrite seq_union_r, RMW_in_W; eauto 12 using rmw_domb with rel.
Qed.
Lemma useq_dom WF : useq ⊆ ⦗W⦘ ⨾ useq ⨾ ⦗W⦘.
Proof. apply domab_helper; split; [apply useq_doma | apply useq_domb]; try done. Qed.
Lemma rs_doma WF : doma rs W.
Proof. unfold rs; eauto with rel. Qed.
Lemma rs_domb WF : domb rs W.
Proof. unfold rs; rewrite useq_dom; [solve_type_mismatch|done]. Qed.
Lemma rel_doma WF : doma release (FW∩₁Rel).
Proof. unfold release; solve_type_mismatch. Qed.
Lemma rel_domb WF : domb release W.
Proof. unfold release; eauto using rs_domb with rel. Qed.
Lemma sw_doma WF : doma sw (FW∩₁Rel).
Proof. unfold sw; eauto using rel_doma with rel. Qed.
Lemma sw_domb WF : domb sw (FR∩₁Acq).
Proof. unfold sw; rewrite rf_dom; auto; solve_type_mismatch. Qed.
Lemma rs_dom WF : rs ⊆ ⦗W⦘ ⨾ rs ⨾ ⦗W⦘.
Proof. apply domab_helper; split; [apply rs_doma | apply rs_domb]; try done. Qed.
Lemma rel_dom WF : release ⊆ ⦗FW∩₁Rel⦘⨾ release ⨾ ⦗W⦘.
Proof. apply domab_helper; split; [apply rel_doma | apply rel_domb]; try done. Qed.
Lemma sw_dom WF : sw ⊆ ⦗FW∩₁Rel⦘ ⨾ sw ⨾ ⦗FR∩₁Acq⦘.
Proof. apply domab_helper; split; [apply sw_doma | apply sw_domb]; try done. Qed.

(******************************************************************************)
(** ** Execution Types  *)
(******************************************************************************)
Definition NO_RMW_EVENTS := RMW ≡₁ ∅₁.
Implicit Type NRMW : NO_RMW_EVENTS.

Lemma NRMW_implies_type_mismatch NRMW : R ∩₁ W ⊆₁ ∅₁.
Proof.
  red in NRMW; type_unfolder; unfolder in *.
  ins; specialize (NRMW x); desf.
Qed.

Lemma NRMW_implies_original_rb WF NRMW : rb ≡ rf⁻¹ ⨾ mo.
Proof.
  unfold rb; split; [basic_solver|].
  unfolder; ins; desf.
  eexists; splits; eauto; red; ins; desf.
  apply rf_domb in H; auto; apply mo_domb in H0; auto.
  apply NRMW_implies_type_mismatch with y; auto.
  unfolder; auto.
Qed.

Lemma NRMW_implies_original_useq WF NRMW : useq ≡ (rf ⨾ rmw)⁺.
Proof.
  unfold useq; red in NRMW; rewrite NRMW, eqv_empty_is_empty; relsf.
Qed.

Lemma NRMW_implies_rf_irr NRMW (RF_DOM: rf ⊆ ⦗W⦘ ⨾ rf⨾ ⦗R⦘) : irreflexive rf.
Proof.
  rewrite RF_DOM; rotate; unfolder; ins; desf.
  by apply (NRMW_implies_type_mismatch NRMW) with z.
Qed.

Lemma NRMW_implies_atomic2 WF NRMW : Atomic2.
Proof.
  red; cdes WF; rewrite rf_dom, mo_dom; auto.
  unfolder; ins; desf.
  by apply (NRMW_implies_type_mismatch NRMW) with z3.
Qed.

(******************************************************************************)
(** ** §3.4 Comparison with C11 *)
(******************************************************************************)

Definition coherent_expanded :=
  ⟪ Chb   : irreflexive hb ⟫ /\
  ⟪ Crf   : irreflexive (rf ⨾ hb) ⟫ /\
  ⟪ Crw   : irreflexive (mo ⨾ rf ⨾ hb) ⟫ /\
  ⟪ Cww   : irreflexive (mo ⨾ hb) ⟫ /\
  ⟪ Cwr   : irreflexive (mo ⨾ hb ⨾ rf⁻¹) ⟫ /\
  ⟪ Crr   : irreflexive (mo ⨾ rf ⨾ hb ⨾ rf⁻¹) ⟫.

(* Proposition 1 *)
Lemma hb_eco_r_alt :
  hb ⨾ eco^? ≡
    hb ∪ hb ⨾ rf ∪ hb ⨾ mo ∪ hb ⨾ mo ⨾ rf ∪ hb ⨾ rb ∪ hb ⨾ rb ⨾ rf.
Proof. unfold eco, rb; basic_solver 42. Qed.

Proposition coherence_expanded_eq :
  irreflexive (hb ⨾ eco^?) <-> coherent_expanded.
Proof.
  rewrite hb_eco_r_alt; unfold coherent_expanded, rb.
  intuition; unnw; repeat (apply irreflexive_union in H; desf); try by rotate.
  - rotate 2.
    red; unfolder; ins; desf.
    apply H1 with x.
    unfolder; ins; desf.
    exists z; splits; auto.
    exists z0; splits; auto.
    red; ins; desf.
    basic_solver.
  - rotate 2.
    red; unfolder; ins; desf.
    apply H0 with x.
    unfolder; ins; desf.
    exists z; splits; auto.
    exists z1; splits; auto.
    exists z0; splits; auto.
    red; ins; desf.
    apply H4 with x.
    basic_solver.
  - unionL; try by (idtac + rotate + rotate 2).
    + apply irreflexive_inclusion with (r' := hb ⨾ rf⁻¹ ⨾ mo).
        basic_solver 42.
      by rotate.
    + apply irreflexive_inclusion with (r' := hb ⨾ rf⁻¹ ⨾ mo ⨾ rf).
        basic_solver 42.
      by rotate 2.
Qed.

(* Proposition 2 *)
Proposition sc_eq :
  acyclic psc <->
  exists S, strict_total_order Sc S /\ irreflexive (S ⨾ psc).
Admitted.

(* Proposition 3 *)
Definition sc_distinct_loc :=
  forall a b,
  ~ is_init a ->
  ~ is_init b ->
  Sc a ->
  loc lab a = loc lab b ->
  Sc b.

Proposition non_sc_loc :
  sc_distinct_loc -> ⦗Sc⦘ ⨾ hb ⨾ ⦗Sc⦘ ⊆ psc⁺.
Admitted.

(******************************************************************************)
(** ** Basic properties *)
(******************************************************************************)

Lemma rmw_in_sb_loc WF: rmw ⊆ sb |loc.
Proof.
  cdes WF; cdes WF_RMW.
  red in RMW_LOC.
  arewrite (rmw ⊆ rmw|loc).
  { unfolder; ins; splits; auto.
    red; splits; auto.
    assert (R x) by (apply RMW_DOM in H; unfolder in H; desf).
    unfold loc; red in H0.
    unfold loc; desf.
  }
  arewrite (rmw ⊆ sb).
    by rewrite RMW_IMM; unfold immediate; basic_solver.
  done.
Qed.

Lemma sb_neq_loc_in_sb_minus_rmw WF:  sb_neq_loc ⊆ sb \ rmw.
Proof.
  unfold sb_neq_loc.
  arewrite (rmw ⊆ sb|loc); try done.
  by apply rmw_in_sb_loc.
Qed.

Lemma rf_seq_mo WF NRMW: rf ⨾ mo ⊆ ∅₂.
Proof.
  rewrite rf_dom, mo_dom; auto.
  assert (T := (NRMW_implies_type_mismatch NRMW)).
  unfolder in *; ins; desf.
  specialize (T z1).
  solve_type_mismatch.
Qed.

Lemma rel_seq_rf WF: release ⨾ rf ⨾ ⦗R∩₁Acq⦘⊆ sw.
Proof. unfold sw; relsf. Qed.

Lemma rf_seq_rf WF NRMW : rf ⨾ rf ⊆ ∅₂.
Proof.
  rewrite rf_dom, rf_dom; auto.
  assert (T := (NRMW_implies_type_mismatch NRMW)).
  unfolder in *; ins; desf.
  specialize (T z4).
  solve_type_mismatch.
Qed.

Lemma irr_rf WF: irreflexive rf.
Proof. by cdes WF; cdes WF_RF. Qed.

Lemma rmw_in_sb WF: rmw ⊆ sb.
Proof.
  by cdes WF; cdes WF_RMW; rewrite RMW_IMM; unfold immediate; basic_solver.
Qed.

Lemma useq_in_sb_rf WF: useq ⊆ (sb ∪ rf)⁺.
Proof.
  unfold useq; rewrite rmw_in_sb; try done.
  clear_equivs ⦗RMW⦘; relsf.
  eauto using inclusion_t_t2, inclusion_step2_ct with rel.
Qed.

Lemma rs_in_sb_rf WF: rs ⊆ (sb ∪ rf)＊.
Proof.
  unfold rs.
  rewrite useq_in_sb_rf; try done; relsf; auto 8 with rel rel_full.
Qed.

Lemma rel_in_sb_rf WF: release ⊆ (sb ∪ rf)＊.
Proof.
  unfold release; rewrite rs_in_sb_rf; try done; relsf; auto 8 with rel rel_full.
Qed.

Lemma sw_in_sb_rf WF: sw ⊆ (sb ∪ rf)⁺.
Proof.
  unfold sw; rewrite rel_in_sb_rf; try done; relsf; auto 8 with rel rel_full.
Qed.

Lemma hb_in_sb_rf WF: hb ⊆ (sb ∪ rf)⁺.
Proof.
  unfold hb; rewrite sw_in_sb_rf; try done; relsf; auto 8 with rel rel_full.
Qed.

Lemma rf_seq_transp_rf (WF: WfRF): rf ⨾ rf⁻¹ ⊆ ⦗fun _ => True⦘.
Proof. by apply functional_alt, WF.  Qed.

Lemma rf_seq_rb WF: rf ⨾ rb ⊆ mo.
Proof.
  unfold rb; arewrite (rf⁻¹ ⨾ mo \ ⦗E⦘ ⊆ rf⁻¹ ⨾ mo).
  sin_rewrite rf_seq_transp_rf. relsf. eapply WF.
Qed.

Lemma mo_seq_mo WF: mo ⨾ mo ⊆ mo.
Proof. apply rewrite_trans, WF. Qed.

Lemma rb_seq_mo WF NRMW : rb ⨾ mo ⊆ rb.
Proof.
  unfold rb.
  rewrite NRMW_implies_original_rb; auto.
  by rewrite seqA, mo_seq_mo.
Qed.

Lemma mo_seq_rb WF NRMW : mo ⨾ rb ⊆ ∅₂.
Proof.
  unfolder; ins; desf.
  apply mo_domb in H; auto.
  eapply rb_doma in H0; auto.
  apply NRMW_implies_type_mismatch with z; solve_type_mismatch.
Qed.

Lemma rb_seq_rb WF NRMW: rb ⨾ rb ⊆ ∅₂.
Proof.
  unfold seq; red; ins; desf.
  apply rb_domb in H; eapply rb_doma in H0; auto.
  apply NRMW_implies_type_mismatch with z; solve_type_mismatch.
Qed.

Lemma eco_alt WF: eco ≡ (mo ∪ rb) ∪ (mo ∪ rb)^? ⨾ rf.
Proof. unfold eco; rewrite !crE; relsf; split; unionL; auto with rel. Qed.

Lemma eco_alt2 WF NRMW: eco ≡ rf ∪ (rf⁻¹)^? ⨾ mo ⨾ rf^?.
Proof.
  unfold eco; rewrite NRMW_implies_original_rb; auto.
  rewrite !crE; relsf; rewrite !seqA; split; unionL; auto with rel.
Qed.

Lemma eco_trans WF NRMW: transitive eco.
Proof.
  apply transitiveI.
  rewrite (eco_alt WF) at 1. unfold eco.
  rewrite !seq_union_l, !seq_union_r, !seqA, rf_seq_rf; try done.
  sin_rewrite !(rf_seq_mo WF NRMW); sin_rewrite !(rf_seq_rb WF).
  relsf.
  rewrite (crE (mo ∪ rb)); relsf.
  sin_rewrite !(rb_seq_mo WF NRMW); sin_rewrite !(mo_seq_mo WF).
  sin_rewrite (rb_seq_rb WF NRMW); sin_rewrite (mo_seq_rb WF NRMW).
  relsf; unionL; eauto with rel.
Qed.

Lemma irr_eco WF NRMW: irreflexive eco.
Proof.
  unfold eco; rewrite crE; relsf.
  do 3 (try apply irreflexive_union; splits).
  by red; ins; eapply rf_seq_rf; unfold seq; eauto.
  eby eapply WF.
  by eapply irreflexive_seqC; red; ins; eapply rf_seq_mo; unfold seq; eauto.
  by red; ins; eapply rb_seq_rb; unfold seq; eauto.
  eby eapply irreflexive_seqC; rewrite rf_seq_rb; eapply WF.
Qed.

Lemma mo_in_eco WF: mo ⊆ eco.
Proof. unfold eco; basic_solver 6. Qed.
Lemma rf_in_eco WF: rf ⊆ eco.
Proof. unfold eco; basic_solver 6. Qed.
Lemma rb_in_eco WF: rb ⊆ eco.
Proof. unfold eco; basic_solver 6. Qed.

Lemma eco_alt3 WF NRMW: eco ≡ (rf ∪ mo ∪ rb)⁺.
Proof.
  split; eauto 8 using rf_in_eco, mo_in_eco, rb_in_eco, eco_trans with rel.
  unfold eco; rewrite !crE; relsf.
  repeat apply inclusion_union_l; eauto 6 using inclusion_step2_ct with rel.
Qed.

Lemma useq_in_eco WF NRMW (RMW_IN_RB: rmw ⊆ rb) : useq ⊆ eco.
Proof.
  rewrite eco_alt3; try done. unfold useq; rewrite RMW_IN_RB.
  clear_equivs ⦗RMW⦘; relsf.
  eauto 10 using inclusion_step2_ct with rel.
Qed.

Lemma eco_seq_f WF : eco ⨾ ⦗F⦘ ≡ ∅₂.
Proof.
split; try done.
rewrite eco_dom; try done.
solve_type_mismatch.
Qed.

Lemma rs_in_eco WF NRMW
  (SBLOC: ⦗W⦘ ⨾ sb |loc ⨾ ⦗W⦘ ⊆ mo)
  (RMW_IN_RB: rmw ⊆ rb) : rs ⊆ eco^?.
Proof.
  unfold rs; rewrite useq_in_eco; try done.
  arewrite (⦗W∩₁Rlx⦘ ⊆ ⦗W⦘ ⨾ ⦗W∩₁Rlx⦘) by solve_type_mismatch.
  rewrite crE. relsf. sin_rewrite SBLOC.
  rewrite !inclusion_seq_eqv_l, mo_in_eco, crE; relsf.
  rewrite (rewrite_trans (eco_trans WF NRMW)); relsf.
Qed.

Lemma sw_in_eco WF NRMW
  (SBLOC: ⦗W⦘ ⨾ sb |loc ⨾ ⦗W⦘ ⊆ mo)
  (RMW_IN_SB: rmw ⊆ rb) : ⦗W⦘ ⨾ sw ⨾ ⦗R⦘ ⊆ eco.
Proof.
  unfold sw, release; rewrite rs_in_eco, rf_in_eco; try edone.
  unfold seq, union, clos_refl, eqv_rel; red; ins; desf.
  all: try by solve_type_mismatch.
  eby eapply eco_trans; eauto.
Qed.

Lemma sw_in_eco_sb WF NRMW
  (SBLOC: ⦗W⦘ ⨾ sb |loc ⨾ ⦗W⦘ ⊆ mo)
  (RMW_IN_RB: rmw ⊆ rb) : ⦗W⦘ ⨾ sw ⨾ ⦗F⦘ ⊆ eco ⨾ sb.
Proof.
unfold sw, release; rewrite rs_in_eco, rf_in_eco; try edone.
relsf; unionL; try by solve_type_mismatch 2.
rewrite !seqA; arewrite(eco ^? ⨾ eco ⊆ eco).
  rewrite crE; relsf; apply inclusion_union_l, rewrite_trans; try done.
  by apply eco_trans.
repeat apply inclusion_union_l; rewrite ?seqA; try done.
solve_type_mismatch 3.
Qed.

Lemma sw_in_sb_eco_sb WF NRMW
  (SBLOC: ⦗W⦘ ⨾ sb |loc ⨾ ⦗W⦘ ⊆ mo)
  (RMW_IN_RB: rmw ⊆ rb) :
    sw ⊆ (⦗F⦘ ⨾ sb)^? ⨾ eco ⨾ (sb ⨾ ⦗F⦘)^?.
Proof.
unfold sw, release; rewrite rs_in_eco, rf_in_eco; try edone.
relsf; rewrite !seqA.
assert (ECO: eco ^? ⨾ eco ⊆ eco).
  rewrite crE; relsf; apply inclusion_union_l, rewrite_trans; try done.
  by apply eco_trans.
sin_rewrite !ECO.
arewrite (⦗F∩₁Acq⦘ ⊆ ⦗F⦘) by solve_type_mismatch 10.
unionL; solve_type_mismatch 15.
Qed.

Lemma eco_sw_helper WF NRMW
  (SBLOC: ⦗W⦘ ⨾ sb |loc ⨾ ⦗W⦘ ⊆ mo)
  (RMW_IN_RB: rmw ⊆ rb)
  x y z (ECO: eco x y) (SW: sw y z) (NECO: ~ eco y z) :
  exists k, eco x k /\ sb k z /\ ~ rmw k z.
Proof.
assert (Wy: W y).
  apply eco_domb in ECO; try edone.
  apply sw_doma in SW; try edone.
  by solve_type_mismatch.
assert (SW1 := SW).
apply sw_domb in SW1; try edone.
repeat autounfold with type_unfolderDb in SW1.
destruct SW1, H; cycle 1.
- exfalso; apply NECO.
  apply sw_in_eco; try done.
  unfolder; ins; desf.
- exploit sw_in_eco_sb; eauto.
  unfolder; splits; eauto.
  unfold eqv_rel, seq; ins; desf.
  exists z0; splits; eauto using (eco_trans WF NRMW).
  intro A; eapply rmw_domb in A; auto; solve_type_mismatch.
Qed.

Lemma eco_sw WF NRMW
  (SBLOC: ⦗W⦘ ⨾ sb |loc ⨾ ⦗W⦘ ⊆ mo)
  (RMW_IN_RB: rmw ⊆ rb) :
eco ⨾ (sw \ eco) ⊆ eco ⨾ (sb \ rmw).
Proof.
unfold seq, minus_rel, inclusion; ins; desc.
eapply eco_sw_helper; eauto.
Qed.

Lemma eco_seq_hb WF NRMW
  (SBLOC: ⦗W⦘ ⨾ sb |loc ⨾ ⦗W⦘ ⊆ mo)
  (RMW_IN_RB: rmw ⊆ rb) :
  eco ⨾ hb ⊆ eco ∪ eco ⨾ (sb \ rmw) ⨾ hb^?.
Proof.
  unfold hb; rewrite seq_ct_absorb_lt, cr_of_ct; eauto using eco_trans.
  rewrite minus_union_l.
  relsf; repeat apply inclusion_union_l; eauto with rel.
  rewrite RMW_IN_RB, rb_in_eco; auto with rel.
  sin_rewrite eco_sw; auto.
  rewrite !seqA; auto with rel.
Qed.

Lemma eco_almost_total WF NRMW x y
  (ACTx: In x acts) (ACTy: In y acts)
  (RWx: RW x) (RWy: RW y) (LOC: loc lab x = loc lab y)
  (NEQ: x <> y):
  eco x y \/ eco y x \/ exists z, rf z x /\ rf z y.
Proof.
unfold RC11_Events.RW, set_union in *.
assert (exists l, loc lab x = Some l).
by eapply rw_has_location; solve_type_mismatch.
cdes WF; cdes WF_RF; cdes WF_MO.
desf.
- apply RF_TOT in RWx; try done.
  apply RF_TOT in RWy; try done.
  desf.
  assert (RF_LOC' := RF_LOC).
  specialize (RF_LOC _ _ RWx); specialize (RF_LOC' _ _ RWy); desc.
  destruct (classic (a=a0)); try subst; eauto.
  assert (mo a a0 \/ mo a0 a); cycle 1.
  { unfold eco. unfold rb.
    desf; [right; left | left];
    hahn_rewrite (NRMW_implies_original_rb WF NRMW); basic_solver 42. }
  eapply MO_TOT; splits; eauto; unfold set_inter; splits.
  eapply rf_acta; eauto.
  by eapply rf_doma; eauto.
  eby rewrite RF_LOC', <- LOC.
  by eapply rf_acta; eauto.
  by eapply rf_doma; eauto.
  by rewrite RF_LOC.
- apply RF_TOT in RWy; try done.
  desf.
  specialize (RF_LOC _ _ RWy); desc.
  destruct (classic (a=x)); [subst; unfold eco; basic_solver 5|].
  assert (mo a x \/ mo x a); cycle 1.
  { unfold eco. unfold rb.
    desf; [right; left | left];
    hahn_rewrite (NRMW_implies_original_rb WF NRMW); basic_solver 42. }
  eapply MO_TOT; splits; eauto; unfold set_inter; splits; eauto.
  by eapply rf_acta; eauto.
  by eapply rf_doma; eauto.
  eby rewrite RF_LOC, <- LOC.
- apply RF_TOT in RWx; try done.
  desf.
  specialize (RF_LOC _ _ RWx); desc.
  destruct (classic (a=y)); [subst; unfold eco; basic_solver 5|].
  assert (mo a y \/ mo y a); cycle 1.
  { unfold eco. unfold rb.
    desf; [left | right; left];
    hahn_rewrite (NRMW_implies_original_rb WF NRMW); basic_solver 42. }
  eapply MO_TOT; splits; eauto; unfold set_inter; splits; auto.
  by eapply rf_acta; eauto.
  by eapply rf_doma; eauto.
  eby rewrite RF_LOC.
  eby rewrite <- LOC.
- assert (mo x y \/ mo y x); [|  unfold eco; basic_solver 10].
  eapply MO_TOT; splits; eauto; unfold set_inter; splits; eauto.
  eby rewrite <- LOC.
Qed.

Lemma irr_hb COH: irreflexive hb.
Proof. red; ins; eapply COH; econstructor; eauto. Qed.

Lemma cww_mo
  WF COH
  a b (A: hb a b)
  (Wa : W a) (Wb : W b)
  (LOC: loc lab a = loc lab b) :
  mo a b.
Proof.
  assert (exists l, loc lab a = Some l).
  by eapply rw_has_location; solve_type_mismatch.
  desc.
  ins; eapply tot_ex.
  - eapply WF.
  - unfolder; splits; try edone. eapply hb_actb; eauto. eby rewrite <- LOC.
  - unfolder; splits; try edone. eapply hb_acta; eauto.
  - intro; eapply COH.
    unfold eco, clos_refl, seq, union, eqv_rel; eauto 10.
  - intro; subst; eapply irr_hb; eauto.
Qed.

Lemma sb_loc_in_mo WF COH:
  ⦗W⦘ ⨾ sb |loc ⨾ ⦗W⦘ ⊆ mo.
Proof.
  red; ins.
  unfold same_loc in H; unfolder in H; desf.
  apply cww_mo; auto using sb_in_hb.
Qed.

Lemma BasicRMW WF COH:
  forall a b (MO: a=b \/ mo a b) c (RF: rf b c) (RMW_CA: rmw c a), False.
Proof.
ins; apply rmw_in_sb, sb_in_hb in RMW_CA; eauto.
eapply COH; desf; unfold eco, clos_refl, seq, union, eqv_rel; eauto 10.
Qed.

Lemma rmw_in_rb WF COH: rmw ⊆ rb.
Proof.
  intros a b A; cdes WF; cdes WF_RMW; cdes WF_RF; cdes WF_MO.
  unfold seq in *; desf.
  assert (Ra: R a).
    by eapply rmw_doma; eauto.
  assert (ACT: In a acts).
    by eapply rmw_acta; eauto.
  specialize (RMW_LOC _ _ A); desf.
  destruct (RF_TOT a ACT Ra) as [c RF].
  unfold rb; unfolder; splits.
  - exists c; split; ins.
    specialize (RF_LOC _ _ RF); desf.
    assert (exists l, loc lab a = Some l).
    by eapply rw_has_location; solve_type_mismatch.
    desc.
    desf; eapply tot_ex; eauto using BasicRMW.
    unfolder; splits;
      [eapply rmw_actb; eauto| eapply rmw_domb; eauto| eby rewrite <- RMW_LOC].
    unfolder; splits;
      [eapply rf_acta; eauto| eapply rf_doma; eauto| eby rewrite RF_LOC].
  - apply or_not_and; left; intro; desf.
    apply RMW_IMM in A; destruct A.
    by cdes WF_SB; apply SB_IRR in H.
Qed.

Lemma rf_rmw_mo WF COH:
    rf ⨾ rmw ⊆ mo.
Proof.
  rewrite rmw_in_rb; eauto using rf_seq_rb.
Qed.

Lemma useq_mo WF NRMW COH:
   useq ⊆ mo.
Proof.
  rewrite (NRMW_implies_original_useq WF NRMW).
  eapply inclusion_t_ind, WF.
  eauto 10 using rf_rmw_mo.
Qed.

Lemma rs_mo WF NRMW COH:
   rs ⊆ mo^?.
Proof.
  unfold rs.
  arewrite (⦗W∩₁Rlx⦘ ⊆ ⦗W⦘) by solve_type_mismatch.
  rewrite useq_mo, crE; relsf.
  sin_rewrite sb_loc_in_mo; auto.
  rewrite !inclusion_seq_eqv_l, crE; relsf.
  rewrite mo_seq_mo; eauto with rel.
Qed.

Lemma rel_mo WF NRMW COH:
   ⦗W⦘ ⨾ release ⊆ mo^?.
Proof.
  unfold release; rewrite rs_mo; relsf.
  apply inclusion_union_l; [by rewrite !inclusion_seq_eqv_l|].
  unfold seq, eqv_rel; red; ins; desf.
  exfalso; solve_type_mismatch.
Qed.

Lemma rel_hb_mo WF NRMW COH:
    release ⊆ (hb^? ⨾ mo^?).
Proof.
  unfold release; rewrite rs_mo, !inclusion_seq_eqv_l, sb_in_hb; auto.
  basic_solver 10.
Qed.

Lemma transp_rf_rf_eco WF NRMW COH:
    rf⁻¹ ⨾ rf ⨾ eco ⊆ eco.
Proof.
unfold eco; relsf.
rewrite rf_seq_rf; auto.
sin_rewrite rf_seq_mo; auto.
rewrite NRMW_implies_original_rb; auto.
rewrite !seqA.
sin_rewrite rf_seq_transp_rf; auto.
relsf.
Qed.

Lemma eco_transp_rf_rf WF NRMW COH:
    eco ⨾ rf⁻¹ ⨾ rf ⊆ eco.
Proof.
  unfold eco; relsf.
  rewrite NRMW_implies_original_rb; auto.
  rewrite !seqA, !crE; relsf.
  arewrite_false (mo ⨾ rf⁻¹).
  { rewrite rf_dom; auto.
    rewrite mo_dom; auto.
    assert (T := NRMW_implies_type_mismatch NRMW).
    unfolder in *; ins; desf.
    specialize (T z0).
    solve_type_mismatch.
  }
  sin_rewrite !rf_seq_transp_rf; auto.
  basic_solver 8.
Qed.

Lemma hb_loc_in_eco WF NRMW COH:
  ⦗RW⦘ ⨾ hb|loc ⨾ ⦗RW⦘ ⊆ eco ∪ (sb \ rmw) ∪ (sb \ rmw) ⨾ hb ⨾ (sb \ rmw).
Proof.
  unfold restr_eq_rel, same_loc.
  unfolder; ins; desf.
  rename H0 into HB, H2 into LOC, H3 into SAME_LOC, H into RWx, H1 into RWy.
  forward (apply eco_almost_total with (x:=x) (y:=y)); eauto.
    eapply hb_acta; eauto.
    eapply hb_actb; eauto.
    red in LOC; desf.
    intro; subst; eapply irr_hb; edone.
  ins; desf; [basic_solver | |].
  by exfalso; eapply COH; basic_solver.
  apply ct_begin in HB.
  unfold seq in HB; desc.
  destruct HB as [HB|X]; cycle 1.
  exfalso; eapply sw_doma in X; eapply rf_domb in H; eauto.
  { assert (T := NRMW_implies_type_mismatch NRMW).
    apply T with x; solve_type_mismatch. }
  apply rtE in HB0.
  unfold eqv_rel, union in HB0; desf.
  - destruct (classic (rmw x y)).
    by left; left; apply rb_in_eco, rmw_in_rb; auto.
    by left; right; splits; eauto.
  - apply ct_end in HB0.
    unfold seq in HB0; desc.
    destruct HB1 as [HB1|X]; cycle 1.
    * exfalso.
      apply sw_in_sb_eco_sb in X; auto using sb_loc_in_mo, rmw_in_rb.
      unfold seq, eqv_rel, clos_refl in X; desf.
      + apply COH with (x:=x).
        exists z2; splits.
        apply ct_begin; basic_solver.
        right; apply eco_transp_rf_rf; auto; basic_solver 8.
      + apply COH with (x:=x).
        exists z2; splits.
        apply ct_begin; eexists; splits; try apply rt_end; basic_solver 6.
        by right; apply eco_transp_rf_rf; auto; basic_solver 8.
      + solve_type_mismatch.
      + solve_type_mismatch.
    * assert (~rmw x z0).
      { intro RMW_x_z0.
        apply COH with (x:=z0).
        exists y; splits.
        apply ct_end; basic_solver 6.
        apply rmw_in_rb, rb_in_eco in RMW_x_z0; auto.
        right; apply transp_rf_rf_eco; auto; basic_solver 8.
      }
      assert (~rmw z1 y).
      { intro RMW_z1_y.
        apply COH with (x:=x).
        exists z1; splits.
        apply ct_begin; basic_solver 6.
        apply rmw_in_rb, rb_in_eco in RMW_z1_y; auto.
        right; apply eco_transp_rf_rf; auto; basic_solver 8.
      }
      apply rtE in HB0; unfold union, eqv_rel in HB0; desf.
      + left; right; splits.
        cdes COH; cdes WF; cdes WF_SB; eapply SB_T; eauto.
        intro RMW_x_y.
        apply rf_domb in H0; auto.
        apply rmw_domb in RMW_x_y; auto.
        apply (NRMW_implies_type_mismatch NRMW) with y.
        solve_type_mismatch.
      + basic_solver 8.
Qed.

(******************************************************************************)
(** ** Propositions in Appendix C *)
(******************************************************************************)

Section C_RC11_Properties.
Hypothesis WF: Wf.

(* Proposition C.1 *)
Proposition C1_spo_eco NRMW : strict_partial_order eco.
Proof.
  unfold strict_partial_order; splits.
  - (* irreflexive *) by apply irr_eco.
  - (* transitive *) by apply eco_trans.
Qed.

(* Proposition C.2 *)
Hypothesis SB_IN_MO : ⦗W⦘ ⨾ sb|loc ⨾ ⦗W⦘ ⊆ mo.
Hypothesis RMW_IN_RB : rmw ⊆ rb.

Proposition C2_1_rs_in_eco NRMW : rs ⊆ eco^?.
Proof. by apply rs_in_eco. Qed.

Proposition C2_2_sw_in_eco NRMW : ⦗W⦘ ⨾ sw ⨾ ⦗R⦘ ⊆ eco.
Proof. by apply sw_in_eco. Qed.

Proposition C2_3_sw_in_eco_sb NRMW : ⦗W⦘ ⨾ sw ⨾ ⦗F⦘ ⊆ eco ⨾ sb.
Proof. by apply sw_in_eco_sb. Qed.

Proposition C2_4_eco_seq_hb NRMW : eco ⨾ hb ⊆ eco ∪ eco ⨾ (sb \ rmw) ⨾ hb^?.
Proof. by apply eco_seq_hb. Qed.

End C_RC11_Properties.

(* Proposition C.3 *)
Proposition C3
  dom_rf (DOM_RF: doma rf dom_rf)
  a (A: a ≡₁ W∩₁Rel \₁ dom_rf)
  : True.
Proof. Admitted.

End Consistency.

Hint Resolve con_wf.
Hint Unfold  E : unfolderDb.

(* Lemma fence_hb_r WF NRMW
  (SBLOC: ⦗W⦘ ⨾ sb |loc ⨾ ⦗W⦘ ⊆ mo)
  (RMW_IN_RB: rmw ⊆ rb) :
  ⦗Sc⦘⨾ hb ⨾ ⦗F~Sc⦘ ⊆
    ⦗Sc⦘⨾ sb ⨾ ⦗F~Sc⦘
  ∪ ⦗Sc⦘⨾ sb ⨾ hb ⨾ ⦗F~Sc⦘
  ∪ ⦗Sc⦘⨾ eco ⨾ hb ⨾ ⦗F~Sc⦘
  ∪ ⦗F~Sc⦘ ⨾ hb ⨾ eco ⨾ hb ⨾ ⦗F~Sc⦘.
Proof.
  unfold hb.
  arewrite ((sb ∪ sw)⁺ ⊆ (sb ∪ sw) ⨾ (sb ∪ sw)＊) at 1.
    by rels.
  relsf; repeat apply inclusion_union_l.
   rewrite rtE at 1; relsf.
  rewrite sw_in_sb_eco_sb at 1; try done.
  arewrite (sb ⨾ ⦗F⦘ ⊆ sb).
  arewrite (sb ^? ⊆ (sb ∪ sw) ^?).
  arewrite ((sb ∪ sw) ^? ⨾ (sb ∪ sw)＊ ⊆ (sb ∪ sw)＊).
  rewrite rtE at 1; relsf.
  arewrite_false (eco ⨾ ⦗F~Sc⦘).
    rewrite eco_dom; try done.
    solve_type_mismatch.
  relsf.
  rewrite crE at 1; relsf.
  repeat apply inclusion_union_l; eauto with rel.
  rewrite !seqA.
  arewrite (⦗Sc⦘ ⨾ ⦗F⦘ ⊆ ⦗F~Sc⦘).
  solve_type_mismatch.
  arewrite (sb ⊆ (sb ∪ sw) ⁺).
  eauto with rel.
Qed.

Lemma fence_hb_l WF NRMW
  (SBLOC: ⦗W⦘ ⨾ sb |loc ⨾ ⦗W⦘ ⊆ mo)
  (RMW_IN_RB: rmw ⊆ rb) :
  ⦗F~Sc⦘ ⨾ hb ⨾ ⦗Sc⦘ ⊆
    ⦗F~Sc⦘ ⨾ sb ⨾ ⦗Sc⦘
  ∪ ⦗F~Sc⦘ ⨾ hb ⨾ sb ⨾ ⦗Sc⦘
  ∪ ⦗F~Sc⦘ ⨾ hb ⨾ eco ⨾ ⦗Sc⦘
  ∪ ⦗F~Sc⦘ ⨾ hb ⨾ eco ⨾ hb ⨾ ⦗F~Sc⦘.
Proof.
  unfold hb.
  arewrite ((sb ∪ sw)⁺ ⊆ (sb ∪ sw)＊ ⨾ (sb ∪ sw)).
  relsf; repeat apply inclusion_union_l; eauto with rel.
  by rewrite rtE at 1; relsf.
  rewrite sw_in_sb_eco_sb at 2; try done.
  rewrite !seqA.
  arewrite ((⦗F⦘ ⨾ sb) ^? ⊆ (sb ∪ sw)^?).
  arewrite ((sb ∪ sw)＊ ⨾ (sb ∪ sw) ^? ⊆ (sb ∪ sw)＊).
  rewrite rtE; relsf.
  arewrite_false (⦗F~Sc⦘ ⨾ eco).
    rewrite eco_dom; try done.
    solve_type_mismatch.
  relsf.
  rewrite crE; relsf.
  repeat apply inclusion_union_l; eauto with rel.
  rewrite !seqA.
  arewrite (⦗F⦘ ⨾ ⦗Sc⦘⊆ ⦗F~Sc⦘).
    solve_type_mismatch.
  arewrite (sb ⊆ (sb ∪ sw) ⁺) at 2.
  eauto with rel.
Qed.

Lemma fence_hb WF NRMW
  (SBLOC: ⦗W⦘ ⨾ sb |loc ⨾ ⦗W⦘ ⊆ mo)
  (RMW_RB: rmw ⊆ rb) :
  ⦗F~Sc⦘ ⨾ hb ⨾ ⦗F~Sc⦘ ⊆
    ⦗F~Sc⦘ ⨾ sb ⨾ ⦗F~Sc⦘
  ∪ ⦗F~Sc⦘ ⨾ hb ⨾ sb ⨾ hb ⨾ ⦗F~Sc⦘
  ∪ ⦗F~Sc⦘ ⨾ hb ⨾ eco ⨾ hb ⨾ ⦗F~Sc⦘.
Proof.
  assert (M: sb ⨾ sb^? ⊆ sb).
    rewrite crE; relsf.
    assert (T: transitive sb) by (eapply WF).
    by sin_rewrite (rewrite_trans T); eauto with rel.
  unfold hb.
  rewrite ct_begin at 1; rewrite !seqA; relsf.
  rewrite rtE at 1; relsf.
  repeat apply inclusion_union_l; eauto with rel.
  {
    rewrite ct_begin at 1; rewrite !seqA; relsf.
    rewrite rtE at 1; relsf.
    repeat apply inclusion_union_l; eauto with rel.
     assert (T: transitive sb) by (eapply WF).
     by sin_rewrite (rewrite_trans T); eauto with rel.
    by rewrite sb_in_hb at 1; eauto with rel.

    rewrite sw_in_sb_eco_sb at 1; try done.
    rewrite (inclusion_seq_eqv_l (dom := F)).
    rewrite (inclusion_seq_eqv_r (dom := F)).
    rewrite !seqA.
    sin_rewrite M.
    rewrite crE; relsf.
    rewrite rtE at 1; relsf.
    arewrite_false (eco ⨾ ⦗F~Sc⦘).
      rewrite eco_dom; try done.
      solve_type_mismatch.
    repeat apply inclusion_union_l; eauto 6 with rel.
    by rewrite ct_begin at 4; relsf; rewrite !seqA; eauto 8 with rel.
    by rewrite ct_begin at 4; relsf; rewrite !seqA; eauto 8 with rel.
  }
  rewrite sw_in_sb_eco_sb at 1; try done.
  rewrite (inclusion_seq_eqv_l (dom := F)).
  rewrite (inclusion_seq_eqv_r (dom := F)).
  rewrite !seqA; rewrite crE at 1; relsf.
  arewrite_false (⦗F~Sc⦘ ⨾ eco).
    rewrite eco_dom; try done.
    solve_type_mismatch.
  relsf.
  rewrite crE; relsf.
  rewrite rtE at 1; relsf.
  arewrite_false (eco ⨾ ⦗F~Sc⦘).
    rewrite eco_dom; try done.
    solve_type_mismatch.
  relsf.
  repeat apply inclusion_union_l; eauto 6 with rel.
  by rewrite ct_begin at 4; relsf; rewrite !seqA; eauto 8 with rel.
Qed. *)

(* Lemma cwr_mo
    WF
    COH
    a b (A: (hb ⨾ rf⁻¹) a b)
    (Wa : W a) (Wb : W b)
    (LOC: loc lab a = loc lab b) (NEQ: a <> b):
    mo a b.
Proof.
  unfold seq,transp in A; desc.
  assert (exists l, loc lab a = Some l).
    by eapply rw_has_location; solve_type_mismatch.
  desc.
  ins; eapply tot_ex.
  - eapply WF.
  - unfolder; splits; try edone. eapply rf_acta; eauto. eby rewrite <- LOC.
  - unfolder; splits; try edone. eapply hb_acta; eauto.
  - intro; eapply COH.
    eexists; splits; eauto.
    unfold eco, rb; unfolder; repeat right.
    eexists; splits; eauto.
    apply or_not_and; left; red; ins; desf.
    apply COH with a; basic_solver.
  - intro; subst; auto.
Qed. *)

(* Lemma crr_mo
    WF
    COH
    a b (A: (rf ⨾ hb ⨾ rf⁻¹) a b)
    (Wa : W a) (Wb : W b)
    (LOC: loc lab a = loc lab b) (NEQ: a <> b):
    mo a b.
Proof.
  unfolder in A; desc.
  assert (exists l, loc lab a = Some l).
    by eapply rw_has_location; solve_type_mismatch.
  desc.
  ins; eapply tot_ex.
  - eapply WF.
  - unfolder; splits; try edone. eapply rf_acta; eauto. eby rewrite <- LOC.
  - unfolder; splits; try edone. eapply rf_acta; eauto.
  - rewrite hb_eco_r_alt in COH. unfold rb in COH.
    repeat (apply irreflexive_union in COH; desf).
    intro; eapply COH0.
    eexists; splits; eauto.
    exists a; splits; auto.
    unfolder; splits; try basic_solver.
    apply or_not_and; left; red; ins; desf.
    apply COH4 with z; basic_solver.
  - intro; subst; auto.
Qed. *)

(* Lemma crw_mo
    WF
    COH
    a b (A: (rf ⨾ hb) a b)
    (Wa : W a) (Wb : W b)
    (LOC: loc lab a = loc lab b) :
    mo a b.
Proof.
  unfold seq in A; desc.
  assert (exists l, loc lab a = Some l).
    by eapply rw_has_location; solve_type_mismatch.
  desc.
  ins; eapply tot_ex.
  - eapply WF.
  - unfolder; splits; try edone. eapply hb_actb; eauto. eby rewrite <- LOC.
  - unfolder; splits; try edone. eapply rf_acta; eauto.
  - intro; eapply COH.
    eexists; splits; eauto.
    unfold eco, clos_refl, seq, union, eqv_rel; eauto 10.
  - intro; subst; eapply COH.
    eexists; splits; eauto.
    unfold eco, clos_refl, seq, union, eqv_rel; eauto 10.
Qed. *)


(** * Exponential functors between products and sums in exponents *)
Require Import Functor.Core FunctorCategory.Core Functor.Identity NaturalTransformation.Core Category.Sum Category.Prod Functor.Sum Functor.Prod.Core NaturalTransformation.Sum Functor.Pointwise.Core NaturalTransformation.Paths.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope functor_scope.

Local Notation fst_type := Basics.Datatypes.fst.
Local Notation snd_type := Basics.Datatypes.snd.
Local Notation pair_type := Basics.Datatypes.pair.

Section law2.
  Context `{Funext}.
  Variables D C1 C2 : PreCategory.

  (** ** [yⁿ⁺ᵐ → yⁿ × yᵐ] *)
  Definition functor
  : Functor (C1 + C2 -> D) ((C1 -> D) * (C2 -> D))
    := pointwise (inl C1 C2) 1
       * pointwise (inr C1 C2) 1.

  (** ** [yⁿ × yᵐ → yⁿ⁺ᵐ] *)
  Definition inverse
  : Functor ((C1 -> D) * (C2 -> D)) (C1 + C2 -> D).
  Proof.
    refine (Build_Functor
              ((C1 -> D) * (C2 -> D)) (C1 + C2 -> D)
              (fun FG => fst FG + snd FG)%functor
              (fun _ _ m => fst_type m + snd_type m)%natural_transformation
              _
              _);
    simpl in *;
    abstract (
        repeat (intros [?|?] || intros [? ?]);
        simpl in *;
          apply path_natural_transformation; intros [?|?];
        reflexivity
      ).
  Defined.
End law2.


(*===========================================================================
    C-style string code
  ===========================================================================*)
Require Import ssreflect ssrbool ssrnat eqtype seq fintype tuple.
Require Import procstate procstatemonad bitsrep bitsops bitsprops bitsopsprops.
Require Import SPred septac spec spectac safe basic basicprog program.
Require Import instr instrsyntax instrcodec instrrules reader pointsto cursor basic flags macros.
Require Import Coq.Strings.String cstring Ascii.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* String s contains no null characters *)
Fixpoint zeroFree s :=
  if s is String c s' then charToBYTE c != #0 /\ zeroFree s' else True.

Lemma zeroFree_append (s1 s2: string) :
  zeroFree (s1 ++ s2) -> zeroFree s1 /\ zeroFree s2.
Proof. induction s1 => //. simpl; intuition. Qed.

(* A couple of trivial lemmas concerning strings *)
Lemma length_append (s1 s2: string) : length (s1 ++ s2) = length s1 + length s2.
Proof. induction s1 => //. by rewrite /= IHs1. Qed.

Lemma append_cons s1 c s2 : (s1 ++ String c s2 = (s1 ++ String c EmptyString) ++ s2)%string.
Proof. induction s1 => //. by rewrite /= IHs1.  Qed.

(* The bytes between p and q correspond precisely to the contents of string s *)
Fixpoint memIsString (p q: DWORD) (s: string)  :=
  if s is String c s
  then p :-> charToBYTE c ** memIsString (p +# 1) q s
  else p == q /\\ empSP.

(* The memory at [p] contains a null-terminated string [s]
   (Note that [s] should not itself not contain null characters) *)
Fixpoint pointsToCString (p: DWORD) (s: string) : SPred :=
  if s is String c s
  then p :-> charToBYTE c ** pointsToCString (p+#1) s
  else p :-> (#0:BYTE).

Lemma pointsToCStringCons p c s :
  pointsToCString p (String c s) -|- p :-> charToBYTE c ** pointsToCString (p+#1) s.
Proof. split; rewrite /pointsToCString; by ssimpl. Qed.

(* If [p] points to a C-string [prefix ++ suffix] then it can be split into memory
   from [p] to [p +# length prefix] containing [prefix] and [p +# length prefix]
   pointing to [suffix] *)
Lemma pointsToCString_append prefix : forall p suffix,
  pointsToCString p (prefix ++ suffix) |--
  memIsString p (p +# length prefix) prefix ** pointsToCString (p +# length prefix) suffix.
Proof. induction prefix => p suffix.
+ simpl (_ ++ _).  rewrite /memIsString. simpl (length _). rewrite addB0/=. sbazooka.
+ rewrite /memIsString-/memIsString pointsToCStringCons -/append.
rewrite -> IHprefix. simpl (length _). ssimpl. by rewrite -addB_addn add1n.
Qed.

Lemma pointsToCString_append_op prefix : forall p q suffix,
  memIsString p q prefix ** pointsToCString q suffix |--
  pointsToCString p (prefix ++ suffix).
Proof. induction prefix => p q suffix.
+ rewrite /=. sdestructs => /eqP ->. by ssimpl.
+ rewrite /=. ssimpl. by rewrite <- (IHprefix (p+#1) q).
Qed.

(* Given a pointer to a C-style string in EDI, return its length in ECX *)
Definition strlen : program :=
  (MOV ECX, 0;;
   while (CMP BYTE [EDI + ECX + 0], #0) CC_Z false
     (INC ECX))%asm.

(* Correctness of strlen *)
Lemma strlen_correct p s :
  zeroFree s ->
  |-- basic ECX? strlen (ECX ~= #(length s))
    @ (OSZCP? ** EDI ~= p ** pointsToCString p s).
Proof.
  move => ISZF. rewrite /strlen.
  autorewrite with push_at.

  unhideReg ECX => oldecx.

  (* MOV ECX, 0 *)
  basicapply MOV_RI_rule. rewrite /stateIsAny. sbazooka.

  (* WHILE *)
  (* Loop invariant is most easily expressed by splitting the string into
     a prefix and suffix. ECX contains the length of the prefix *)
  set (I := fun b =>
    Exists prefix, Exists suffix,
    s = (prefix ++ suffix)%string /\\ (if suffix is ""%string then true else false) == b /\\
    EDI ~= p ** ECX ~= #(length prefix) **
    pointsToCString p s ** OF? ** SF? ** CF? ** PF?).
  eapply basic_basic; first apply (while_rule_ro (I:=I)). (*first 2 last. *)

  (* Condition code: CMP [EDX+ECX], 0 *)
  specintros => b1 b2.
  subst I; cbv beta.
  specintros => prefix suffix APPEND END.

  case E: suffix => [| a s'].

  (* Empty string *)
  + rewrite /ConditionIs.
  eapply basic_basic; first eapply CMP_MbxI_ZC_rule.
  rewrite /stateIsAny/ConditionIs.
  subst. rewrite -> pointsToCString_append. rewrite /pointsToCString.
  sbazooka. subst. sbazooka. rewrite <-pointsToCString_append_op.
  rewrite /pointsToCString. rewrite /stateIsAny. sbazooka.

  (* Non-empty string *)
  + subst. rewrite /ConditionIs.
  eapply basic_basic; first eapply CMP_MbxI_ZC_rule.
  rewrite /stateIsAny/ConditionIs.
  subst. rewrite -> pointsToCString_append. rewrite /pointsToCString-/pointsToCString.
  sbazooka.
  sbazooka.
    red. destruct (zeroFree_append ISZF) as [_ [ZFM _]].
    by rewrite eq_sym eqbF_neg.
    rewrite <- pointsToCString_append_op. rewrite /pointsToCString-/pointsToCString/stateIsAny. sbazooka.

  (* Body of loop: INC ECX *)
  rewrite /ConditionIs/I.
  specintros => prefix suffix APPEND END. rewrite /stateIsAny. specintros => ofl sfl cfl pfl.
  subst.
  eapply basic_basic. eapply INC_R_rule.
  rewrite /OSZCP. sbazooka.

  case E: suffix => [| a s'].

  (* Empty string *)
  + by subst.
  (* Non-empty string *)
  + subst. ssplit. ssplit. instantiate (1:= (prefix ++ String a EmptyString)%string).
    rewrite /OSZCP. sbazooka.
    by rewrite append_cons.
    rewrite length_append. simpl (length _). rewrite incB_fromNat addn1. by ssimpl.

  (**)
  subst I.
    rewrite /ConditionIs.
    rewrite /stateIsAny.
    sdestructs => o sf z c pf. sbazooka. instantiate (1:=s). by instantiate (1:=EmptyString).
    simpl (length _). rewrite /natAsDWORD. by ssimpl.
  subst I; cbv beta.
    sdestructs => prefix suffix -> END.
    rewrite /ConditionIs.
    destruct suffix => //.
    rewrite /stateIsAny. rewrite length_append addn0.
    sbazooka.
Qed.


(** ** Kripke Completeness **)

From FOL Require Import FragmentSyntax Theories Deduction.FragmentSequentFacts.
From Undecidability.Synthetic Require Import Definitions DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts.
From Undecidability Require Import Shared.ListAutomation Shared.Dec.
From Coq Require Import Vector List.
Import ListAutomationNotations ListAutomationHints ListAutomationInstances ListAutomationFacts.
From FOL.Completeness Require Export TarskiCompleteness.
From FOL.Utils Require Import MPFacts.

(* ** Universal Models *)

Section KripkeCompleteness.
  Context {Σf : funcs_signature} {Σp : preds_signature}. (*
  Variable eF : nat -> option Σf.
  Context {HeF : enumerator__T eF Σf}.
  Variable eP : nat -> option Σp.
  Context {HeP : enumerator__T eP Σp}. *)

(*  Hint Constructors sprv. *)
  Instance model_bot : interp term :=
    {| i_func := func; i_atom := fun P v => False|}.
  Lemma universal_interp_eval rho t :
    eval rho t = t`[rho].
  Proof.
    now induction t; cbn.
  Qed.

  Section Contexts.

    Program Instance K_ctx {ff:falsity_flag} : kmodel term :=
      {|
        nodes := list form ;
        reachable := @incl form ;
        k_interp := model_bot ;
        k_P := fun A P v => sprv A None (atom P v) ;
      |}.
    Next Obligation.
      abstract (eauto using seq_Weak).
    Qed.

    Definition F_P {ff} : list (@form _ _ _ ff) -> Prop := match ff with falsity_on => fun n => sprv n None ⊥ | _ => fun _ => False end.
    Lemma mon_F {ff:falsity_flag} (u v : @nodes _ _ _ K_ctx) : reachable u v -> F_P u -> F_P v.
    Proof.
      cbn. unfold F_P. destruct ff; try easy. intros H H1. eapply seq_Weak; [ exact H1| exact H].
    Qed.

    Notation "rho '⊩⊥(' u , M ')' phi" :=  (@ksat_bot _ _ _ M _ F_P mon_F u rho phi) (at level 20).

    Lemma K_ctx_correct_exp {ff:falsity_flag} (A : list form) rho phi :
      (rho ⊩⊥(A, K_ctx ) phi-> A ⊢S phi[rho]) /\
      ((forall B psi, A <<= B -> B ;; phi[rho] ⊢s psi -> B ⊢S psi) -> rho ⊩⊥(A, K_ctx) phi).
    Proof.
      revert A rho; enough ((forall A rho, rho ⊩⊥( A, K_ctx) phi -> A ⊢S phi[rho]) /\
                          (forall A rho, (forall B psi, A <<= B -> B;; phi[rho] ⊢s psi -> B ⊢S psi)
                                  -> rho ⊩⊥( A, K_ctx) phi)) by intuition.
      induction phi as [|t1 t2|ff [] phi IHphi psi IHpsi|ff [] phi IHphi]; cbn; split; intros A rho.
      - tauto.
      - eauto.
      - erewrite Vector.map_ext. 1: eauto. apply universal_interp_eval.
      - intros H. erewrite Vector.map_ext. 1: now apply H. apply universal_interp_eval.
      - intros Hsat. apply IR, IHpsi. apply Hsat, IHphi. 1: intuition. eauto.
      - intros H B HB Hphi % IHphi. apply IHpsi. intros C xi HC Hxi. apply H.
        1: now transitivity B. eauto using seq_Weak.
      - intros Hsat. apply AllR.
        pose (phi' := phi[up rho]).
        destruct (find_bounded_L (phi' :: A)).
        eapply seq_nameless_equiv_all' with (n := x) (phi := phi').
        + intros xi Hxi. apply b. now right.
        + eapply bounded_up. 1: apply b; now left. lia.
        + unfold phi'. asimpl. apply IHphi, Hsat.
      - intros H t. apply IHphi. intros B psi HB Hpsi. apply H. assumption.
        apply AllL with (t := t). now asimpl.
    Qed.

    Corollary K_ctx_sprv_exp {ff:falsity_flag} A rho phi :
      rho ⊩⊥(A, K_ctx) phi -> A ⊢S phi[rho].
    Proof.
      now destruct (K_ctx_correct_exp A rho phi).
    Qed.

    Lemma K_ctx_subst_exp {ff:falsity_flag} A phi rho :
      rho ⊩⊥( A, K_ctx) phi <-> var ⊩⊥( A, K_ctx) phi[rho].
    Proof.
      unfold ksat_bot, falsity_to_pred.
      rewrite <- atom_subst_comp. 2:easy.
      assert (forall {ff:falsity_flag} rho, (atom (Σ_preds := Σ_preds_bot) (inl tt) (Vector.nil _)) = (atom (Σ_preds := Σ_preds_bot) (inl tt) (Vector.nil _))[rho]) as Heq by easy.
      erewrite Heq.
      rewrite <- subst_falsity_comm. cbn.
      rewrite (ksat_comp A var rho).
      apply ksat_ext. intros x. unfold funcomp. induction (rho x); cbn; try easy.
      erewrite <- Vector.map_ext_in. 2: apply IH.
      now rewrite Vector.map_id.
    Qed.

    Lemma K_ctx_constraint_exp {ff:falsity_flag} A rho psi:
      rho ⊩⊥(A, K_ctx) (⊥ → psi).
    Proof.
      destruct ff eqn : Hff; try now intros.
      intros v B HB. cbn in HB. apply K_ctx_correct_exp.
      intros B' psi' HB' Hprv. subst. eauto using seq_Weak.
    Qed.

    Corollary K_ctx_ksat_exp {ff:falsity_flag} A rho phi :
      (forall B psi, A <<= B -> B ;; phi[rho] ⊢s psi -> B ⊢S psi) -> rho ⊩⊥(A, K_ctx) phi.
    Proof.
      now destruct (K_ctx_correct_exp A rho phi).
    Qed.

    #[local] Existing Instance falsity_off.

    Lemma K_ctx_correct (A : list form) rho phi :
      (rho ⊩(A, K_ctx ) phi-> A ⊢S phi[rho]) /\
      ((forall B psi, A <<= B -> B ;; phi[rho] ⊢s psi -> B ⊢S psi) -> rho ⊩(A, K_ctx) phi).
    Proof.
      revert phi. remember falsity_off as ff eqn:Heqff. intros phi.
      revert A rho; enough ((forall A rho, rho ⊩( A, K_ctx) phi -> A ⊢S phi[rho]) /\
                          (forall A rho, (forall B psi, A <<= B -> B;; phi[rho] ⊢s psi -> B ⊢S psi)
                                  -> rho ⊩( A, K_ctx) phi)) by intuition.
      induction phi as [|t1 t2|ff [] phi IHphi psi IHpsi|ff [] phi IHphi]; cbn; split; intros A rho.
      - tauto.
      - congruence.
      - erewrite Vector.map_ext. 1: eauto. apply universal_interp_eval.
      - intros H. erewrite Vector.map_ext. 1: now apply H. apply universal_interp_eval.
      - intros Hsat. apply IR, IHpsi. 1:easy. apply Hsat, IHphi. 1: intuition. 1:easy. eauto.
      - intros H B HB Hphi % IHphi. 2:easy. apply IHpsi. 1:easy. intros C xi HC Hxi. apply H.
        1: now transitivity B. eauto using seq_Weak.
      - intros Hsat. apply AllR.
        pose (phi' := phi[up rho]).
        destruct (find_bounded_L (phi' :: A)).
        eapply seq_nameless_equiv_all' with (n := x) (phi := phi').
        + intros xi Hxi. apply b. now right.
        + eapply bounded_up. 1: apply b; now left. lia.
        + unfold phi'. asimpl. apply IHphi, Hsat. easy.
      - intros H t. apply IHphi. 1:easy. intros B psi HB Hpsi. apply H. assumption.
        apply AllL with (t := t). now asimpl.
    Qed.

    Corollary K_ctx_sprv A rho phi :
      rho ⊩(A, K_ctx) phi -> A ⊢S phi[rho].
    Proof.
      now destruct (K_ctx_correct A rho phi).
    Qed.

    Lemma K_ctx_subst A phi rho :
      rho ⊩( A, K_ctx) phi <-> var ⊩( A, K_ctx) phi[rho].
    Proof.
      rewrite (ksat_comp A var rho).
      apply ksat_ext. intros x. unfold funcomp. induction (rho x); cbn; try easy.
      erewrite <- Vector.map_ext_in. 2: apply IH.
      now rewrite Vector.map_id.
    Qed.

    Corollary K_ctx_ksat A rho phi :
      (forall B psi, A <<= B -> B ;; phi[rho] ⊢s psi -> B ⊢S psi) -> rho ⊩(A, K_ctx) phi.
    Proof.
      now destruct (K_ctx_correct A rho phi).
    Qed.
  End Contexts.

  Section ExplodingCompleteness.

    Lemma K_ctx_exploding {ff:falsity_flag}:
      kexploding mon_F.
    Proof.
      unfold kexploding.
      apply K_ctx_constraint_exp.
    Qed.

    Lemma K_exp_completeness A phi :
      kvalid_exploding_ctx A phi -> A ⊢SE phi.
    Proof.
      intros Hsat. erewrite <-subst_id. 1: apply K_ctx_sprv_exp with (rho := var). 2: reflexivity.
      apply Hsat. 1: apply K_ctx_exploding. intros psi Hpsi. apply K_ctx_ksat_exp. intros B xi HB Hxi.
      rewrite subst_id in Hxi. 2:reflexivity. eauto.
    Qed.

    Ltac clean_ksoundness :=
      match goal with
      | [ H : ?x = ?x -> _ |- _ ] => specialize (H eq_refl)
      | [ H : (?A -> ?B), H2 : (?A -> ?B) -> _ |- _] => specialize (H2 H)
      end.
    Lemma K_exp_ksoundness {ff:falsity_flag} A phi :
      A ⊢I phi -> kvalid_exploding_ctx A phi.
    Proof.
      intros Hprv. cbn in Hprv. intros D M F_P mon_F u rho Hexpl. revert u rho.
      remember intu as s in Hprv. induction Hprv; subst; cbn; intros u rho HA.
      all: repeat (clean_ksoundness + discriminate). all: (eauto || cbn ; eauto).
      - intros v Hr Hpi. eapply IHHprv. intros ? []; subst; eauto using ksat_mon. eapply ksat_mon. 2: now apply HA. easy.
      - eapply IHHprv1. 3: eapply IHHprv2. all: eauto. apply M.
      - intros d. apply IHHprv. intros psi [psi' [<- Hp]] % in_map_iff. cbn.
        unfold ksat_bot. rewrite falsity_to_pred_subst.
        rewrite ksat_comp. apply HA, Hp.
      - unfold ksat_bot. rewrite falsity_to_pred_subst.
        rewrite ksat_comp. eapply ksat_ext. 2: eapply (IHHprv u rho HA (eval rho t)).
        unfold funcomp. now intros [].
      - apply (Hexpl u rho phi u (ltac:(apply M))).
        specialize (IHHprv u rho HA). cbn in IHHprv. apply IHHprv.
    Qed.

    Lemma K_exp_seq_ksoundness {ff:falsity_flag} A phi :
      A ⊢SE phi -> kvalid_exploding_ctx A phi.
    Proof.
      intros H%seq_ND. now apply K_exp_ksoundness.
    Qed.

    Fact SE_cut A phi psi :
      A ⊢SE phi -> A;;phi ⊢sE psi -> A ⊢SE psi.
    Proof.
      intros H1 % seq_ND H2 % seq_ND; cbn in *.
      apply H2 in H1. apply K_exp_completeness.
      apply K_exp_ksoundness. firstorder.
    Qed.

  End ExplodingCompleteness.

  Section BottomlessCompleteness.
    #[local] Existing Instance falsity_off.

    Lemma K_bottomless_completeness A phi :
      kvalid_ctx A phi -> A ⊢S phi.
    Proof.
      intros Hsat. erewrite <- subst_id. apply K_ctx_sprv with (rho := var). 2: reflexivity.
      apply Hsat. intros psi Hpsi. apply K_ctx_ksat. intros B xi HB Hxi.
      rewrite subst_id in Hxi. 2:easy. eauto.
    Qed.
  End BottomlessCompleteness.

(* *** Standard Models *)

  Section StandardCompleteness.
    #[local] Existing Instance falsity_on.

    Definition cons A := ~ A ⊢SE ⊥.
    Definition cons_ctx := { A | cons A }.
    Definition ctx_incl (A B : cons_ctx) := incl (proj1_sig A) (proj1_sig B).

    #[local] Hint Unfold cons cons_ctx ctx_incl : core.

    Notation "A <<=C B" := (ctx_incl A B) (at level 20).
    Notation "A ⊢SC phi" := ((proj1_sig A) ⊢SE phi) (at level 20).
    Notation "A ;; psi ⊢sC phi" := ((proj1_sig A) ;; psi ⊢sE phi) (at level 20).

    Ltac dest_con_ctx :=
      match goal with
      | [ |- forall u : cons_ctx, _] => let Hu := fresh "H" u in intros [u Hu]
      | [ A : cons_ctx |- _] => let HA := fresh "H" A in destruct A as [A HA]
      end.

    Ltac cctx := repeat (progress dest_con_ctx; unfold ctx_incl); cbn.

    Hint Extern 1 => cctx : core.

    Program Instance K_std : kmodel term :=
      {|
        reachable := ctx_incl ;
        k_interp := model_bot ;
        k_P := fun A P v => ~ ~ A ⊢SC (@atom _ _ _ _ P v)
      |}.
    Next Obligation.
      abstract (apply H0; intros K; apply H1; eapply seq_Weak; eauto).
    Qed.

    Lemma K_std_correct (A : cons_ctx) rho phi :
      (rho ⊩(A, K_std) phi -> ~ ~ A ⊢SC phi[rho]) /\
      ((forall B psi, A <<=C B -> B ;; phi[rho] ⊢sC psi -> ~ ~ B ⊢SC psi) -> rho ⊩(A, K_std) phi).
    Proof.
      revert A rho; enough ((forall A rho, rho ⊩( A, K_std) phi -> ~ ~ A ⊢SC phi[rho])
                          /\ (forall A rho, (forall B psi, A <<=C B -> B;; phi[rho] ⊢sC psi -> ~ ~ B ⊢SC psi)
                                    -> rho ⊩( A, K_std) phi)) by firstorder.
      induction phi as [| t1 t2 | [ ] phi [IHphi1 IHphi2] psi [IHpsi1 IHpsi2] | [ ] phi [IHphi1 IHphi2] ] using form_ind_falsity.
      all: cbn; split; intros A rho.
      - tauto.
      - intros H. exfalso. apply (H A ⊥); auto.
      - now rewrite (Vector.map_ext _ _ _ _ (universal_interp_eval rho)).
      - rewrite <- (Vector.map_ext _ _ _ _ (universal_interp_eval rho)). intros H H'.
        eapply H. 3: { intros H1. apply H', H1. } all: auto.
      - intros Hsat H.
        assert (HA : ~ ~ ((phi[rho] :: proj1_sig A) ⊢SE ⊥ \/ ~ (phi[rho] :: proj1_sig A) ⊢SE ⊥)) by tauto.
        apply HA. clear HA. intros [HA|HA].
        + apply H. apply IR. apply Absurd. assumption.
        + pose (A' := exist cons (phi[rho] :: proj1_sig A) HA). apply (IHpsi1 A' rho).
          * apply Hsat. 1: now apply incl_tl. apply IHphi2. intros B theta HB HT.
            intros H'. apply H'. eauto.
          * intros H'. apply H. apply IR, H'.
      - intros H B HB Hphi % IHphi1. apply IHpsi2. intros C xi HC Hxi.
        intros HX. apply Hphi. intros Hphi'. apply (H C xi); trivial.
        + cctx. now transitivity B.
        + apply IL; trivial. eapply seq_Weak; eauto.
      - pose (phi' := subst_form ($0 .: (rho >> subst_term (S >> var))) phi).
        intros Hsat. intros H. cctx. destruct (find_bounded_L (phi' :: A)) as [x b].
        apply (IHphi1 (exist cons A HA) ($x.:rho)).
        rewrite ksat_ext. 2: reflexivity. now apply Hsat.
        intros H'. apply H, AllR. cbn.
        eapply seq_nameless_equiv_all' with (n := x) (phi := phi').
        + intros xi Hxi. apply b. now right.
        + eapply bounded_up. 1: apply b; now left. lia.
        + unfold phi'. cbn in H'. now asimpl.
      - intros H t. apply IHphi2. intros B psi HB Hpsi. apply H. assumption.
        apply AllL with (t := t). now asimpl.
    Qed.

    Corollary K_std_sprv A rho phi :
      rho ⊩(A, K_std) phi -> ~ ~ A ⊢SC phi[rho].
    Proof.
      now destruct (K_std_correct A rho phi).
    Qed.

    Corollary K_std_sprv' A rho phi :
       ~ ~ A ⊢SC phi[rho] -> rho ⊩(A, K_std) phi.
    Proof.
      intros H. apply (K_std_correct A rho phi).
      intros B psi H1 H2 H3. apply H. intros H'.
      apply H3. eapply SE_cut; try eassumption.
      now apply (seq_Weak H').
    Qed.

    Corollary K_std_ksat A rho phi :
      (forall B psi, A <<=C B -> B ;; phi[rho] ⊢sC psi -> ~ ~ B ⊢SC psi) -> rho ⊩(A, K_std) phi.
    Proof.
      now destruct (K_std_correct A rho phi).
    Qed.

    Lemma K_std_completeness A phi :
      kvalid_ctx A phi -> ~ ~ A ⊢SE phi.
    Proof.
      intros Hsat H.
      assert (HA : ~ ~ (A ⊢SE ⊥ \/ ~ A ⊢SE ⊥)) by tauto.
      apply HA. clear HA. intros [HA|HA].
      - apply H. apply Absurd. assumption.
      - specialize (Hsat _ K_std (exist cons A HA) var).
        apply K_std_sprv in Hsat.
        + apply Hsat. intros Hsat'. apply H.
          erewrite <- subst_id; trivial. apply Hsat'.
        + intros psi Hpsi. apply K_std_ksat.
          intros B xi HB Hxi. asimpl in Hxi. eauto.
    Qed.

    Lemma K_std_seq_ksoundness A phi :
      A ⊢SE phi -> kvalid_ctx A phi.
    Proof.
      intros H % seq_ND. apply ksoundness, H.
    Qed.
  End StandardCompleteness.

  Section Stability.
    Existing Instance falsity_on.
    Context (T_kind : theory -> Prop).
    Definition K_completeness := forall T phi, T_kind T -> closed_T T -> closed phi ->
                  kvalid_theo T phi -> T ⊩SE phi.
    Lemma kcompleteness_implies_stability T phi : K_completeness ->
      T_kind (tmap negative_translation T) ->
      closed_T T -> closed phi ->
      ~ ~ T ⊢TC phi -> T ⊢TC phi.
    Proof.
      intros Hcomp kindT clT clphi HTDN.
      apply DN_T. apply nt_correct_theory. cbn. apply seq_ND_T.
      apply Hcomp.
      - easy.
      - apply tmap_closed. 1: apply nt_bounded. easy.
      - unfold closed. solve_bounds. apply nt_bounded. apply clphi.
      - intros D M u rho HT.
        intros v Huv Hphiv. cbn. apply HTDN.
        intros (A & HTA & HTphi). eapply nt_Cprv_to_Iprv in HTphi.
        eapply DN_into in HTphi.
        apply ksoundness in HTphi.
        unshelve eapply (@HTphi D M u rho _ v Huv Hphiv).
        intros ? (psi & <- & HApsi) %in_map_iff. apply HT.
        exists psi. split; try easy. now apply HTA.
    Qed.
  End Stability.

  Section MP_Equivalence.
    Definition kcompleteness_enumerable := K_completeness enumerable.

    Lemma bot_deriv_stable_enum_k (T : @theory _ _ _ falsity_on) : kcompleteness_enumerable -> closed_T T -> enumerable T ->
      stable (@FragmentND.tprv _ _ _ class T ⊥).
    Proof.
      intros Hcomp Hclosed Henum HC.
      apply (kcompleteness_implies_stability Hcomp); try easy. 2: econstructor.
      now apply enum_tmap.
    Qed.

(*
    Lemma MP_implies_kcompleteness_enum : MP -> kcompleteness_enumerable.
    Proof.
      intros Hmp T phi HT Hphi Henum Hvalid.
      apply completeness_classical_stability; eauto. unfold stable.
      eapply mp_tprv_stability; try tauto. now eapply enumerable_list_enumerable.
    Qed.
*)
    Lemma kcompleteness_enum_implies_MP : kcompleteness_enumerable -> MP.
    Proof.
      intros HC f Hf.
      pose (fun x : form => exists n, x = ⊥ /\ f n = true) as T.
      assert (closed_T T) as Hclosed by (now intros k [n [-> Hn]]; econstructor).
      assert (enumerable T) as Henum.
      { exists (fun n => if f n then Some (⊥) else None). intros phi; split; intros H.
        + destruct H as (n & Heq & Hfn). exists n. rewrite Hfn. now rewrite Heq.
        + destruct H as (n & Hn). unfold T. exists n. destruct (f n); try congruence.
          split; try easy. congruence.
       }
      pose proof (@bot_deriv_stable_enum_k T HC Hclosed Henum).
      enough (T ⊢TC ⊥) as [[|lx lr] [HL HL']].
      - exfalso. eapply consistent_ND. apply HL'.
      - destruct (HL lx) as (n & Heq & Hfn). 1:now left. now exists n.
      - apply H. intros Hc. apply Hf. intros [n Hn]. apply Hc. exists [⊥]. split.
        + intros ? [<- | []]. unfold T. exists n. split; try easy.
        + apply Ctx; now left.
    Qed.

  End MP_Equivalence.

  Section LEM_Equivalence.
    Definition kcompleteness_arbitrary := K_completeness (fun x => True).
    Definition LEM := forall (P:Prop), P \/ ~ P.

    Lemma bot_valid_stable (T : @theory _ _ _ falsity_on) : closed_T T -> stable (valid_theory_C (classical (ff := falsity_on)) T ⊥).
    Proof.
      intros Hclosed HH D I rho Hclass H.
      apply HH. intros Hc. apply (Hc D I rho Hclass H).
    Qed.
    Lemma bot_deriv_stable_k (T : @theory _ _ _ falsity_on) : kcompleteness_arbitrary ->
      closed_T T -> stable (@FragmentND.tprv _ _ _ class T ⊥).
    Proof.
      intros Hcomp Hclosed HC.
      apply (kcompleteness_implies_stability Hcomp); try easy. econstructor.
    Qed.
    Existing Instance falsity_on.
    Lemma kcompleteness_implies_LEM : kcompleteness_arbitrary -> LEM.
    Proof.
      intros HC P.
      pose (fun x : form => closed x /\ (P \/ ~P)) as T.
      assert (closed_T T) as Hclosed by (intros k; cbv; tauto).
      pose proof (@bot_deriv_stable_k T HC Hclosed).
      enough (T ⊢TC ⊥) as [[|lx lr] [HL HL']].
      - exfalso. eapply consistent_ND. apply HL'.
      - eapply HL. now left.
      - enough (~~ (P \/ ~P)).
        + apply H. intros Hc. apply H0. intros Hc2. apply Hc. exists [⊥]. split; try (apply Ctx; now left).
          intros ? [<- | []]. cbv. split; try apply Hc2. econstructor.
        + tauto.
    Qed.
(*
    Lemma LEM_implies_kcompleteness : LEM -> kcompleteness_arbitrary.
    Proof.
      intros Hlem T phi HT Hphi Hvalid Htheo.
      destruct (Hlem (T ⊩SE phi)); try easy. exfalso.
      apply K_std_completeness.
      intros H. destruct (Hlem (T ⊢TC phi)); tauto.
    Qed.
*)
  End LEM_Equivalence.

End KripkeCompleteness.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.NewProofs.ProofHelpers.
Require Import depoolContract.DePoolFunc.

(* Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100. *)

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Require Import depoolContract.Lib.CommonStateProofs.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Require Import depoolContract.DePoolConsts.
Module DePoolContract_Ф_isEmptyRound (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Module ProofHelpers := ProofHelpers dc.

Import dc.
Import ProofHelpers.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Opaque Z.eqb Z.add Z.sub Z.div Z.mul hmapLookup hmapInsert Z.ltb Z.geb Z.leb Z.gtb Z.modulo deleteListPair.

(* function isEmptyRound(Round round) private pure returns (bool) {
  return round.step == RoundStep.Completed || round.stake == 0;
} *)

Lemma DePoolContract_Ф_isEmptyRound_exec : forall (Л_round: RoundsBase_ι_Round)
                                                           (l: Ledger) ,
exec_state ( ↓ DePoolContract_Ф_isEmptyRound Л_round ) l = l .
Proof.
  intros. destruct l. auto.
Qed.

Lemma DePoolContract_Ф_isEmptyRound_eval : forall ( Л_round: RoundsBase_ι_Round )
                                                  ( l: Ledger ) ,
eval_state ( ↓ DePoolContract_Ф_isEmptyRound Л_round ) l =
       ( ( eqb ( Л_round ->> RoundsBase_ι_Round_ι_step ) RoundsBase_ι_RoundStepP_ι_Completed ) ||
         ( Л_round ->> RoundsBase_ι_Round_ι_stake =? 0 ) )%bool.
Proof.
  intros. auto.
Qed.

End DePoolContract_Ф_isEmptyRound.


From mathcomp Require Import all_ssreflect seq.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import FinMap.finmap.
Require Import FinMap.ordtype.

Require Import MiniEMTST.AtomScopes.

Require Import MiniEMTST.Env.
Require Import MiniEMTST.Syntax.
Require Import MiniEMTST.Types.

Definition comm (t : tp) : tp :=
  match t with
  | input _ T => T
  | output _ T => T
  | ended => t
  | bottom => t
  end.

Lemma dual_comm T : dual (comm T) = comm (dual T).
Proof. by case: T. Qed.

Reserved Notation "D ~~> E" (at level 60).
Inductive typ_red : tp_env -> tp_env -> Prop :=
| tred_none D : D ~~> D
| tred_head D k T :
    add k T D ~~>
        add k (comm T) D
| tred_next D D' k T :
    D ~~> D' ->
    add k T D ~~>
        add k T D'
where "D ~~> E" := (typ_red D E).

(* Derive Inversion typred_inv with (forall D E, D ~~> E) Sort Prop. *)

Lemma typred_def D D' :
  D ~~> D' -> def D = def D' /\ forall k, (k \in dom D) = (k \in dom D').
Proof.
  elim=>{D}{D'}//.
  + move=>D k0 T ; split ; first by rewrite !def_addb.
    move=> k.
    by do ! rewrite !in_addb.
  + intros D D' k T.
    intros Hred.
    intros HD.
    destruct HD.
    split.
    - unfold def.
      unfold add.
      rewrite <- H0.
      destruct (k \in dom D); auto.
      destruct D; simpl.
      + assert (D' = Undef _ _). {
          destruct D'.
          - auto.
          - inversion H.
        }
        rewrite H1. auto.
      + destruct D'; simpl; auto.
    - intro.
      repeat rewrite in_dom_add.
      destruct (D) eqn:H1;
      destruct (D') eqn:H2; auto;
      inversion H.

      destruct (k0 \in dom (Def f)) eqn: H3;
      rewrite H0 in H3; rewrite H3;
      destruct (k \in dom (Def f)) eqn:H4;
      unfold add; rewrite H4; rewrite H0 in H4; rewrite H4; auto.
  Qed.

(* Lemma typred_undef D : undef_env ~~> D -> D = undef_env. *)
(* Proof. by move=>/typred_def-/=[]; case: D. Qed. *)

(* Lemma typred_dom D D' : D ~~> D' -> dom D' =i dom D. *)
(* Proof. *)
(*   elim=>//{D}{D'}. *)
(*   + by move=> l D k p T x; rewrite !in_addb !def_addb. *)
(*   + move=> D D' k p T DD' IH x. *)
(*     by rewrite !in_addb !def_addb !IH !(proj1 (typred_def DD')). *)
(* Qed. *)

Theorem CongruencePreservesOft G P Q D :
  P === Q -> oft G P D -> oft G Q D.
Proof.
  elim=>{P}{Q}//.
  { (* c_inact *)
    move=> P /oft_par_inv []D1 []D2 []Hdef []<- []Oinact Oq.
    elim/oft_inv: Oinact =>// Oinact G0 D0 cD1 dG _{G0} _ _{D0}.
    by apply: Weakening.
  }
  { (* c_comm *)
    intros.
    inversion H.
    rewrite composeC.
    apply t_par; auto.
    apply compatibleC; auto.
  }
  { (* c_asoc *)
    admit.
  }
  { (* c_nu *)
    admit.
  }
  {
    (* c_nu_inact *)
    intro.
    inversion H; auto.
    apply t_inact;
    move: (CH.fresh _) (CH.fresh_not_in L) => ki ki_L;
    assert (oft G (open_k0 inact ki) (add ki T (add ki (dual T) D))); try
    exact (H2 _ ki_L);
    unfold open_k0 in H4; unfold open_k in H4;
    inversion H4; auto.
    inversion H5.
    repeat apply weaken_completed in H5; auto.
  }
  { (* c_bang *)
    intros.
    inversion H.
    rewrite <- compose0.
    rewrite composeC.
    apply t_par; auto.
    inversion H1.
    inversion H5.
    destruct D.
    inversion H8.
    apply compatible_nil_def.
  }
(* Qed. *)
Admitted.

Theorem SubjectReductionStep G P Q D:
  oft G P D -> P --> Q -> exists D', D ~~> D' /\ oft G Q D'.
Proof.
  move=> Op PQ.
  elim: PQ G D Op => {P} {Q}.
  { (* r_com *)
    admit.
  }

  { (* r_cong *)
    (* will make use of CongruencePreservesOft *)
    intros.
    assert (exists D' : tp_env, D ~~> D' /\ oft G Q' D').
    {
      apply H3.
      apply CongruencePreservesOft with (P := P); auto.
    }
    destruct H5 as [D'].
    exists D'.
    destruct H5.
    split; auto.
    apply CongruencePreservesOft with (P := Q'); auto.
  }
  { (* r_scop *)
    admit.
  }

  { (* r_par *)
    admit.
  }

  { (* r_if_tt *)
    move=> P Q G D Ho.
    by exists D; split; first (by apply: tred_none); move: Ho=>/oft_ife_inv-[].
  }

  { (* r_if_ff *)
    move=> P Q G D Ho.
    exists D.
    split ; [by apply: tred_none| ].
    by move: Ho=>/oft_ife_inv-[].
  }
(* Qed. *)
Admitted.

Theorem SubjectReduction G P Q D:
  oft G P D -> P -->* Q -> exists D', oft G Q D'.
Proof.
  move => Hoft PQ; elim: PQ D Hoft => {P} {Q} P.
  + by move=> D Hoft; exists D.
  + move=> Q R Step QR IH D Hoft.
    move: (SubjectReductionStep Hoft Step) => []D' []bD' Hoft'.
    by move: (IH D' Hoft').
Qed.

(* Print Assumptions SubjectReduction. *)