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

Require Import Coq.Init.Byte.
Require Import Coq.Lists.List.

Require Import AesSpec.Sbox.
Require Import Cava.Util.List.

Section Spec.
  Variables bytes_per_word Nb : nat.
  Local Notation word := (list byte) (only parsing).
  Local Notation state := (list word) (only parsing).

  Definition sub_bytes : state -> state :=
    map (map forward_sbox).

  Definition inv_sub_bytes : state -> state :=
    map (map inverse_sbox).

  Section Properties.

    Lemma inverse_sbox_prop (x : byte) : inverse_sbox (forward_sbox x) = x.
    Proof.
      destruct x; reflexivity.
    Qed.

    Theorem inverse_sub_bytes (x : state) :
      inv_sub_bytes (sub_bytes x) = x.
    Proof.
      unfold inv_sub_bytes.
      unfold sub_bytes.
      induction x; [reflexivity|].
      simpl.
      rewrite IHx.
      rewrite map_map.
      rewrite map_id_ext.
      { reflexivity. }
      { intro b.
        destruct b; reflexivity. }
    Qed.

    Theorem sub_bytes_length_outer (x : state) :
      length (sub_bytes x) = length x.
    Proof.
      cbv [sub_bytes]. autorewrite with push_length.
      reflexivity.
    Qed.

    Theorem sub_bytes_length_inner (x : state) n r :
      (forall r, In r x -> length r = n) ->
      In r (sub_bytes x) -> length r = n.
    Proof.
      cbv [sub_bytes]; intros Hx Hin.
      apply in_map_iff in Hin.
      destruct Hin as [? [? ?]]. subst.
      autorewrite with push_length.
      auto.
    Qed.

  End Properties.
End Spec.
#[export] Hint Resolve sub_bytes_length_inner sub_bytes_length_outer : length.


Definition le_trans := 0.

Module Test_Read.
  Module M.
    Require Le.        (* Reading without importing *)

    Check Le.le_trans.

    Lemma th0 : le_trans = 0.
      reflexivity.
    Qed.
  End M.

  Check Le.le_trans.

  Lemma th0 : le_trans = 0.
    reflexivity.
  Qed.

  Import M.

  Lemma th1 : le_trans = 0.
    reflexivity.
  Qed.
End Test_Read.

(****************************************************************)

Definition le_decide := 1.  (* from Arith/Compare *)
Definition min := 0.            (* from Arith/Min *)

Module Test_Require.

  Module M.
    Require Import Compare.              (* Imports Min as well *)

    Lemma th1 : le_decide = le_decide.
      reflexivity.
    Qed.

    Lemma th2 : min = min.
      reflexivity.
    Qed.

  End M.

  (* Checks that Compare and List are loaded *)
  Check Compare.le_decide.
  Check Min.min.

  (* Checks that Compare and List are _not_ imported *)
  Lemma th1 : le_decide = 1.
    reflexivity.
  Qed.

  Lemma th2 : min = 0.
    reflexivity.
  Qed.

  (* It should still be the case after Import M *)
  Import M.

  Lemma th3 : le_decide = 1.
    reflexivity.
  Qed.

  Lemma th4 : min = 0.
    reflexivity.
  Qed.

End Test_Require.

(****************************************************************)

Module Test_Import.
  Module M.
    Import Compare.              (* Imports Min as well *)

    Lemma th1 : le_decide = le_decide.
      reflexivity.
    Qed.

    Lemma th2 : min = min.
      reflexivity.
    Qed.

  End M.

  (* Checks that Compare and List are loaded *)
  Check Compare.le_decide.
  Check Min.min.

  (* Checks that Compare and List are _not_ imported *)
  Lemma th1 : le_decide = 1.
    reflexivity.
  Qed.

  Lemma th2 : min = 0.
    reflexivity.
  Qed.

  (* It should still be the case after Import M *)
  Import M.

  Lemma th3 : le_decide = 1.
    reflexivity.
  Qed.

  Lemma th4 : min = 0.
    reflexivity.
  Qed.
End Test_Import.

(************************************************************************)

Module Test_Export.
  Module M.
    Export Compare.              (* Exports Min as well *)

    Lemma th1 : le_decide = le_decide.
      reflexivity.
    Qed.

    Lemma th2 : min = min.
      reflexivity.
    Qed.

  End M.

  (* Checks that Compare and List are _not_ imported *)
  Lemma th1 : le_decide = 1.
    reflexivity.
  Qed.

  Lemma th2 : min = 0.
    reflexivity.
  Qed.

  (* After Import M they should be imported as well *)

  Import M.

  Lemma th3 : le_decide = le_decide.
    reflexivity.
  Qed.

  Lemma th4 : min = min.
    reflexivity.
  Qed.
End Test_Export.

(************************************************************************)

Module Test_Require_Export.

  Definition mult_sym := 1.    (* from Arith/Mult *)
  Definition plus_sym := 0.        (* from Arith/Plus *)

  Module M.
    Require Export Mult.         (* Exports Plus as well *)

    Lemma th1 : mult_comm = mult_comm.
      reflexivity.
    Qed.

    Lemma th2 : plus_comm = plus_comm.
      reflexivity.
    Qed.

  End M.

  (* Checks that Mult and Plus are _not_ imported *)
  Lemma th1 : mult_sym = 1.
    reflexivity.
  Qed.

  Lemma th2 : plus_sym = 0.
    reflexivity.
  Qed.

  (* After Import M they should be imported as well *)

  Import M.

  Lemma th3 : mult_comm = mult_comm.
    reflexivity.
  Qed.

  Lemma th4 : plus_comm = plus_comm.
    reflexivity.
  Qed.

End Test_Require_Export.


From Coq Require Import ZArith List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From BitBlasting Require Import QFBV CNF BBCommon.
From ssrlib Require Import ZAriths Seqs Tactics.
From nbits Require Import NBits.

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

(* ===== bit_blast_and ===== *)

Definition bit_blast_and1 g l1 l2 : generator * cnf * literal :=
  if (l1 == lit_ff) || (l2 == lit_ff) then (g, [::], lit_ff)
  else if l1 == lit_tt then (g, [::], l2)
       else if l2 == lit_tt then (g, [::], l1)
            else let (g', r) := gen g in
                 let cs := [:: [:: neg_lit r; l1]; [:: neg_lit r; l2];
                              [:: r; neg_lit l1; neg_lit l2]] in
                 (g', cs, r).

Definition mk_env_and1 E g l1 l2 : env * generator * cnf * literal :=
  if (l1 == lit_ff) || (l2 == lit_ff) then (E, g, [::], lit_ff)
  else if l1 == lit_tt then (E, g, [::], l2)
       else if l2 == lit_tt then (E, g, [::], l1)
            else let (g', r) := gen g in
                 let E' := env_upd E (var_of_lit r)
                                   (interp_lit E l1 && interp_lit E l2) in
                 let cs := [:: [:: neg_lit r; l1]; [:: neg_lit r; l2];
                              [:: r; neg_lit l1; neg_lit l2]] in
                 (E', g', cs, r).

Fixpoint bit_blast_and_zip g lsp : generator * cnf * word :=
  match lsp with
  | [::] => (g, [::], [::])
  | (l1, l2)::tl =>
      let '(g_hd, cs_hd, lrs_hd) := bit_blast_and1 g l1 l2 in
      let '(g_tl, cs_tl, lrs_tl) := bit_blast_and_zip g_hd tl in
      (g_tl, catrev cs_hd cs_tl, lrs_hd::lrs_tl)
  end.

Fixpoint mk_env_and_zip E g lsp : env * generator * cnf * word :=
  match lsp with
  | [::] => (E, g, [::], [::])
  | (l1, l2)::tl =>
    let '(E_hd, g_hd, cs_hd, lrs_hd) := mk_env_and1 E g l1 l2 in
    let '(E_tl, g_tl, cs_tl, lrs_tl) := mk_env_and_zip E_hd g_hd tl in
    (E_tl, g_tl, catrev cs_hd cs_tl, lrs_hd::lrs_tl)
  end.

Definition bit_blast_and g ls1 ls2 := bit_blast_and_zip g (extzip_ff ls1 ls2).

Definition mk_env_and E g ls1 ls2 := mk_env_and_zip E g (extzip_ff ls1 ls2).

Lemma bit_blast_and_size_ss :
      forall ls1 ls2 g g' cs lrs,
  bit_blast_and g ls1 ls2 = (g', cs, lrs) -> size ls1 = size ls2 -> size ls1 = size lrs.
Proof.
  elim => [|ls1_hd ls1_tl IH] ls2 g g' cs lrs.
  - move => /=Hbband Hsz0. move : Hbband. symmetry in Hsz0; rewrite (size0nil Hsz0). by case => _ _ <-.
  - rewrite/bit_blast_and /=. case ls2 => [|ls2_hd ls2_tl]; try discriminate.
    rewrite /bit_blast_and_zip (lock bit_blast_and1) /= -!lock -/bit_blast_and_zip.
    dcase (bit_blast_and1 g ls1_hd ls2_hd) => [[[g_hd cs_hd] lrs_hd] Hbband1].
    dcase (bit_blast_and_zip g_hd (extzip_ff ls1_tl ls2_tl)) => [[[g_tl cs_tl] lrs_tl] Hbbandzip].
    move => Hres Hsz. rewrite -addn1 in Hsz; symmetry in Hsz; rewrite -addn1 in Hsz. move : (addIn Hsz) => Hszeq; symmetry in Hszeq.
    rewrite /bit_blast_and in IH; rewrite (IH _ _ _ _ _ Hbbandzip Hszeq).
    by case : Hres =>  _ _ <-.
Qed.

Lemma bit_blast_and1_correct E g b1 b2 l1 l2 g' cs lr :
  bit_blast_and1 g l1 l2 = (g', cs, lr) ->
  enc_bit E l1 b1 -> enc_bit E l2 b2 ->
  interp_cnf E (add_prelude cs) -> enc_bit E lr (andb b1 b2).
Proof.
  rewrite /bit_blast_and1 /enc_bit. case Hff: ((l1 == lit_ff) || (l2 == lit_ff)).
  - case => _ <- <- /eqP <- /eqP <- /= Hpre. move: (add_prelude_tt Hpre) => /= Htt.
    case/orP: Hff => /eqP -> /=; rewrite Htt //=. by rewrite andbF.
  - case Htt1: (l1 == lit_tt); last case Htt2: (l2 == lit_tt).
    + case=> _ <- <- /eqP <- /eqP <- /= Hpre. move: (add_prelude_tt Hpre) => /= Htt.
      rewrite (eqP Htt1) /= Htt andTb. exact: eqxx.
    + case=> _ <- <- /eqP <- /eqP <- /= Hpre. move: (add_prelude_tt Hpre) => /= Htt.
      rewrite (eqP Htt2) /= Htt andbT. exact: eqxx.
    + case => _ <- <-. move=> /eqP <- /eqP <- /= /andP [/= Htt Hcs]; t_clear.
      rewrite !interp_lit_neg_lit in Hcs. move: Hcs.
      by case: (E g); case: (interp_lit E l1); case: (interp_lit E l2).
Qed.

Lemma bit_blast_and_zip_correct E g bsp lsp g' cs lrs :
  bit_blast_and_zip g lsp = (g', cs, lrs) ->
  enc_bits E (unzip1 lsp) (unzip1 bsp) -> enc_bits E (unzip2 lsp) (unzip2 bsp) ->
  interp_cnf E (add_prelude cs) -> enc_bits E lrs (map (fun e => andb e.1 e.2) bsp).
Proof.
  elim: lsp E g bsp g' cs lrs => [| [l1_hd l2_hd] lsp_tl IH] E g bsp g' cs lrs /=.
  - rewrite !enc_bits_nil_l unzip1_l_nil. case=> _ <- <- /eqP -> _ _ /=.
    exact: enc_bits_nil.
  - dcase (bit_blast_and1 g l1_hd l2_hd) => [[[g_hd cs_hd] lrs_hd] Hbb_hd].
    dcase (bit_blast_and_zip g_hd lsp_tl) => [[[g_tl cs_tl] lrs_tl] Hbb_tl].
    case=> _ <- <- /=. case: bsp => [| [bsp_hd1 bsp_hd2] bsp_tl] //=.
    rewrite !enc_bits_cons. move=> /andP [Henc1hd Henc1tl] /andP [Henc2hd Henc2tl].
    rewrite add_prelude_catrev => /andP [Hpre_hd Hpre_tl].
    rewrite (bit_blast_and1_correct Hbb_hd Henc1hd Henc2hd Hpre_hd) andTb.
    by rewrite (IH _ _ _ _ _ _ Hbb_tl Henc1tl Henc2tl Hpre_tl).
Qed.

Lemma bit_blast_and_correct g bs1 bs2 E ls1 ls2 g' cs lrs :
  bit_blast_and g ls1 ls2 = (g', cs, lrs) ->
  enc_bits E ls1 bs1 -> enc_bits E ls2 bs2 -> interp_cnf E (add_prelude cs) ->
  enc_bits E lrs (andB bs1 bs2).
Proof.
  rewrite /bit_blast_and => Hbb Henc1 Henc2 Hcs.
  move: (enc_bits_size Henc1) (enc_bits_size Henc2) => Hs1 Hs2.
  move: (add_prelude_enc_bit_tt Hcs) => Henctt.
  exact: (bit_blast_and_zip_correct Hbb
                                    (enc_bits_unzip1_extzip Henctt Henc1 Henc2)
                                    (enc_bits_unzip2_extzip Henctt Henc1 Henc2) Hcs).
Qed.

Lemma mk_env_and1_is_bit_blast_and1 E g l1 l2 E' g' cs lr :
  mk_env_and1 E g l1 l2 = (E', g', cs, lr) -> bit_blast_and1 g l1 l2 = (g', cs, lr).
Proof.
  rewrite /mk_env_and1 /bit_blast_and1; intros;
    dite_hyps; dcase_hyps; subst; reflexivity.
Qed.

Lemma mk_env_and_zip_is_bit_blast_and_zip E g lsp E' g' cs lrs :
  mk_env_and_zip E g lsp = (E', g', cs, lrs) ->
  bit_blast_and_zip g lsp = (g', cs, lrs).
Proof.
  elim: lsp E g E' g' cs lrs => [| [ls1_hd ls2_hd] lsp_tl IH] E g E' g' cs lrs /=.
  - by case=> _ <- <- <-.
  - dcase (mk_env_and1 E g ls1_hd ls2_hd) => [[[[E_hd g_hd] cs_hd] lrs_hd] Henv_hd].
    dcase (mk_env_and_zip E_hd g_hd lsp_tl) => [[[[E_tl g_tl] cs_tl] lrs_tl] Henv_tl].
    case=> _ <- <- <-. rewrite (mk_env_and1_is_bit_blast_and1 Henv_hd).
    by rewrite (IH _ _ _ _ _ _ Henv_tl).
Qed.

Lemma mk_env_and_is_bit_blast_and E g ls1 ls2 E' g' cs lrs :
  mk_env_and E g ls1 ls2 = (E', g', cs, lrs) ->
  bit_blast_and g ls1 ls2 = (g', cs, lrs).
Proof. exact: mk_env_and_zip_is_bit_blast_and_zip. Qed.

Lemma mk_env_and1_newer_gen E g l1 l2 E' g' cs lr :
  mk_env_and1 E g l1 l2 = (E', g', cs, lr) -> (g <=? g')%positive.
Proof.
  rewrite /mk_env_and1. case Hff : ((l1 == lit_ff) || (l2 == lit_ff)).
  - case=> _ <- _ _; exact: Pos.leb_refl.
  - case Hl1t : (l1 == lit_tt); last case Hl2t : (l2 == lit_tt); case=> _ <- _ _.
    + exact: Pos.leb_refl.
    + exact: Pos.leb_refl.
    + exact: pos_leb_add_diag_r.
Qed.

Lemma mk_env_and_zip_newer_gen E g lsp E' g' cs lrs :
  mk_env_and_zip E g lsp = (E', g', cs, lrs) -> (g <=? g')%positive.
Proof.
  elim: lsp E g E' g' cs lrs => [| [ls1_hd ls2_hd] lsp_tl IH] E g E' g' cs lrs /=.
  - case=> _ <- _ _. exact: Pos.leb_refl.
  - dcase (mk_env_and1 E g ls1_hd ls2_hd) => [[[[E_hd g_hd] cs_hd] lsr_hd] Henv_hd].
    dcase (mk_env_and_zip E_hd g_hd lsp_tl) => [[[[E_tl g_tl] cs_tl] lsr_tl] Henv_tl].
    case=> _ <- _ _. apply: (pos_leb_trans (mk_env_and1_newer_gen Henv_hd)).
    exact: (IH _ _ _ _ _ _ Henv_tl).
Qed.

Lemma mk_env_and_newer_gen E g ls1 ls2 E' g' cs lrs :
  mk_env_and E g ls1 ls2 = (E', g', cs, lrs) -> (g <=? g')%positive.
Proof. exact: mk_env_and_zip_newer_gen. Qed.

Lemma mk_env_and1_newer_res E g l1 l2 E' g' cs lr :
  mk_env_and1 E g l1 l2 = (E', g', cs, lr) ->
  newer_than_lit g l1 -> newer_than_lit g l2 -> newer_than_lit g' lr.
Proof.
  rewrite /mk_env_and1. case Hff : ((l1 == lit_ff) || (l2 == lit_ff)).
  - case=> _ <- _ <-. by case/orP: Hff; move/eqP => ->.
  - case Hl1t : (l1 == lit_tt); last case Hl2t : (l2 == lit_tt); case=> _ <- _ <- //=.
    move=> _ _; exact: newer_than_lit_add_diag_r.
Qed.

Lemma mk_env_and_zip_newer_res E g lsp E' g' cs lrs :
  mk_env_and_zip E g lsp = (E', g', cs, lrs) ->
  newer_than_lits g (unzip1 lsp) -> newer_than_lits g (unzip2 lsp) ->
  newer_than_lits g' lrs.
Proof.
  elim: lsp E g E' g' cs lrs => [| [ls1_hd ls2_hd] lsp_tl IH] E g E' g' cs lrs /=.
  - by case=> _ <- _ <- _ _.
  - dcase (mk_env_and1 E g ls1_hd ls2_hd) => [[[[E_hd g_hd] cs_hd] lsr_hd] Henv_hd].
    dcase (mk_env_and_zip E_hd g_hd lsp_tl) => [[[[E_tl g_tl] cs_tl] lsr_tl] Henv_tl].
    case=> _ <- _ <-. move=> /andP [Hnew1hd Hnew1tl] /andP [Hnew2hd Hnew2tl].
    move: (mk_env_and1_newer_gen Henv_hd) => Hnewg1.
    move: (mk_env_and_zip_newer_gen Henv_tl) => Hnewg2.
    move: (mk_env_and1_newer_res Henv_hd Hnew1hd Hnew2hd)=> Hnew.
    rewrite newer_than_lits_cons.
    apply/andP; split; first by t_auto_newer.
    by rewrite (IH _ _ _ _ _ _ Henv_tl); t_auto_newer.
Qed.

Lemma mk_env_and_newer_res E g ls1 ls2 E' g' cs lrs :
  mk_env_and E g ls1 ls2 = (E', g', cs, lrs) ->
  newer_than_lit g lit_tt -> newer_than_lits g ls1 -> newer_than_lits g ls2 ->
  newer_than_lits g' lrs.
Proof.
  rewrite /mk_env_and => Henv Hnewtt Hnew1 Hnew2.
  apply: (mk_env_and_zip_newer_res Henv); by t_auto_newer.
Qed.

Lemma mk_env_and1_newer_cnf E g l1 l2 E' g' cs lr :
  mk_env_and1 E g l1 l2 = (E', g', cs, lr) ->
  newer_than_lit g l1 -> newer_than_lit g l2 -> newer_than_cnf g' cs.
Proof.
  rewrite /mk_env_and1. case Hff : ((l1 == lit_ff) || (l2 == lit_ff)).
  - case=> _ <- <- _; done.
  - case Hl1t : (l1 == lit_tt); last case Hl2t : (l2 == lit_tt); case=> _ <- <- _ //=.
    move=> Hnew1 Hnew2. by repeat (apply/andP; split); t_auto_newer.
Qed.

Lemma mk_env_and_zip_newer_cnf E g lsp E' g' cs lrs :
  mk_env_and_zip E g lsp = (E', g', cs, lrs) ->
  newer_than_lits g (unzip1 lsp) -> newer_than_lits g (unzip2 lsp) ->
  newer_than_cnf g' cs.
Proof.
  elim: lsp E g E' g' cs lrs => [| [ls1_hd ls2_hd] lsp_tl IH] E g E' g' cs lrs /=.
  - by case=> _ <- <- _ _ _.
  - dcase (mk_env_and1 E g ls1_hd ls2_hd) => [[[[E_hd g_hd] cs_hd] lsr_hd] Henv_hd].
    dcase (mk_env_and_zip E_hd g_hd lsp_tl) => [[[[E_tl g_tl] cs_tl] lsr_tl] Henv_tl].
    case=> _ <- <- _. move=> /andP [Hnew1hd Hnew1tl] /andP [Hnew2hd Hnew2tl].
    move: (mk_env_and1_newer_gen Henv_hd) => Hnewg1.
    move: (mk_env_and_zip_newer_gen Henv_tl) => Hnewg2.
    move: (mk_env_and1_newer_cnf Henv_hd Hnew1hd Hnew2hd) => Hnew1.
    rewrite newer_than_cnf_catrev. apply/andP; split; first by t_auto_newer.
    apply: (IH _ _ _ _ _ _ Henv_tl); by t_auto_newer.
Qed.

Lemma mk_env_and_newer_cnf E g ls1 ls2 E' g' cs lrs :
  mk_env_and E g ls1 ls2 = (E', g', cs, lrs) ->
  newer_than_lit g lit_tt -> newer_than_lits g ls1 -> newer_than_lits g ls2 ->
  newer_than_cnf g' cs.
Proof.
  rewrite /mk_env_and => Henv Hnewtt Hnew1 Hnew2.
  apply: (mk_env_and_zip_newer_cnf Henv); by t_auto_newer.
Qed.

Lemma mk_env_and1_preserve E g l1 l2 E' g' cs lr :
  mk_env_and1 E g l1 l2 = (E', g', cs, lr) -> env_preserve E E' g.
Proof.
  rewrite /mk_env_and1. case Hff : ((l1 == lit_ff) || (l2 == lit_ff)).
  - by case=> <- _ _ _.
  - case Hl1t : (l1 == lit_tt); last case Hl2t : (l2 == lit_tt); case=> <- _ _ _ //=.
    exact: env_upd_eq_preserve.
Qed.

Lemma mk_env_and_zip_preserve E g lsp E' g' cs lrs :
  mk_env_and_zip E g lsp = (E', g', cs, lrs) -> env_preserve E E' g.
Proof.
  elim: lsp E g E' g' cs lrs => [| [ls1_hd ls2_hd] lsp_tl IH] E g E' g' cs lrs /=.
  - by case=> <- _ _ _.
  - dcase (mk_env_and1 E g ls1_hd ls2_hd) => [[[[E_hd g_hd] cs_hd] lsr_hd] Henv_hd].
    dcase (mk_env_and_zip E_hd g_hd lsp_tl) => [[[[E_tl g_tl] cs_tl] lsr_tl] Henv_tl].
    case=> <- _ _ _. move: (mk_env_and1_preserve Henv_hd) => Hpre_hd.
    move: (IH _ _ _ _ _ _ Henv_tl) => Hpre_tl.
    move: (mk_env_and1_newer_gen Henv_hd) => Hnewg1. by t_auto_preserve.
Qed.

Lemma mk_env_and_preserve E g ls1 ls2 E' g' cs lrs :
  mk_env_and E g ls1 ls2 = (E', g', cs, lrs) -> env_preserve E E' g.
Proof. exact: mk_env_and_zip_preserve. Qed.

Lemma mk_env_and1_sat E g l1 l2 E' g' cs lr :
  mk_env_and1 E g l1 l2 = (E', g', cs, lr) ->
  newer_than_lit g l1 -> newer_than_lit g l2 -> interp_cnf E' cs.
Proof.
  rewrite /mk_env_and1. case Hff : ((l1 == lit_ff) || (l2 == lit_ff)).
  - by case=> <- _ <- _.
  - case Hl1t : (l1 == lit_tt); last case Hl2t : (l2 == lit_tt); case=> <- _ <- _ //=.
    move=> Hgl1 Hgl2.
    move: (newer_than_lit_neq Hgl1) (newer_than_lit_neq Hgl2) => Hngl1 Hngl2.
    rewrite /= !env_upd_eq !interp_lit_neg_lit.
    rewrite (interp_lit_env_upd_neq _ _ Hngl1).
    rewrite (interp_lit_env_upd_neq _ _ Hngl2).
    by case (interp_lit E l1); case (interp_lit E l2).
Qed.

Lemma mk_env_and_zip_sat E g lsp E' g' cs lrs :
  mk_env_and_zip E g lsp = (E', g', cs, lrs) ->
  newer_than_lits g (unzip1 lsp) -> newer_than_lits g (unzip2 lsp) ->
  interp_cnf E' cs.
Proof.
  elim: lsp E g E' g' cs lrs => [| [ls1_hd ls2_hd] lsp_tl IH] E g E' g' cs lrs /=.
  - by case=> <- _ <- _ _ _.
  - dcase (mk_env_and1 E g ls1_hd ls2_hd) => [[[[E_hd g_hd] cs_hd] lsr_hd] Henv_hd].
    dcase (mk_env_and_zip E_hd g_hd lsp_tl) => [[[[E_tl g_tl] cs_tl] lsr_tl] Henv_tl].
    case=> <- _ <- _. move=> /andP [Hnew1hd Hnew1tl] /andP [Hnew2hd Hnew2tl].
    rewrite interp_cnf_catrev.
    move: (mk_env_and1_newer_cnf Henv_hd Hnew1hd Hnew2hd) => Hnew1.
    move: (mk_env_and1_newer_gen Henv_hd) => Hnewg1.
    move: (mk_env_and1_sat Henv_hd Hnew1hd Hnew2hd) => Hcs_hd.
    move: (mk_env_and1_preserve Henv_hd) => Hpre_hd.
    move: (mk_env_and_zip_preserve Henv_tl) => Hpre_tl. apply/andP; split.
    (* interp_cnf E_tl cs_hd *)
    - rewrite (env_preserve_cnf Hpre_tl); last by t_auto_newer. assumption.
    - apply: (IH _ _ _ _ _ _ Henv_tl); by t_auto_newer.
Qed.

Lemma mk_env_and_sat E g ls1 ls2 E' g' cs lrs :
  mk_env_and E g ls1 ls2 = (E', g', cs, lrs) ->
  newer_than_lit g lit_tt -> newer_than_lits g ls1 -> newer_than_lits g ls2 ->
  interp_cnf E' cs.
Proof.
  rewrite /mk_env_and => Henv Hnewtt Hnew1 Hnew2.
  apply: (mk_env_and_zip_sat Henv); by t_auto_newer.
Qed.

Lemma mk_env_and1_env_equal E1 E2 g l1 l2 E1' E2' g1' g2' cs1 cs2 lr1 lr2 :
  env_equal E1 E2 ->
  mk_env_and1 E1 g l1 l2 = (E1', g1', cs1, lr1) ->
  mk_env_and1 E2 g l1 l2 = (E2', g2', cs2, lr2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lr1 = lr2.
Proof.
  rewrite /mk_env_and1 => Heq. case ((l1 == lit_ff) || (l2 == lit_ff)).
  - case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
  - case (l1 == lit_tt).
    + case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
    + case (l2 == lit_tt).
      * case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
      * dcase (gen g) => [[g' r] Hg]. case=> ? ? ? ?; case=> ? ? ? ?; subst.
        repeat split. rewrite (env_equal_interp_lit l1 Heq) (env_equal_interp_lit l2 Heq).
        apply: env_equal_upd. assumption.
Qed.

Lemma mk_env_and_zip_env_equal E1 E2 g lsp E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_and_zip E1 g lsp = (E1', g1', cs1, lrs1) ->
  mk_env_and_zip E2 g lsp = (E2', g2', cs2, lrs2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof.
  elim: lsp E1 E2 g E1' E2' g1' g2' cs1 cs2 lrs1 lrs2
  => [| [l1 l2] lsp IH] //= E1 E2 g E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 Heq.
  - case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
  - dcase (mk_env_and1 E1 g l1 l2) => [[[[E_hd1 g_hd1] cs_hd1] lrs_hd1] Hvhd1].
    dcase (mk_env_and1 E2 g l1 l2) => [[[[E_hd2 g_hd2] cs_hd2] lrs_hd2] Hvhd2].
    move: (mk_env_and1_env_equal Heq Hvhd1 Hvhd2) => [Heq' [? [? ?]]]; subst.
    dcase (mk_env_and_zip E_hd1 g_hd2 lsp) => [[[[E_tl1 g_tl1] cs_tl1] lrs_tl1] Hvtl1].
    dcase (mk_env_and_zip E_hd2 g_hd2 lsp) => [[[[E_tl2 g_tl2] cs_tl2] lrs_tl2] Hvtl2].
    move: (IH _ _ _ _ _ _ _ _ _ _ _ Heq' Hvtl1 Hvtl2) => [Heq'' [? [? ?]]]; subst.
    case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
Qed.

Lemma mk_env_and_env_equal E1 E2 g ls1 ls2 E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_and E1 g ls1 ls2 = (E1', g1', cs1, lrs1) ->
  mk_env_and E2 g ls1 ls2 = (E2', g2', cs2, lrs2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof. exact: mk_env_and_zip_env_equal. Qed.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Import CpdtTactics.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.
Require Import wyv_common.
Require Import rhs_mat_tree.
Require Import rhs_mat_subtype_lhs_sel_low_reduce.
Require Import rhs_mat_subtype_lhs_sel_upp_reduce.
Require Import rhs_mat_subtype_lhs_sel_equ_reduce.
Require Import rhs_mat_subtype_lhs_sel_nom_reduce.
Require Import rhs_mat_subtype_lhs_all_reduce.
Require Import rhs_mat_subtype_lhs_rfn_top_reduce.
Require Import rhs_mat_subtype_lhs_rfn_sel_reduce.
Require Import rhs_mat_subtype_lhs_sha_top_reduce.
Require Import rhs_mat_subtype_lhs_sha_sel_reduce.
Require Import rhs_mat_subtype_lhs_upp_reduce.
Require Import rhs_mat_subtype_lhs_low_reduce.
Require Import rhs_mat_subtype_lhs_equ_reduce.
Require Import rhs_mat_subtype_lhs_nom_reduce.
Require Import rhs_mat_subtype_lhs_nil_reduce.
Require Import rhs_mat_subtype_lhs_con_reduce.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_lhs_sel_equ_reduce :
  forall T1 x1 L1 T1', T1 = t_sel_equ x1 L1 T1' ->
                  forall T2, subtype T1' T2 = true ->
                        (T2 <> t_nil) ->
                        (forall T2' Ts2, T2 <> t_con T2' Ts2) ->
                        (forall L2 T2', T2 <> t_upp L2 T2') ->
                        (forall L2 T2', T2 <> t_low L2 T2') ->
                        (forall L2 T2', T2 <> t_equ L2 T2') ->
                        (forall L2 T2', T2 <> t_nom L2 T2') ->
                        subtype T1 T2 = true.
Proof.
  intros.

  subst T1.
  rewrite subtype_sel_equ_reduce with (x1:=x1)(L1:=L1)(T1':=T1');
    [|auto].

  destruct T2; simpl; auto.

  rewrite H0, orb_true_r; auto.

  rewrite H0, orb_true_r; auto.

  rewrite H0, orb_true_r; auto.

  rewrite H0, orb_true_r; auto.

  contradiction (H3 l T2); auto.
  contradiction (H4 l T2); auto.
  contradiction (H5 l T2); auto.
  contradiction (H6 l T2); auto.
  contradiction (H2 T2_1 T2_2); auto.
Qed.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Eqdep.

Require Export CatSem.PCF_order_comp.RPCF_rep_hom.
Require Export CatSem.CAT.rmonad_gen_comp.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Section rep_comp.

Variables P Q R : PCFPO_rep.
Variable M : PCFPO_rep_Hom P Q.
Variable N : PCFPO_rep_Hom Q R.

Lemma functy t :
   tcomp N (tcomp M (type_mor P t)) =
                 type_mor R t.
Proof.
  intros.
  simpl.
  rewrite (ttriag M).
  rewrite (ttriag N).
  auto.
Qed.

Obligation Tactic := idtac.

Program Instance Rep_comp_struct :
  PCFPO_rep_Hom_struct (P:=P) (R:=R)(f := fun t => tcomp N (tcomp M t))
      functy (RMon_comp M N).
Next Obligation.
Proof.
  simpl.
  intros V TT.
  elim TT.
  simpl.
  assert (HM:= CondB_hom (PCFPO_rep_Hom_struct := M)).
  simpl in HM.
  assert (HN:= CondB_hom (PCFPO_rep_Hom_struct := N)).
  simpl in HN.
(*  unfold eq_type_c in *.*)
  generalize functy.
  destruct M.
  destruct N.
  simpl in *.
  clear M.
  clear N.
  destruct R.
  clear R.
  destruct Q.
  clear Q.
  destruct P.
  clear P.
  simpl in *.

  assert (H' : (fun t => tcomp0 (tcomp (type_mor1 t)))
           = type_mor).
     apply functional_extensionality.
     intros;
     rewrite ttriag;
     rewrite ttriag0;
     auto.
  assert (H1 : (fun t => tcomp (type_mor1 t)) = type_mor0).
    apply functional_extensionality; auto.
  assert (H2 : (fun t => tcomp0 (type_mor0 t)) = type_mor).
    apply functional_extensionality; auto.

  generalize dependent rep_gen_Hom_monad_struct.
  generalize dependent rep_gen_Hom_monad_struct0.
  generalize dependent pcf_rep_struct.
  generalize dependent rep_Hom_monad0.
  generalize dependent pcf_rep_monad.
  generalize dependent rep_Hom_monad.
  generalize dependent pcf_rep_monad1.
  generalize dependent ttriag.
  generalize dependent pcf_rep_struct0.
  generalize dependent pcf_rep_monad0.
  generalize dependent ttriag0.
  rewrite <- H'.
  rewrite <- H1.

  intros;
  simpl.

  rewrite (UIP_refl _ _ (e _)).
  simpl.

  rewrite (UIP_refl _ _ (ttriag _ )) in HM.
  simpl in HM.
  rewrite (UIP_refl _ _ (ttriag0 _ )) in HN.
  simpl in HN.

  rewrite HM.
  rewrite HN.
  simpl.

  unfold rlift.
  simpl.
  rerew (rmod_hom_rmkl (CondB (PCFPO_rep_struct := pcf_rep_struct))).
Qed.
Next Obligation.
Proof.
  simpl.
  intros V TT.
  elim TT.
  simpl.
  assert (HM:= CondN_hom (PCFPO_rep_Hom_struct := M)).
  simpl in HM.
  assert (HN:= CondN_hom (PCFPO_rep_Hom_struct := N)).
  simpl in HN.
(*  unfold eq_type_c in *.*)
  generalize functy.
  destruct M.
  destruct N.
  simpl in *.
  clear M.
  clear N.
  destruct R.
  clear R.
  destruct Q.
  clear Q.
  destruct P.
  clear P.
  simpl in *.

  assert (H' : (fun t => tcomp0 (tcomp (type_mor1 t)))
           = type_mor).
     apply functional_extensionality.
     intros;
     rewrite ttriag;
     rewrite ttriag0;
     auto.
  assert (H1 : (fun t => tcomp (type_mor1 t)) = type_mor0).
    apply functional_extensionality; auto.
  assert (H2 : (fun t => tcomp0 (type_mor0 t)) = type_mor).
    apply functional_extensionality; auto.

  generalize dependent rep_gen_Hom_monad_struct.
  generalize dependent rep_gen_Hom_monad_struct0.
  generalize dependent pcf_rep_struct.
  generalize dependent rep_Hom_monad0.
  generalize dependent pcf_rep_monad.
  generalize dependent rep_Hom_monad.
  generalize dependent pcf_rep_monad1.
  generalize dependent ttriag.
  generalize dependent pcf_rep_struct0.
  generalize dependent pcf_rep_monad0.
  generalize dependent ttriag0.
  rewrite <- H'.
  rewrite <- H1.

  intros;
  simpl.

  rewrite (UIP_refl _ _ (e _)).
  simpl.

  rewrite (UIP_refl _ _ (ttriag _ )) in HM.
  simpl in HM.
  rewrite (UIP_refl _ _ (ttriag0 _ )) in HN.
  simpl in HN.

  rewrite HM.
  rewrite HN.
  simpl.

  unfold rlift.
  simpl.
  rerew (rmod_hom_rmkl (CondN (PCFPO_rep_struct := pcf_rep_struct))).
Qed.
Next Obligation.
Proof.
  simpl.
  intros V TT.
  elim TT.
  simpl.
  assert (HM:= Pred_hom (PCFPO_rep_Hom_struct := M)).
  simpl in HM.
  assert (HN:= Pred_hom (PCFPO_rep_Hom_struct := N)).
  simpl in HN.
(*  unfold eq_type_c in *.*)
  generalize functy.
  destruct M.
  destruct N.
  simpl in *.
  clear M.
  clear N.
  destruct R.
  clear R.
  destruct Q.
  clear Q.
  destruct P.
  clear P.
  simpl in *.

  assert (H' : (fun t => tcomp0 (tcomp (type_mor1 t)))
           = type_mor).
     apply functional_extensionality.
     intros;
     rewrite ttriag;
     rewrite ttriag0;
     auto.
  assert (H1 : (fun t => tcomp (type_mor1 t)) = type_mor0).
    apply functional_extensionality; auto.
  assert (H2 : (fun t => tcomp0 (type_mor0 t)) = type_mor).
    apply functional_extensionality; auto.

  generalize dependent rep_gen_Hom_monad_struct.
  generalize dependent rep_gen_Hom_monad_struct0.
  generalize dependent pcf_rep_struct.
  generalize dependent rep_Hom_monad0.
  generalize dependent pcf_rep_monad.
  generalize dependent rep_Hom_monad.
  generalize dependent pcf_rep_monad1.
  generalize dependent ttriag.
  generalize dependent pcf_rep_struct0.
  generalize dependent pcf_rep_monad0.
  generalize dependent ttriag0.
  rewrite <- H'.
  rewrite <- H1.

  intros;
  simpl.

  rewrite (UIP_refl _ _ (e _)).
  simpl.

  rewrite (UIP_refl _ _ (ttriag _ )) in HM.
  simpl in HM.
  rewrite (UIP_refl _ _ (ttriag0 _ )) in HN.
  simpl in HN.

  rewrite HM.
  rewrite HN.
  simpl.

  unfold rlift.
  simpl.
  rerew (rmod_hom_rmkl (Pred (PCFPO_rep_struct := pcf_rep_struct))).
Qed.
Next Obligation.
Proof.
  simpl.
  intros V TT.
  elim TT.
  simpl.
  assert (HM:= Zero_hom (PCFPO_rep_Hom_struct := M)).
  simpl in HM.
  assert (HN:= Zero_hom (PCFPO_rep_Hom_struct := N)).
  simpl in HN.
(*  unfold eq_type_c in *.*)
  generalize functy.
  destruct M.
  destruct N.
  simpl in *.
  clear M.
  clear N.
  destruct R.
  clear R.
  destruct Q.
  clear Q.
  destruct P.
  clear P.
  simpl in *.

  assert (H' : (fun t => tcomp0 (tcomp (type_mor1 t)))
           = type_mor).
     apply functional_extensionality.
     intros;
     rewrite ttriag;
     rewrite ttriag0;
     auto.
  assert (H1 : (fun t => tcomp (type_mor1 t)) = type_mor0).
    apply functional_extensionality; auto.
  assert (H2 : (fun t => tcomp0 (type_mor0 t)) = type_mor).
    apply functional_extensionality; auto.

  generalize dependent rep_gen_Hom_monad_struct.
  generalize dependent rep_gen_Hom_monad_struct0.
  generalize dependent pcf_rep_struct.
  generalize dependent rep_Hom_monad0.
  generalize dependent pcf_rep_monad.
  generalize dependent rep_Hom_monad.
  generalize dependent pcf_rep_monad1.
  generalize dependent ttriag.
  generalize dependent pcf_rep_struct0.
  generalize dependent pcf_rep_monad0.
  generalize dependent ttriag0.
  rewrite <- H'.
  rewrite <- H1.

  intros;
  simpl.

  rewrite (UIP_refl _ _ (e _)).
  simpl.

  rewrite (UIP_refl _ _ (ttriag _ )) in HM.
  simpl in HM.
  rewrite (UIP_refl _ _ (ttriag0 _ )) in HN.
  simpl in HN.

  rewrite HM.
  rewrite HN.
  simpl.

  unfold rlift.
  simpl.
  rerew (rmod_hom_rmkl (Zero (PCFPO_rep_struct := pcf_rep_struct))).
Qed.
Next Obligation.
Proof.
  simpl.
  intros V TT.
  elim TT.
  simpl.
  assert (HM:= Succ_hom (PCFPO_rep_Hom_struct := M)).
  simpl in HM.
  assert (HN:= Succ_hom (PCFPO_rep_Hom_struct := N)).
  simpl in HN.
(*  unfold eq_type_c in *.*)
  generalize functy.
  destruct M.
  destruct N.
  simpl in *.
  clear M.
  clear N.
  destruct R.
  clear R.
  destruct Q.
  clear Q.
  destruct P.
  clear P.
  simpl in *.

  assert (H' : (fun t => tcomp0 (tcomp (type_mor1 t)))
           = type_mor).
     apply functional_extensionality.
     intros;
     rewrite ttriag;
     rewrite ttriag0;
     auto.
  assert (H1 : (fun t => tcomp (type_mor1 t)) = type_mor0).
    apply functional_extensionality; auto.
  assert (H2 : (fun t => tcomp0 (type_mor0 t)) = type_mor).
    apply functional_extensionality; auto.

  generalize dependent rep_gen_Hom_monad_struct.
  generalize dependent rep_gen_Hom_monad_struct0.
  generalize dependent pcf_rep_struct.
  generalize dependent rep_Hom_monad0.
  generalize dependent pcf_rep_monad.
  generalize dependent rep_Hom_monad.
  generalize dependent pcf_rep_monad1.
  generalize dependent ttriag.
  generalize dependent pcf_rep_struct0.
  generalize dependent pcf_rep_monad0.
  generalize dependent ttriag0.
  rewrite <- H'.
  rewrite <- H1.

  intros;
  simpl.

  rewrite (UIP_refl _ _ (e _)).
  simpl.

  rewrite (UIP_refl _ _ (ttriag _ )) in HM.
  simpl in HM.
  rewrite (UIP_refl _ _ (ttriag0 _ )) in HN.
  simpl in HN.

  rewrite HM.
  rewrite HN.
  simpl.

  unfold rlift.
  simpl.
  rerew (rmod_hom_rmkl (Succ (PCFPO_rep_struct := pcf_rep_struct))).
Qed.
Next Obligation.
Proof.
  simpl.
  intros V TT.
  elim TT.
  simpl.
  assert (HM:= fff_hom (PCFPO_rep_Hom_struct := M)).
  simpl in HM.
  assert (HN:= fff_hom (PCFPO_rep_Hom_struct := N)).
  simpl in HN.
(*  unfold eq_type_c in *.*)
  generalize functy.
  destruct M.
  destruct N.
  simpl in *.
  clear M.
  clear N.
  destruct R.
  clear R.
  destruct Q.
  clear Q.
  destruct P.
  clear P.
  simpl in *.

  assert (H' : (fun t => tcomp0 (tcomp (type_mor1 t)))
           = type_mor).
     apply functional_extensionality.
     intros;
     rewrite ttriag;
     rewrite ttriag0;
     auto.
  assert (H1 : (fun t => tcomp (type_mor1 t)) = type_mor0).
    apply functional_extensionality; auto.
  assert (H2 : (fun t => tcomp0 (type_mor0 t)) = type_mor).
    apply functional_extensionality; auto.

  generalize dependent rep_gen_Hom_monad_struct.
  generalize dependent rep_gen_Hom_monad_struct0.
  generalize dependent pcf_rep_struct.
  generalize dependent rep_Hom_monad0.
  generalize dependent pcf_rep_monad.
  generalize dependent rep_Hom_monad.
  generalize dependent pcf_rep_monad1.
  generalize dependent ttriag.
  generalize dependent pcf_rep_struct0.
  generalize dependent pcf_rep_monad0.
  generalize dependent ttriag0.
  rewrite <- H'.
  rewrite <- H1.

  intros;
  simpl.

  rewrite (UIP_refl _ _ (e _)).
  simpl.

  rewrite (UIP_refl _ _ (ttriag _ )) in HM.
  simpl in HM.
  rewrite (UIP_refl _ _ (ttriag0 _ )) in HN.
  simpl in HN.

  rewrite HM.
  rewrite HN.
  simpl.

  unfold rlift.
  simpl.
  rerew (rmod_hom_rmkl (ffff (PCFPO_rep_struct := pcf_rep_struct))).
Qed.
Next Obligation.
Proof.
  simpl.
  intros V TT.
  elim TT.
  simpl.
  assert (HM:= ttt_hom (PCFPO_rep_Hom_struct := M)).
  simpl in HM.
  assert (HN:= ttt_hom (PCFPO_rep_Hom_struct := N)).
  simpl in HN.
(*  unfold eq_type_c in *.*)
  generalize functy.
  destruct M.
  destruct N.
  simpl in *.
  clear M.
  clear N.
  destruct R.
  clear R.
  destruct Q.
  clear Q.
  destruct P.
  clear P.
  simpl in *.

  assert (H' : (fun t => tcomp0 (tcomp (type_mor1 t)))
           = type_mor).
     apply functional_extensionality.
     intros;
     rewrite ttriag;
     rewrite ttriag0;
     auto.
  assert (H1 : (fun t => tcomp (type_mor1 t)) = type_mor0).
    apply functional_extensionality; auto.
  assert (H2 : (fun t => tcomp0 (type_mor0 t)) = type_mor).
    apply functional_extensionality; auto.

  generalize dependent rep_gen_Hom_monad_struct.
  generalize dependent rep_gen_Hom_monad_struct0.
  generalize dependent pcf_rep_struct.
  generalize dependent rep_Hom_monad0.
  generalize dependent pcf_rep_monad.
  generalize dependent rep_Hom_monad.
  generalize dependent pcf_rep_monad1.
  generalize dependent ttriag.
  generalize dependent pcf_rep_struct0.
  generalize dependent pcf_rep_monad0.
  generalize dependent ttriag0.
  rewrite <- H'.
  rewrite <- H1.

  intros;
  simpl.

  rewrite (UIP_refl _ _ (e _)).
  simpl.

  rewrite (UIP_refl _ _ (ttriag _ )) in HM.
  simpl in HM.
  rewrite (UIP_refl _ _ (ttriag0 _ )) in HN.
  simpl in HN.

  rewrite HM.
  rewrite HN.
  simpl.

  unfold rlift.
  simpl.
  rerew (rmod_hom_rmkl (tttt (PCFPO_rep_struct := pcf_rep_struct))).
Qed.
Next Obligation.
Proof.
  simpl.
  intros t V TT.
  elim TT.
  simpl.
  assert (HM:= bottom_hom t (PCFPO_rep_Hom_struct := M)).
  simpl in HM.
  assert (HN:= bottom_hom t (PCFPO_rep_Hom_struct := N)).
  simpl in HN.
(*  unfold eq_type_c in *.*)
  generalize functy.
  destruct M.
  destruct N.
  simpl in *.
  clear M.
  clear N.
  destruct R.
  clear R.
  destruct Q.
  clear Q.
  destruct P.
  clear P.
  simpl in *.

  assert (H' : (fun t => tcomp0 (tcomp (type_mor1 t)))
           = type_mor).
     apply functional_extensionality.
     intros;
     rewrite ttriag;
     rewrite ttriag0;
     auto.
  assert (H1 : (fun t => tcomp (type_mor1 t)) = type_mor0).
    apply functional_extensionality; auto.
  assert (H2 : (fun t => tcomp0 (type_mor0 t)) = type_mor).
    apply functional_extensionality; auto.

  generalize dependent rep_gen_Hom_monad_struct.
  generalize dependent rep_gen_Hom_monad_struct0.
  generalize dependent pcf_rep_struct.
  generalize dependent rep_Hom_monad0.
  generalize dependent pcf_rep_monad.
  generalize dependent rep_Hom_monad.
  generalize dependent pcf_rep_monad1.
  generalize dependent ttriag.
  generalize dependent pcf_rep_struct0.
  generalize dependent pcf_rep_monad0.
  generalize dependent ttriag0.
  rewrite <- H'.
  rewrite <- H1.

  intros;
  simpl.

  rewrite (UIP_refl _ _ (e _)).
  simpl.

  rewrite (UIP_refl _ _ (ttriag _ )) in HM.
  simpl in HM.
  rewrite (UIP_refl _ _ (ttriag0 _ )) in HN.
  simpl in HN.

  rewrite HM.
  rewrite HN.
  simpl.

  unfold rlift.
  simpl.
  rerew (rmod_hom_rmkl (bottom t (PCFPO_rep_struct := pcf_rep_struct))).
Qed.
Next Obligation.
Proof.
  simpl.
  intros m V TT.
  elim TT.
  simpl.
  assert (HM:= nats_hom m (PCFPO_rep_Hom_struct := M)).
  simpl in HM.
  assert (HN:= nats_hom m (PCFPO_rep_Hom_struct := N)).
  simpl in HN.
(*  unfold eq_type_c in *.*)
  generalize functy.
  destruct M.
  destruct N.
  simpl in *.
  clear M.
  clear N.
  destruct R.
  clear R.
  destruct Q.
  clear Q.
  destruct P.
  clear P.
  simpl in *.

  assert (H' : (fun t => tcomp0 (tcomp (type_mor1 t)))
           = type_mor).
     apply functional_extensionality.
     intros;
     rewrite ttriag;
     rewrite ttriag0;
     auto.
  assert (H1 : (fun t => tcomp (type_mor1 t)) = type_mor0).
    apply functional_extensionality; auto.
  assert (H2 : (fun t => tcomp0 (type_mor0 t)) = type_mor).
    apply functional_extensionality; auto.

  generalize dependent rep_gen_Hom_monad_struct.
  generalize dependent rep_gen_Hom_monad_struct0.
  generalize dependent pcf_rep_struct.
  generalize dependent rep_Hom_monad0.
  generalize dependent pcf_rep_monad.
  generalize dependent rep_Hom_monad.
  generalize dependent pcf_rep_monad1.
  generalize dependent ttriag.
  generalize dependent pcf_rep_struct0.
  generalize dependent pcf_rep_monad0.
  generalize dependent ttriag0.
  rewrite <- H'.
  rewrite <- H1.

  intros;
  simpl.

  rewrite (UIP_refl _ _ (e _)).
  simpl.

  rewrite (UIP_refl _ _ (ttriag _ )) in HM.
  simpl in HM.
  rewrite (UIP_refl _ _ (ttriag0 _ )) in HN.
  simpl in HN.

  rewrite HM.
  rewrite HN.
  simpl.

  unfold rlift.
  simpl.
  rerew (rmod_hom_rmkl (nats m (PCFPO_rep_struct := pcf_rep_struct))).
Qed.
Next Obligation.
Proof.
  simpl.
  intros r s V y.
  assert (HM:= app_hom (PCFPO_rep_Hom_struct := M)
                         (r:=r) (s:=s)).
  simpl in HM.
  assert (HN:= app_hom (PCFPO_rep_Hom_struct := N)
                            (r:=r) (s:=s)).
  simpl in HN.

  generalize functy.
  destruct M.
  destruct N.
  simpl in *.
  clear M.
  clear N.
  destruct R.
  clear R.
  destruct Q.
  clear Q.
  destruct P.
  clear P.
  simpl in *.

  assert (H' : (fun t => tcomp0 (tcomp (type_mor1 t)))
           = type_mor).
     apply functional_extensionality.
     intros;
     rewrite ttriag;
     rewrite ttriag0;
     auto.
  assert (H1 : (fun t => tcomp (type_mor1 t)) = type_mor0).
    apply functional_extensionality; auto.
  assert (H2 : (fun t => tcomp0 (type_mor0 t)) = type_mor).
    apply functional_extensionality; auto.

  generalize dependent rep_gen_Hom_monad_struct.
  generalize dependent rep_gen_Hom_monad_struct0.
  generalize dependent pcf_rep_struct.
  generalize dependent rep_Hom_monad0.
  generalize dependent pcf_rep_monad.
  generalize dependent rep_Hom_monad.
  generalize dependent pcf_rep_monad1.
  generalize dependent ttriag.
  generalize dependent pcf_rep_struct0.
  generalize dependent pcf_rep_monad0.
  generalize dependent ttriag0.
  rewrite <- H'.
  rewrite <- H1.

  intros;
  simpl.

  rewrite (UIP_refl _ _ (e s)).
  rewrite (UIP_refl _ _ (e r)).
  rewrite (UIP_refl _ _ (e (r ~> s))).
  simpl in *.

  rewrite (UIP_refl _ _ (ttriag s)) in HM.
  rewrite (UIP_refl _ _ (ttriag r)) in HM.
  rewrite (UIP_refl _ _ (ttriag (r ~> s))) in HM.
  simpl in HM.

  rewrite (UIP_refl _ _ (ttriag0 s)) in HN.
  rewrite (UIP_refl _ _ (ttriag0 r)) in HN.
  rewrite (UIP_refl _ _ (ttriag0 (r ~> s))) in HN.
  simpl in HN.

  rewrite HM.
  rewrite HN.
  simpl.

  unfold rlift.
  simpl.
  rerew (rmod_hom_rmkl (app r s
              (PCFPO_rep_struct := pcf_rep_struct))).
Qed.
Next Obligation.
Proof.
  simpl.
  intros r s V y.
  assert (HM:= abs_hom (PCFPO_rep_Hom_struct := M)
            (r:=r) (s:=s)).
  simpl in HM.
  assert (HN:= abs_hom (PCFPO_rep_Hom_struct := N)
            (r:=r) (s:=s)).
  simpl in HN.

  generalize functy.
  destruct M.
  destruct N.
  simpl in *.
  clear M.
  clear N.
  destruct R.
  clear R.
  destruct Q.
  clear Q.
  destruct P.
  clear P.
  simpl in *.

  assert (H' : (fun t => tcomp0 (tcomp (type_mor1 t)))
                 = type_mor).
     apply functional_extensionality.
     intros;
     rewrite ttriag;
     rewrite ttriag0;
     auto.
  assert (H1 : (fun t => tcomp (type_mor1 t)) = type_mor0).
    apply functional_extensionality; auto.
  assert (H2 : (fun t => tcomp0 (type_mor0 t)) = type_mor).
    apply functional_extensionality; auto.

  generalize dependent rep_gen_Hom_monad_struct.
  generalize dependent rep_gen_Hom_monad_struct0.
  generalize dependent pcf_rep_struct.
  generalize dependent rep_Hom_monad0.
  generalize dependent pcf_rep_monad.
  generalize dependent rep_Hom_monad.
  generalize dependent pcf_rep_monad1.
  generalize dependent ttriag.
  generalize dependent pcf_rep_struct0.
  generalize dependent pcf_rep_monad0.
  generalize dependent ttriag0.
  rewrite <- H'.
  rewrite <- H1.

  intros;
  simpl.

  rewrite (UIP_refl _ _ (e s)).
  rewrite (UIP_refl _ _ (e r)).
  rewrite (UIP_refl _ _ (e (r ~> s))).
  simpl in *.

  rewrite (UIP_refl _ _ (ttriag s)) in HM.
  rewrite (UIP_refl _ _ (ttriag r)) in HM.
  rewrite (UIP_refl _ _ (ttriag (r ~> s))) in HM.
  simpl in HM.

  rewrite (UIP_refl _ _ (ttriag0 s)) in HN.
  rewrite (UIP_refl _ _ (ttriag0 r)) in HN.
  rewrite (UIP_refl _ _ (ttriag0 (r ~> s))) in HN.
  simpl in HN.

  clear e.
  rewrite HM.
  rewrite HN.
  clear HM HN.
  simpl.
  unfold rlift.
  simpl.
  rerew (rmhom_rmkl (abs r s (PCFPO_rep_struct := pcf_rep_struct))).

  apply f_equal.
  assert (H4:=rklkl pcf_rep_monad).
  simpl in H4.
  rewrite H4.
  rewrite H4.
  simpl.

  rew (gen_rh_rkl rep_Hom_monad0).
  rewrite H4.

  apply (rkl_eq pcf_rep_monad).

  simpl.
  clear y.
  intros t y.
  rew (retakl pcf_rep_monad).

  destruct y as [t y].
  simpl in *.
  rew (gen_rh_rweta rep_Hom_monad0).
  rew (retakl pcf_rep_monad).
  rew (retakl pcf_rep_monad).
  destruct y as [t y];
  simpl.
  destruct y as [t y | ];
  simpl; auto.
  rew (rlift_rweta pcf_rep_monad).
Qed.
Next Obligation.
Proof.
  simpl.
  intros t V y.
  assert (HM:= rec_hom (t:=t) (PCFPO_rep_Hom_struct := M)).
  simpl in HM.
  assert (HN:= rec_hom  (t:=t)(PCFPO_rep_Hom_struct := N)).
  simpl in HN.

  generalize functy.
  destruct M.
  destruct N.
  simpl in *.
  clear M.
  clear N.
  destruct R.
  clear R.
  destruct Q.
  clear Q.
  destruct P.
  clear P.
  simpl in *.

  assert (H' : (fun t => tcomp0 (tcomp (type_mor1 t)))
           = type_mor).
     apply functional_extensionality.
     intros;
     rewrite ttriag;
     rewrite ttriag0;
     auto.
  assert (H1 : (fun t => tcomp (type_mor1 t)) = type_mor0).
    apply functional_extensionality; auto.
  assert (H2 : (fun t => tcomp0 (type_mor0 t)) = type_mor).
    apply functional_extensionality; auto.

  generalize dependent rep_gen_Hom_monad_struct.
  generalize dependent rep_gen_Hom_monad_struct0.
  generalize dependent pcf_rep_struct.
  generalize dependent rep_Hom_monad0.
  generalize dependent pcf_rep_monad.
  generalize dependent rep_Hom_monad.
  generalize dependent pcf_rep_monad1.
  generalize dependent ttriag.
  generalize dependent pcf_rep_struct0.
  generalize dependent pcf_rep_monad0.
  generalize dependent ttriag0.
  rewrite <- H'.
  rewrite <- H1.

  intros;
  simpl.

  rewrite (UIP_refl _ _ (e _)).
  rewrite (UIP_refl _ _ (e _ )).

  rewrite (UIP_refl _ _ (ttriag _)) in HM.
  rewrite (UIP_refl _ _ (ttriag _)) in HM.
  simpl in HM.

  rewrite (UIP_refl _ _ (ttriag0 _)) in HN.
  rewrite (UIP_refl _ _ (ttriag0 _)) in HN.
  simpl in HN.

  rewrite HM.
  rewrite HN.
  simpl.

  unfold rlift.
  simpl.
  rerew (rmod_hom_rmkl (rec t
              (PCFPO_rep_struct := pcf_rep_struct))).
Qed.

Definition Rep_comp :
  PCFPO_rep_Hom P R := Build_PCFPO_rep_Hom Rep_comp_struct.

End rep_comp.


(** Propositions for reasoning about monotone partial bijections.

This library provides two propositions [gset_bij_own_auth γ L] and
[gset_bij_own_elem γ a b], where [L] is a bijection between types [A] and [B]
represented by a set of associations [gset (A * B)]. The idea is that
[gset_bij_own_auth γ L] is an authoritative bijection [L], while
[gset_bij_own_elem γ a b] is a persistent resource saying [L] associates [a]
and [b].

The main use case is in a logical relation-based proof where [L] maintains the
association between locations [A] in one execution and [B] in another (perhaps
of different types, if the logical relation relates two different semantics).

The association [L] is always bijective, so that if [a] is mapped to [b], there
should be no other mappings for either [a] or [b]; the [gset_bij_own_extend]
update theorem enforces that new mappings respect this property, and
[gset_bij_own_elem_agree] allows the user to exploit bijectivity. The bijection
grows monotonically, so that the set of associations only grows; this is
captured by the persistence of [gset_bij_own_elem].

This library is a logical, ownership-based wrapper around [gset_bij]. *)

From iris.algebra.lib Require Import gset_bij.
From iris.bi.lib Require Import fractional.
From iris.base_logic.lib Require Import own.
From iris.proofmode Require Import proofmode.
From iris.prelude Require Import options.

(* The uCMRA we need. *)
Class gset_bijG Σ A B `{Countable A, Countable B} :=
  GsetBijG { gset_bijG_inG : inG Σ (gset_bijR A B); }.
Local Existing Instance gset_bijG_inG.
Global Hint Mode gset_bijG - ! ! - - - - : typeclass_instances.

Definition gset_bijΣ A B `{Countable A, Countable B}: gFunctors :=
  #[ GFunctor (gset_bijR A B) ].
Global Instance subG_gset_bijΣ `{Countable A, Countable B} Σ :
  subG (gset_bijΣ A B) Σ → gset_bijG Σ A B.
Proof. solve_inG. Qed.

Definition gset_bij_own_auth_def `{gset_bijG Σ A B} (γ : gname)
    (dq : dfrac) (L : gset (A * B)) : iProp Σ :=
  own γ (gset_bij_auth dq L).
Definition gset_bij_own_auth_aux : seal (@gset_bij_own_auth_def). Proof. by eexists. Qed.
Definition gset_bij_own_auth := unseal gset_bij_own_auth_aux.
Definition gset_bij_own_auth_eq :
  @gset_bij_own_auth = @gset_bij_own_auth_def := seal_eq gset_bij_own_auth_aux.
Global Arguments gset_bij_own_auth {_ _ _ _ _ _ _ _}.

Definition gset_bij_own_elem_def `{gset_bijG Σ A B} (γ : gname)
  (a : A) (b : B) : iProp Σ := own γ (gset_bij_elem a b).
Definition gset_bij_own_elem_aux : seal (@gset_bij_own_elem_def). Proof. by eexists. Qed.
Definition gset_bij_own_elem := unseal gset_bij_own_elem_aux.
Definition gset_bij_own_elem_eq :
  @gset_bij_own_elem = @gset_bij_own_elem_def := seal_eq gset_bij_own_elem_aux.
Global Arguments gset_bij_own_elem {_ _ _ _ _ _ _ _}.

Section gset_bij.
  Context `{gset_bijG Σ A B}.
  Implicit Types (L : gset (A * B)) (a : A) (b : B).

  Global Instance gset_bij_own_auth_timeless γ q L :
    Timeless (gset_bij_own_auth γ q L).
  Proof. rewrite gset_bij_own_auth_eq. apply _. Qed.
  Global Instance gset_bij_own_elem_timeless γ a b :
    Timeless (gset_bij_own_elem γ a b).
  Proof. rewrite gset_bij_own_elem_eq. apply _. Qed.
  Global Instance gset_bij_own_elem_persistent γ a b :
    Persistent (gset_bij_own_elem γ a b).
  Proof. rewrite gset_bij_own_elem_eq. apply _. Qed.

  Global Instance gset_bij_own_auth_fractional γ L :
    Fractional (λ q, gset_bij_own_auth γ (DfracOwn q) L).
  Proof.
    intros p q. rewrite gset_bij_own_auth_eq -own_op gset_bij_auth_dfrac_op //.
  Qed.
  Global Instance gset_bij_own_auth_as_fractional γ q L :
    AsFractional (gset_bij_own_auth γ (DfracOwn q) L) (λ q, gset_bij_own_auth γ (DfracOwn q) L) q.
  Proof. split; [auto|apply _]. Qed.

  Lemma gset_bij_own_auth_agree γ dq1 dq2 L1 L2 :
    gset_bij_own_auth γ dq1 L1 -∗ gset_bij_own_auth γ dq2 L2 -∗
    ⌜✓ (dq1 ⋅ dq2) ∧ L1 = L2 ∧ gset_bijective L1⌝.
  Proof.
    rewrite gset_bij_own_auth_eq. iIntros "H1 H2".
    by iCombine "H1 H2" gives %?%gset_bij_auth_dfrac_op_valid.
  Qed.
  Lemma gset_bij_own_auth_exclusive γ L1 L2 :
    gset_bij_own_auth γ (DfracOwn 1) L1 -∗ gset_bij_own_auth γ (DfracOwn 1) L2 -∗ False.
  Proof.
    iIntros "H1 H2".
    by iDestruct (gset_bij_own_auth_agree with "H1 H2") as %[[] _].
  Qed.

  Lemma gset_bij_own_valid γ q L :
    gset_bij_own_auth γ q L -∗ ⌜✓ q ∧ gset_bijective L⌝.
  Proof.
    rewrite gset_bij_own_auth_eq. iIntros "Hauth".
    by iDestruct (own_valid with "Hauth") as %?%gset_bij_auth_dfrac_valid.
  Qed.

  Lemma gset_bij_own_elem_agree γ a a' b b' :
    gset_bij_own_elem γ a b -∗ gset_bij_own_elem γ a' b' -∗
    ⌜a = a' ↔ b = b'⌝.
  Proof.
    rewrite gset_bij_own_elem_eq. iIntros "Hel1 Hel2".
    by iCombine "Hel1 Hel2" gives %?%gset_bij_elem_agree.
  Qed.

  Lemma gset_bij_own_elem_get {γ q L} a b :
    (a, b) ∈ L →
    gset_bij_own_auth γ q L -∗ gset_bij_own_elem γ a b.
  Proof.
    intros. rewrite gset_bij_own_auth_eq gset_bij_own_elem_eq.
    by apply own_mono, bij_view_included.
  Qed.

  Lemma gset_bij_elem_of {γ q L} a b :
    gset_bij_own_auth γ q L -∗ gset_bij_own_elem γ a b -∗ ⌜(a, b) ∈ L⌝.
  Proof.
    iIntros "Hauth Helem". rewrite gset_bij_own_auth_eq gset_bij_own_elem_eq.
    iCombine "Hauth Helem" gives "%Ha".
    iPureIntro. revert Ha. rewrite bij_both_dfrac_valid. intros (_ & _ & ?); done.
  Qed.

  Lemma gset_bij_own_elem_get_big γ q L :
    gset_bij_own_auth γ q L -∗ [∗ set] ab ∈ L, gset_bij_own_elem γ ab.1 ab.2.
  Proof.
    iIntros "Hauth". iApply big_sepS_forall. iIntros ([a b] ?) "/=".
    by iApply gset_bij_own_elem_get.
  Qed.

  Lemma gset_bij_own_alloc L :
    gset_bijective L →
    ⊢ |==> ∃ γ, gset_bij_own_auth γ (DfracOwn 1) L ∗ [∗ set] ab ∈ L, gset_bij_own_elem γ ab.1 ab.2.
  Proof.
    intro. iAssert (∃ γ, gset_bij_own_auth γ (DfracOwn 1) L)%I with "[>]" as (γ) "Hauth".
    { rewrite gset_bij_own_auth_eq. iApply own_alloc. by apply gset_bij_auth_valid. }
    iExists γ. iModIntro. iSplit; [done|].
    by iApply gset_bij_own_elem_get_big.
  Qed.
  Lemma gset_bij_own_alloc_empty :
    ⊢ |==> ∃ γ, gset_bij_own_auth γ (DfracOwn 1) (∅ : gset (A * B)).
  Proof. iMod (gset_bij_own_alloc ∅) as (γ) "[Hauth _]"; by auto. Qed.

  Lemma gset_bij_own_extend {γ L} a b :
    (∀ b', (a, b') ∉ L) → (∀ a', (a', b) ∉ L) →
    gset_bij_own_auth γ (DfracOwn 1) L ==∗
    gset_bij_own_auth γ (DfracOwn 1) ({[(a, b)]} ∪ L) ∗ gset_bij_own_elem γ a b.
  Proof.
    iIntros (??) "Hauth".
    iAssert (gset_bij_own_auth γ (DfracOwn 1) ({[(a, b)]} ∪ L)) with "[> Hauth]" as "Hauth".
    { rewrite gset_bij_own_auth_eq. iApply (own_update with "Hauth").
      by apply gset_bij_auth_extend. }
    iModIntro. iSplit; [done|].
    iApply (gset_bij_own_elem_get with "Hauth"). set_solver.
  Qed.

  Lemma gset_bij_own_extend_internal {γ L} a b :
    (∀ b', gset_bij_own_elem γ a b' -∗ False) -∗
    (∀ a', gset_bij_own_elem γ a' b -∗ False) -∗
    gset_bij_own_auth γ (DfracOwn 1) L ==∗
    gset_bij_own_auth γ (DfracOwn 1) ({[(a, b)]} ∪ L) ∗ gset_bij_own_elem γ a b.
  Proof.
    iIntros "Ha Hb HL".
    iAssert ⌜∀ b', (a, b') ∉ L⌝%I as %?.
    { iIntros (b' ?). iApply ("Ha" $! b'). by iApply gset_bij_own_elem_get. }
    iAssert ⌜∀ a', (a', b) ∉ L⌝%I as %?.
    { iIntros (a' ?). iApply ("Hb" $! a'). by iApply gset_bij_own_elem_get. }
    by iApply (gset_bij_own_extend with "HL").
  Qed.
End gset_bij.