(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(* File Eqdep.v created by Christine Paulin-Mohring in Coq V5.6, May 1992 *)
(* Further documentation and variants of eq_rect_eq by Hugo Herbelin,
   Apr 2003 *)
(* Abstraction with respect to the eq_rect_eq axiom and renaming to
   EqdepFacts.v by Hugo Herbelin, Mar 2006 *)

(** This file defines dependent equality and shows its equivalence with
    equality on dependent pairs (inhabiting sigma-types). It derives
    the consequence of axiomatizing the invariance by substitution of
    reflexive equality proofs and shows the equivalence between the 4
    following statements

    - Invariance by Substitution of Reflexive Equality Proofs.
    - Injectivity of Dependent Equality
    - Uniqueness of Identity Proofs
    - Uniqueness of Reflexive Identity Proofs
    - Streicher's Axiom K

  These statements are independent of the calculus of constructions [2].

  References:

  [1] T. Streicher, Semantical Investigations into Intensional Type Theory,
      Habilitationsschrift, LMU München, 1993.
  [2] M. Hofmann, T. Streicher, The groupoid interpretation of type theory,
      Proceedings of the meeting Twenty-five years of constructive
      type theory, Venice, Oxford University Press, 1998

Table of contents:

1. Definition of dependent equality and equivalence with equality of
   dependent pairs and with dependent pair of equalities

2. Eq_rect_eq <-> Eq_dep_eq <-> UIP <-> UIP_refl <-> K

3. Definition of the functor that builds properties of dependent
   equalities assuming axiom eq_rect_eq

*)

(************************************************************************)
(** * Definition of dependent equality and equivalence with equality of dependent pairs *)

Import EqNotations.

(* Set Universe Polymorphism. *)

Section Dependent_Equality.

  Variable U : Type.
  Variable P : U -> Type.

  (** Dependent equality *)

  Inductive eq_dep (p:U) (x:P p) : forall q:U, P q -> Prop :=
    eq_dep_intro : eq_dep p x p x.
  Hint Constructors eq_dep: core.

  Lemma eq_dep_refl : forall (p:U) (x:P p), eq_dep p x p x.
  Proof eq_dep_intro.

  Lemma eq_dep_sym :
    forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep q y p x.
  Proof.
    destruct 1; auto.
  Qed.
  Hint Immediate eq_dep_sym: core.

  Lemma eq_dep_trans :
    forall (p q r:U) (x:P p) (y:P q) (z:P r),
      eq_dep p x q y -> eq_dep q y r z -> eq_dep p x r z.
  Proof.
    destruct 1; auto.
  Qed.

  Scheme eq_indd := Induction for eq Sort Prop.

  (** Equivalent definition of dependent equality as a dependent pair of
      equalities *)

  Inductive eq_dep1 (p:U) (x:P p) (q:U) (y:P q) : Prop :=
    eq_dep1_intro : forall h:q = p, x = rew h in y -> eq_dep1 p x q y.

  Lemma eq_dep1_dep :
    forall (p:U) (x:P p) (q:U) (y:P q), eq_dep1 p x q y -> eq_dep p x q y.
  Proof.
    destruct 1 as (eq_qp, H).
    destruct eq_qp using eq_indd.
    rewrite H.
    apply eq_dep_intro.
  Qed.

  Lemma eq_dep_dep1 :
    forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep1 p x q y.
  Proof.
    destruct 1.
    apply eq_dep1_intro with (eq_refl p).
    simpl; trivial.
  Qed.

End Dependent_Equality.

Arguments eq_dep  [U P] p x q _.
Arguments eq_dep1 [U P] p x q y.

(** Dependent equality is equivalent to equality on dependent pairs *)

Lemma eq_sigT_eq_dep :
  forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q),
    existT P p x = existT P q y -> eq_dep p x q y.
Proof.
  intros.
  dependent rewrite H.
  apply eq_dep_intro.
Qed.

Notation eq_sigS_eq_dep := eq_sigT_eq_dep (compat "8.6"). (* Compatibility *)

Lemma eq_dep_eq_sigT :
  forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q),
    eq_dep p x q y -> existT P p x = existT P q y.
Proof.
  destruct 1; reflexivity.
Qed.

Lemma eq_sigT_iff_eq_dep :
  forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q),
    existT P p x = existT P q y <-> eq_dep p x q y.
Proof.
  split; auto using eq_sigT_eq_dep, eq_dep_eq_sigT.
Qed.

Notation equiv_eqex_eqdep := eq_sigT_iff_eq_dep (only parsing). (* Compat *)

Lemma eq_sig_eq_dep :
  forall (U:Type) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
    exist P p x = exist P q y -> eq_dep p x q y.
Proof.
  intros.
  dependent rewrite H.
  apply eq_dep_intro.
Qed.

Lemma eq_dep_eq_sig :
  forall (U:Type) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
    eq_dep p x q y -> exist P p x = exist P q y.
Proof.
  destruct 1; reflexivity.
Qed.

Lemma eq_sig_iff_eq_dep :
  forall (U:Type) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
    exist P p x = exist P q y <-> eq_dep p x q y.
Proof.
  split; auto using eq_sig_eq_dep, eq_dep_eq_sig.
Qed.

(** Dependent equality is equivalent to a dependent pair of equalities *)

Set Implicit Arguments.

Lemma eq_sigT_sig_eq : forall X P (x1 x2:X) H1 H2, existT P x1 H1 = existT P x2 H2 <->
                                                   {H:x1=x2 | rew H in H1 = H2}.
Proof.
  intros; split; intro H.
  - change x2 with (projT1 (existT P x2 H2)).
    change H2 with (projT2 (existT P x2 H2)) at 5.
    destruct H. simpl.
    exists eq_refl.
    reflexivity.
  - destruct H as (->,<-).
    reflexivity.
Defined.

Lemma eq_sigT_fst :
  forall X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2), x1 = x2.
Proof.
  intros.
  change x2 with (projT1 (existT P x2 H2)).
  destruct H.
  reflexivity.
Defined.

Lemma eq_sigT_snd :
  forall X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2), rew (eq_sigT_fst H) in H1 = H2.
Proof.
  intros.
  unfold eq_sigT_fst.
  change x2 with (projT1 (existT P x2 H2)).
  change H2 with (projT2 (existT P x2 H2)) at 3.
  destruct H.
  reflexivity.
Defined.

Lemma eq_sig_fst :
  forall X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2), x1 = x2.
Proof.
  intros.
  change x2 with (proj1_sig (exist P x2 H2)).
  destruct H.
  reflexivity.
Defined.

Lemma eq_sig_snd :
  forall X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2), rew (eq_sig_fst H) in H1 = H2.
Proof.
  intros.
  unfold eq_sig_fst, eq_ind.
  change x2 with (proj1_sig (exist P x2 H2)).
  change H2 with (proj2_sig (exist P x2 H2)) at 3.
  destruct H.
  reflexivity.
Defined.

Unset Implicit Arguments.

(** Exported hints *)

Hint Resolve eq_dep_intro: core.
Hint Immediate eq_dep_sym: core.

(************************************************************************)
(** * Eq_rect_eq <-> Eq_dep_eq <-> UIP <-> UIP_refl <-> K          *)

Section Equivalences.

  Variable U:Type.

  (** Invariance by Substitution of Reflexive Equality Proofs *)

  Definition Eq_rect_eq_on (p : U) (Q : U -> Type) (x : Q p) :=
    forall (h : p = p), x = eq_rect p Q x p h.
  Definition Eq_rect_eq := forall p Q x, Eq_rect_eq_on p Q x.

  (** Injectivity of Dependent Equality *)

  Definition Eq_dep_eq_on (P : U -> Type) (p : U) (x : P p) :=
    forall (y : P p), eq_dep p x p y -> x = y.
  Definition Eq_dep_eq := forall P p x, Eq_dep_eq_on P p x.

  (** Uniqueness of Identity Proofs (UIP) *)

  Definition UIP_on_ (x y : U) (p1 : x = y) :=
    forall (p2 : x = y), p1 = p2.
  Definition UIP_ := forall x y p1, UIP_on_ x y p1.

  (** Uniqueness of Reflexive Identity Proofs *)

  Definition UIP_refl_on_ (x : U) :=
    forall (p : x = x), p = eq_refl x.
  Definition UIP_refl_ := forall x, UIP_refl_on_ x.

  (** Streicher's axiom K *)

  Definition Streicher_K_on_ (x : U) (P : x = x -> Prop) :=
    P (eq_refl x) -> forall p : x = x, P p.
  Definition Streicher_K_ := forall x P, Streicher_K_on_ x P.

  (** Injectivity of Dependent Equality is a consequence of *)
  (** Invariance by Substitution of Reflexive Equality Proof *)

  Lemma eq_rect_eq_on__eq_dep1_eq_on (p : U) (P : U -> Type) (y : P p) :
    Eq_rect_eq_on p P y -> forall (x : P p), eq_dep1 p x p y -> x = y.
  Proof.
    intro eq_rect_eq.
    simple destruct 1; intro.
    rewrite <- eq_rect_eq; auto.
  Qed.
  Lemma eq_rect_eq__eq_dep1_eq :
    Eq_rect_eq -> forall (P:U->Type) (p:U) (x y:P p), eq_dep1 p x p y -> x = y.
  Proof (fun eq_rect_eq P p y x =>
           @eq_rect_eq_on__eq_dep1_eq_on p P x (eq_rect_eq p P x) y).

  Lemma eq_rect_eq_on__eq_dep_eq_on (p : U) (P : U -> Type) (x : P p) :
    Eq_rect_eq_on p P x -> Eq_dep_eq_on P p x.
  Proof.
    intros eq_rect_eq; red; intros.
    symmetry; apply (eq_rect_eq_on__eq_dep1_eq_on _ _ _ eq_rect_eq).
    apply eq_dep_sym in H; apply eq_dep_dep1; trivial.
  Qed.
  Lemma eq_rect_eq__eq_dep_eq : Eq_rect_eq -> Eq_dep_eq.
  Proof (fun eq_rect_eq P p x y =>
           @eq_rect_eq_on__eq_dep_eq_on p P x (eq_rect_eq p P x) y).

  (** Uniqueness of Identity Proofs (UIP) is a consequence of *)
  (** Injectivity of Dependent Equality *)

  Lemma eq_dep_eq_on__UIP_on (x y : U) (p1 : x = y) :
    Eq_dep_eq_on (fun y => x = y) x eq_refl -> UIP_on_ x y p1.
  Proof.
    intro eq_dep_eq; red.
    elim p1 using eq_indd.
    intros; apply eq_dep_eq.
    elim p2 using eq_indd.
    apply eq_dep_intro.
  Qed.
  Lemma eq_dep_eq__UIP : Eq_dep_eq -> UIP_.
  Proof (fun eq_dep_eq x y p1 =>
           @eq_dep_eq_on__UIP_on x y p1 (eq_dep_eq _ _ _)).

  (** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *)

  Lemma UIP_on__UIP_refl_on (x : U) :
    UIP_on_ x x eq_refl -> UIP_refl_on_ x.
  Proof.
    intro UIP; red; intros; symmetry; apply UIP.
  Qed.
  Lemma UIP__UIP_refl : UIP_ -> UIP_refl_.
  Proof (fun UIP x p =>
           @UIP_on__UIP_refl_on x (UIP x x eq_refl) p).

  (** Streicher's axiom K is a direct consequence of Uniqueness of
      Reflexive Identity Proofs *)

  Lemma UIP_refl_on__Streicher_K_on (x : U) (P : x = x -> Prop) :
    UIP_refl_on_ x -> Streicher_K_on_ x P.
  Proof.
    intro UIP_refl; red; intros; rewrite UIP_refl; assumption.
  Qed.
  Lemma UIP_refl__Streicher_K : UIP_refl_ -> Streicher_K_.
  Proof (fun UIP_refl x P =>
           @UIP_refl_on__Streicher_K_on x P (UIP_refl x)).

  (** We finally recover from K the Invariance by Substitution of
      Reflexive Equality Proofs *)

  Lemma Streicher_K_on__eq_rect_eq_on (p : U) (P : U -> Type) (x : P p) :
    Streicher_K_on_ p (fun h => x = rew -> [P] h in x)
    -> Eq_rect_eq_on p P x.
  Proof.
    intro Streicher_K; red; intros.
    apply Streicher_K.
    reflexivity.
  Qed.
  Lemma Streicher_K__eq_rect_eq : Streicher_K_ -> Eq_rect_eq.
  Proof (fun Streicher_K p P x =>
           @Streicher_K_on__eq_rect_eq_on p P x (Streicher_K p _)).

(** Remark: It is reasonable to think that [eq_rect_eq] is strictly
    stronger than [eq_rec_eq] (which is [eq_rect_eq] restricted on [Set]):

   [Definition Eq_rec_eq :=
      forall (P:U -> Set) (p:U) (x:P p) (h:p = p), x = eq_rec p P x p h.]

    Typically, [eq_rect_eq] allows proving UIP and Streicher's K what
    does not seem possible with [eq_rec_eq]. In particular, the proof of [UIP]
    requires to use [eq_rect_eq] on [fun y -> x=y] which is in [Type] but not
    in [Set].
*)

End Equivalences.

(** UIP_refl is downward closed (a short proof of the key lemma of Voevodsky's
    proof of inclusion of h-level n into h-level n+1; see hlevelntosn
    in https://github.com/vladimirias/Foundations.git). *)

Theorem UIP_shift_on (X : Type) (x : X) :
  UIP_refl_on_ X x -> forall y : x = x, UIP_refl_on_ (x = x) y.
Proof.
  intros UIP_refl y.
  rewrite (UIP_refl y).
  intros z.
  assert (UIP:forall y' y'' : x = x, y' = y'').
  { intros. apply eq_trans with (eq_refl x). apply UIP_refl.
    symmetry. apply UIP_refl. }
  transitivity (eq_trans (eq_trans (UIP (eq_refl x) (eq_refl x)) z)
                         (eq_sym (UIP (eq_refl x) (eq_refl x)))).
  - destruct z. destruct (UIP _ _). reflexivity.
  - change
      (match eq_refl x as y' in _ = x' return y' = y' -> Prop with
       | eq_refl => fun z => z = (eq_refl (eq_refl x))
       end (eq_trans (eq_trans (UIP (eq_refl x) (eq_refl x)) z)
                     (eq_sym (UIP (eq_refl x) (eq_refl x))))).
    destruct z. destruct (UIP _ _). reflexivity.
Qed.
Theorem UIP_shift : forall U, UIP_refl_ U -> forall x:U, UIP_refl_ (x = x).
Proof (fun U UIP_refl x =>
         @UIP_shift_on U x (UIP_refl x)).

Section Corollaries.

  Variable U:Type.

  (** UIP implies the injectivity of equality on dependent pairs in Type *)

 Definition Inj_dep_pair_on (P : U -> Type) (p : U) (x : P p) :=
   forall (y : P p), existT P p x = existT P p y -> x = y.
 Definition Inj_dep_pair := forall P p x, Inj_dep_pair_on P p x.

 Lemma eq_dep_eq_on__inj_pair2_on (P : U -> Type) (p : U) (x : P p) :
   Eq_dep_eq_on U P p x -> Inj_dep_pair_on P p x.
 Proof.
   intro eq_dep_eq; red; intros.
   apply eq_dep_eq.
   apply eq_sigT_eq_dep.
   assumption.
 Qed.
 Lemma eq_dep_eq__inj_pair2 : Eq_dep_eq U -> Inj_dep_pair.
 Proof (fun eq_dep_eq P p x =>
          @eq_dep_eq_on__inj_pair2_on P p x (eq_dep_eq P p x)).

End Corollaries.

Notation Inj_dep_pairS := Inj_dep_pair.
Notation Inj_dep_pairT := Inj_dep_pair.
Notation eq_dep_eq__inj_pairT2 := eq_dep_eq__inj_pair2.

(************************************************************************)
(** * Definition of the functor that builds properties of dependent equalities assuming axiom eq_rect_eq *)

Module Type EqdepElimination.

  Axiom eq_rect_eq :
    forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p),
      x = eq_rect p Q x p h.

End EqdepElimination.

Module EqdepTheory (M:EqdepElimination).

  Section Axioms.

    Variable U:Type.

(** Invariance by Substitution of Reflexive Equality Proofs *)

Lemma eq_rect_eq :
  forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
Proof M.eq_rect_eq U.

Lemma eq_rec_eq :
  forall (p:U) (Q:U -> Set) (x:Q p) (h:p = p), x = eq_rec p Q x p h.
Proof (fun p Q => M.eq_rect_eq U p Q).

(** Injectivity of Dependent Equality *)

Lemma eq_dep_eq : forall (P:U->Type) (p:U) (x y:P p), eq_dep p x p y -> x = y.
Proof (eq_rect_eq__eq_dep_eq U eq_rect_eq).

(** Uniqueness of Identity Proofs (UIP) is a consequence of *)
(** Injectivity of Dependent Equality *)

Lemma UIP : forall (x y:U) (p1 p2:x = y), p1 = p2.
Proof (eq_dep_eq__UIP U eq_dep_eq).

(** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *)

Lemma UIP_refl : forall (x:U) (p:x = x), p = eq_refl x.
Proof (UIP__UIP_refl U UIP).

(** Streicher's axiom K is a direct consequence of Uniqueness of
    Reflexive Identity Proofs *)

Lemma Streicher_K :
  forall (x:U) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p.
Proof (UIP_refl__Streicher_K U UIP_refl).

End Axioms.

(** UIP implies the injectivity of equality on dependent pairs in Type *)

Lemma inj_pair2 :
 forall (U:Type) (P:U -> Type) (p:U) (x y:P p),
   existT P p x = existT P p y -> x = y.
Proof (fun U => eq_dep_eq__inj_pair2 U (eq_dep_eq U)).

Notation inj_pairT2 := inj_pair2.

End EqdepTheory.

(** Basic facts about eq_dep *)

Lemma f_eq_dep :
  forall U (P:U->Type) R p q x y (f:forall p, P p -> R p),
    eq_dep p x q y -> eq_dep p (f p x) q (f q y).
Proof.
intros * []. reflexivity.
Qed.

Lemma eq_dep_non_dep :
  forall U P p q x y, @eq_dep U (fun _ => P) p x q y -> x = y.
Proof.
intros * []. reflexivity.
Qed.

Lemma f_eq_dep_non_dep :
  forall U (P:U->Type) R p q x y (f:forall p, P p -> R),
    eq_dep p x q y -> f p x = f q y.
Proof.
intros * []. reflexivity.
Qed.

Arguments eq_dep  U P p x q _ : clear implicits.
Arguments eq_dep1 U P p x q y : clear implicits.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)

Require Import ssreflect.
Require Import ssrfun ssrbool TestSuite.ssr_mini_mathcomp.

Lemma test1 n : n >= 0.
Proof.
have [:s1] @h m : 'I_(n+m).+1.
  apply: Sub 0 _.
  abstract: s1 m.
  by auto.
cut (forall m, 0 < (n+m).+1); last assumption.
rewrite [_ 1 _]/= in s1 h *.
by [].
Qed.

Lemma test2 n : n >= 0.
Proof.
have [:s1] @h m : 'I_(n+m).+1 := Sub 0 (s1 m).
  move=> m; reflexivity.
cut (forall m, 0 < (n+m).+1); last assumption.
by [].
Qed.

Lemma test3 n : n >= 0.
Proof.
Fail have [:s1] @h m : 'I_(n+m).+1 by apply: (Sub 0 (s1 m)); auto.
have [:s1] @h m : 'I_(n+m).+1 by apply: (Sub 0); abstract: s1 m; auto.
cut (forall m, 0 < (n+m).+1); last assumption.
by [].
Qed.

Lemma test4 n : n >= 0.
Proof.
have @h m : 'I_(n+m).+1 by apply: (Sub 0); abstract auto.
by [].
Qed.


Require Export parser.

Definition P1: IA := parse
"IA [IDLE_SS, WAIT_SS, DATA_SS] (IDLE_SS)
[Sa_CONN_conf_S, Sa_DISC_ind_S, Sa_HPDATA_ind_S, Sa_DATA_ind_S]
[Sa_CONN_req_S, Sa_DISC_req_S, Sa_HPDATA_req_S, Sa_DATA_req_S] []
[IDLE_SS->(Sa_CONN_req_S)WAIT_SS,
 WAIT_SS->(Sa_DISC_ind_S)IDLE_SS,
 WAIT_SS->(Sa_CONN_conf_S)DATA_SS,
 DATA_SS->(Sa_DATA_ind_S)DATA_SS, DATA_SS->(Sa_HPDATA_ind_S)DATA_SS,
 DATA_SS->(Sa_DATA_req_S)DATA_SS, DATA_SS->(Sa_HPDATA_req_S)DATA_SS,
 DATA_SS->(Sa_DISC_ind_S)IDLE_SS, DATA_SS->(Sa_DISC_req_S)IDLE_SS]".

Definition P2: IA := parse
"IA
 [DISC_1_S, IDLE_S, DISC_2_S, CONN_S, WFDIS_S, DISC_3_S, SA_HP_S, DISC_4_S,
  WFTC_S, T_DA_S, DATA_S, SA_DA_S, T_HP_S, CONF_S, WFAR_S, AR_S]
 (IDLE_S)
 [Sa_CONN_req_S, Sa_DISC_req_S, T_DISC_ind_S, Sa_HPDATA_req_S, T_DATA_ind_S, T_CONN_conf_S, Sa_DATA_req_S, T_HPDATA_ind_S]
 [T_CONN_req_S, T_DISC_req_S, Sa_DISC_ind_S, T_HPDATA_req_S, Sa_DATA_ind_S, Sa_CONN_conf_S, T_DATA_req_S, Sa_HPDATA_ind_S]
 [e]
 [IDLE_S->(Sa_CONN_req_S)CONN_S,
  CONN_S->(T_CONN_req_S)WFTC_S, CONN_S->(e)DISC_1_S,
  DISC_1_S->(Sa_DISC_ind_S)IDLE_S,
  WFTC_S->(Sa_DISC_ind_S)WFDIS_S, WFTC_S->(T_DISC_ind_S)DISC_1_S,
  WFDIS_S->(T_DISC_req_S)IDLE_S,
  WFTC_S->(T_CONN_conf_S)CONF_S,
  CONF_S->(T_DISC_req_S)DISC_1_S, CONF_S->(T_DATA_req_S)WFAR_S,
  WFAR_S->(T_DISC_ind_S)DISC_1_S, WFAR_S->(Sa_DISC_req_S)DISC_2_S,
  WFAR_S->(T_DATA_ind_S)AR_S,
  AR_S->(Sa_DISC_ind_S)DISC_2_S, AR_S->(Sa_CONN_conf_S)DATA_S,
  DATA_S->(Sa_DISC_req_S)DISC_2_S, DISC_2_S->(T_DISC_req_S)IDLE_S,
  DATA_S->(T_DISC_ind_S)DISC_4_S, DISC_4_S->(Sa_DISC_ind_S)IDLE_S,
  DATA_S->(Sa_HPDATA_req_S)SA_HP_S, SA_HP_S->(T_HPDATA_req_S)DATA_S,
  DATA_S->(T_DATA_ind_S)T_DA_S, T_DA_S->(Sa_DATA_ind_S)DATA_S,
  DATA_S->(Sa_DATA_req_S)SA_DA_S, SA_DA_S->(T_DATA_req_S)DATA_S,
  DATA_S->(T_HPDATA_ind_S)T_HP_S, T_HP_S->(Sa_HPDATA_ind_S)DATA_S,
  T_DA_S->(Sa_DISC_ind_S)DISC_3_S, DISC_3_S->(T_DISC_req_S)IDLE_S]".

(*this is an alternative P2 that considers
  the maximum connection establishment delay timer T_{estab} thus
  the dash arcs in Fig5.(a) of Zhang Yan's SciChinaE *)
Definition P2': IA := parse
"IA [DISC_1_S, IDLE_S, DISC_2_S, CONN_S, WFDIS_S, DISC_3_S, SA_HP_S, DISC_4_S,
    WFTC_S, T_DA_S, DATA_S, SA_DA_S, T_HP_S, CONF_S, WFAR_S, AR_S] (IDLE_S)
 [Sa_CONN_req_S, Sa_DISC_req_S, T_DISC_ind_S, Sa_HPDATA_req_S, T_DATA_ind_S,
  T_CONN_conf_S, Sa_DATA_req_S, T_HPDATA_ind_S]
 [T_CONN_req_S, T_DISC_req_S, Sa_DISC_ind_S, T_HPDATA_req_S, Sa_DATA_ind_S,
  Sa_CONN_conf_S, T_DATA_req_S, Sa_HPDATA_ind_S] [e]
 [DISC_1_S->(Sa_DISC_ind_S)IDLE_S, DISC_2_S->(T_DISC_req_S)IDLE_S,
 IDLE_S->(Sa_CONN_req_S)CONN_S, CONN_S->(e)DISC_1_S,
 WFDIS_S->(T_DISC_req_S)IDLE_S,
 DISC_3_S->(T_DISC_req_S)IDLE_S, DISC_4_S->(Sa_DISC_ind_S)IDLE_S,
 CONN_S->(T_CONN_req_S)WFTC_S, WFTC_S->(Sa_DISC_ind_S)WFDIS_S,
 WFTC_S->(T_DISC_ind_S)DISC_1_S,
 WFTC_S->(T_CONN_conf_S)CONF_S, CONF_S->(T_DISC_req_S)DISC_1_S,
 CONF_S->(T_DATA_req_S)WFAR_S, WFAR_S->(T_DISC_ind_S)DISC_1_S,
 WFAR_S->(Sa_DISC_req_S)DISC_2_S,
 WFAR_S->(T_DATA_ind_S)AR_S, AR_S->(Sa_DISC_ind_S)DISC_2_S,
 AR_S->(Sa_CONN_conf_S)DATA_S,
 DATA_S->(T_DISC_ind_S)DISC_4_S, DATA_S->(Sa_DISC_req_S)DISC_2_S,
 DATA_S->(Sa_HPDATA_req_S)SA_HP_S, SA_HP_S->(T_HPDATA_req_S)DATA_S,
 DATA_S->(T_DATA_ind_S)T_DA_S, T_DA_S->(Sa_DATA_ind_S)DATA_S,
 DATA_S->(Sa_DATA_req_S)SA_DA_S, SA_DA_S->(T_DATA_req_S)DATA_S,
 DATA_S->(T_HPDATA_ind_S)T_HP_S, T_HP_S->(Sa_HPDATA_ind_S)DATA_S,
 T_DA_S->(Sa_DISC_ind_S)DISC_3_S,
 WFAR_S->(Sa_DISC_ind_S)DISC_2_S, WFTC_S->(T_DISC_req_S)DISC_1_S]".

Definition P3: IA := parse
"IA [IDLE_T, HP_F_T, CONR_S_T, DA_S_T, DISC_S_T, HP_S_T, DISC_F_T, DA_F_T, CONRS_F_T]
 (IDLE_T)
 [T_HPDATA_req_F, T_CONN_resp_F, T_DATA_req_F, T_DISC_req_F, T_HPDATA_req_S, T_DISC_req_S, T_DATA_req_S, T_CONN_req_S]
 [T_HPDATA_ind_S, T_CONN_conf_S, T_DATA_ind_S, T_DISC_ind_S, T_HPDATA_ind_F, T_DISC_ind_F, T_DATA_ind_F, T_CONN_ind_F]
 [e]
 [ IDLE_T->(T_HPDATA_req_F)HP_F_T, HP_F_T->(T_HPDATA_ind_S)IDLE_T,
   IDLE_T->(T_CONN_resp_F)CONRS_F_T, CONRS_F_T->(T_CONN_conf_S)IDLE_T,
   IDLE_T->(T_DATA_req_F)DA_F_T, DA_F_T->(T_DATA_ind_S)IDLE_T,
   IDLE_T->(T_DISC_req_F)DISC_F_T, DISC_F_T->(T_DISC_ind_S)IDLE_T,
   IDLE_T->(T_HPDATA_req_S)HP_S_T, HP_S_T->(T_HPDATA_ind_F)IDLE_T,
   IDLE_T->(T_DISC_req_S)DISC_S_T, DISC_S_T->(T_DISC_ind_F)IDLE_T, DISC_S_T->(e)IDLE_T,
   IDLE_T->(T_DATA_req_S)DA_S_T, DA_S_T->(T_DATA_ind_F)IDLE_T,
   IDLE_T->(T_CONN_req_S)CONR_S_T, CONR_S_T->(T_CONN_ind_F)IDLE_T
 ]".

Definition P4: IA := parse
"IA [IDLE_F, DISC_1_F, DISC_2_F, CONIND_F, WFAU3_F, DISC_3_F, SA_HP_F,
 DATA_F, T_HP_F, SA_DA_F, T_DA_F, RAU3_F, WFRESP_F, SNDAR_F]
 (IDLE_F)
 [T_CONN_ind_F, Sa_DISC_req_F, T_DISC_ind_F, Sa_DATA_req_F, T_DATA_ind_F, Sa_CONN_resp_F, Sa_HPDATA_req_F, T_HPDATA_ind_F]
 [Sa_CONN_ind_F, T_DISC_req_F, Sa_DISC_ind_F, T_DATA_req_F, Sa_DATA_ind_F, T_CONN_resp_F, T_HPDATA_req_F, Sa_HPDATA_ind_F] [e]
 [DISC_1_F->(T_DISC_req_F)IDLE_F, DISC_2_F->(Sa_DISC_ind_F)IDLE_F,
 IDLE_F->(T_CONN_ind_F)CONIND_F, CONIND_F->(e)DISC_1_F,
 CONIND_F->(T_CONN_resp_F)WFAU3_F, WFAU3_F->(T_DATA_ind_F)RAU3_F,
 RAU3_F->(e)DISC_1_F, RAU3_F->(Sa_CONN_ind_F)WFRESP_F,
 WFRESP_F->(Sa_DISC_req_F)DISC_1_F, WFRESP_F->(T_DISC_ind_F)DISC_2_F,
 WFRESP_F->(Sa_CONN_resp_F)SNDAR_F, SNDAR_F->(T_DATA_req_F)DATA_F,
 DATA_F->(Sa_HPDATA_req_F)SA_HP_F, SA_HP_F->(T_HPDATA_req_F)DATA_F,
 DATA_F->(T_HPDATA_ind_F)T_HP_F, T_HP_F->(Sa_HPDATA_ind_F)DATA_F,
 DATA_F->(Sa_DATA_req_F)SA_DA_F, SA_DA_F->(T_DATA_req_F)DATA_F,
 DATA_F->(T_DATA_ind_F)T_DA_F, T_DA_F->(Sa_DATA_ind_F)DATA_F,
 WFAU3_F->(T_DISC_ind_F)IDLE_F, DATA_F->(T_DISC_ind_F)DISC_2_F,
 T_DA_F->(Sa_DISC_ind_F)DISC_3_F, DISC_3_F->(T_DISC_req_F)IDLE_F,
 DATA_F->(Sa_DISC_req_F)DISC_3_F]".

Definition P5: IA := parse
"IA [IDLE_SF, WAIT_SF, DATA_SF] (IDLE_SF)
 [Sa_CONN_ind_F, Sa_DISC_ind_F, Sa_HPDATA_ind_F, Sa_DATA_ind_F]
 [Sa_CONN_resp_F, Sa_DISC_req_F, Sa_HPDATA_req_F, Sa_DATA_req_F] []
 [IDLE_SF->(Sa_CONN_ind_F)WAIT_SF, WAIT_SF->(Sa_CONN_resp_F)DATA_SF,
  WAIT_SF->(Sa_DISC_ind_F)IDLE_SF, WAIT_SF->(Sa_DISC_req_F)IDLE_SF,
  DATA_SF->(Sa_DISC_ind_F)IDLE_SF, DATA_SF->(Sa_DISC_req_F)IDLE_SF,
  DATA_SF->(Sa_DATA_ind_F)DATA_SF, DATA_SF->(Sa_HPDATA_ind_F)DATA_SF,
  DATA_SF->(Sa_DATA_req_F)DATA_SF, DATA_SF->(Sa_HPDATA_req_F)DATA_SF]".

(* the S-side synthesis on P2 and P2' *)
Eval compute in IAutomaton.b_compatible P1 P2. (*false*)
Eval compute in IAutomaton.b_compatible P2 P3. (*true*)

Definition P23: IA := IAutomaton.composition P2 P3.

Eval compute in IAutomaton.b_compatible P1 P23. (*true*)

Eval compute in IAutomaton.b_compatible P1 P2'. (*false*)
Eval compute in IAutomaton.b_compatible P2' P3. (*true*)

Definition P23': IA := IAutomaton.composition P2' P3.

Eval compute in IAutomaton.b_compatible P1 P23'. (*true*)

(* according to the synthesis, we get the correct P2 as P2_synthesis *)
Definition P2_synthesis: IA := parse
"IA
 [DISC_1_S, IDLE_S, DISC_2_S, CONN_S, WFDIS_S, DISC_3_S, SA_HP_S, DISC_4_S,
  WFTC_S, T_DA_S, DATA_S, SA_DA_S, T_HP_S, CONF_S, WFAR_S, AR_S]
 (IDLE_S)
 [Sa_CONN_req_S, Sa_DISC_req_S, T_DISC_ind_S, Sa_HPDATA_req_S, T_DATA_ind_S, T_CONN_conf_S, Sa_DATA_req_S, T_HPDATA_ind_S]
 [T_CONN_req_S, T_DISC_req_S, Sa_DISC_ind_S, T_HPDATA_req_S, Sa_DATA_ind_S, Sa_CONN_conf_S, T_DATA_req_S, Sa_HPDATA_ind_S]
 [e]
 [IDLE_S->(Sa_CONN_req_S)CONN_S,
  CONN_S->(T_CONN_req_S)WFTC_S, CONN_S->(e)DISC_1_S,
  DISC_1_S->(Sa_DISC_ind_S)IDLE_S,
  WFTC_S->(Sa_DISC_req_S)WFDIS_S, WFTC_S->(T_DISC_ind_S)DISC_1_S,
  WFDIS_S->(T_DISC_req_S)IDLE_S,
  WFTC_S->(T_CONN_conf_S)CONF_S,
  CONF_S->(T_DISC_req_S)DISC_1_S, CONF_S->(T_DATA_req_S)WFAR_S,
  WFAR_S->(T_DISC_ind_S)DISC_1_S, WFAR_S->(Sa_DISC_req_S)DISC_2_S,
  WFAR_S->(T_DATA_ind_S)AR_S,
  AR_S->(Sa_DISC_ind_S)DISC_2_S, AR_S->(Sa_CONN_conf_S)DATA_S,
  DATA_S->(Sa_DISC_req_S)DISC_2_S, DISC_2_S->(T_DISC_req_S)IDLE_S,
  DATA_S->(T_DISC_ind_S)DISC_4_S, DISC_4_S->(Sa_DISC_ind_S)IDLE_S,
  DATA_S->(Sa_HPDATA_req_S)SA_HP_S, SA_HP_S->(T_HPDATA_req_S)DATA_S,
  DATA_S->(T_DATA_ind_S)T_DA_S, T_DA_S->(Sa_DATA_ind_S)DATA_S,
  DATA_S->(Sa_DATA_req_S)SA_DA_S, SA_DA_S->(T_DATA_req_S)DATA_S,
  DATA_S->(T_HPDATA_ind_S)T_HP_S, T_HP_S->(Sa_HPDATA_ind_S)DATA_S,
  T_DA_S->(Sa_DISC_ind_S)DISC_3_S, DISC_3_S->(T_DISC_req_S)IDLE_S]".

Eval compute in IAutomaton.b_compatible P1 P2_synthesis. (* true *)
Eval compute in IAutomaton.b_compatible P2_synthesis P3. (* true *)

(* the S-side composition *)
Definition P23'': IA := IAutomaton.composition P2_synthesis P3.

Eval compute in IAutomaton.b_compatible P1 P23''. (* true *)

Definition P123: IA := IAutomaton.composition P1 P23''.
Eval compute in :> P123.

(* the F-side composition *)
Eval compute in IAutomaton.b_compatible P3 P4. (*true*)
Eval compute in IAutomaton.b_compatible P4 P5. (*true*)

Definition P45: IA := IAutomaton.composition P4 P5.

Eval compute in IAutomaton.b_compatible P3 P45. (*true*)

Definition P345: IA := IAutomaton.composition P3 P45.

Eval compute in :> P345.


Definition even (n : nat) : Prop :=
  exists p, n = 2 * p.

Definition prime (n : nat) : Prop :=
  n >= 2 /\
  forall p q, n = p * q -> p = n \/ p = 1.

(* Lemma bogus : (2 : {x : nat & prime x}). *)

Lemma fixed : exists y : {x : nat & prime x}, 2 = projT1 y.
Proof. Admitted.

Lemma prime_two : prime 2.
Proof. unfold prime. split.
  {  }

Check even 1.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e384m2e128m2e96p2e32m1_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e369m25_15limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Data.Nat.
Require Import ExtLib.Data.Bool.
Require Import ExtLib.Data.String.
Require Import ExtLib.Tactics.
Require Import ExtLib.Tactics.Consider.

Require Import MirrorCore.TypesI.
Require Import MirrorCore.syms.SymEnv.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.SymI.
Require Import MirrorCore.syms.SymSum.

Require Import Charge.Logics.ILogic.
Require Import Charge.Logics.BILogic.
Require Import Charge.ModularFunc.Denotation.
Require Import Charge.ModularFunc.ILogicFunc.

Require Import Coq.Strings.String.
Require Import Coq.Bool.Bool.
Require Import FunctionalExtensionality.

Set Implicit Arguments.
Set Strict Implicit.
Set Maximal Implicit Insertion.

Inductive bilfunc typ :=
  | bilf_emp (logic : typ)
  | bilf_star (logic : typ)
  | bilf_wand (logic : typ).

Definition bilfunc_logic typ (x : bilfunc typ) : typ :=
  match x with
    | bilf_emp t => t
    | bilf_star t => t
    | bilf_wand t => t
  end.

Class BILogicFunc (typ func : Type) := {
  fEmp : typ -> func;
  fStar : typ -> func;
  fWand : typ -> func;
  bilogicS : func -> option (bilfunc typ)
}.

Section BILogicFuncSum.
	Context {typ func : Type} {H : BILogicFunc typ func}.

	Global Instance BILogicFuncSumL (A : Type) :
		BILogicFunc typ (func + A) := {
		  fEmp l := inl (fEmp l);
		  fStar l := inl (fStar l);
		  fWand l := inl (fWand l);
		  bilogicS f := match f with
		  				  | inl a => bilogicS a
		  				  | _     => None
		  				end
       }.

	Global Instance BILogicFuncSumR (A : Type) :
		BILogicFunc typ (A + func) := {
		  fEmp l := inr (fEmp l);
		  fStar l := inr (fStar l);
		  fWand l := inr (fWand l);
		  bilogicS f := match f with
		  				  | inr a => bilogicS a
		  				  | _     => None
		  				end
       }.

	Global Instance BILogicFuncExpr :
		BILogicFunc typ (expr typ func) := {
		  fEmp l := Inj (fEmp l);
		  fStar l := Inj (fStar l);
		  fWand l := Inj (fWand l);
		  bilogicS f := match f with
		  				  | Inj a => bilogicS a
		  				  | _ => None
		  				end
        }.

End BILogicFuncSum.

Section BILogicFuncInst.

	Context {typ func : Type}.
	Context {HR : RType typ} {Heq : RelDec (@eq typ)} {HC : RelDec_Correct Heq}.

    Context {Typ2_tyArr : Typ2 _ Fun}.
    Context {Typ0_tyProp : Typ0 _ Prop}.

    Context {Typ2Ok_tyArr : Typ2Ok Typ2_tyArr}.

    Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.
    Let tyProp : typ := @typ0 _ _ _ _.

	Global Instance BILogicFuncInst : BILogicFunc typ (bilfunc typ) := {
	  fEmp := bilf_emp;
	  fStar := bilf_star;
	  fWand := bilf_wand;
	  bilogicS f := Some f
	}.

  Variable is : logic_ops.

  Definition bilogic_ops := forall (t : typ),
    option (BILOperators (typD t)).
  Definition bilogic_opsOk (l : bilogic_ops) : Prop :=
    forall g, match is g, l g return Prop with
                | Some T, Some U => @BILogic _ T U
                | _, _ => True
              end.

  Variable gs : bilogic_ops.

  Definition bil_pointwise := typ -> bool.

  Definition bil_pointwiseOk (bilp : bil_pointwise) :=
    forall t,
    typ2_match (fun T : Type => Prop) t
    (fun d r : typ =>
    match bilp (tyArr d r) with
      | true =>
        match gs (tyArr d r), gs r with
          | Some BILOps, Some _ =>
            match eq_sym (typ2_cast d r)  in (_ = t) return BILOperators t -> Prop with
              | eq_refl =>
                fun _ =>
                  (forall a, empSP a = empSP) /\
                  (forall (P Q : typD d -> typD r) a, (P ** Q) a = (P a ** Q a)) /\
                  (forall (P Q : typD d -> typD r) a, (wandSP P Q) a = wandSP (P a) (Q a))
            end BILOps
          | _, _ => False
        end
      | false => True
    end) True.

  Lemma bil_pointwise_bilogic (bilp : bil_pointwise) (bilpOk : bil_pointwiseOk bilp) (t u : typ)
    (H : bilp (tyArr t u) = true) : exists BIL, gs (tyArr t u) = Some BIL.
  Proof.
    specialize (bilpOk (tyArr t u)).
    rewrite typ2_match_zeta in bilpOk; [|apply _].
    rewrite H in bilpOk.
    unfold eq_sym in bilpOk.
    revert bilpOk H. unfold tyArr.
    generalize (typ2_cast t u).
    generalize (typ2 t u).
    generalize dependent (typD t).
    generalize dependent (gs u).
    generalize dependent (typD u).
    intros ? ? ? ?.
    generalize dependent (gs t0).
    generalize (typD t0).
    intros; subst.
    forward. eexists. subst. reflexivity.
  Qed.

  Lemma bil_pointwise_bilogic_range (bilp : bil_pointwise) (bilpOk : bil_pointwiseOk bilp) (t u : typ)
    (H : bilp (tyArr t u) = true) : exists BIL, gs u = Some BIL.
  Proof.
    specialize (bilpOk (tyArr t u)).
    rewrite typ2_match_zeta in bilpOk; [|apply _].
    rewrite H in bilpOk.
    unfold eq_sym in bilpOk.
    revert bilpOk H. unfold tyArr.
    generalize (typ2_cast t u).
    generalize (typ2 t u).
    generalize dependent (typD t).
    generalize dependent (gs u).
    generalize dependent (typD u).
    intros ? ? ? ?.
    generalize dependent (gs t0).
    generalize (typD t0).
    intros; subst.
    forward. eexists. subst. reflexivity.
  Qed.

  Lemma bil_pointwise_empD (bilp : bil_pointwise) (bilpOk : bil_pointwiseOk bilp) (t u : typ)
    (H : bilp (tyArr t u) = true) BIL1 BIL2
    (gstu : gs (tyArr t u) = Some BIL1) (gsu : gs u = Some BIL2) a :
    (tyArrD empSP) a = empSP.
  Proof.
    unfold tyArrD, tyArrD', trmD, funE, eq_rect, id.
    specialize (bilpOk (tyArr t u)).
    rewrite typ2_match_zeta in bilpOk; [|apply _].
    rewrite H in bilpOk.
    unfold eq_sym in bilpOk.
    revert bilpOk.
    rewrite gstu.
    rewrite gsu.
    clear.
    generalize (typ2_cast t u).
    revert BIL1 BIL2.
    unfold tyArr.
    generalize dependent (typD (typ2 t u)).
    generalize dependent (typD t).
    generalize dependent (typD u).
    intros; subst.
    destruct bilpOk as [HEmp _].
    apply HEmp.
  Qed.

  Lemma bil_pointwise_empR (bilp : bil_pointwise) (bilpOk : bil_pointwiseOk bilp) (t u : typ)
    (H : bilp (tyArr t u) = true) BIL1 BIL2
    (gstu : gs (tyArr t u) = Some BIL1) (gsu : gs u = Some BIL2) :
    tyArrR (fun _ => empSP) = empSP.
  Proof.
    unfold tyArrR, tyArrR', trmR, funE, eq_rect_r, eq_rect, eq_sym, id.
    specialize (bilpOk (tyArr t u)).
    rewrite typ2_match_zeta in bilpOk; [|apply _].
    rewrite H in bilpOk.
    unfold eq_sym in bilpOk.
    revert bilpOk.
    rewrite gstu.
    rewrite gsu.
    clear.
    generalize (typ2_cast t u).
    revert BIL1 BIL2.
    unfold tyArr.
    generalize dependent (typD (typ2 t u)).
    generalize dependent (typD t).
    generalize dependent (typD u).
    intros; subst.
    destruct bilpOk as [HEmp _].
    unfold Fun in *.
	apply functional_extensionality; intros; rewrite HEmp; reflexivity.
  Qed.

  Lemma bil_pointwise_starD (bilp : bil_pointwise) (bilpOk : bil_pointwiseOk bilp) (t u : typ)
    (H : bilp (tyArr t u) = true) BIL1 BIL2
    (gstu : gs (tyArr t u) = Some BIL1) (gsu : gs u = Some BIL2) (a b : typD (tyArr t u)) s :
    (tyArrD (sepSP a b)) s = sepSP (tyArrD a s) (tyArrD b s).
  Proof.
    unfold tyArrD, tyArrD', trmD, funE, eq_rect, id.
    specialize (bilpOk (tyArr t u)).
    rewrite typ2_match_zeta in bilpOk; [|apply _].
    rewrite H in bilpOk.
    unfold eq_sym in bilpOk.
    revert bilpOk.
    rewrite gstu.
    rewrite gsu.
    clear.
    generalize (typ2_cast t u).
    revert BIL1 BIL2 a b.
    unfold tyArr.
    generalize dependent (typD (typ2 t u)).
    generalize dependent (typD t).
    generalize dependent (typD u).
    intros; subst.
    destruct bilpOk as [_ [HStar _]].
    apply HStar.
  Qed.

  Lemma bil_pointwise_starR (bilp : bil_pointwise) (bilpOk : bil_pointwiseOk bilp) (t u : typ)
    (H : bilp (tyArr t u) = true) BIL1 BIL2
    (gstu : gs (tyArr t u) = Some BIL1) (gsu : gs u = Some BIL2) (a b : typD t -> typD u) :
    (tyArrR (fun s => sepSP (a s) (b s))) = sepSP (tyArrR a) (tyArrR b).
  Proof.
    unfold tyArrR, tyArrR', trmR, funE, eq_rect_r, eq_rect, eq_sym, id.
    specialize (bilpOk (tyArr t u)).
    rewrite typ2_match_zeta in bilpOk; [|apply _].
    rewrite H in bilpOk.
    unfold eq_sym in bilpOk.
    revert bilpOk.
    rewrite gstu.
    rewrite gsu.
    clear.
    generalize (typ2_cast t u).
    revert BIL1 BIL2.
    unfold tyArr.
    generalize dependent (typD (typ2 t u)).
    generalize dependent (typD t).
    generalize dependent (typD u).
    intros; subst.
    destruct bilpOk as [_ [HStar _]].
	apply functional_extensionality; intros; rewrite HStar; reflexivity.
  Qed.

  Lemma bil_pointwise_wandD (bilp : bil_pointwise) (bilpOk : bil_pointwiseOk bilp) (t u : typ)
    (H : bilp (tyArr t u) = true) BIL1 BIL2
    (gstu : gs (tyArr t u) = Some BIL1) (gsu : gs u = Some BIL2) (a b : typD (tyArr t u)) s :
    (tyArrD (wandSP a b)) s = wandSP (tyArrD a s) (tyArrD b s).
  Proof.
    unfold tyArrD, tyArrD', trmD, funE, eq_rect, id.
    specialize (bilpOk (tyArr t u)).
    rewrite typ2_match_zeta in bilpOk; [|apply _].
    rewrite H in bilpOk.
    unfold eq_sym in bilpOk.
    revert bilpOk.
    rewrite gstu.
    rewrite gsu.
    clear.
    generalize (typ2_cast t u).
    revert BIL1 BIL2 a b.
    unfold tyArr.
    generalize dependent (typD (typ2 t u)).
    generalize dependent (typD t).
    generalize dependent (typD u).
    intros; subst.
    destruct bilpOk as [_ [_ HWand]].
    apply HWand.
  Qed.

  Lemma bil_pointwise_wandR (bilp : bil_pointwise) (bilpOk : bil_pointwiseOk bilp) (t u : typ)
    (H : bilp (tyArr t u) = true) BIL1 BIL2
    (gstu : gs (tyArr t u) = Some BIL1) (gsu : gs u = Some BIL2) (a b : typD t -> typD u) :
    (tyArrR (fun s => wandSP (a s) (b s))) = wandSP (tyArrR a) (tyArrR b).
  Proof.
    unfold tyArrR, tyArrR', trmR, funE, eq_rect_r, eq_rect, eq_sym, id.
    specialize (bilpOk (tyArr t u)).
    rewrite typ2_match_zeta in bilpOk; [|apply _].
    rewrite H in bilpOk.
    unfold eq_sym in bilpOk.
    revert bilpOk.
    rewrite gstu.
    rewrite gsu.
    clear.
    generalize (typ2_cast t u).
    revert BIL1 BIL2.
    unfold tyArr.
    generalize dependent (typD (typ2 t u)).
    generalize dependent (typD t).
    generalize dependent (typD u).
    intros; subst.
    destruct bilpOk as [_ [_ HWand]].
	apply functional_extensionality; intros; rewrite HWand; reflexivity.
  Qed.

  Definition typeof_bilfunc (f : bilfunc typ) : option typ :=
    match f with
      | bilf_emp t => match gs t with
  				   	     | Some _ => Some t
				  	     | None => None
  					   end
      | bilf_star t
      | bilf_wand t => match gs t with
				  	     | Some _ => Some (tyArr t (tyArr t t))
				  	     | None => None
				  	  end
  	end.

  Global Instance RelDec_bilfunc : RelDec (@eq (bilfunc typ)) :=
  { rel_dec := fun a b =>
	         match a, b with
		   | bilf_emp t, bilf_emp t'
		   | bilf_star t, bilf_star t'
		   | bilf_wand t, bilf_wand t' => t ?[eq] t'
		   | _, _ => false
	         end
  }.

  Global Instance RelDec_Correct_bilfunc : RelDec_Correct RelDec_bilfunc.
  Proof.
    constructor.
    destruct x; destruct y; simpl;
    repeat rewrite rel_dec_correct; intuition congruence.
  Qed.

 Definition empD t BIL := @empSP (typD t) BIL.
 Definition starD t BIL := tyArrR2 (@sepSP (typD t) BIL).
 Definition wandD t BIL := tyArrR2 (@wandSP (typD t) BIL).

 Definition funcD (f : bilfunc typ) : match typeof_bilfunc f with
							       | Some t => typD t
							       | None => unit
							      end :=
    match f as f
          return match typeof_bilfunc f with
		   | Some t => typD t
		   | None => unit
		 end
    with
      | bilf_emp t =>
        match gs t as x
          return (match match x with
                          | Some _ => Some t
                          | None => None
                        end with
                    | Some t0 => typD t0
                    | None => unit
                  end) with
        | Some BIL => empD _ BIL
        | None => tt
        end
      | bilf_star t =>
        match gs t as x
              return (match match x with
			      | Some _ => Some (tyArr t (tyArr t t))
			      | None => None
			    end with
			| Some t0 => typD t0
			| None => unit
		      end) with
	  | Some t => starD _ t
	  | None => tt
        end
      | bilf_wand t =>
        match gs t as x
              return (match match x with
			      | Some _ => Some (tyArr t (tyArr t t))
			      | None => None
			    end with
			| Some t0 => typD t0
			| None => unit
		      end) with
	  | Some t => wandD _ t
	  | None => tt
        end
    end.

  Global Instance RSym_bilfunc : SymI.RSym (bilfunc typ) :=
  { typeof_sym := typeof_bilfunc
  ; sym_eqb := fun a b => Some (rel_dec a b)
  ; symD := funcD
  }.

  Global Instance RSymOk_bilfunc : SymI.RSymOk RSym_bilfunc.
  Proof.
    constructor.
    intros. unfold sym_eqb; simpl.
    consider (a ?[ eq ] b); auto.
  Qed.

End BILogicFuncInst.

Section MakeBILogic.
	Context {typ func : Type} {H : BILogicFunc typ func}.

	Definition mkEmp t : expr typ func:= Inj (fEmp t).
	Definition mkStar (t : typ) (P Q : expr typ func) := App (App (fStar t) P) Q.
	Definition mkWand (t : typ) (P Q : expr typ func) := App (App (fWand t) P) Q.

End MakeBILogic.

Section BILogicFuncOk.
  Context {typ func : Type} {HO: BILogicFunc typ func}.
  Context {RType_typ : RType typ} {RSym_func : RSym func}.
  Context {RelDec_eq : RelDec (@eq typ)}.

  Context {Typ2_tyArr : Typ2 _ Fun}.
  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.

  Variable gs : bilogic_ops.

  Class BILogicFuncOk := {
    bilf_funcAsOk (f : func) e : bilogicS f = Some e ->
      forall t, funcAs f t = funcAs (RSym_func := RSym_bilfunc gs) e t;
    bilf_fEmpOk t : bilogicS (fEmp t) = Some (bilf_emp t);
    bilf_fStarOk t : bilogicS (fStar t) = Some (bilf_star t);
    bilf_fWandOk t : bilogicS (fWand t) = Some (bilf_wand t)
  }.

End BILogicFuncOk.

Implicit Arguments BILogicFuncOk [[HO] [RType_typ] [RSym_func] [RelDec_eq] [Typ2_tyArr]].

Section BILogicFuncBaseOk.
  Context {typ func : Type} {HO: ILogicFunc typ func}.
  Context {RType_typ : RType typ} {RSym_func : RSym func}.
  Context {RelDec_eq : RelDec (@eq typ)}.

  Context {Typ2_tyArr : Typ2 _ Fun}.
  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.

  Variable gs : bilogic_ops.

  Global Program Instance BILogicFuncBaseOk : BILogicFuncOk (RSym_func := RSym_bilfunc gs) typ (bilfunc typ) gs := {
    bilf_funcAsOk := fun _ _ _ _ => eq_refl;
    bilf_fEmpOk t := eq_refl;
    bilf_fStarOk t := eq_refl;
    bilf_fWandOk t := eq_refl
  }.

End BILogicFuncBaseOk.

Section BILogicFuncExprOk.
  Context {typ func : Type} `{HOK : BILogicFuncOk typ func}.
  Context {HROk : RTypeOk}.
  Context {A : Type} {RSymA : RSym A}.

  Context {Typ2Ok_tyArr : Typ2Ok Typ2_tyArr}.
  Context {RSymOk_func : RSymOk RSym_func0}.

  Lemma BILogicFunc_typeOk (f : func) (e : bilfunc typ) (H : bilogicS f = Some e) :
    typeof_sym f = typeof_bilfunc gs e.
  Proof.
    admit.
    (*
    destruct HOK as [H1 H2 _ _ _ _ _ _ _].
    specialize (H1 _ _ H).
    destruct e; simpl in *;
    remember (gs logic) as o;
    destruct o; try
    match goal with
      | |- typeof_sym ?f = Some ?t =>
	 	specialize (H1 t);
	 	simpl in H1;
	 	unfold funcAs in H1; simpl in H1; rewrite <- Heqo, type_cast_refl in H1; [|apply _];
	 	generalize dependent (symD f);
	 	destruct (typeof_sym f); simpl; intros; [forward|]; inversion H1
 	end;
 	unfold funcAs in H1; simpl in H1; unfold empD in H1; rewrite <- Heqo in H1;
 	generalize dependent (symD f);
 	remember (typeof_sym f).
 	(destruct o; intros; [|]). specialize (H1 logic). forward. inv_all; subst.
 	specialize (H1 t); (rewrite type_cast_refl in H1; [|apply _]);
 	inversion H1.
*)
  Qed.

  Lemma bilogicS_is_bilogic (f : func) (e : bilfunc typ) t df
  	(H1 : bilogicS f = Some e) (H2 : funcAs f t = Some df) :
    exists IL, gs (bilfunc_logic e) = Some IL.
  Proof.
    admit.
    (*
    pose proof (bilf_funcAsOk _ H1) as H;
    rewrite H in H2; clear H;
    destruct e; simpl in *;
    unfold funcAs in H2; simpl in H2;
    (destruct (gs logic); [eexists; reflexivity | congruence]).
*)
  Qed.

  Lemma bilf_emp_func_type_eq (f : func) t u df
    (H1 : bilogicS f = Some (bilf_emp t)) (H2 : funcAs f u = Some df) :
    t = u.
  Proof.
    rewrite (bilf_funcAsOk _ H1) in H2.
    unfold funcAs, empD in H2; simpl in *.
    forward.
  Qed.

  Lemma bilf_wand_func_type_eq (f : func) t u df
    (H1 : bilogicS f = Some (bilf_wand t)) (H2 : funcAs f u = Some df) :
    u = typ2 t (typ2 t t).
  Proof.
    rewrite (bilf_funcAsOk _ H1) in H2.
    unfold funcAs, wandD in H2; simpl in *.
    forward.
  Qed.

  Lemma bilf_star_func_type_eq (f : func) t u df
    (H1 : bilogicS f = Some (bilf_star t)) (H2 : funcAs f u = Some df) :
    u = typ2 t (typ2 t t).
  Proof.
    rewrite (bilf_funcAsOk _ H1) in H2.
    unfold funcAs, starD in H2; simpl in *.
    forward.
  Qed.

  Lemma bilf_emp_type_eq tus tvs (e : expr typ func) t u df
    (H1 : bilogicS e = Some (bilf_emp t)) (H2 : exprD' tus tvs u e = Some df) :
    t = u.
  Proof.
    destruct e; simpl in *; try congruence.
    autorewrite with exprD_rw in H2; simpl in H2; forward; inv_all; subst.
    eapply bilf_emp_func_type_eq; eassumption.
  Qed.

  Lemma bilf_wand_type_eq tus tvs (e : expr typ func) t u df
    (H1 : bilogicS e = Some (bilf_wand t)) (H2 : exprD' tus tvs u e = Some df) :
    u = typ2 t (typ2 t t).
  Proof.
    destruct e; simpl in *; try congruence.
    autorewrite with exprD_rw in H2; simpl in H2; forward; inv_all; subst.
    eapply bilf_wand_func_type_eq; eassumption.
  Qed.

  Lemma bilf_star_type_eq tus tvs (e : expr typ func) t u df
    (H1 : bilogicS e = Some (bilf_star t)) (H2 : exprD' tus tvs u e = Some df) :
    u = typ2 t (typ2 t t).
  Proof.
    destruct e; simpl in *; try congruence.
    autorewrite with exprD_rw in H2; simpl in H2; forward; inv_all; subst.
    eapply bilf_star_func_type_eq; eassumption.
  Qed.

  Existing Instance RSym_sum.

  Global Program Instance ILogicFuncOkSumR : BILogicFuncOk typ ((A + func)%type) gs := {
    bilf_funcAsOk :=
      fun a f H t =>
        match a with
          | inl b => _
          | inr b => _
        end;
    bilf_fEmpOk t := bilf_fEmpOk (func := func) t;
    bilf_fStarOk t := bilf_fStarOk (func := func) t;
    bilf_fWandOk t := bilf_fWandOk (func := func) t
  }.
  Next Obligation.
    apply (bilf_funcAsOk (func := func)).
    apply H.
  Qed.

  Global Program Instance ILogicFuncOkSumL : BILogicFuncOk typ ((func + A)%type) gs := {
    bilf_funcAsOk :=
      fun a f H t =>
        match a with
          | inl b => _
          | inr b => _
        end;
    bilf_fEmpOk t := bilf_fEmpOk (func := func) t;
    bilf_fStarOk t := bilf_fStarOk (func := func) t;
    bilf_fWandOk t := bilf_fWandOk (func := func) t
  }.
  Next Obligation.
    apply (bilf_funcAsOk (func := func)).
    apply H.
  Qed.

End BILogicFuncExprOk.

Section MakeBILogicSound.
  Context {typ func : Type} `{HOK : BILogicFuncOk typ func}.
  Context {HROk : RTypeOk} {Typ2_tyArrOk : Typ2Ok Typ2_tyArr}
          {RSym_funcOk : RSymOk RSym_func0}.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.

  Lemma bilf_emp_func_eq (t : typ) (f : func) (df : typD t) BIL
    (H : gs t = Some BIL)
    (Ho : bilogicS f = Some (bilf_emp t))
    (Hf : funcAs f t = Some df) :
    df = empSP.
  Proof.
   rewrite (bilf_funcAsOk _ Ho) in Hf.
   unfold funcAs in Hf; simpl in *.
   rewrite H in Hf.
   rewrite type_cast_refl in Hf; [|apply HROk].
   unfold Rcast, Relim_refl in Hf.
   inversion Hf. reflexivity.
  Qed.

  Lemma bilf_emp_eq tus tvs (t : typ) (e : expr typ func) (df : ExprI.exprT tus tvs (typD t)) BIL
    (H : gs t = Some BIL)
    (Ho : bilogicS e = Some (bilf_emp t))
    (Hf : exprD' tus tvs t e = Some df) :
    df = fun us vs => empSP.
  Proof.
   destruct e; simpl in *; try congruence.
   autorewrite with exprD_rw in Hf; simpl in Hf; forward; inv_all; subst.
   erewrite <- bilf_emp_func_eq; try eassumption; reflexivity.
  Qed.

  Lemma bilf_star_func_eq (t : typ) (f : func) (df : typD (tyArr t (tyArr t t))) BIL
    (H : gs t = Some BIL)
    (Ho : bilogicS f = Some (bilf_star t))
    (Hf : funcAs f (tyArr t (tyArr t t)) = Some df) :
    df = starD t _.
  Proof.
   rewrite (bilf_funcAsOk _ Ho) in Hf.
   unfold funcAs in Hf; simpl in *.
   rewrite H in Hf.
   rewrite type_cast_refl in Hf; [|apply HROk].
   unfold Rcast, Relim_refl in Hf.
   inversion Hf. reflexivity.
  Qed.

  Lemma bilf_star_eq tus tvs (t : typ) (e : expr typ func)
    (df : ExprI.exprT tus tvs (typD (tyArr t (tyArr t t)))) BIL
    (H : gs t = Some BIL)
    (Ho : bilogicS e = Some (bilf_star t))
    (Hf : exprD' tus tvs (tyArr t (tyArr t t)) e = Some df) :
    df = fun us vs => starD t _.
  Proof.
   destruct e; simpl in *; try congruence.
   autorewrite with exprD_rw in Hf; simpl in Hf; forward; inv_all; subst.
   erewrite <- bilf_star_func_eq; try eassumption; reflexivity.
  Qed.

  Lemma bilf_wand_func_eq (t : typ) (f : func) (df : typD (tyArr t (tyArr t t))) BIL
    (H : gs t = Some BIL)
    (Ho : bilogicS f = Some (bilf_wand t))
    (Hf : funcAs f (tyArr t (tyArr t t)) = Some df) :
    df = wandD t _.
  Proof.
   rewrite (bilf_funcAsOk _ Ho) in Hf.
   unfold funcAs in Hf; simpl in *.
   rewrite H in Hf.
   rewrite type_cast_refl in Hf; [|apply HROk].
   unfold Rcast, Relim_refl in Hf.
   inversion Hf. reflexivity.
  Qed.

  Lemma bilf_wand_eq tus tvs (t : typ) (e : expr typ func)
    (df : ExprI.exprT tus tvs (typD (tyArr t (tyArr t t)))) BIL
    (H : gs t = Some BIL)
    (Ho : bilogicS e = Some (bilf_wand t))
    (Hf : exprD' tus tvs (tyArr t (tyArr t t)) e = Some df) :
    df = fun us vs => wandD t _.
  Proof.
   destruct e; simpl in *; try congruence.
   autorewrite with exprD_rw in Hf; simpl in Hf; forward; inv_all; subst.
   erewrite <- bilf_wand_func_eq; try eassumption; reflexivity.
  Qed.

  Lemma mkEmp_sound (t : typ) (tus tvs : tenv typ) BIL
    (Hgs : gs t = Some BIL) :
    exprD' tus tvs t (mkEmp t) = Some (fun _ _ => empD _ BIL).
  Proof.
    unfold mkEmp; simpl.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    pose proof (bilf_fEmpOk t) as Ho.
    pose proof (bilf_funcAsOk _ Ho) as H.
    rewrite H.
    unfold funcAs. simpl.
    rewrite Hgs, type_cast_refl; [reflexivity | apply _].
  Qed.

  Lemma mkStar_sound (t : typ) (tus tvs : tenv typ) p q BIL
    (dp dq : ExprI.exprT tus tvs (typD t))
    (Hgs : gs t = Some BIL)
    (Hp : exprD' tus tvs t p = Some dp)
    (Hq : exprD' tus tvs t q = Some dq) :
    exprD' tus tvs t (mkStar t p q) = Some (exprT_App (exprT_App (fun _ _ => starD _ BIL) dp) dq).
  Proof.
    unfold mkStar; simpl.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    rewrite (ExprTac.exprD_typeof_Some _ _ _ q _ Hq).
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    rewrite (ExprTac.exprD_typeof_Some _ _ _ p _ Hp).
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    pose proof (bilf_fStarOk t) as Ho.
    pose proof (bilf_funcAsOk _ Ho) as H1.
    rewrite H1. unfold funcAs; simpl.
    rewrite Hgs. rewrite type_cast_refl; [reflexivity | apply _].
  Qed.

  Lemma mkWand_sound (t : typ) (tus tvs : tenv typ) p q BIL
    (dp dq : ExprI.exprT tus tvs (typD t))
    (Hgs : gs t = Some BIL)
    (Hp : exprD' tus tvs t p = Some dp)
    (Hq : exprD' tus tvs t q = Some dq) :
    exprD' tus tvs t (mkWand t p q) = Some (exprT_App (exprT_App (fun _ _ => wandD _ BIL) dp) dq).
  Proof.
    unfold mkWand; simpl.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    rewrite (ExprTac.exprD_typeof_Some _ _ _ q _ Hq).
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    rewrite (ExprTac.exprD_typeof_Some _ _ _ p _ Hp).
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    pose proof (bilf_fWandOk t) as Ho.
    pose proof (bilf_funcAsOk _ Ho) as H1.
    rewrite H1. unfold funcAs; simpl.
    rewrite Hgs. rewrite type_cast_refl; [reflexivity | apply _].
  Qed.

End MakeBILogicSound.


From RecordUpdate Require Import RecordSet.
Import RecordSetNotations.

From Perennial.program_proof Require Import disk_prelude.
From Goose.github_com.mit_pdos.go_journal Require Import addr.

Set Implicit Arguments.

Definition addr : Type := u64 * u64.

Definition addrBlock (a : addr) := fst a.
Definition addrOff (a : addr) := snd a.
Definition Build_addr b o : addr := (b, o).

Notation "a '.(addrBlock)'" := (addrBlock a) (at level 0, only parsing).
Notation "a '.(addrOff)'" := (addrOff a) (at level 0, only parsing).

#[global]
Remove Hints finite.finite_countable : typeclass_instances.

Definition addr2val (a : addr) : val :=
  (#a.(addrBlock), (#a.(addrOff), #())).

Definition addr2flat_z (a : addr) : Z :=
  int.Z a.(addrBlock) * block_bytes * 8 + int.Z a.(addrOff).

Definition addr2flat (a : addr) : u64 :=
  addr2flat_z a.

Definition valid_addr (a : addr) : Prop :=
  int.Z a.(addrOff) < block_bytes*8 ∧
  int.Z a.(addrBlock) * block_bytes < 2^64 ∧
  int.Z a.(addrBlock) * block_bytes * 8 < 2^64 ∧
  addr2flat_z a < 2^64.

Theorem addr2flat_z_eq `(valid_addr a0) `(valid_addr a1) :
  addr2flat a0 = addr2flat a1 →
  addr2flat_z a0 = addr2flat_z a1.
Proof.
  destruct a0, a1.
  unfold addr2flat, valid_addr, addr2flat_z, block_bytes in *.
  simpl in *; intuition.
  apply (f_equal int.Z) in H.
  revert H.
  word.
Qed.

Theorem addr2flat_eq `(valid_addr a0) `(valid_addr a1) :
  addr2flat a0 = addr2flat a1 →
  a0 = a1.
Proof.
  intros.
  eapply addr2flat_z_eq in H; eauto.
  destruct a0, a1.
  unfold valid_addr, addr2flat_z, block_bytes in *.
  simpl in *.
  intuition.
  replace u0 with u2 in *.
  { replace u with u1; auto.
    assert (int.Z u * Z.to_nat 4096 * 8 = int.Z u1 * Z.to_nat 4096 * 8) by lia.
    word.
  }
  word.
Qed.

Theorem addr2flat_ne `(valid_addr a0) `(valid_addr a1) :
  a0 ≠ a1 ->
  addr2flat a0 ≠ addr2flat a1.
Proof.
  intros; intuition.
  apply H.
  eapply addr2flat_eq; eauto.
Qed.

Section flatid2addr.

  Variable (T : Type).

  Definition flatid_addr_map (fm : gmap u64 T) (am : gmap addr T) : Prop :=
    ( ∀ a v, am !! a = Some v -> valid_addr a ∧ fm !! (addr2flat a) = Some v ) ∧
    ( ∀ fa v, fm !! fa = Some v -> ∃ a, valid_addr a ∧ addr2flat a = fa ∧ am !! a = Some v ).

  Theorem flatid_addr_lookup fm am a :
    flatid_addr_map fm am ->
    valid_addr a ->
    fm !! (addr2flat a) = am !! a.
  Proof.
    unfold flatid_addr_map; intros.
    destruct (am !! a) eqn:Heq.
    - apply H; eauto.
    - destruct (fm !! addr2flat a) eqn:Heq2; eauto.
      apply H in Heq2; eauto.
      destruct Heq2; intuition idtac.
      apply addr2flat_eq in H1; eauto; subst.
      congruence.
  Qed.

  Theorem flatid_addr_lookup_valid fm am a :
    flatid_addr_map fm am ->
    is_Some (am !! a) ->
    valid_addr a.
  Proof.
    unfold flatid_addr_map; intros.
    destruct H0. apply H in H0. intuition eauto.
  Qed.

  Theorem flatid_addr_insert fm am a v :
    flatid_addr_map fm am ->
    valid_addr a ->
    flatid_addr_map (<[addr2flat a := v]> fm) (<[a := v]> am).
  Proof.
    rewrite /flatid_addr_map; split; intros.
    - destruct (decide (a = a0)); subst.
      + rewrite lookup_insert in H1; inversion H1; clear H1; subst.
        repeat rewrite -> lookup_insert; eauto.
      + rewrite -> lookup_insert_ne in H1 by eauto.
        apply H in H1; intuition eauto.
        rewrite -> lookup_insert_ne by (apply addr2flat_ne; eauto).
        eauto.
    - destruct (decide (addr2flat a = fa)); subst.
      + rewrite lookup_insert in H1; inversion H1; clear H1; subst.
        eexists.
        repeat rewrite -> lookup_insert; eauto.
      + rewrite -> lookup_insert_ne in H1 by eauto.
        apply H in H1; destruct H1. intuition eauto.
        exists x; intuition eauto.
        rewrite -> lookup_insert_ne; eauto.
        congruence.
  Qed.

  Theorem flatid_addr_insert_inv_2 fm am a v :
    flatid_addr_map fm (<[a := v]> am) ->
      valid_addr a ∧
      fm !! (addr2flat a) = Some v ∧
      flatid_addr_map (delete (addr2flat a) fm) (delete a am).
  Proof.
    intros.
    destruct H.
    edestruct H.
    { erewrite lookup_insert; eauto. }
    intuition eauto.
    split; intros.
    - destruct (decide (a = a0)); subst.
      { rewrite lookup_delete in H3; congruence. }
      rewrite lookup_delete_ne in H3; eauto.
      edestruct H.
      { rewrite lookup_insert_ne; eauto. }
      intuition eauto.
      rewrite lookup_delete_ne; eauto.
      eapply addr2flat_ne; eauto.
    - destruct (decide (addr2flat a = fa)); subst.
      { rewrite lookup_delete in H3; congruence. }
      rewrite lookup_delete_ne in H3; eauto.
      apply H0 in H3. destruct H3.
      exists x. intuition eauto.
      rewrite -> lookup_insert_ne in H6 by congruence.
      rewrite -> lookup_delete_ne by congruence.
      eauto.
  Qed.

  Theorem flatid_addr_insert_inv_1 fm am fa v :
    flatid_addr_map (<[fa := v]> fm) am ->
    ∃ a,
      valid_addr a ∧
      fa = addr2flat a ∧
      am !! a = Some v ∧
      flatid_addr_map (delete fa fm) (delete a am).
  Proof.
    intros.
    destruct H.
    edestruct H0.
    { erewrite lookup_insert; eauto. }
    exists x.
    intuition eauto.
    split; intros.
    - destruct (decide (a = x)); subst.
      { rewrite lookup_delete in H3; congruence. }
      rewrite lookup_delete_ne in H3; eauto.
      edestruct H; eauto.
      intuition eauto.
      rewrite -> lookup_insert_ne in H5 by (apply addr2flat_ne; eauto).
      rewrite lookup_delete_ne; eauto.
      eapply addr2flat_ne; eauto.
    - destruct (decide (fa = fa0)); subst.
      { rewrite lookup_delete in H3; congruence. }
      rewrite lookup_delete_ne in H3; eauto.
      edestruct H0.
      { rewrite lookup_insert_ne; eauto. }
      exists x0; intuition eauto.
      rewrite -> lookup_delete_ne by congruence.
      eauto.
  Qed.

  Theorem flatid_addr_delete fm am a :
    flatid_addr_map fm am ->
    valid_addr a ->
    flatid_addr_map (delete (addr2flat a) fm) (delete a am).
  Proof.
    rewrite /flatid_addr_map; split; intros.
    - destruct (decide (a = a0)); subst.
      + rewrite lookup_delete in H1; congruence.
      + rewrite -> lookup_delete_ne in H1 by eauto.
        apply H in H1; intuition eauto.
        rewrite -> lookup_delete_ne by (apply addr2flat_ne; eauto).
        eauto.
    - destruct (decide (addr2flat a = fa)); subst.
      + rewrite lookup_delete in H1; congruence.
      + rewrite -> lookup_delete_ne in H1 by eauto.
        apply H in H1; destruct H1.
        exists x; intuition eauto.
        rewrite lookup_delete_ne; eauto.
        congruence.
  Qed.

  Theorem flatid_addr_empty :
    flatid_addr_map ∅ ∅.
  Proof.
    unfold flatid_addr_map; split; intros.
    - rewrite lookup_empty in H; congruence.
    - rewrite lookup_empty in H; congruence.
  Qed.

  Theorem flatid_addr_empty_1 m :
    flatid_addr_map ∅ m -> m = ∅.
  Proof.
    unfold flatid_addr_map; intros.
    apply map_empty; intros.
    destruct (m !! i) eqn:He; eauto.
    apply H in He. rewrite lookup_empty in He. intuition congruence.
  Qed.

  Theorem flatid_addr_empty_2 m :
    flatid_addr_map m ∅ -> m = ∅.
  Proof.
    unfold flatid_addr_map; intros.
    apply map_empty; intros.
    destruct (m !! i) eqn:He; eauto.
    apply H in He. destruct He. rewrite lookup_empty in H0. intuition congruence.
  Qed.

  Lemma flatid_addr_map_size fm am :
    flatid_addr_map fm am →
    size fm = size am.
  Proof.
    intros Hflatid.
    generalize dependent am.
    induction fm using map_ind; intros am Hflatid.
    - apply flatid_addr_empty_1 in Hflatid; subst; auto.
    - apply flatid_addr_insert_inv_1 in Hflatid.
      destruct Hflatid as (a & Hvalid & -> & Hamlookup & Hflatid).
      assert (delete (addr2flat a) m = m).
      { rewrite delete_notin //. }
      rewrite H0 in Hflatid.
      rewrite map_size_insert_None //.
      apply IHfm in Hflatid as ->.
      rewrite map_size_delete_Some; eauto.
      assert (0 < size am)%nat.
      { eauto using Map.map_size_nonzero_lookup. }
      lia.
  Qed.

End flatid2addr.

Section map.
  Context {PROP : bi}.
  Context `{Countable K} {A : Type}.

  Theorem big_sepM_flatid_addr_map_1 (Φ : _ -> A -> PROP) fm am :
    flatid_addr_map fm am ->
    ([∗ map] a↦b ∈ am, Φ a b) -∗ [∗ map] fa↦b ∈ fm, ∃ a, ⌜ fa = addr2flat a ⌝ ∗ Φ a b.
  Proof.
    rewrite <- (list_to_map_to_list am).
    pose proof (NoDup_fst_map_to_list am); revert H0.
    generalize (map_to_list am); intros l H0.
    clear am; intros.
    iIntros "H".

    iInduction l as [|] "IH" forall (fm H0 H1).
    - simpl in *. apply flatid_addr_empty_2 in H1. rewrite H1.
      repeat rewrite big_sepM_empty. done.
    - simpl in *. inversion H0; clear H0; subst.
      apply flatid_addr_insert_inv_2 in H1; intuition idtac.
      iDestruct (big_sepM_insert_delete with "H") as "[Ha H]".
      erewrite <- (insert_id fm) by eauto.
      iApply big_sepM_insert_delete.
      iSplitL "Ha".
      { iExists _; iFrame. done. }
      rewrite delete_notin.
      2: { apply not_elem_of_list_to_map_1; eauto. }
      rewrite -> (delete_notin (list_to_map _)) in H3.
      2: { apply not_elem_of_list_to_map_1; eauto. }
      iDestruct ("IH" $! _ H5 H3 with "H") as "H".
      iFrame.
  Qed.

  Theorem big_sepM_flatid_addr_map_2 (Φ : _ -> A -> PROP) fm am :
    flatid_addr_map fm am ->
    ([∗ map] fa↦b ∈ fm, Φ fa b) -∗ [∗ map] a↦b ∈ am, Φ (addr2flat a) b.
  Proof.
    rewrite <- (list_to_map_to_list fm).
    pose proof (NoDup_fst_map_to_list fm); revert H0.
    generalize (map_to_list fm); intros l H0.
    clear fm; intros.
    iIntros "H".

    iInduction l as [|] "IH" forall (am H0 H1).
    - simpl in *. apply flatid_addr_empty_1 in H1. rewrite H1.
      repeat rewrite big_sepM_empty. done.
    - simpl in *. inversion H0; clear H0; subst.
      apply flatid_addr_insert_inv_1 in H1; destruct H1; intuition subst.
      iDestruct (big_sepM_insert_delete with "H") as "[Ha H]".
      erewrite <- (insert_id am) by eauto.
      iApply big_sepM_insert_delete.
      iSplitL "Ha".
      { rewrite H0. iFrame. }
      rewrite delete_notin.
      2: { apply not_elem_of_list_to_map_1; eauto. }
      rewrite -> (delete_notin (list_to_map _)) in H6.
      2: { apply not_elem_of_list_to_map_1; eauto. }
      iDestruct ("IH" $! _ H5 H6 with "H") as "H".
      iFrame.
  Qed.

End map.

Section gmap_addr_by_block.

  Variable (T : Type).

  Definition gmap_addr_by_block (m : gmap addr T) : gmap u64 (gmap u64 T) :=
    gmap_curry m.

  Theorem gmap_addr_by_block_empty :
    gmap_addr_by_block ∅ = ∅.
  Proof.
    rewrite /gmap_addr_by_block /gmap_curry.
    apply map_fold_empty.
  Qed.

  Theorem gmap_addr_by_block_insert (m : gmap addr T) (a : addr) (v : T) :
    m !! a = None ->
    gmap_addr_by_block (<[a:=v]> m) =
      <[a.(addrBlock) :=
        <[a.(addrOff) := v]> (default ∅ ((gmap_addr_by_block m) !! a.(addrBlock)))]>
      (gmap_addr_by_block m).
  Proof.
    intros.
    destruct a as [b o].
    rewrite /gmap_addr_by_block.
    rewrite gmap_curry_insert; eauto.
  Qed.

  Theorem gmap_addr_by_block_filter (m : gmap addr T) (P : u64 -> Prop)
      `{! ∀ blkno, Decision (P blkno)} :
    gmap_addr_by_block (filter (λ x, P (fst x).(addrBlock)) m) =
    filter (λ x, P (fst x)) (gmap_addr_by_block m).
  Proof.
    induction m using map_ind.
    - rewrite /gmap_addr_by_block /gmap_curry.
      rewrite map_filter_empty.
      rewrite map_fold_empty.
      rewrite map_filter_empty. eauto.
    - destruct i as [b o].
      rewrite gmap_addr_by_block_insert; eauto; simpl.
      destruct (decide (P b)).
      2: {
        rewrite map_filter_insert_not; eauto.
        rewrite map_filter_insert_not; eauto.
      }

      rewrite map_filter_insert_True; eauto.
      rewrite map_filter_insert_True; eauto.
      rewrite -IHm; clear IHm.
      rewrite gmap_addr_by_block_insert; eauto; simpl.
      2: { rewrite map_filter_lookup_None; eauto. }

      f_equal. f_equal. f_equal.
      rewrite /gmap_addr_by_block.

      clear H0.
      induction m using map_ind.
      + rewrite map_filter_empty. eauto.
      + destruct (decide (P (addrBlock i))).
        * rewrite map_filter_insert_True; eauto.
          repeat rewrite gmap_curry_insert; eauto.
          2: rewrite map_filter_lookup_None; eauto.
          destruct (decide (i.1 = b)); subst.
          { repeat rewrite lookup_insert. f_equal. f_equal. rewrite IHm. eauto. }
          repeat rewrite lookup_insert_ne; eauto.
        * rewrite map_filter_insert_not; eauto. rewrite IHm.
          rewrite gmap_curry_insert; eauto.
          destruct (decide (i.1 = b)); subst.
          { exfalso. apply n. eauto. }
          rewrite lookup_insert_ne; eauto.
  Qed.

  Theorem gmap_addr_by_block_off_not_empty (m : gmap addr T) (blkno : u64) (offmap : gmap u64 T) :
    gmap_addr_by_block m !! blkno = Some offmap ->
    offmap ≠ ∅.
  Proof.
    intros. eapply gmap_curry_non_empty. eauto.
  Qed.

  Theorem gmap_addr_by_block_lookup (m : gmap addr T) (a : addr) (v : T) :
    m !! a = Some v ->
    ∃ offmap,
      gmap_addr_by_block m !! a.(addrBlock) = Some offmap ∧
      offmap !! a.(addrOff) = Some v.
  Proof.
    intros.
    rewrite /gmap_addr_by_block.
    apply gmap_curry_lookup_exists. eauto.
  Qed.

  Context {PROP : bi}.

  Theorem gmap_addr_by_block_big_sepM (m : gmap addr T) (Φ : addr -> T -> PROP) :
    ( [∗ map] a ↦ v ∈ m, Φ a v ) -∗
    ( [∗ map] blkno ↦ offmap ∈ gmap_addr_by_block m,
        [∗ map] off ↦ v ∈ offmap, Φ (Build_addr blkno off) v ).
  Proof.
    iIntros "Hm".
    iInduction m as [|i x m] "IH" using map_ind.
    - rewrite gmap_addr_by_block_empty. iApply big_sepM_empty. done.
    - iDestruct (big_sepM_insert with "Hm") as "[Hi Hm]"; eauto.
      iDestruct ("IH" with "Hm") as "Hm".
      rewrite gmap_addr_by_block_insert; eauto.
      destruct i as [b o].
      destruct (gmap_addr_by_block m !! b) eqn:He.
      + iDestruct (big_sepM_insert_acc with "Hm") as "[Hb Hm]"; eauto.
        iApply "Hm".
        iApply big_sepM_insert.
        { simpl.
          pose proof (lookup_gmap_curry m b o).
          rewrite H in H0. rewrite He in H0. simpl in H0.
          rewrite He. simpl. eauto. }
        rewrite He. iFrame.
      + iApply big_sepM_insert; eauto.
        iFrame.
        rewrite He /=.
        iApply big_sepM_insert; eauto. iFrame.
        iApply big_sepM_empty. done.
  Qed.

  Theorem gmap_addr_by_block_big_sepM' (m : gmap addr T) (Φ : addr -> T -> PROP) :
    ( [∗ map] blkno ↦ offmap ∈ gmap_addr_by_block m,
        [∗ map] off ↦ v ∈ offmap, Φ (Build_addr blkno off) v ) -∗
    ( [∗ map] a ↦ v ∈ m, Φ a v ).
  Proof.
    iIntros "Hm".
    rewrite /gmap_addr_by_block.
    iInduction m as [|i x m] "IH" using map_ind.
    - iApply big_sepM_empty. done.
    - destruct i as [i0 i1].
      rewrite gmap_curry_insert; eauto; simpl.
      destruct (gmap_curry m !! i0) eqn:He.
      + iDestruct (big_sepM_insert_delete with "Hm") as "[Hi0 Hm]"; simpl.
        iDestruct (big_sepM_insert with "Hi0") as "[Hi1 Hi0]".
        { rewrite -lookup_gmap_curry in H. rewrite He /= in H. done. }
        iApply big_sepM_insert; eauto. iFrame.
        iDestruct (big_sepM_insert_delete with "[$Hm $Hi0]") as "Hm".
        rewrite insert_id; eauto.
        iApply "IH"; iFrame.
      + iDestruct (big_sepM_insert with "Hm") as "[Hi0 Hm]"; eauto; simpl.
        iDestruct (big_sepM_insert with "Hi0") as "[Hi1 _]".
        { rewrite lookup_empty; eauto. }
        iApply big_sepM_insert; eauto. iFrame.
        iApply "IH". iFrame.
  Qed.

  Theorem gmap_addr_by_block_dom_union (m0 m1 : gmap addr T) :
    dom (gmap_addr_by_block (m0 ∪ m1)) =
    dom (gmap_addr_by_block m0) ∪
    dom (gmap_addr_by_block m1).
  Proof.
    rewrite /gmap_addr_by_block.
    eapply set_eq; split; intros.
    - destruct (decide (x ∈ dom (gmap_curry m0))); try set_solver.
      destruct (decide (x ∈ dom (gmap_curry m1))); try set_solver.
      exfalso.
      assert (x ∉ dom (gmap_curry (m0 ∪ m1))); try set_solver.

      apply not_elem_of_dom in n.
      apply not_elem_of_dom in n0.
      apply not_elem_of_dom.

      erewrite lookup_gmap_curry_None in n.
      erewrite lookup_gmap_curry_None in n0.
      erewrite lookup_gmap_curry_None; intros j.
      specialize (n j). specialize (n0 j).
      eapply lookup_union_None; eauto.

    - destruct (decide (x ∈ dom (gmap_curry (m0 ∪ m1)))); try set_solver.
      exfalso.
      assert (x ∉ dom (gmap_curry m0) ∪ dom (gmap_curry m1)); try set_solver.
      apply not_elem_of_dom in n.
      apply not_elem_of_union; split; apply not_elem_of_dom.

      + erewrite lookup_gmap_curry_None; intros j.
        erewrite lookup_gmap_curry_None in n.
        specialize (n j).
        eapply lookup_union_None in n. intuition.

      + erewrite lookup_gmap_curry_None; intros j.
        erewrite lookup_gmap_curry_None in n.
        specialize (n j).
        eapply lookup_union_None in n. intuition.
  Qed.

  Lemma gmap_addr_by_block_union_lookup (m0 m1 : gmap addr T) o0 o1 k :
    gmap_addr_by_block m0 !! k = Some o0 ->
    gmap_addr_by_block m1 !! k = Some o1 ->
    gmap_addr_by_block (m0 ∪ m1) !! k = Some (o0 ∪ o1).
  Proof.
    rewrite /gmap_addr_by_block.
    intros.
    eapply gmap_curry_non_empty in H as H'.
    eapply map_choose in H'. destruct H' as [i [x H']].
    assert (m0 !! (k, i) = Some x).
    { rewrite -(lookup_gmap_curry m0). rewrite H. eauto. }
    assert ((m0 ∪ m1) !! (k, i) = Some x).
    { eapply lookup_union_Some_l; eauto. }
    eapply gmap_curry_lookup_exists in H2 as H2'.
    destruct H2' as [offmap [H2' H2'']].
    simpl in *.
    rewrite H2'. f_equal.
    apply map_eq; intros j.
    destruct ((m0 ∪ m1) !! (k, j)) eqn:He.
    all: pose proof He as He'.
    all: rewrite -lookup_gmap_curry H2' /= in He'.
    all: rewrite He'; symmetry.
    2: {
      eapply lookup_union_None in He; intuition.
      rewrite -lookup_gmap_curry H /= in H3.
      rewrite -lookup_gmap_curry H0 /= in H4.
      eapply lookup_union_None; eauto.
    }
    eapply lookup_union_Some_raw in He; intuition.
    { rewrite -lookup_gmap_curry H /= in H3. eapply lookup_union_Some_l; eauto. }
    { rewrite -lookup_gmap_curry H /= in H4. rewrite -lookup_gmap_curry H0 /= in H5.
      eapply lookup_union_Some_raw; eauto. }
  Qed.

  Lemma gmap_addr_by_block_union_lookup_none (m0 m1 : gmap addr T) k :
    gmap_addr_by_block m0 !! k = None ->
    gmap_addr_by_block (m0 ∪ m1) !! k = gmap_addr_by_block m1 !! k.
  Proof.
    rewrite /gmap_addr_by_block.
    intros.
    destruct (gmap_curry m1 !! k) eqn:Hk.
    {
      eapply gmap_curry_non_empty in Hk as H'.
      eapply map_choose in H'. destruct H' as [i [x H']].
      assert (m0 !! (k, i) = None).
      { rewrite -(lookup_gmap_curry m0). rewrite H. eauto. }
      assert ((m0 ∪ m1) !! (k, i) = Some x).
      { rewrite lookup_union_r; eauto.
        rewrite -(lookup_gmap_curry m1). rewrite Hk. eauto. }
      eapply gmap_curry_lookup_exists in H1 as H1'.
      destruct H1' as [offmap [H1' H1'']].
      simpl in *.
      rewrite H1'. f_equal.
      apply map_eq; intros j.
      destruct ((m0 ∪ m1) !! (k, j)) eqn:He.
      all: pose proof He as He'.
      all: rewrite -lookup_gmap_curry H1' /= in He'.
      all: rewrite He'; symmetry.
      2: {
        eapply lookup_union_None in He; intuition.
        rewrite -lookup_gmap_curry H /= in H2.
        rewrite -lookup_gmap_curry Hk /= in H3.
        eauto.
      }
      eapply lookup_union_Some_raw in He; intuition.
      { rewrite -lookup_gmap_curry H /= in H2. congruence. }
      { rewrite -lookup_gmap_curry H /= in H3. rewrite -lookup_gmap_curry Hk /= in H4. eauto. }
    }
    {
      eapply lookup_gmap_curry_None; intros j.
      eapply lookup_gmap_curry_None in H.
      eapply lookup_gmap_curry_None in Hk.
      eapply lookup_union_None; eauto.
    }
  Qed.

  Lemma gmap_addr_by_block_elem_of_1 m offmap blk off :
    gmap_addr_by_block m !! blk = Some offmap ->
    off ∈ dom offmap ->
    (blk, off) ∈ dom m.
  Proof.
    rewrite /gmap_addr_by_block; intros.
    apply elem_of_dom. apply elem_of_dom in H0. destruct H0.
    rewrite -lookup_gmap_curry. rewrite H /=. rewrite H0. eauto.
  Qed.

  Lemma gmap_addr_by_block_elem_of_2 m offmap blk off :
    gmap_addr_by_block m !! blk = Some offmap ->
    (blk, off) ∈ dom m ->
    off ∈ dom offmap.
  Proof.
    rewrite /gmap_addr_by_block; intros.
    apply elem_of_dom. apply elem_of_dom in H0. destruct H0.
    rewrite -lookup_gmap_curry in H0. rewrite H /= in H0.
    rewrite H0. eauto.
  Qed.

End gmap_addr_by_block.

Lemma gmap_addr_by_block_dom_eq {T0 T1} (m0 : gmap addr T0) (m1 : gmap addr T1) :
  dom m0 = dom m1 ->
  dom (gmap_addr_by_block m0) = dom (gmap_addr_by_block m1).
Proof.
  intros.
  eapply set_eq; intros x.
  rewrite /gmap_addr_by_block.
  rewrite !elem_of_dom.
  destruct (gmap_curry m0 !! x) eqn:He0;
    destruct (gmap_curry m1 !! x) eqn:He1.
  1: { split; intros; eauto. }
  3: { split; intros Hx; inversion Hx; inversion H0. }
  { exfalso.
    eapply gmap_curry_non_empty in He0 as Hg. eapply map_choose in Hg. destruct Hg as [i [ix Hg]].
    eapply lookup_gmap_curry_None in He1. rewrite <- not_elem_of_dom in He1.
    rewrite -H in He1. eapply not_elem_of_dom in He1.
    rewrite -lookup_gmap_curry in He1. rewrite He0 /= in He1. erewrite Hg in He1. congruence.
  }
  { exfalso.
    eapply gmap_curry_non_empty in He1 as Hg. eapply map_choose in Hg. destruct Hg as [i [ix Hg]].
    eapply lookup_gmap_curry_None in He0. rewrite <- not_elem_of_dom in He0.
    rewrite H in He0. eapply not_elem_of_dom in He0.
    rewrite -lookup_gmap_curry in He0. rewrite He1 /= in He0. erewrite Hg in He0. congruence.
  }
Qed.

Lemma gmap_addr_by_block_dom_eq2 {T0 T1} (m0 : gmap addr T0) (m1 : gmap addr T1) (blk : u64) (mb0 : gmap u64 T0) (mb1 : gmap u64 T1) :
  dom m0 = dom m1 ->
  gmap_addr_by_block m0 !! blk = Some mb0 ->
  gmap_addr_by_block m1 !! blk = Some mb1 ->
  dom mb0 = dom mb1.
Proof.
  intros.
  eapply set_eq; intros x.
  split; intros Hx.
  - eapply gmap_addr_by_block_elem_of_1 in Hx; eauto. rewrite H in Hx.
    eapply gmap_addr_by_block_elem_of_2 in Hx; eauto.
  - eapply gmap_addr_by_block_elem_of_1 in Hx; eauto. rewrite -H in Hx.
    eapply gmap_addr_by_block_elem_of_2 in Hx; eauto.
Qed.

Theorem gmap_addr_by_block_map_zip {T1 T2} (m1 : gmap addr T1) (m2 : gmap addr T2) :
  (∀ k : addr, is_Some (m1 !! k) ↔ is_Some (m2 !! k)) ->
  (λ (x : gmap _ _ * _), map_zip x.1 x.2) <$> map_zip (gmap_addr_by_block m1) (gmap_addr_by_block m2) =
  gmap_addr_by_block (map_zip m1 m2).
Proof.
  revert m2.
  induction m1 using map_ind; intros.
  - rewrite gmap_addr_by_block_empty !map_zip_empty_l gmap_addr_by_block_empty fmap_empty //.
  - specialize (IHm1 (delete i m2)).
    assert (is_Some (m2 !! i)) as Hk2.
    { apply H0. rewrite lookup_insert. eauto. }
    destruct Hk2 as [x2 Hkx2].
    replace m2 with (<[i:=x2]> (delete i m2)).
    2: rewrite insert_delete //.
    rewrite gmap_addr_by_block_insert; eauto.
    rewrite gmap_addr_by_block_insert. 2: rewrite lookup_delete //.
    rewrite !map_zip_insert.
    rewrite gmap_addr_by_block_insert. 2: rewrite map_zip_lookup_none_2 // lookup_delete //.
    rewrite fmap_insert /=.
    rewrite -IHm1.
    2: { intro k. destruct (decide (k = i)); subst.
      { rewrite H. rewrite lookup_delete. split; intro Hx; inversion Hx; congruence. }
      specialize (H0 k). rewrite lookup_insert_ne in H0; eauto. rewrite lookup_delete_ne; eauto.
    }
    f_equal.
    rewrite !map_zip_insert. f_equal.
    destruct (gmap_addr_by_block m !! addrBlock i) eqn:He.
    2: { simpl. rewrite map_zip_empty_l. rewrite lookup_fmap.
      rewrite map_zip_lookup_none_1; eauto. }
    destruct (gmap_addr_by_block (delete i m2) !! addrBlock i) eqn:He2.
    2: { simpl. rewrite map_zip_empty_r. rewrite lookup_fmap.
      rewrite map_zip_lookup_none_2; eauto. }
    rewrite lookup_fmap. erewrite map_zip_lookup_some; eauto.
Qed.

Theorem gmap_addr_by_block_big_sepM2
        {PROP: bi} `{BiAffine PROP}
        {T1 T2} (m1 : gmap addr T1) (m2: gmap addr T2) (Φ : addr -> T1 -> T2 -> PROP) :
  ( [∗ map] a ↦ v1; v2 ∈ m1; m2, Φ a v1 v2 ) -∗
  ( [∗ map] blkno ↦ offmap1; offmap2 ∈ gmap_addr_by_block m1; gmap_addr_by_block m2,
      [∗ map] off ↦ v1; v2 ∈ offmap1; offmap2, Φ (Build_addr blkno off) v1 v2 ).
Proof.
  rewrite big_op.big_sepM2_unseal /big_op.big_sepM2_def.
  rewrite gmap_addr_by_block_big_sepM.
  iIntros "[%Hdom Hm]".
  rewrite -gmap_addr_by_block_map_zip //.
  iSplit.
  { iPureIntro; intros. split; intros Hm.
    { destruct Hm as [m Hm]. apply gmap_addr_by_block_off_not_empty in Hm as Hme.
      apply map_choose in Hme. destruct Hme as [i [x Hme]]. apply elem_of_dom_2 in Hme.
      eapply gmap_addr_by_block_elem_of_1 in Hme; eauto.
      rewrite -> elem_of_dom in Hme. eapply Hdom in Hme. destruct Hme as [v Hme].
      eapply gmap_addr_by_block_lookup in Hme. destruct Hme. intuition eauto. }
    { destruct Hm as [m Hm]. apply gmap_addr_by_block_off_not_empty in Hm as Hme.
      apply map_choose in Hme. destruct Hme as [i [x Hme]]. apply elem_of_dom_2 in Hme.
      eapply gmap_addr_by_block_elem_of_1 in Hme; eauto.
      rewrite -> elem_of_dom in Hme. eapply Hdom in Hme. destruct Hme as [v Hme].
      eapply gmap_addr_by_block_lookup in Hme. destruct Hme. intuition eauto. }
  }
  rewrite big_sepM_fmap.
  iApply (big_sepM_mono with "Hm"); intros.
  iIntros "Hm".
  iFrame.
  iPureIntro; intros.
  apply map_lookup_zip_with_Some in H0 as (m1_ & m2_ & -> & Hlookup1 & Hlookup2).
  simpl.
  apply (f_equal (λ x, x ≫= lookup k0)) in Hlookup1.
  rewrite lookup_gmap_curry in Hlookup1.
  apply (f_equal (λ x, x ≫= lookup k0)) in Hlookup2.
  rewrite lookup_gmap_curry in Hlookup2.
  simpl in *.
  rewrite -Hlookup1 -Hlookup2.
  auto.
Qed.

Theorem gmap_addr_by_block_fmap {A B} (m : gmap addr A) (f : A -> B) :
  gmap_addr_by_block (f <$> m) =
    (λ (bm : gmap _ _), f <$> bm) <$> (gmap_addr_by_block m).
Proof.
  rewrite /gmap_addr_by_block.
  apply map_eq; intros.
  rewrite lookup_fmap.
  destruct (gmap_curry m !! i) eqn:He; simpl.
  - destruct (gmap_curry (f <$> m) !! i) eqn:Hee.
    2: {
      eapply gmap_curry_non_empty in He as He'.
      apply map_choose in He'. destruct He' as [j' [x' He']].
      erewrite lookup_gmap_curry_None in Hee.
      specialize (Hee j'). rewrite lookup_fmap in Hee.
      rewrite -lookup_gmap_curry He /= He' /= in Hee.
      congruence.
    }
    rewrite Hee.
    f_equal.
    apply map_eq; intros.

    replace (g0 !! i0) with ((f <$> m) !! (i, i0)).
    2: { rewrite -lookup_gmap_curry Hee /=. done. }

    rewrite ?lookup_fmap.
    replace (g !! i0) with (m !! (i, i0)).
    2: { rewrite -lookup_gmap_curry He /=. done. }
    done.

  - erewrite lookup_gmap_curry_None in He.
    erewrite lookup_gmap_curry_None. intros j. specialize (He j).
    rewrite lookup_fmap. rewrite He. done.
Qed.

Section heap.
Context `{!heapGS Σ}.

Hint Unfold block_bytes : word.
Hint Unfold valid_addr : word.
Hint Unfold addr2flat : word.
Hint Unfold addr2flat_z : word.

Theorem wp_Addr__Flatid a stk E :
  {{{
    ⌜ valid_addr a ⌝
  }}}
    Addr__Flatid (addr2val a) @ stk; E
  {{{
    v, RET #v; ⌜ v = addr2flat a ⌝
  }}}.
Proof.
  iIntros (Φ) "% HΦ".
  wp_call.
  iApply "HΦ".
  iPureIntro.

  word_cleanup.
  rewrite ?word.unsigned_mul. (* XXX why is this needed? *)
  word_cleanup.
Qed.

End heap.


Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Import Coq.Program.Tactics.
Require Import Language LibTactics.
Require Import Strings.String.
Require Import SubAndTopLike Value Disjoint Ptype.
Require Import Psatz. (* lia *)

(* aux lemma for tred_determinism *)
Lemma tred_ord_toplike :
  forall (v v' : trm) (A : typ),
    ordinary A -> toplike A -> typedred v A v' ->
    v' = (trm_anno (trm_int 1) A).
Proof.
  induction 3; eauto.
  - inversion H0.
  - dependent destruction H0. contradiction.
  - exfalso; eauto.
Qed.

Hint Resolve tred_ord_toplike : core.

(* aux lemma for disjoint_value_consistent *)
Lemma tred_sub :
  forall (A : typ) (v v' : trm),
    value v -> typedred v A v' -> forall (B : typ),
    typing nil v B ->
    sub B A.
Proof.
  introv Hv Hred.
  dependent induction Hred; eauto; introv Htyp.
  - dependent destruction Htyp.
    dependent destruction Htyp; eauto.
  - dependent destruction Htyp; eauto.
  - dependent destruction Hv.
    dependent destruction Htyp;
      eapply sub_and_l; eauto.
  - dependent destruction Hv.
    dependent destruction Htyp;
    eapply sub_and_r; eauto.
Qed.

Theorem tred_determinism :
  forall (v1 v2 v1' v2' : trm) (A B C : typ),
    value v1 -> value v2 ->
    typing nil v1 A -> typing nil v2 B ->
    typedred v1 C v1' -> typedred v2 C v2' ->
    consistent v1 v2 -> v1' = v2'.
Proof.
  introv Hv1 Hv2 Htyp1 Htyp2 Hr1 Hr2 Hcons.
  gen A B v1 v2 v1' v2'.
  ind_typ_size (size_typ C).
  destruct (split_or_ord C).
  - gen A B. induction Hcons; intros.
    + dependent destruction Htyp1. dependent destruction Htyp1.
      dependent destruction Htyp2. dependent destruction Htyp2.
      dependent destruction Hr1; dependent destruction Hr2;
        try solve [exfalso; eapply split_and_ord; eauto | reflexivity].
      * inversion H0.
      * inversion H.
    + dependent destruction Htyp1. dependent destruction Htyp1.
      dependent destruction Htyp2. dependent destruction Htyp2.
      dependent destruction Hr1; dependent destruction Hr2;
        try solve [exfalso; eapply split_and_ord; eauto | reflexivity].
      * dependent destruction H. contradiction.
      * dependent destruction H2. contradiction.
    + assert (ptype v1 A0) by (now eapply typing_to_ptype in Htyp1).
      eapply ptype_determinism in H0; eauto. subst.
      assert (ptype v2 B0) by (now eapply typing_to_ptype in Htyp2).
      eapply ptype_determinism in H1; eauto. subst.
      eapply disjoint_complete in H2.
      assert (sub A C) by (eapply tred_sub in Hr1; eauto).
      assert (sub B C) by (eapply tred_sub in Hr2; eauto).
      assert (toplike C) by (now eapply H2).
      eapply tred_ord_toplike in Hr1; eauto.
      eapply tred_ord_toplike in Hr2; eauto.
      now subst.
    + dependent destruction Hv1.
      dependent destruction Hr1.
      * symmetry. eapply tred_ord_toplike; eauto.
      * dependent destruction Htyp1; eapply IHHcons1; eauto.
      * dependent destruction Htyp1; eapply IHHcons2; eauto.
      * exfalso; eauto.
    + dependent destruction Hv2.
      dependent destruction Hr2.
      * eapply tred_ord_toplike; eauto.
      * dependent destruction Htyp2; eapply IHHcons1; eauto.
      * dependent destruction Htyp2; eapply IHHcons2; eauto.
      * exfalso; eauto.
  - destruct_conjs.
    dependent destruction Hr1; try solve [exfalso; eauto 3].
    dependent destruction Hr2; try solve [exfalso; eauto 3].
    eapply split_determinism in H0; eauto.
    destruct_conjs. subst.
    eapply split_determinism in H; eauto.
    destruct_conjs. subst.
    assert (forall A B C, splitable A B C -> size_typ B < size_typ A /\ size_typ C < size_typ A).
    eapply split_decrease_size.
    pose proof (H A0 B0 C H3).
    destruct_conjs.
    assert (size_typ B0 < i) by lia.
    assert (size_typ C < i) by lia.
    assert (v1 = v2); eauto 3.
    assert (v0 = v3); eauto 3.
    congruence.
Qed.

Lemma tred_value_preservation :
  forall (v v' : trm) (A : typ),
    value v -> typedred v A v' -> value v'.
Proof.
  intros.
  dependent induction H0;
    try solve [eauto | dependent destruction H; eauto].
Qed.

Hint Resolve tred_value_preservation : core.

Lemma tred_transitivity :
  forall (v1 v2 v3 : trm) (A B : typ),
    value v1 ->
    typedred v1 A v2 ->
    typedred v2 B v3 ->
    typedred v1 B v3.
Proof.
Abort.

Theorem tred_preservation:
  forall (v v': trm) (A B: typ),
    value v ->
    typing nil v B ->
    typedred v A v' ->
    (exists C, typing nil v' C /\ isomorphic C A).
Proof.
Abort.

Theorem tred_progress :
  forall (v : trm) (A B : typ),
    value v -> typing nil v A ->
    sub A B ->
    exists v', typedred v B v'.
Proof.
  introv Hv Htyp Hsub.
  gen v.
  dependent induction Hsub; intros; eauto.
  - dependent destruction Htyp;
      try solve [exfalso; eauto].
    + dependent destruction Hv.
      dependent induction H; eauto.
      dependent destruction Htyp.
      exfalso; eauto.
    + inversion Hv.
  - dependent destruction Htyp.
    + inversion H1.
    + inversion Hv.
    + assert (toplike D \/ not (toplike D)).
      eapply toplike_or_not_toplike.
      destruct H1.
      (* case top *)
      exists (trm_anno (trm_int 1) (typ_arrow B D)); eauto.
      (* case not top *)
      dependent destruction Hv.
      dependent destruction H0.
      (* case int *)
      dependent destruction Htyp.
      eapply sub_int_arrow_false in H1; eauto. contradiction.
      intro Hcontra. eapply sub_toplike_preservation in Hsub2; eauto.
      (* case arrow *)
      dependent destruction Htyp.
      exists (trm_anno (trm_abs e A0 B0) (typ_arrow B D)); eauto.
    + inversion Hv.
  - assert (exists v', typedred v B v'); eauto.
    assert (exists v', typedred v C v'); eauto.
    destruct_conjs; eauto.
  - dependent destruction Htyp; eauto; try solve [inversion Hv].
    + destruct (toplike_or_not_toplike C).
      * exists (trm_anno (trm_int 1) C); eauto.
      * dependent destruction Hv.
        dependent destruction H0.
        (* case int *)
        dependent destruction Htyp.
        dependent destruction H1. inversion H1. dependent destruction H1.
        assert (sub typ_int C). eapply sub_transitivity. eapply H1_. eapply Hsub.
        eapply sub_int_form in H1; eauto. subst.
        eauto.
    (* case arrow *)
        dependent destruction Htyp.
        dependent destruction H1. inversion H1.
        dependent destruction H1.
        assert (sub (typ_arrow A0 B0) C).
        eapply sub_transitivity. eapply H1_. eapply Hsub.
        dependent destruction H1.
        contradiction.
        exists (trm_anno (trm_abs e A0 B0) (typ_arrow  B2 D)); eauto.
        eapply tred_arrow_anno; eauto.
        exfalso; eauto.
    + dependent destruction Hv.
      assert (exists v', typedred e1 C v'); eauto.
      destruct_conjs; eauto.
    + dependent destruction Hv.
      assert (exists v', typedred v1 C v'); eauto.
      destruct_conjs; eauto.
  - dependent destruction Htyp; eauto; try solve [inversion Hv].
    + destruct (toplike_or_not_toplike C).
      * exists (trm_anno (trm_int 1) C); eauto.
      * dependent destruction Hv.
        dependent destruction H0.
        (* case int *)
        dependent destruction Htyp.
        dependent destruction H1. inversion H1. dependent destruction H1.
        assert (sub typ_int C). eapply sub_transitivity. eapply H1_0. eapply Hsub.
        eapply sub_int_form in H1; eauto. subst.
        eauto.
        (* case arrow *)
        dependent destruction Htyp.
        dependent destruction H1. inversion H1.
        dependent destruction H1.
        assert (sub (typ_arrow A0 B0) C).
        eapply sub_transitivity. eapply H1_0. eapply Hsub.
        dependent destruction H1.
        contradiction.
        exists (trm_anno (trm_abs e A0 B0) (typ_arrow  B2 D)); eauto.
        eapply tred_arrow_anno; eauto.
        exfalso; eauto.
    + dependent destruction Hv.
      assert (exists v', typedred e2 C v'); eauto.
      destruct_conjs; eauto.
    + dependent destruction Hv.
      assert (exists v', typedred v2 C v'); eauto.
      destruct_conjs; eauto.
Qed.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 This defines the static semantics of statements and expressions, pg. 63.

*)
Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax Cyclone_Static_Semantics_Typing_Heap_Objects.
Require Export Cyclone_LN_Tactics.
Import LibEnvNotations.
Import LVPE.LibVarPathEnvNotations.

(* TODO Not in the thesis. I need it and in K when the context is formed. *)

Inductive WFD : Delta -> Prop :=
  | WFD_ddot   : WFD ddot
  | WFD_xtau   : forall (d : Delta) (alpha : var) (k : Kappa),
                 get alpha d = None ->
                 WFD  d ->
                 WFD (alpha ~ k & d).
Hint Constructors WFD.

Inductive K : Delta -> Tau -> Kappa -> Prop :=
 | K_cint   : forall (d : Delta),
                  K d cint B

 | K_B     : forall (d : Delta) (alpha : var),
               get alpha d = Some B ->
               K d (ftvar alpha) B

 | K_star_A  : forall (d : Delta) (alpha : var),
                 get alpha d = Some A ->
                 K  d (ptype (ftvar alpha)) B

 | K_B_A     : forall (d : Delta) (tau : Tau),
                  K  d tau B ->
                  K  d tau A

 | K_cross   : forall (d : Delta) (t0 t1 : Tau),
                    K d t0 A ->
                    K d t1 A ->
                    K d (cross t0 t1) A

 | K_arrow   : forall (d : Delta) (t0 t1 : Tau),
                    K d t0 A ->
                    K d t1 A ->
                    K d (arrow t0 t1) A

 | K_ptype    :  forall (d : Delta) (tau : Tau),
                    K d tau A ->
                    K d (ptype tau) B

 | K_utype  : forall (L : vars) (d : Delta) (k : Kappa) (tau : Tau),
                (forall (alpha : var),
                   alpha \notin L ->
                   WFD (alpha ~ k & d) ->
                   K  ((alpha ~ k) & d) (T.open_rec 0 (ftvar alpha) tau) A) ->
                K d (utype k tau) A

 | K_etype  : forall (L : vars) (d : Delta) (k : Kappa) (tau : Tau) (p : Phi),
              (forall (alpha : var),
                 alpha \notin L ->
                 WFD ((alpha ~ k) & d) ->
                 K ((alpha ~ k) & d) (T.open_rec 0 (ftvar alpha) tau) A) ->
              K d (etype p k tau) A.

Hint Constructors K.
Ltac simpl_K :=
  try solve[constructor; simpl_get; auto; try case_var~].
Hint Extern 1 (K _ _ _) => simpl_K.

Inductive AK : Delta -> Tau -> Kappa -> Prop :=

 | AK_AK_K  : forall (d : Delta) (tau : Tau) (k : Kappa),
                   K  d tau k ->
                   AK d tau k

 | AK_A     : forall (d : Delta) (alpha : var),
                get alpha d = Some A ->
                AK d (ftvar alpha) A.

Hint Constructors AK.

Inductive ASGN : Delta -> Tau -> Prop :=

  | ASGN_cint  : forall (d : Delta),
                      ASGN d cint

  | ASGN_B     : forall (d : Delta) (alpha : var),
                   get alpha d = Some B ->
                   ASGN d (ftvar alpha)

  | ASGN_ptype : forall (d : Delta) (tau : Tau),
                   ASGN d (ptype tau)

  | ASGN_cross : forall (d : Delta) (t0 t1 : Tau),
                   ASGN d t0 ->
                   ASGN d t1 ->
                   ASGN d (cross t0 t1)

  | ASGN_arrow : forall (d : Delta) (t0 t1 : Tau),
                   ASGN d t0 ->
                   ASGN d t1 ->
                   ASGN d (arrow t0 t1)

  | ASGN_utype : forall (L : vars) (d : Delta)  (k : Kappa) (tau : Tau),
                 (forall (alpha : var),
                     alpha \notin L ->
                   ASGN ((alpha ~ k) & d) (T.open_rec 0 (ftvar alpha) tau)) ->
                   ASGN d (utype k tau)

  | ASGN_etype : forall (L : vars) (d : Delta) (k : Kappa) (tau : Tau),
                 (forall (alpha : var),
                     alpha \notin L ->
                     ASGN ((alpha ~ k) & d) (T.open_rec 0 (ftvar alpha) tau)) ->
                   ASGN d (etype witnesschanges k tau).
Hint Constructors ASGN.

Inductive WFU : Upsilon -> Prop :=
  | WFU_udot : WFU udot
  | WFU_A   : forall (u : Upsilon) (tau : Tau) (p : Path) (x : var),
                 LVPE.V.get (x,p) u = None ->
                 WFU  u ->
                 K ddot tau A ->
                 WFU (((x,p) ~p tau) &p u).
Hint Constructors WFU.

Inductive WFDG : Delta -> Gamma -> Prop :=
  | WFDG_d_gdot : forall (d: Delta),
                     WFDG d gdot
  | WFDG_xt      : forall (d: Delta) (g: Gamma) (x : var) (tau : Tau),
                     get x g = None ->
                     K d tau A ->
                     WFDG d g ->
                     WFDG d (g & (x ~ tau))
(* Proposed Thesis bug, I have to be able to extend WFDG with a new type variable. *)
  | WFDG_alphak   : forall (d: Delta) (g: Gamma) (alpha : var) (k : Kappa),
                     get alpha d = None ->
                     WFDG d g ->
                     WFDG (d & (alpha ~ k)) g.

Hint Constructors WFDG.

(* Thesis change, we really need to know that kinding contexts are unique,
   so we're adding it here. Another option is to add it inside WFDG. *)
Inductive WFC : Delta -> Upsilon -> Gamma -> Prop :=
  | WFC_DUG : forall (d : Delta) (g: Gamma) (u : Upsilon),
                WFD d ->
                WFDG d g ->
                WFU u ->
                WFC d u g.
Hint Constructors WFC.

(* Automation for judgements with LN constructors. *)

Ltac fv_of_kinding_goal :=
  match goal with
    | |- K ?d (utype _ ?tau) _   => constr:((fv_delta d) \u  (T.fv tau))
    | |- K ?d (etype _ _ ?tau) _ => constr:((fv_delta d) \u  (T.fv tau))
    | |- ASGN ?d (utype _ ?tau)  => constr:((fv_delta d) \u  (T.fv tau))
    | |- ASGN ?d (etype _ _ ?tau)  => constr:((fv_delta d) \u  (T.fv tau))
    | |- ASGN ?d (etype _ _ ?tau)  => constr:((fv_delta d) \u  (T.fv tau))
  end.

(* BUG these are problematic for performance. *)
Hint Extern 6 (K ?d (utype _ ?tau) _) =>
idtac "20"; apply_fresh_from K_utype with fv_of_kinding_goal;
  try simpl; try case_nat~;auto.
Hint Extern 6 (K ?d (etype _ _ ?tau) _)  =>
idtac "21"; apply_fresh_from K_etype with fv_of_kinding_goal;
  try simpl; try case_nat~.
Hint Extern 6 (ASGN ?d (utype _ ?tau))   =>
idtac "22"; apply_fresh_from ASGN_utype with fv_of_kinding_goal;
  try simpl; try case_nat~.
Hint Extern 6 (ASGN ?d (etype _ _ ?tau)) =>
idtac "23"; apply_fresh_from ASGN_etype with fv_of_kinding_goal;
  try simpl; try case_nat~.
Hint Extern 6 (WFU _) =>
 idtac "24"; constructor~; simpl_env.


From Fiat.Narcissus Require Import Examples.TutorialPrelude.

Record msg := { data : bool }.
Definition format := format_nat 7 ◦ const 0 ++ format_bool ◦ data.
Definition invariant (_ : msg) := True.

Definition dec : CorrectAlignedDecoderFor invariant format.
Proof.
  synthesize_aligned_decoder.
Defined.


Require Import ZArith List.

Require Export Labels.
Require Export Instructions.
Require Import Rules.

Context{T : Type}.
Context{Latt : JoinSemiLattice T}.

Definition none := bot.

Record MVec := MkMVec {
  mop : OpCode;
  ml1 : T;
  ml2 : T;
  ml3 : T;
  mpc : T
}.

Record RVec := MkRVec {
  rlab : T;
  rpc  : T
}.

Inductive table : MVec -> RVec -> Prop :=
| TLab : forall pc l1 l2 l3,
  table (MkMVec OpLab l1 l2 l3 pc) (MkRVec bot pc)
| TMLab : forall pc l1 l2 l3,
  table (MkMVec OpMLab l1 l2 l3 pc) (MkRVec l1 pc)
| TPcLab : forall pc l1 l2 l3,
  table (MkMVec OpPcLab l1 l2 l3 pc) (MkRVec bot pc)
| TBCall : forall pc l1 l2 l3,
  table (MkMVec OpBCall l1 l2 l3 pc) (MkRVec (join l2 pc) (join l1 pc))
| TBRet : forall pc l1 l2 l3,
  flows (join l1 pc) (join l2 l3) = true ->
  table (MkMVec OpBRet l1 l2 l3 pc) (MkRVec l2 l3)
| TPutBot : forall pc l1 l2 l3,
  table (MkMVec OpPutLab l1 l2 l3 pc) (MkRVec bot pc)
| TNop : forall pc l1 l2 l3,
  table (MkMVec OpNop l1 l2 l3 pc) (MkRVec none pc)
| TPut : forall pc l1 l2 l3,
  table (MkMVec OpPut l1 l2 l3 pc) (MkRVec bot pc)
| TBinOp : forall pc l1 l2 l3,
  table (MkMVec OpBinOp l1 l2 l3 pc) (MkRVec (join l1 l2) pc)
| TJump : forall pc l1 l2 l3,
  table (MkMVec OpJump l1 l2 l3 pc) (MkRVec none (join pc l1))
| TBNZ : forall pc l1 l2 l3,
  table (MkMVec OpBNZ l1 l2 l3 pc) (MkRVec none (join pc l1))
| TLoad : forall pc l1 l2 l3,
  table (MkMVec OpLoad l1 l2 l3 pc) (MkRVec l3 (join pc (join l1 l2)))
| TStore : forall pc l1 l2 l3,
  flows (join l1 pc) l2 = true ->
  table (MkMVec OpStore l1 l2 l3 pc) (MkRVec l3 pc)
| TAlloc : forall pc l1 l2 l3,
  table (MkMVec OpAlloc l1 l2 l3 pc) (MkRVec (join l1 l2) pc)
| TPSetOff : forall pc l1 l2 l3,
  table (MkMVec OpPSetOff l1 l2 l3 pc) (MkRVec (join l1 l2) pc)
| TPGetOff : forall pc l1 l2 l3,
  table (MkMVec OpPGetOff l1 l2 l3 pc) (MkRVec l1 pc)
| TMSize : forall pc l1 l2 l3,
  table (MkMVec OpMSize l1 l2 l3 pc) (MkRVec l2 (join pc l1)).

Declare ML Module "relation_extraction_plugin".

Extraction Relation table [1].

(* This produces:
let rec table1 p1 =
  match p1 with
  | MkMVec (OpLab, l1, l2, l3, pc) -> MkRVec (bot, pc)
  | MkMVec (OpMLab, l1, l2, l3, pc) -> MkRVec (l1, pc)
  | MkMVec (OpPcLab, l1, l2, l3, pc) -> MkRVec (bot, pc)
  | MkMVec (OpBCall, l1, l2, l3, pc) -> MkRVec ((join l2 pc), (join l1 pc))
  | MkMVec (OpBRet, l1, l2, l3, pc) ->
    (match flows (join l1 pc) (join l2 l3) with
     | true -> MkRVec (l2, l3)
     | _ -> assert false (*  *))
  | MkMVec (OpFlowsTo, l1, l2, l3, pc) -> MkRVec ((join l1 l2), pc)
  | MkMVec (OpLJoin, l1, l2, l3, pc) -> MkRVec ((join l1 l2), pc)
  | MkMVec (OpPutBot, l1, l2, l3, pc) -> MkRVec (bot, pc)
  | MkMVec (OpNop, l1, l2, l3, pc) -> MkRVec (none, pc)
  | MkMVec (OpPut, l1, l2, l3, pc) -> MkRVec (bot, pc)
  | MkMVec (OpBinOp, l1, l2, l3, pc) -> MkRVec ((join l1 l2), pc)
  | MkMVec (OpJump, l1, l2, l3, pc) -> MkRVec (none, (join pc l1))
  | MkMVec (OpBNZ, l1, l2, l3, pc) -> MkRVec (none, (join pc l1))
  | MkMVec (OpLoad, l1, l2, l3, pc) -> MkRVec (l3, (join pc (join l1 l2)))
  | MkMVec (OpStore, l1, l2, l3, pc) ->
    (match flows (join l1 pc) l2 with
     | true -> MkRVec (l3, pc)
     | _ -> assert false (*  *))
  | MkMVec (OpAlloc, l1, l2, l3, pc) -> MkRVec ((join l1 l2), pc)
  | MkMVec (OpPSetOff, l1, l2, l3, pc) -> MkRVec ((join l1 l2), pc)
  | MkMVec (OpPGetOff, l1, l2, l3, pc) -> MkRVec (l1, pc)
  | MkMVec (OpMSize, l1, l2, l3, pc) -> MkRVec (l2, (join pc l1))
  | MkMVec (OpOutput, l1, l2, l3, pc) -> MkRVec ((join l1 pc), pc)
  | _ -> assert false (*  *)
*)