(******************************************************************************)
(* A bit library for Coq: sets encoded as bitseqs.                            *)
(******************************************************************************)
(*                                                                            *)
(* (c) 2016, MINES ParisTech                                                  *)
(*                                                                            *)
(* Written by Arthur Blot                                                     *)
(*            Pierre-Evariste Dagand                                          *)
(*            Emilio J. Gallego Arias                                         *)
(*                                                                            *)
(* LICENSE: CECILL-B                                                          *)
(*                                                                            *)
(******************************************************************************)
From mathcomp
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div.
From mathcomp
Require Import choice fintype finset tuple path bigop.
From mathcomp
Require Import ssralg ssrnum fingroup perm finalg zmodp.

(******************************************************************************)
(* A bit library for Coq: sets encoded as bitseqs.                            *)
(* WARNING: This library is just a proof of concept and extremely unstable.   *)
(*                                                                            *)
(* Operations:                                                                *)
(*                                                                            *)
(*   to_set b == seq of nats representing the bits set in bitseq b            *)
(* from_set s == bitseq correponding to (s : seq nat)                         *)
(*                                                                            *)
(*     seqn s == k.-bit tuple for (s : seq 'I_k)                              *)
(*     setn S == k.-bit tuple for (S : {set 'I_k})                            *)
(*                                                                            *)
(*     seqB B ==  seq 'I_k  corresponding to (B : k.-bit_tuple)               *)
(*     setB B == {set 'I_k} corresponding to (B : k.-bit_tuple)               *)
(*                                                                            *)
(* Future:                                                                    *)
(*                                                                            *)
(*     seqF F ==  seq 'I_k  corresponding to (B : {ffun ...}                  *)
(*     setF B == {ffun 'I_k... } corresponding to (B : k.-bit_tuple)          *)
(*                                                                            *)
(* Operations are designed to cancel in the proper way, the *_morphL family   *)
(* or lemmas provide the correspondence between set and bit operations.       *)
(*                                                                            *)
(* This file uses the following suffix conventions (FIXME):                   *)
(*                                                                            *)
(*  n - operations on nat seq/seq representation.                             *)
(*  B - operations on k.-tuple bool                                           *)
(*                                                                            *)
(******************************************************************************)

(* Import bits operations. *)
Require Import bitseq notation.

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

Open Scope bits_scope.

Hint Resolve orbb andbb.

Section MemIota.
(* Indexes *)
Implicit Types (i j : nat).
Implicit Types (s : seq nat).

(* Auxiliary results *)
Lemma memS_mask l i m j k :
  (l + i \in mask m (iota (l + j) k)) =
  (    i \in mask m (iota      j  k)).
Proof.
elim: k m i j l => [|k ihk] [|b m] i j l; rewrite // !mem_mask_cons.
by rewrite eqn_add2l -addnS ihk.
Qed.

Lemma mem_mask_gt i j k m : i < j -> (i \in mask m (iota j k)) = false.
Proof.
elim: k i j m => [|k ihk] i j m hij; first by rewrite mask0.
by case: m => // -[] m; rewrite mem_mask_cons ihk ?(ltn_eqF hij) ?ltnS // ltnW.
Qed.

(* Main lemma relating bitmasks with their enumerations *)
Lemma mem_mask_iota k i j m : j <= i < k ->
   i \in mask m (iota j k) = m`_(i - j).
Proof.
elim: k i j m => [|k ihk] i j [|b m] /andP [hji hik] //.
  by rewrite nth_nil.
rewrite mem_mask_cons; case: eqP => [->|/eqP/negbTE neq_ij].
  by rewrite mem_mask_gt // subnn andbT orbF.
have hj : j < i by rewrite ltn_neqAle hji eq_sym neq_ij.
case: i hji hik {neq_ij} hj => // i hji hik hj.
rewrite (memS_mask 1) // andbF (ihk i) ?subSn //.
by rewrite ltnS in hj; rewrite hj.
Qed.

End MemIota.

(* Untyped operations, useful for computing and avoid {set _} *)
Definition to_set   m := mask m (iota 0 (size m)).
(* Definition from_set k s := foldr (fun idx bs => setb bs idx true) (nseq k false) s. *)
Definition from_set s := foldr (fun idx bs => sets bs idx true) [::] s.

Lemma size_from_set s : size (from_set s) = \max_(n <- s) n.+1.
Proof.
by elim: s => [|n s ihs]; rewrite ?big_nil ?big_cons ?size_nseq ?size_set_nth // ihs.
Qed.

Lemma from_setE s : from_set s = \big[ors/[::]]_(n <- s) sets [::] n true.
Proof.
elim: s => [|n s ihs]; rewrite ?(big_nil, big_cons) //=.
by rewrite set_bitE ?size_from_set orsC ihs.
Qed.

Lemma eq_perm_from_set s1 s2 : perm_eq s1 s2 ->
  from_set s1 = from_set s2.
Proof. rewrite !from_setE; exact: eq_big_perm. Qed.

(* TODO: We must work up to (perm_eq uniq) for the image of to_set *)
Lemma eq_from_set s1 s2 : uniq s1 -> uniq s2 -> s1 =i s2 ->
                  from_set s1 = from_set s2.
Proof. by move=> ? ? ?; apply/eq_perm_from_set/uniq_perm_eq. Qed.

Lemma from_set_tupleP k (s : seq 'I_k) : size (ors (from_set (map val s)) '0_k) == k.
Proof.
rewrite size_liftz size_nseq size_from_set big_map.
elim/big_rec: _ => [|j n _ /eqP/maxn_idPr ihj]; first by rewrite max0n.
by apply/eqP/maxn_idPr; rewrite geq_max ltn_ord.
Qed.

Definition seqn k (s : seq 'I_k)   := Tuple (from_set_tupleP s).
Definition setn k (s : {set 'I_k}): 'B_k
  := seqn (enum s).

Definition seqB k (m : 'B_k) := mask m (enum 'I_k).
Definition setB k (m : 'B_k): {set 'I_k}
  := [set x in seqB m].

(* Alternative *)
Definition setb' k (m : 'B_k) := [set i in 'I_k | m`_i].

Lemma val_mem_seq (T : eqType) (P : pred T) (sT : subType P)
      (i : sT) (s : seq sT) : (i \in s) = (val i \in [seq val x | x <- s]).
Proof. by elim: s => //= x s ihs; rewrite !inE val_eqE ihs. Qed.

(* This is interesting (and true) but a bit cumbersome to prove *)
Lemma setb_def k (m : 'B_k) : setB m = [set i in 'I_k | m`_i].
Proof.
apply/setP=> i; rewrite !inE val_mem_seq map_mask val_enum_ord.
by rewrite mem_mask_iota ?subn0 ?ltn_ord ?size_tuple.
Qed.

Lemma eq_seqn k (s1 s2 : seq 'I_k) :
  uniq s1 -> uniq s2 -> s1 =i s2 -> seqn s1 = seqn s2.
Proof.
move=> u1 u2 hi; apply/val_inj; congr ors.
apply/eq_from_set; rewrite ?(map_inj_uniq val_inj) //.
by move=> u; apply/mapP/mapP=> -[v v1 ->]; exists v; rewrite ?hi // -hi.
Qed.

Lemma seqb_uniq k (s : 'B_k) : uniq (seqB s).
Proof. by rewrite mask_uniq ?enum_uniq. Qed.

Lemma mem_setb k (b : 'B_k) (i : 'I_k) :
  (i \in setB b) = b`_i.
Proof.
rewrite inE val_mem_seq !map_mask val_enum_ord.
by rewrite mem_mask_iota ?subn0 ?ltn_ord ?size_tuple.
Qed.

Lemma mem_setB k (b : 'B_k) (i : 'I_k) :
  (i \in setB b) = tnth b i.
Proof. by rewrite mem_setb (tnth_nth false). Qed.

(* XXX: Needs fixing *)
(* Lemma seqn_cons k n (s : seq 'I_k) : *)
(*   seqn (n :: s) = [tuple of setb (seqn s) n true]. *)
(* Proof. exact: val_inj. Qed. *)

Lemma nth_ors0 bs i k : (ors bs '0_k)`_i = bs`_i.
Proof. by rewrite /ors nth_liftz_idem ?gets0 ?orbF. Qed.

(* Perm_eq is not enough as we also remove the dups *)
Lemma seqnK k (x : seq 'I_k) : (seqB (seqn x)) =i x.
Proof.
move=> i; rewrite val_mem_seq map_mask val_enum_ord.
rewrite mem_mask_iota ?ltn_ord ?size_tuple ?subn0 // /seqn /= nth_ors0.
elim: x => [|x s ihs]; first by rewrite nth_nil.
rewrite inE nth_set_nth /=; case: (i == x) / boolP => [/eqP->|/negbTE heq].
  by rewrite eqxx.
by rewrite val_eqE heq ihs.
Qed.

Lemma nth_from_set s i : (nth false (from_set s)) i = (i \in s).
Proof.
elim: s => [|x s ihs]; first by rewrite nth_nil.
by rewrite nth_set_nth /= !inE; case: eqP.
Qed.

Lemma seqbK k : cancel (@seqB k) (@seqn _).
Proof.
move=> b; apply: eq_from_tnth => i.
rewrite !(tnth_nth false) /seqn /setB /= nth_ors0 nth_from_set ?ltn_ord //.
by rewrite map_mask val_enum_ord mem_mask_iota ?subn0 ?ltn_ord ?size_tuple.
Qed.

Lemma setnK k : cancel (@setn k) (@setB _).
Proof. by move=> x; apply/setP=> i; rewrite inE seqnK mem_enum. Qed.

Lemma setbK k : cancel (@setB k) (@setn _).
Proof.
move=> t; rewrite -{2}[t]seqbK; apply/eq_seqn; rewrite ?mask_uniq ?enum_uniq //.
by move => i; rewrite mem_enum inE.
Qed.

Prenex Implicits setnK setbK.

(******************************************************************************)
(** Main operators, union, intersection                                       *)
(******************************************************************************)

(* Example property: union *)
(* XXX: move to use {morph ...} notation *)
Lemma union_morphL k (b1 b2 : 'B_k) :
  setB (orB b1 b2) = (setB b1 :|: setB b2).
Proof.
by apply/setP=> i; rewrite !mem_setb inE !mem_setb nth_liftz ?size_tuple.
Qed.

(* Example of derived property *)
Lemma union_morphR k (s1 s2 : {set 'I_k}) :
  orB (setn s1) (setn s2) = setn (s1 :|: s2).
Proof. by apply: (can_inj setbK); rewrite union_morphL !setnK. Qed.

(* Basically the same proof. *)
Lemma inter_morphL k (b1 b2 : 'B_k) :
  setB (andB b1 b2) = (setB b1 :&: setB b2).
Proof.
by apply/setP=> i; rewrite !mem_setb inE !mem_setb nth_liftz ?size_tuple.
Qed.

Lemma neg_morphL k (b : 'B_k) :
  setB (negB b) = ~: (setB b).
Proof.
by apply/setP=> i; rewrite !mem_setb inE !mem_setb (nth_map false) ?size_tuple.
Qed.

Lemma symdiff_morphL k (b1 b2 : 'B_k) :
  setB (xorB b1 b2) = (setB b1 :\: setB b2 :|: setB b2 :\: setB b1).
Proof.
apply/setP=> i.
rewrite !mem_setb 2!inE !mem_setb inE !mem_setb nth_liftz ?size_tuple //.
case: b1`_i b2`_i=> -[] // .
Qed.

(* More properties: singleton *)
(* XXX: This should be one liner as you can see with the mismatches *)
Lemma setB1 k (n : 'I_k.+1) :
  setB [tuple of setlB [tuple of '0_k.+1] n true] = [set n].
Proof.
apply/setP=> i; rewrite mem_setb /= inE /setls size_tuple ltn_ord.
rewrite nth_set_nth /=; case: eqP => [/eqP|] heq.
  by rewrite -val_eqE heq.
by rewrite -val_eqE (gets0 k.+1); apply/esym/eqP.
Qed.

(* Operations to do *)
(* remove. *)
(* inter. *)
(* symdiff. *)
(* insert. *)
(* union. *)
(* compl. *)
(* shift. *)
(* get. *)

(******************************************************************************)
(** Cardinality                                                               *)
(******************************************************************************)
Definition cardb k (s : 'B_k) := count id s.

Arguments seqb_uniq [k s].

(* This follows directly from the library *)
Lemma cardbP k (s : 'B_k) : #| setB s | = cardb s.
Proof.
by rewrite cardsE (card_uniqP seqb_uniq) size_mask // size_tuple size_enum_ord.
Qed.

(* test for Zero*)
Lemma mem_setBN n (bs : 'B_n) (hN : forall i, i \notin setB bs) :
  true \notin bs.
Proof. by apply/tnthP => -[xi hi]; have := hN xi; rewrite mem_setB -hi. Qed.

Lemma mem_setBN' n (bs : 'B_n) (hN : forall i, i \in setB bs = false) :
  true \notin bs.
Proof. by apply/tnthP => -[xi hi]; have := hN xi; rewrite mem_setB -hi. Qed.

(******************************************************************************)
(** Minimum                                                                   *)
(******************************************************************************)

Section MinOrdSet.

Variable (n : nat).
Variable (T : finType).
Implicit Types (A : {set 'I_n}).

Definition setmin  A := [set [arg min_(k<x in A) k] | x in A].

(* Definition setmin' A := [set x in A | [forall y in A, x < y] ]. *)

(* Lemma u A : setmin A = setmin' A. *)
(* Proof. *)
(* apply/setP=> x; rewrite /setmin !inE. *)
(* apply/imsetP/andP. *)
(* + case=> x0 x0_in -> {x}; case: arg_minP => // i _ hmin; split. *)
(*   admit. *)
(*   apply/forallP. *)

Lemma min1P A x (x_inA : x \in A) : setmin A = [set [arg min_(k<x in A) val k]].
Proof.
apply/setP=> i; rewrite /min !inE; apply/imsetP/eqP; last by exists x.
case=> [u u_in ->]; case: arg_minP => // i1 I1 h1; case: arg_minP => // i2 I2 h2.
by apply/val_inj/eqP; rewrite eqn_leq h1 // h2.
Qed.

Lemma min0P A : (setmin A == set0) = (A == set0).
Proof. by rewrite /min imset_eq0. Qed.

Lemma card_setmin A : (0 < #|setmin A|) = (A != set0).
Proof. by rewrite -min0P card_gt0. Qed.

(* Lemma card_setmin A : (0 < #|setmin A|) = (A != set0). *)
(* Proof. by rewrite -min0P card_gt0. Qed. *)

End MinOrdSet.

Section MinIndex.

Lemma indexP (T : eqType) d (x : T) s idx :
  d != x ->
  nth d s idx = x ->
  (forall j, j < size s -> nth d s j = x -> idx <= j) ->
  index x s = idx.
Proof.
elim: s idx => [|s ss ihs] idx hneq; first by move/eqP: hneq; rewrite nth_nil.
case: idx => /= [->|idx]; first by rewrite eqxx.
move=> /ihs-/(_ hneq) {ihs} ihs hj.
case: ifP => [/eqP|] he; first by have /= := hj 0 erefl he; rewrite ltn0.
by congr S; apply: ihs => j hjs hnt; have := hj j.+1 hjs hnt.
Qed.

(* Lemma min_ref A : min A = index true (setn A). *)

(* Lemma min_ref (A : {set 'I_n}) x (x_inA : x \in A) : *)

(* This should be improved. *)
Lemma index_repr n (bs : 'B_n) x (hs : x \in setB bs) :
  index true bs = [arg min_(k < x in setB bs) val k].
Proof.
case: arg_minP => // i ih h_min.
have/indexP: bs`_i = true by rewrite -mem_setb.
apply=> // j hj hnt; rewrite size_tuple in hj.
by have:= h_min (Ordinal hj); apply; rewrite mem_setb.
Qed.

(* XXX: A likely better approach is to work with the modular version,
   as index will overflow if the bitseq is empty *)

Lemma index_repr_mod n (bs : 'B_n) x (hs : x \in setB bs) :
  index true bs = [arg min_(k < x in setB bs) val k] %[mod n].
Proof.
Admitted.

Require Import bitocaml.

Lemma mask_setls_one T d n m (l : seq T) :
  m < n -> n <= size l ->
  mask (setls '0_n m true) l = [:: nth d l m].
Proof.
elim: n m l => //= n ihn [|m] [| x l] //= hs /ihn ihn'.
  by rewrite mask_false.
by rewrite setls_cons /= ihn'.
Qed.

Lemma setminP n (bs : 'B_n) : setmin (setB bs) = setB (keep_min bs).
Proof.
case: [pick x | x \in setB bs] / pickP => [x xin|nin].
  rewrite (min1P xin) /setB /seqB keep_minP.
  apply/setP=> u; rewrite !inE -val_eqE /= -(index_repr xin).
  have idx_size: index true bs < n.
    rewrite -{2}(size_tuple bs) index_mem.
    move: xin; rewrite mem_setb => <-.
    by rewrite mem_nth // ?size_tuple.
  rewrite (mask_setls_one x) ?size_enum_ord // inE -val_eqE /= nth_enum_ord //.
have U: setB bs = set0.
  by apply/setP=> x; rewrite nin inE.
have V: bs = '0.
  apply/(can_inj setbK); rewrite U.
  by apply/setP=> x; rewrite !inE /= /seqB mask_false.
have W : setmin set0 = set0.
  by move=> k; apply/eqP; rewrite min0P.
rewrite U W V; apply/setP => o.
rewrite !inE /seqB keep_minP.
rewrite setls_default /= ?size_nseq ?mask_false //.
have: true \notin '0_n. by elim: n {bs nin U V W o}.
by rewrite -index_mem ltnNge negbK size_nseq.
Qed.

Print Assumptions setminP.

(* Lemma  n (bs : 'B_n) x (hs : x \in setB bs) : *)
(*   index true bs = [arg min_(k < x in setB bs) val k] %[mod n]. *)
(* Proof. *)
(* Admitted. *)

(* Extend with the minimum *)
(* Definition extm n (A : {set 'I_n}) : {set 'I_n.+1} := *)
(*   [set widen_ord (@leqnSn _) x | x in A] :|: [set inord n]. *)

(* Lemma index_repr' n (bs : 'B_n) : *)
(*   index true bs = [arg min_(k < inord n in extm (setB bs)) val k]. *)
(* Proof. *)
(* Admitted. *)

(* Corollary *)
(* Lemma index_reprP n (bs : 'B_n) (x : 'I_n) (hs : x \in setB bs) : *)
(*   index true bs \in map val (enum (min (setB bs))). *)

End MinIndex.

(* =keep_setP= *)
(* Lemma keep_min_setP n (bs : 'B_n) : *)
(*   if [pick x in setB bs] is Some x *)
(*   then setB (keep_min bs) = [set [arg min_(i < x in setB bs) i]] *)
(*   else setB (keep_min bs) = set0. *)
(* (* =end= *) *)
(* Proof. *)
(* case: pickP => [x xin|inN]. *)
(*   have bs_x := xin; rewrite mem_setb in bs_x. *)
(*   apply/setP => y; rewrite mem_setb keep_minP. *)
(*   rewrite /setls size_nseq -[n in _ < n](size_tuple bs). *)
(*   rewrite index_mem -bs_x mem_nth ?size_tuple // !inE. *)
(*   case: arg_minP => // i hin hmin; rewrite nth_set_nth /=. *)
(*   admit. (* Import indexP from old development *) *)
(* apply/setP => y; rewrite mem_setb keep_minP. *)
(* have:= mem_setBN' inN; rewrite -index_mem /setls size_tuple size_nseq. *)
(* by move/negbTE->; rewrite nth_nseq ltn_ord inE. *)
(* Admitted. *)
(* =end= *)

(* =ntz_setP= *)
(* Lemma ntz_setP n (bs : 'B_n) : *)
(*   if [pick x in setB bs] is Some x *)
(*   then ntz bs = inB [arg min_(k < x in setB bs) k] *)
(*   else ntz bs = inB n. *)
(* (* =end= *) *)
(* Proof. *)
(* case: pickP => [x xinT|xinN]. *)
(*   case: arg_minP => // y yin ymin; rewrite ntzP; congr inB. *)
(*   (* Same applications of indexP as before *) *)
(*   admit. *)
(* have:= mem_setBN' xinN; rewrite -index_mem ltn_neqAle index_size andbT negbK. *)
(* by rewrite size_tuple ntzP => /eqP ->. *)
(* Admitted. *)
(* =end= *)

(* XXX: Emilio: move? *)
Definition ord_iota k m n : seq 'I_k := pmap insub (iota m n).
Definition set_iota k m n : {set 'I_k} := [set x in ord_iota k m n].

(* Initial segment (ie set containing element orders 0, ..., k) *)
(* XXX: Emilio? *)
(*
Definition initseg k i := @decB k (shlB (bito 1%R) i).

Lemma initseg_repr k i : setB (initseg k i) = set_iota k 0 i.
(* Admitted. *)
*)

(* Add a bitset with 1 bit to true to any bitset *)
Definition set_isNext_g {n} (S: {set 'I_n.+1}) y x := (y \notin S) && (y >= x).
Definition set_next_g   {n} (S: {set 'I_n.+1}) x := [arg min_(y < ord0 | set_isNext_g S y x) y].

(* Lemma ripple_repr_1 k (bs: 'B_k.+1) (x: 'I_k.+1) f (isNext_f: set_isNext_g (setB bs) f x) : *)
(*   setB (addB (setn [set x]) bs) = *)
(*   (set_next_g (setB bs) x) |: [set y in (setB bs) | y < x] :|: [set y in (setB bs) | y > set_next_g (setB bs) x]. *)
(* XXX: Arthur *)
(* Admitted. *)

(******************************************************************************)
(** Set Shifting                                                              *)
(******************************************************************************)

Section SetShift.

(* Local Open Scope ring_scope. *)
Import GRing.Theory.

(* Aux lemmas *)

Lemma ord_add_mod k (i n : 'I_k.+1) (in_le_k : i + n < k.+1) :
  (i + n)%R = i + n :> nat.
Proof. by rewrite /= modn_small. Qed.

Lemma ord_sub_mod k (i n : 'I_k.+1) (n_le_i : n <= i) : (i - n)%R = i - n :> nat.
Proof.
rewrite /= modnDmr addnBA 1?ltnW // addnC -addnBA //.
by rewrite modnDl modn_small // (leq_ltn_trans (leq_subr _ _)).
Qed.

(* Shift a set *)
Definition shlS k (s : {set 'I_k.+1}) (n : 'I_k.+1) :=
  [set (i + n)%R | i in s & i < k.+1 - n].

Lemma shl_morph k (b : 'B_k.+1) (n : 'I_k.+1) :
  setB (shlB b n) = shlS (setB b) n.
Proof.
apply/setP=> i; rewrite mem_setB tnth_shlB /shlS.
apply/andP/imsetP=> /= [[h_le_i hnth]|[x]].
  exists (i-n)%R; last by rewrite addrNK.
  by rewrite inE mem_setB hnth ord_sub_mod ?ltn_sub2r.
rewrite inE; case/andP; rewrite mem_setB => [htnth hlt ->].
rewrite ord_add_mod ?addrK ?htnth ?leq_addl //.
by rewrite ltn_subRL addnC in hlt.
Qed.

Definition shrS k (s : {set 'I_k.+1}) (n : 'I_k.+1) :=
  [set (i - n)%R | i in s & n <= i].

Lemma shr_morph k (b : 'B_k.+1) (n : 'I_k.+1) :
  setB (shrB b n) = shrS (setB b) n.
Proof.
apply/setP=> i; rewrite mem_setB tnth_shrB /shrS.
apply/andP/imsetP=> /= [[h_le_i hnth]|[x]].
  exists (i+n)%R; last by rewrite addrK.
  rewrite inE mem_setB hnth ord_add_mod ?leq_addl //.
  by rewrite ltn_subRL addnC in h_le_i.
rewrite inE mem_setB; case/andP=> [htnth hnx ->{i}].
by rewrite addrNK htnth ord_sub_mod ?ltn_sub2r.
Qed.

End SetShift.

(******************************************************************************)
(* Bijection to any set of cardinality n, from an o
idea by Arthur Blot.        *)
(******************************************************************************)
Section FinSet.

Variable T : finType.
Implicit Types (A B : {set T}).
Implicit Types (b : 'B_#|T|).

(* From a finite set to tuple *)
Definition bitF (A: {set T}): 'B_#| T |
  := setn [set enum_rank x | x in A].

(* From a tuple to a finite set *)
Definition finB (b: 'B_#| T |): {set T}
  := [set enum_val x | x in setB b].

(* Aux Lemma to avoid using prenex implicits *)
Let can_enum D := can2_imset_pre D (@enum_valK T) (@enum_rankK _).
Let enum_can D := can2_imset_pre D (@enum_rankK T) (@enum_valK _).

Lemma preimsetK (U V : finType) (A : {set U}) (f : U -> V)
                (f_inj : injective f) :
  f @^-1: (f @: A) = A.
Proof.
apply/setP=> x; rewrite inE; apply/imsetP/idP; last by move=> x_in; exists x.
by case=> y y_in /f_inj->.
Qed.

Lemma finBK : cancel bitF finB.
Proof.
by move=> A; rewrite /finB can_enum setnK (preimsetK _ enum_rank_inj).
(* move=> A; rewrite /finB /bitF setnK -imset_comp (eq_imset _ (@enum_rankK _)). *)
(* exact: imset_id. *)
Qed.

Lemma bitFK : cancel finB bitF.
Proof.
by move=> A; rewrite /finB /bitF enum_can (preimsetK _ enum_val_inj) setbK.
(* move=> b; rewrite /finB /bitF -imset_comp (eq_imset _ (@enum_valK _)) imset_id. *)
(* exact: setbK. *)
Qed.

Definition f_repr b A := A = [set x : T | b`_(enum_rank x)].

Lemma f_repr_uniq b E : f_repr b E -> E = finB b.
Proof.
by move->; rewrite /finB can_enum; apply/setP=> ?; rewrite !inE -mem_setb inE.
Qed.

Lemma setDB (b: 'B_#| T |):
  [set enum_val x | x in ~: setB b] =  ~: [set enum_val x | x in setB b].
Proof. by apply/setP=> t; rewrite in_setC !can_enum !inE. Qed.

Lemma Fcompl_morphL (b : 'B_#|T|) :
  finB (negB b) = ~: (finB b).
Proof. by rewrite /finB neg_morphL setDB. Qed.

Lemma Funion_morphL (b1 b2 : 'B_#|T|) :
  finB (orB b1 b2) = (finB b1 :|: finB b2).
Proof. by rewrite /finB -imsetU union_morphL. Qed.

Lemma Finter_morphL (b1 b2 : 'B_#|T|) :
  finB (andB b1 b2) = (finB b1 :&: finB b2).
Proof.
rewrite /finB inter_morphL imsetI //.
by move=> x y _ _; apply: enum_val_inj.
Qed.

Lemma Fsymdiff_morphL (b1 b2 : 'B_#|T|) :
  finB (xorB b1 b2) = (finB b1 :\: finB b2 :|: finB b2 :\: finB b1).
Proof.
rewrite !setDE /finB symdiff_morphL imsetU !setDE !imsetI.
  by rewrite !setDB.
- move=> x y _ _; apply: enum_val_inj.
- move=> x y _ _; apply: enum_val_inj.
Qed.

End FinSet.

(******************************************************************************)
(* Taken from the paper, we see indeed that there exists a unique repr which  *)
(* is the one given by setB.                                                  *)
(******************************************************************************)

Section ReprUniq.
Definition s_repr k (bs : 'B_k) E :=
  E = [set x : 'I_k | bs`_x].

Lemma s_repr_uniq k (bs : 'B_k) E : s_repr bs E -> E = setB bs.
Proof. by move ->; rewrite setb_def. Qed.

Lemma count_repr k (bs : 'B_k) E : s_repr bs E -> count_mem true bs = #|E|.
Proof. by move -> ; rewrite -setb_def cardbP; apply: eq_count; case. Qed.
End ReprUniq.

(** * Generic set-theoretic operations *)

(**

  The following operations are defined parametrically wrt. the
  underlying implementation of bitvectors. This means that we can
  instantiate them to [BITS n] and later to, say, Int32. This also
  means that we can use domain-specific notations for defining them.

 *)

From CoqEAL Require Import hrel param refinements.

Import Refinements.Op.
Import Logical.Op.

Section Operations.

Variables (Idx : Type).
Variables (Bits : Type).

Context `{eq_of   Bits}.
Context `{sub_of  Bits}.
Context `{zero_of Bits}.
Context `{one_of  Bits}.

Context `{not_of Bits}.
Context `{or_of  Bits}.
Context `{and_of Bits}.
Context `{xor_of Bits}.
Context `{shl_of Idx Bits}.
Context `{shr_of Idx Bits}.

Implicit Types (k: Idx)(bs : Bits).
Local Open Scope computable_scope.

Definition get     k bs := negb ((bs && (1 :<<: k)) == 0)%C.
Definition singleton  k := 1 :<<: k.
Definition compl     bs := ~ bs.

Definition empty : Bits := (0)%C.
Definition full  : Bits := (0-1)%C.

Definition inter bs bs' := bs && bs'.
Definition union bs bs' := bs || bs'.
Definition keep_min bs  := bs && ~ bs.

(* XXX: Order of arguments *)
Definition insert  k bs    := bs || (1 :<<: k).
Definition remove  bs k    := bs && (~ (1 :<<: k)).
Definition symdiff bs1 bs2 := bs1 ^^ bs2.
Definition subset  bs1 bs2 := (bs1 && bs2) == bs1.

End Operations.

Arguments get {_}{_}{_}{_}{_}{_}{_} k bs.
Arguments singleton {_}{_}{_}{_} k.
Arguments compl {_}{_} bs.
Arguments empty {_}{_}.
Arguments full {_}{_}{_}{_}.
Arguments inter {_}{_} bs bs'.
Arguments union {_}{_} bs bs'.
Arguments keep_min {_}{_}{_} bs.
Arguments insert {_}{_}{_}{_}{_} k bs.
Arguments remove {_}{_}{_}{_}{_}{_} bs k.
Arguments symdiff {_}{_} bs1 bs2.
Arguments subset {_}{_}{_} bs1 bs2.

Parametricity get.
Parametricity singleton.
Parametricity compl.
Parametricity full.
Parametricity empty.
Parametricity inter.
Parametricity union.
Parametricity keep_min.
Parametricity insert.
Parametricity remove.
Parametricity symdiff.
Parametricity subset.

(******************************************************************************)
(* Typeclass notations                                                        *)
(******************************************************************************)

From CoqEAL
     Require Import refinements.
Require Import notation.

Import Refinements.Op.
Import Logical.Op.
Import Sets.Op.

(* For finset: *)

Section OpFin.

Variable T: finType.

Global Instance eq_fin:        eq_of {set T}    := fun x y => x == y.

Global Instance get_fin:       get_of T       {set T} := fun k E => k \in E.
Global Instance singleton_fin: singleton_of T {set T} := fun k => [set k].

Global Instance compl_fin:     compl_of {set T} := @setC _.
Global Instance full_fin:      full_of  {set T} := [set : T ].
Global Instance empty_fin:     empty_of {set T} := set0.

Global Instance set_fin:       set_of    T {set T} := fun k E => k |: E.
Global Instance remove_fin:    remove_of T {set T} := fun A a => A :\ a.

Global Instance inter_fin: inter_of {set T} := @setI _.
Global Instance union_fin: union_of {set T} := @setU _.
Global Instance symdiff_fin: symdiff_of {set T} := fun E E' => ((E :\: E') :|: (E' :\: E)).
Global Instance subset_fin:  subset_of {set T}  := fun E E' => E \subset E'.

Global Instance cardinal_fin:  cardinal_of nat {set T}  := fun E => #| E |.
Global Instance keep_min_fin:  keep_min_of {set T}  :=
  fun E => [set x in E | [forall (y | y \in E), enum_rank x <= enum_rank y]].

End OpFin.

(* For ordinals: *)

Section OpOrds.

Variable n: nat.

Global Instance pred_fin:  pred_of {set 'I_n.+1}  :=
  fun E => shlS E (inord 1).
Global Instance succ_fin:  succ_of {set 'I_n.+1}  :=
  fun E => shrS E (inord 1).

End OpOrds.

(* For bit vectors: *)

Section OpB.

Variable n: nat.

Global Instance get_B       : get_of 'I_n 'B_n       := get.
Global Instance singleton_B : singleton_of 'I_n 'B_n := singleton.
Global Instance compl_B     : compl_of 'B_n          := compl.
Global Instance empty_B     : empty_of 'B_n          := empty (Bits := 'B_n).
Global Instance full_B      : full_of 'B_n           := full  (Bits := 'B_n).
(* This creates a problem in typeclass resolution, see Rbitset_full *)
(* Global Instance full_B      : full_of 'B_n           := '1. (* Optimized *) *)
Global Instance set_B       : set_of 'I_n 'B_n       := insert.
Global Instance remove_B    : remove_of 'I_n 'B_n    := remove.
Global Instance inter_B     : inter_of 'B_n          := inter.
Global Instance union_B     : union_of 'B_n          := union.
Global Instance symdiff_B   : symdiff_of 'B_n        := symdiff.
Global Instance subset_B    : subset_of 'B_n         := subset.
Global Instance cardinal_B  : cardinal_of nat 'B_n   :=
  (fun x => nats (cardinal_smart x)).
Global Instance keep_min_B  : keep_min_of 'B_n. Admitted.

End OpB.


Require Import Utf8 List.
Require Import Cpdt.CpdtTactics.
Require Import TLC.LibFset.
Require Import UFO.Util.Subset.
Local Set Implicit Arguments.
Local Open Scope list_scope.

Inductive postfix A : list A → list A → Prop :=
| postfix_same l : postfix l l
| postfix_tail a l1 l2 : postfix l1 l2 → postfix l1 (a :: l2)
.

Section section_postfix_facts.

Context (A : Set).

Hint Constructors postfix.

Lemma postfix_refl (l : list A) : postfix l l.
Proof.
auto.
Qed.

Lemma tail_is_postfix_aux (a : A) l1 l2 l3 :
postfix l2 l3 → l2 = a :: l1 → postfix l1 l3.
Proof.
induction 1 ; crush.
Qed.

Lemma tail_is_postfix (a : A) l1 l2 :
postfix (a :: l1) l2 → postfix l1 l2.
Proof.
intro ; eapply tail_is_postfix_aux with (l2 := a :: l1) ; crush.
Qed.

Hint Resolve tail_is_postfix.

Lemma postfix_trans_aux (l1 l2 : list A) :
postfix l1 l2 → ∀ l3, postfix l2 l3 → postfix l1 l3.
Proof.
induction 1 ; intros l3 H23 ; crush.
inversion H23 ; subst ; clear H23 ; eauto.
Qed.

Lemma postfix_trans (l1 l2 l3 : list A) :
postfix l1 l2 → postfix l2 l3 → postfix l1 l3.
Proof.
intros ; eapply postfix_trans_aux ; eauto.
Qed.

Hint Resolve subset_union_weak_r.

Lemma postfix_is_subset (l1 l2 : list A) :
postfix l1 l2 → from_list l1 \c from_list l2.
Proof.
induction 1.
+ apply subset_refl.
+ rewrite from_list_cons.
  eapply subset_trans ; eauto.
Qed.

Lemma postfix_In (l1 l2 : list A) :
postfix l1 l2 → ∀ a, In a l1 → In a l2.
Proof.
induction 1 ; intros ; crush.
Qed.

Lemma postfix_inv_app (l1 l2 : list A) :
postfix l1 l2 →
∃ l3, l2 = l3 ++ l1.
Proof.
induction 1 as [ | a ? ? ? IH ].
+ exists nil ; rewrite app_nil_l ; reflexivity.
+ destruct IH as [l3 IH] ; subst.
  exists (a :: l3).
  rewrite app_comm_cons ; reflexivity.
Qed.

Lemma In_from_list (a : A) l :
In a l → a \in from_list l.
Proof.
induction l as [ | a' l' ] ; intro ; simpl in H.
+ contradict H.
+ rewrite from_list_cons, in_union, in_singleton ; crush.
Qed.

End section_postfix_facts.


Require Export Iron.Language.SystemF2Effect.Type.Relation.KindT.Base.

(* A well kinded type is well formed *)
Lemma kind_wfT
 :  forall ke sp t k
 ,  KindT   ke sp t k
 -> WfT (length ke) t.
Proof.
 intros ke sp t k HK. gen ke sp k.
 induction t; intros; inverts_kind; burn.
 lets D: IHt H4. burn.
Qed.
Hint Resolve kind_wfT.

Lemma kind_wfT_Forall
 :  forall ks sp k ts
 ,  Forall (fun t => KindT ks sp t k) ts
 -> Forall (WfT (length ks)) ts.
Proof.
 intros. norm. eauto.
Qed.
Hint Resolve kind_wfT_Forall.

Lemma kind_wfT_Forall2
 :  forall  (ke: kienv) (sp: stprops) ts ks
 ,  Forall2 (KindT ke sp) ts ks
 -> Forall  (WfT (length ke)) ts.
Proof.
 intros.
 eapply (Forall2_Forall_left (KindT ke sp)); burn.
Qed.
Hint Resolve kind_wfT_Forall2.

(* If a type is well kinded in an empty environment,
   then that type is closed. *)
Lemma kind_empty_is_closed
 :  forall sp t k
 ,  KindT   nil sp t k
 -> ClosedT t.
Proof.
 intros.
 have (@length ki nil = 0).
  rewrite <- H0.
  eapply kind_wfT. eauto.
Qed.
Hint Resolve kind_empty_is_closed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frédéric Blanqui, 2014-02-18

Class of ordered semi-rings.
*)

Set Implicit Arguments.

Require Import Relations Structures.Equalities LogicUtil Morphisms Basics
  Ring_theory.

(** Setoids. *)

Class Setoid := {
  s_typ      :> Type;
  s_eq       : relation s_typ;
  s_eq_Equiv : Equivalence s_eq }.

Existing Instance s_eq_Equiv.

Module Import Setoid_Notations.
  Infix "==" := s_eq (at level 70).
End Setoid_Notations.

Global Instance LeibnizSetoid (A : Type) : Setoid.

Proof.
  apply Build_Setoid with (s_eq := @eq A).
  constructor. fo. fo.
  unfold Transitive. apply eq_trans.
Defined.

(** Setoids with decidable equivalence. *)

Class DecidableSetoid := {
  ds_setoid :> Setoid;
  ds_eq_dec : forall x y, {s_eq x y} + {~s_eq x y} }.

(** Ordered setoids. *)

Class OrderedSetoid := {
  os_setoid    :> Setoid;
  os_gt        : relation s_typ;
  os_gt_compat : Proper (s_eq ==> s_eq ==> impl) os_gt }.

(***********************************************************************)
(** Dedicable semi-rings. *)

Class SemiRing := {
  sr_ds     :> DecidableSetoid;
  sr_0      : s_typ;
  sr_1      : s_typ;
  sr_add    : s_typ -> s_typ -> s_typ;
  sr_add_eq : Proper (s_eq ==> s_eq ==> s_eq) sr_add;
  sr_mul    : s_typ -> s_typ -> s_typ;
  sr_mul_eq : Proper (s_eq ==> s_eq ==> s_eq) sr_mul;
  sr_th     : semi_ring_theory sr_0 sr_1 sr_add sr_mul s_eq }.

Existing Instance sr_add_eq.
Existing Instance sr_mul_eq.

(*******************************************************************)
(* Ring class *)

Class Ring := {
  sr       :> SemiRing;
  r_opp    : s_typ -> s_typ;
  r_sub    : s_typ -> s_typ -> s_typ := fun x y => sr_add x (r_opp y);
  r_opp_eq : Proper (s_eq ==> s_eq) r_opp;
  r_sub_eq : Proper (s_eq ==> s_eq ==> s_eq) r_sub;
  r_th     : ring_theory sr_0 sr_1 sr_add sr_mul r_sub r_opp s_eq }.

Existing Instance r_opp_eq.
Existing Instance r_sub_eq.

Module Import SR_Notations.
  Include Setoid_Notations.
  Notation "0"     := sr_0.
  Notation "1"     := sr_1.
  Infix "+"        := sr_add.
  Infix "*"        := sr_mul.
  Notation "- x"   := (r_opp x).
  Notation "x - y" := (r_sub x y).
End SR_Notations.

Section SR_Theory.

  Variable SR : SemiRing.

  Definition Aplus_comm          := SRadd_comm sr_th.
  Definition Aplus_assoc         := SRadd_assoc sr_th.
  Definition Aplus_0_l           := SRadd_0_l sr_th.
  Definition Amult_comm          := SRmul_comm sr_th.
  Definition Amult_assoc         := SRmul_assoc sr_th.
  Definition Amult_0_l           := SRmul_0_l sr_th.
  Definition Amult_1_l           := SRmul_1_l sr_th.
  Definition A_plus_mult_distr_l := SRdistr_l sr_th.

  (* Addition *)

  Lemma Aplus_0_r n : n + 0 == n.

  Proof. rewrite Aplus_comm. apply Aplus_0_l. Qed.

  (* Multiplication *)

  Lemma Amult_0_r n : n * 0 == 0.

  Proof. rewrite Amult_comm. apply Amult_0_l. Qed.

  Lemma Amult_1_r n : n * 1 == n.

  Proof. rewrite Amult_comm. apply Amult_1_l. Qed.

  Lemma A_plus_mult_distr_r m n p : m * (n + p) == m * n + m * p.

  Proof.
    rewrite Amult_comm, (Amult_comm m n), (Amult_comm m p).
    apply A_plus_mult_distr_l.
  Qed.

  (* Power *)

  Fixpoint power x n {struct n} :=
    match n with
      | 0 => 1
      | S n' => x * power x n'
    end.

  Notation "x ^ n" := (power x n).

  Lemma power_add : forall x n1 n2, x ^ (n1 + n2) == x ^ n1 * x ^ n2.

  Proof.
  induction n1; simpl; intros. rewrite Amult_1_l. refl. rewrite IHn1.
  rewrite Amult_assoc. refl.
  Qed.

End SR_Theory.

Hint Rewrite Aplus_0_l Aplus_0_r Amult_0_l Amult_0_r Amult_1_l Amult_1_r
  : arith.

(***********************************************************************)
(** Dedicable ordered semi-rings. *)

Class OrderedSemiRing := {
  osr_sr :> SemiRing;
  osr_gt : relation s_typ;
  osr_ge : relation s_typ;
  osr_eq_incl_ge : forall x y, s_eq x y -> osr_ge x y;
  osr_ge_refl  : Reflexive osr_ge;
  osr_ge_trans : Transitive osr_ge;
  osr_gt_trans : Transitive osr_gt;
  osr_ge_dec : forall x y, {osr_ge x y} + {~osr_ge x y};
  osr_gt_dec : forall x y, {osr_gt x y} + {~osr_gt x y};
  osr_ge_gt  : forall x y z, osr_ge x y -> osr_gt y z -> osr_gt x z;
  osr_gt_ge  : forall x y z, osr_gt x y -> osr_ge y z -> osr_gt x z;
  osr_add_gt : Proper (osr_gt ==> osr_gt ==> osr_gt) sr_add;
  osr_add_ge : Proper (osr_ge ==> osr_ge ==> osr_ge) sr_add;
  osr_mul_ge : Proper (osr_ge ==> osr_ge ==> osr_ge) sr_mul
 }.

Existing Instance osr_ge_refl.
Existing Instance osr_ge_trans.
Existing Instance osr_gt_trans.
Existing Instance osr_add_gt.
Existing Instance osr_add_ge.
Existing Instance osr_mul_ge.

Module Import OSR_Notations.
  Include SR_Notations.
  Infix ">>" := osr_gt (at level 70).
  Infix ">>=" := osr_ge (at level 70).
End OSR_Notations.

Section OSR_Theory.

  Variable OSR : OrderedSemiRing.

  Global Instance ge_eq : Proper (s_eq ==> s_eq ==> iff) osr_ge.

  Proof.
    intros x y H x0 y0 H0. intuition.
    trans x. apply osr_eq_incl_ge. sym. hyp.
    trans x0. hyp. apply osr_eq_incl_ge. hyp.
    trans y. apply osr_eq_incl_ge. hyp.
    trans y0. hyp. apply osr_eq_incl_ge. sym. hyp.
  Qed.

  Global Instance gt_eq : Proper (s_eq ==> s_eq ==> iff) osr_gt.

  Proof.
    intros x y H x0 y0 H0.
    intuition. apply osr_gt_ge with x0. 2: apply osr_eq_incl_ge; hyp.
    apply osr_ge_gt with x. apply osr_eq_incl_ge. sym. hyp. hyp.
    apply osr_gt_ge with y0. 2: apply osr_eq_incl_ge; sym; hyp.
    apply osr_ge_gt with y. apply osr_eq_incl_ge. hyp. hyp.
  Qed.

  (* Define boolean function for [eq]. *)

  Definition beq x y :=
    match ds_eq_dec x y with
      | left _  => true
      | right _ => false
    end.

  Lemma beq_ok : forall x y, beq x y = true <-> s_eq x y.
  Proof.
    intros. unfold beq. case_eq (ds_eq_dec x y); intuition; discr.
  Qed.

  (* Define boolean function for [ge]. *)

  Definition bge x y :=
    match osr_ge_dec x y with
      | left _  => true
      | right _ => false
    end.

  Lemma bge_ok : forall x y, bge x y = true <-> x >>= y.
  Proof.
    intros. unfold bge. case_eq (osr_ge_dec x y); intuition; discr.
  Qed.

  (* Define boolean function for [gt]. *)

  Definition bgt x y :=
    match osr_gt_dec x y with
      | left _  => true
      | right _ => false
    end.

  Lemma bgt_ok : forall x y, bgt x y = true <-> x >> y.
  Proof.
    intros. unfold bgt. case_eq (osr_gt_dec x y); intuition; discr.
  Qed.

End OSR_Theory.

(* TEST: It is simpler to define the relation [ge] than define it as a
field like the definition above. *)
(*******************************************************************************)
(* Class Order Ring *)

Class OrderedRing := {
  or           :> Ring;
  or_gt        : relation s_typ;
  or_gt_trans  : Transitive or_gt;
  or_gt_irrefl : Irreflexive or_gt;
  or_bgt       : s_typ -> s_typ -> bool;
  (* x > y = true -> x > y *)
  or_bgt_ok : forall x y, or_bgt x y = true <-> or_gt x y;
  (* x > y - ~ x > y *)
  or_gt_dec : forall x y, {or_gt x y} + {~or_gt x y};
  (* 1 > 0 *)
  or_one_gt_zero  : or_gt sr_1 sr_0;
  (*or_one_ge_zero: forall x, or_gt x sr_0 \/ s_eq x sr_0 -> or_gt x sr_0;*)
  (* FIXME: this lemma needed in the Polynomial. *)
  (*  or_gt_0 : forall x, or_gt x 0 -> x <> 0;*)
  (* x > y -> x + z > y + z *)
  or_add_gt_mono_r : forall x y z, or_gt x y -> or_gt (sr_add x z) (sr_add y z);
  (* z > 0 -> x > y -> x * z > y * z *)
  or_mul_gt_mono_r : forall x y z, or_gt z sr_0 -> or_gt x y ->
                                   or_gt (sr_mul x z) (sr_mul y z);
  ogt_eq           : Proper (s_eq ==> s_eq ==> iff) or_gt }.

Existing Instance or_gt_trans.
Existing Instance or_gt_irrefl.
Existing Instance ogt_eq.

Module Import OR_Notations.
  Include SR_Notations.
  Infix ">>" := or_gt (at level 70).

End OR_Notations.

(***********************************************************************)
(* Define not_neg of type [s_typ] in OrderedRing. *)

Section OR_Theory.

  Context {OR: OrderedRing}.

  Definition or_ge x y := x >> y \/ x == y.

  Notation "x >>= y" := (or_ge x y) (at level 70).

  (* TODO *)
  Lemma or_gt_0 : forall x, x >> 0 -> x <> 0.
  Proof.
    intros.
  Admitted.

  (* TODO *)
  Lemma or_gt_eq_ge_dec : forall x y, x >>= y -> {x >> y} + {x == y}.
  Proof.
    intuition. unfold or_ge in H.
  Admitted.

  Lemma or_ge_refl : forall x, x >>= x.

  Proof.
    right. refl.
  Qed.

  Lemma or_ge_trans : forall x y z, x >>= y -> y >>= z -> x >>= z.

  Proof.
    unfold transitive, or_ge. intuition.
    left. transitivity y; hyp. left.
    rewrite <- H. auto.
    rewrite H1. auto.
    rewrite H1. rewrite H. right. refl.
  Qed.

   Add Relation s_typ or_ge
    reflexivity proved by or_ge_refl
    transitivity proved by or_ge_trans
      as or_ge_rel.

   Global Instance or_ge_mor : Proper (s_eq ==> s_eq ==> iff) or_ge.

   Proof.
     intros x y H x0 y0 H0.
     unfold or_ge. intuition.
     rewrite <- H. rewrite <- H0. auto.
     rewrite <- H. rewrite H2. auto.
     rewrite H. rewrite H0. auto.
     rewrite H. rewrite H2. rewrite H0. right. refl.
   Qed.

  Definition bool_or_gt x y :=
    match or_gt_dec x y with
      | left _  => true
      | right _ => false
    end.

  Definition bool_s_eq x y :=
    match ds_eq_dec x y with
      | left _  => true
      | right _ => false
    end.

  (* FIXME: bge = bgt || beq? *)

  Require Import BoolUtil.

  (*  x > y || x = y *)

  Definition bool_or_ge x y := bool_or_gt x y || bool_s_eq x y.

  Lemma bool_s_eq_ok : forall x y, bool_s_eq x y = true <-> x == y.

  Proof.
    intros. unfold bool_s_eq. case_eq (ds_eq_dec x y); intuition; discr.
  Qed.

  Lemma bool_or_gt_ok : forall x y, bool_or_gt x y = true <-> x >> y.

  Proof.
    intros. unfold bool_or_gt. case_eq (or_gt_dec x y); intuition; discr.
  Qed.

  Lemma bool_or_ge_ok : forall x y, bool_or_ge x y = true <-> x >>= y.

  Proof.
    intros x y. unfold bool_or_ge. rewrite orb_eq. rewrite bool_or_gt_ok.
    rewrite bool_s_eq_ok. unfold or_ge; intuition.
  Qed.

  (* z > 0 || z = 0 *)

  Definition bnot_neg z := bool_or_gt z 0 || bool_s_eq z 0.

  Lemma bnot_neg_ok : forall z, bnot_neg z = true <-> z >>= 0.
  Proof.
    intros. unfold bnot_neg. rewrite orb_eq.
    rewrite bool_or_gt_ok. rewrite bool_s_eq_ok.
    unfold or_ge; intuition.
  Qed.

  (* Addition *)

  Lemma or_add_ge_mono_r : forall x y z, x >>= y -> x + z >>= y + z.

  Proof.
    unfold or_ge. intuition. left. apply or_add_gt_mono_r. hyp.
    right. rewrite H0. refl.
  Qed.

  Lemma or_add_ge_0 : forall n m, n >>= 0 -> m >>= 0 -> n + m >>= 0.

  Proof.
    intros. apply or_ge_trans with (x := n + m)(y := m).
    rewrite <- (SRadd_0_l sr_th m). rewrite (SRadd_assoc sr_th), Aplus_0_r.
    apply or_add_ge_mono_r. hyp. hyp.
  Qed.

  Lemma or_add_gt_mono_l : forall x y z, x >> y -> z + x >> z + y.

  Proof.
    intros. set (a := z + x). rewrite (SRadd_comm sr_th). unfold a.
    rewrite (SRadd_comm sr_th). apply or_add_gt_mono_r. hyp.
  Qed.

  Lemma or_add_ge_mono_l : forall x y z, x >>= y -> z + x >>= z + y.

  Proof.
    intros x y z. unfold or_ge.
    intuition. left. apply or_add_gt_mono_l. hyp.
    right. rewrite H0. refl.
  Qed.

  (*
  Lemma or_add_ge_mono_r : forall x y z, x >>= y -> x + z >>= y + z.

  Proof.
    intros x y z. unfold or_ge.
    intuition. left. apply or_add_gt_mono_r. hyp.
    right. rewrite H0. refl.
  Qed.*)

  Lemma or_add_ge_compat: forall x y z w, x >>= y -> z >>= w -> x + z >>= y + w.

  Proof.
    intros. eapply or_ge_trans. apply or_add_ge_mono_r. apply H.
    apply or_add_ge_mono_l. hyp.
  Qed.

  Lemma ge_gt_trans : forall x y z, x >>= y -> y >> z  -> x >> z.

  Proof.
    unfold or_ge. intuition. transitivity y; hyp. rewrite H1. hyp.
  Qed.

  Lemma gt_ge_trans : forall x y z, x >> y -> y >>= z -> x >> z.
  Proof.
    intros. apply ge_gt_trans with (y:=x). apply or_ge_refl.
    destruct H0. transitivity y; hyp. rewrite <- H0. hyp.
  Qed.

  Lemma or_add_ge_gt_mono : forall x y p q,
    x >>= y -> p >> q -> x + p >> y + q.

  Proof.
    intros. apply ge_gt_trans with (y:=y+p). apply or_add_ge_mono_r.
    hyp. apply or_add_gt_mono_l. hyp.
  Qed.

  Lemma or_add_gt_ge_mono : forall x y p q,
    x >> y -> p >>= q -> x + p >> y + q.

  Proof.
    intros. apply gt_ge_trans with (y:=y+p). apply or_add_gt_mono_r.
    hyp. apply or_add_ge_mono_l. hyp.
  Qed.

  (* Multiplication *)

  Lemma or_mul_gt_mono_l : forall x y z, z >> 0 -> x >> y -> z * x >> z * y.

  Proof.
  intros. set (a := z * x). rewrite (SRmul_comm sr_th). unfold a.
  rewrite (SRmul_comm sr_th). apply or_mul_gt_mono_r. hyp. hyp.
  Qed.

  Lemma or_mul_ge_mono_l : forall x y z, z >>= 0 -> x >>= y -> z * x >>= z * y.

  Proof.
  intros x y z. unfold or_ge. intros. elim H.
  intros. elim H0. intros. left. apply or_mul_gt_mono_l. hyp.
  hyp. right. rewrite H2. refl. intros. right. rewrite H1.
  do 2 rewrite Amult_0_l. refl.
  Qed.

  Lemma or_mul_ge_mono_r : forall x y z,  z >>= 0 -> x >>= y -> x * z >>= y * z.

  Proof.
  intros. set (a := x * z). rewrite (SRmul_comm sr_th). unfold a.
  rewrite (SRmul_comm sr_th). apply or_mul_ge_mono_l. hyp. hyp.
  Qed.

  Lemma or_mul_ge_0 : forall n m, n >>= 0 -> m >>= 0 -> n * m >>= 0.

  Proof.
    intros. rewrite <- (Amult_0_l _ m). apply or_mul_ge_mono_r.
    hyp. hyp.
  Qed.

  Lemma or_mul_ge_compat : forall x y z w, y >>= 0 -> w >>= 0 -> x >>= y ->
    z >>= w -> x * z >>= y * w.

  Proof.
    intros. eapply or_ge_trans. apply or_mul_ge_mono_r.
    eapply or_ge_trans. apply H2. hyp. apply H1.
    apply or_mul_ge_mono_l. hyp. hyp.
  Qed.

  (* Power *)

  Notation "x ^ n" := (power _ x n).

  Lemma or_power_ge_0 : forall x n, x >>= 0 ->  x ^ n >>= 0.

  Proof.
  induction n.
  intros. simpl. unfold or_ge. left. apply or_one_gt_zero.
  simpl. intros. apply or_mul_ge_0. hyp.
  apply IHn. hyp.
  Qed.

  Lemma or_power_ge_compat : forall x y (n : nat),
    x >>= 0 -> y >>= x -> y ^ n >>= x ^ n.

  Proof.
  induction n. simpl. intros. apply or_ge_refl.
  intros. simpl. apply or_mul_ge_compat. hyp.
  apply or_power_ge_0. hyp. hyp. apply IHn. hyp. hyp.
  Qed.

End OR_Theory.


(****************************************************************************)
(* 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.                                           *)
(****************************************************************************)

From Coq Require Import Bool.Bool.
From Coq Require Import Lists.List.
Import ListNotations.
Open Scope list_scope.

(* The usual sequential semantics we use with Lava style cicuits operates
   over lists or stream. This is an experiment to how an alternative approach
   works where signals are functions from a time index to a value. *)

(* An invertor of an input signal at time t is the negation of the input value.
*)
Definition inv (i : nat -> bool) : nat -> bool :=
  fun t => negb (i t).

(* A sequential nand2 gate performs a pointwise AND over the two inputs
   stream. *)
Definition and2 (a : nat -> bool) (b : nat -> bool) : nat -> bool :=
  fun t => a t &&  b t.

(* A NAND gate is simply the composition of inv and and2. *)
Definition nandGate a b := inv (and2 a b).

(* A delay models a register state element that delays its input by one
   tick and has the default value false at t=0. *)
Definition delay (i : nat -> bool) : nat -> bool  :=
  fun t => match t with
           | O => false
           | S t' => i t'
        end.

(* Some sample input streams. *)
Definition s1 t := nth t [true; true;  false; true;  true; false] false.
Definition s2 t := nth t [true; false; false; false; true; true]  false.

Compute map (delay s1) (seq 0 7).

Compute map (nandGate s1 s2) (seq 0 7).

Lemma nand_correct: forall (t : nat)
                           (a b : nat -> bool),
                           nandGate a b t = negb (a t && b t).
Proof.
  intros.
  auto.
Qed.

(* A pipelined NAND gate that has a register at the output of the AND2 gate.*)
Definition pipelinedNAND a b := inv (delay (and2 a b)).

(* The expected behaviour of the pipelined NAND gate. *)
Definition pipelinedNAND_spec a b t :=
  match t with
  | O => true
  | S n' => negb ((a n') && (b n'))
  end.

Compute map (pipelinedNAND s1 s2) (seq 0 7).
Compute map (pipelinedNAND_spec s1 s2) (seq 0 7).

(* A proof that the implemented pipelined NAND has the same behaviour as
   the spec. *)
Lemma pipelinedNAND_correct: forall (t : nat)
                            (a b : nat -> bool),
                            pipelinedNAND a b t = pipelinedNAND_spec a b t.
Proof.
  intros.
  unfold pipelinedNAND.
  unfold pipelinedNAND_spec.
  unfold delay. unfold and2.
  unfold inv. destruct t.
  - simpl. reflexivity.
  - reflexivity.
Qed.

(* Next step: a circuit with a loop e.g. a counter. *)


Require Import Lia.
Require Import RelationClasses.

From sflib Require Import sflib.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import Loc.

Require Import Event.
Require Import Time.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.

Require Import AMemory.

Set Implicit Arguments.

Module ATView.
  Lemma promise_closed
        tview1
        promises1 mem1 loc from to msg promises2 mem2 kind
        (CLOSED: TView.closed tview1 mem1)
        (PROMISE: AMemory.promise promises1 mem1 loc from to msg promises2 mem2 kind):
    TView.closed tview1 mem2.
  Proof.
    inv CLOSED. econs; i; eapply AMemory.promise_closed_view; eauto.
  Qed.
End ATView.


Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Import Strings.String.
Require Import Language.
Require Import Tactical.
Require Import Subtyping.Subtyping.
Require Import Appsub.
Require Import Disjoint.
Require Import Value.
Require Import PrincipalTyping.
Require Import Consistent.

Import ListNotations.

(** * Definition *)

Inductive mode : Set :=
| Inf
| Chk.

Inductive typing : ctx -> term -> mode -> type -> Prop :=
| Ty_Int : forall T n,
    uniq T ->
    typing T (Lit n) Inf Int
| Ty_Var : forall T x A,
    uniq T -> binds x A T ->
    typing T (Fvar x) Inf A
| Ty_Lam : forall L T A B e,
    (forall x, x \notin L ->
          typing ((one (x, A)) ++ T) (open e (Fvar x)) Chk B) ->
    typing T (Lam A e B) Inf (Arr A B)
| Ty_Ann : forall T A e,
    typing T e Chk A ->
    typing T (Ann e A) Inf A
| Ty_App : forall T A B C e1 e2,
    typing T e1 Inf A ->
    typing T e2 Inf B ->
    appsub (Some B) A C ->
    typing T (App e1 e2) Inf C
| Ty_Mrg : forall T A B e1 e2,
    disjoint A B ->
    typing T e1 Inf A ->
    typing T e2 Inf B ->
    typing T (Mrg e1 e2) Inf (And A B)
| Ty_Mrg_Uv : forall T A B u1 u2,
    uniq T ->
    uvalue u1 -> uvalue u2 ->
    consistent u1 u2 ->
    typing nil u1 Inf A ->
    typing nil u2 Inf B ->
    typing T (Mrg u1 u2) Inf (And A B)
| Ty_Sub : forall T e A B,
    typing T e Inf A ->
    sub A B ->
    typing T e Chk B.

Hint Constructors typing : core.

Notation "T ⊢ e ⇒ A" := (typing T e Inf A) (at level 50).
Notation "T ⊢ e ⇐ A" := (typing T e Chk A) (at level 50).

(** * Typing & PrincipalTyping *)

Lemma typing_to_ptype :
  forall u A,
    uvalue u ->
    typing nil u Inf A ->
    ptype u A.
Proof.
  introv Uval Typ. gen A.
  induction Uval; intros.
  - dependent destruction Typ; eauto.
  - dependent destruction Typ; eauto.
Qed.

Hint Resolve typing_to_ptype : core.

(** * Typing & Consistent *)

(** ** Reflexivity *)

(** Well-typed values are consistent with themselves *)

Lemma consistent_reflexivity :
  forall v A,
    typing nil v Inf A ->
    value v ->
    consistent v v.
Proof.
  introv Typ Val. gen A.
  induction Val; eauto; intros.
  Case "Merge".
  dependent destruction Typ.
  - SCase "Disjoint".
    assert (consistent v1 v2) by (eapply Con_Dj; eauto).
    eapply Con_Mrg_L; eauto.
    eapply Con_Mrg_R; eauto.
    now apply consistent_symmetry.
  - SCase "Consistent".
    eapply Con_Mrg_L; eauto.
    eapply Con_Mrg_R; eauto.
    now apply consistent_symmetry.
Qed.

Hint Resolve consistent_reflexivity : core.

(** * Typing & LC *)

Lemma typing_to_lc :
  forall T e A,
    typing T e Inf A -> lc e.
Proof.
  introv Typ.
  induction Typ; eauto 3; try solve [econstructor; eauto].
Qed.

Hint Resolve typing_to_lc : core.

(** * Check Subsumption *)

Lemma typing_chk_sub :
  forall A B e T,
    typing T e Chk A ->
    sub A B ->
    typing T e Chk B.
Proof.
  introv Typ Sub.
  dependent destruction Typ.
  eapply Ty_Sub; eauto.
  eapply sub_transitivity; eauto.
Qed.


Theorem Disjunctive_syllogism : forall P Q : Prop, (P \/ Q) -> ~P -> Q.
Proof.
  intros.
  destruct H.
  destruct H0.
  apply H.
  apply H.
Qed
.


Set Implicit Arguments.
Require Import RelationClasses Morphisms Init.Wf List Lia Init.Nat Setoid.
From Undecidability.HOU Require Import calculus.calculus unification.unification.
From Undecidability.HOU.second_order Require Export diophantine_equations goldfarb.encoding goldfarb.multiplication.
Import ListNotations.

Set Default Proof Using "Type".

(* ** Equivalences *)
Section EquationEquivalences.

  Variable (sigma: fin -> exp ag).
  Hypothesis (N: forall x, normal (sigma x)).

  Section Variables.
    Lemma forward_vars x n: encodes (sigma (F x)) n -> sigma • fst (varEQ x) ≡ sigma • snd (varEQ x).
    Proof.
      intros H. unfold varEQ; cbn; unfold funcomp.
      change shift with (add 1); rewrite ren_plus_combine, !H; cbn; unfold var_zero.
      change (g a (var 1)) with (enc 1 (var 1)); now simplify.
    Qed.

    Lemma backward_vars x: sigma • fst (varEQ x) ≡ sigma • snd (varEQ x) -> exists n, encodes (sigma (F x)) n.
    Proof using N.
      cbn; simplify.
      unfold funcomp; change shift with (add 1); rewrite ren_plus_combine; unfold var_zero; cbn.
      intros H; eapply normal_forms_encodes in H; (eauto 2).
    Qed.

  End Variables.

  Section Constants.
      Variable (n: nat) (x: nat).
      Hypothesis (Ex: encodes (sigma (F x)) n).

      Lemma forward_consts: n = 1 -> sigma • fst (constEQ x) ≡ sigma • snd (constEQ x).
      Proof using Ex.
        cbn; unfold funcomp; change shift with (add 1); rewrite ren_plus_combine; unfold var_zero; cbn.
        rewrite Ex; asimpl; now intros ->.
      Qed.

      Lemma backward_consts:  sigma • fst (constEQ x) ≡ sigma • snd (constEQ x) -> n = 1.
      Proof using Ex.
        cbn.
        unfold funcomp; change shift with (add 1); rewrite ren_plus_combine; unfold var_zero; cbn.
        rewrite Ex. asimpl. intros ? % equiv_lam_elim % equiv_lam_elim.
        eapply enc_injective;[| |eauto]; (eauto 2).
      Qed.

  End Constants.

  Section Addition.
    Variable (m n p: nat) (x y z: nat).
    Hypothesis (Ex: encodes (sigma (F x)) m) (Ey: encodes (sigma (F y)) n) (Ez: encodes (sigma (F z)) p).

    Lemma forward_add: m + n = p -> sigma • fst (addEQ x y z) ≡ sigma • snd (addEQ x y z).
    Proof using Ex Ey Ez.
      intros <-; cbn.
      unfold funcomp; change shift with (add 1); rewrite !ren_plus_combine; unfold var_zero; cbn.
      erewrite Ex, Ey, Ez; now simplify.
    Qed.

    Lemma backward_add:
      sigma • fst (addEQ x y z) ≡ sigma • snd (addEQ x y z) -> m + n = p.
    Proof using Ex Ey Ez.
      cbn.
      unfold funcomp; change shift with (add 1); rewrite !ren_plus_combine; unfold var_zero; cbn.
      rewrite Ex, Ey, Ez; simplify; intros H % equiv_lam_elim % equiv_lam_elim.
      rewrite <-enc_app in H.
      eapply enc_injective;[| |eauto]; (eauto 2).
    Qed.

  End Addition.

  (* *** Multiplication *)
  Section Multiplication.

    Variable (m n p: nat) (x y z: nat).
    Hypothesis
      (Ex: encodes (sigma (F x)) m) (Ey: encodes (sigma (F y)) n) (Ez: encodes (sigma (F z)) p).

    Lemma forward_mul:
        m * n = p -> sigma (G x y z) = T n m -> sigma • fst (mulEQ x y z) ≡ sigma • snd (mulEQ x y z).
    Proof using Ex Ey Ez.
      intros H1 H2. unfold mulEQ; cbn. unfold funcomp.
      rewrite H2. change shift with (add 1); rewrite !ren_plus_combine; cbn [plus].
      rewrite Ex, Ey, Ez. subst p. eapply G_forward.
    Qed.

    Lemma backward_mult:
      sigma • fst (mulEQ x y z) ≡ sigma • snd (mulEQ x y z) -> m * n = p /\ sigma (G x y z) = T n m.
    Proof using N Ex Ey Ez.
      unfold mulEQ; cbn. unfold funcomp.
      change shift with (add 1); rewrite !ren_plus_combine; cbn [plus].
      rewrite Ex, Ey, Ez. intros H. apply G_iff in H; (eauto 2).
    Qed.

  End Multiplication.

End EquationEquivalences.

(* ** Forward Direction **)
Section Forward.

  Variables (E: list deq).

  Definition gf n := lambda enc n (var 0).

  Lemma tab_typing {X} n (f: nat -> exp X) g k Gamma:
    (forall i, Gamma ⊢(n) f i : g i) -> Gamma ⊢₊(n) tab f k : tab g k.
  Proof.
    intros; induction k; cbn; (eauto 2).
    eapply orderlisttyping_app; (eauto 2).
  Qed.

  Lemma gf_typing Gamma n: Gamma ⊢(2) gf n : alpha → alpha.
  Proof.
    econstructor. eapply enc_typing. eauto.
  Qed.

  Lemma GT_typing Gamma m n: Gamma ⊢(2) T n m : alpha → alpha → alpha → alpha.
  Proof.
    do 3 econstructor. eapply lin_typing; [|eauto].
    rewrite repeated_tab. simplify.
    eapply tab_typing.
    intros; econstructor; cbn. econstructor.
    all: eauto using enc_typing.
  Qed.

  Definition enc_sol (sigma: nat -> nat) (x: fin) :=
    match partition_F_G x with
    | inl (exist _ x _) => gf (sigma x)
    | inr (exist _ (x,y,z) _) => T (sigma y) (sigma x)
    end.

  Lemma enc_sol_encodes theta h: encodes (enc_sol theta (F h)) (theta h).
  Proof.
    unfold enc_sol.
    destruct partition_F_G as [[x ?]|[((x,y),z) ?]].
    - eapply F_injective in e as ->.
      intros t delta. unfold gf. cbn; rewrite stepBeta; asimpl; (eauto 2).
    - exfalso; eapply disjoint_F_G; (eauto 2).
  Qed.

  Lemma enc_sol_T theta x y z: (enc_sol theta (G x y z)) = T (theta y) (theta x).
  Proof.
    unfold enc_sol.
    destruct partition_F_G as [[x' ?]|[((x',y'),z') ?]].
    - exfalso; eapply disjoint_F_G; (eauto 2).
    - now eapply G_injective in y0 as (-> & -> & ->).
  Qed.

  Lemma typing_forward sigma:
    (sigma ⊢⁺ₑ E) -> [] ⊩(2) enc_sol sigma : Gamma__deq E.
  Proof.
    eauto; intros ????; unfold enc_sol.
    destruct partition_F_G as [[]|[((x & y) & z) ?]]; subst.
    + eapply nth_Gamma__deq_F in H0 as ->. eapply gf_typing.
    + eapply nth_Gamma__deq_G in H0 as ->. eapply GT_typing.
  Qed.

  Lemma H10_SU: H10 E -> SOU ag 2 (H10_to_SOU  E).
  Proof.
    intros [sigma H].
    exists []. exists (enc_sol sigma).
    split. now eapply typing_forward.
    intros s t; change s with (fst (s,t)) at 2; change t with (snd (s,t)) at 3.
    remember (s,t) as e. clear Heqe s t.
    intros H'; cbn in *. eapply in_Equations in H' as (d & ? & ?).
      destruct d; cbn in *; intuition idtac; subst.
      all: try eapply forward_add. all: try eapply forward_consts.
      all: try eapply forward_mul.
      all: try eapply forward_vars.
      all: try eapply enc_sol_encodes.
      all: eapply H in H0; inv H0; (eauto 2).
      apply enc_sol_T.
    Qed.

End Forward.

(* ** Backward Direction **)
Section Backward.

  Definition decode_subst (sigma: fin -> exp ag) (N: forall x, normal (sigma x)) (x: fin) :=
    match dec_enc (N (F x)) with
    | inl  (exist _ n _) => n
    | inr _ => 0
    end.

  Lemma decode_subst_encodes (sigma: fin -> exp ag) N x n:
    encodes (sigma (F x)) n -> decode_subst sigma N x = n.
  Proof.
    intros H; unfold decode_subst.
    destruct dec_enc as [[m H1]|H1].
    - specialize (H a id); asimpl in H. rewrite H in H1. eapply enc_injective in H1 as []; (eauto 2).
    - exfalso. eapply H1. exists n. specialize (H a id); asimpl in H. now rewrite H.
  Qed.

  Lemma SU_H10 E: SOU ag 2 (H10_to_SOU E) -> H10 E.
  Proof.
    rewrite SOU_NSOU; (eauto 2). intros (Delta & sigma & T & EQ & N).
    exists (decode_subst sigma N). intros e H; pose (Q := eqs e).
    assert (forall p, p ∈ Q -> sigma • fst p ≡ sigma • snd p) as EQs; [|clear EQ].
    - intros [s t] G. eapply EQ.
      eapply in_Equations. eauto.
    - destruct e; econstructor; cbn in Q, EQs.
      all: specialize (EQs (varEQ x)) as EQx; mp EQx; intuition idtac; eapply backward_vars in EQx as [n EQx]; (eauto 2).
      2 - 3: specialize (EQs (varEQ y)) as EQy; mp EQy; intuition idtac; eapply backward_vars in EQy as [m EQy]; (eauto 2).
      2 - 3: specialize (EQs (varEQ z)) as EQz; mp EQz; intuition idtac; eapply backward_vars in EQz as [p EQz]; (eauto 2).
      all: repeat (erewrite decode_subst_encodes;[|eauto]).
      + eapply backward_consts; (eauto 4).
      + eapply backward_add; (eauto 1); eapply EQs; (eauto 5).
      + eapply backward_mult; (eauto 1); eapply EQs; intuition.
  Qed.
End Backward.

Lemma Goldfarb': H10 ⪯ SOU ag 2.
Proof.
  exists H10_to_SOU; intros x; split.
  - eapply H10_SU.
  - eapply SU_H10.
Qed.

Definition nileq: eq ag := (lambda lambda a, lambda lambda a).
Definition conseqs e1 e2 :=
  match e1, e2 with
  | (lambda lambda s1, lambda lambda t1), (lambda lambda s2, lambda lambda t2) => (lambda lambda g s1 s2, lambda lambda g t1 t2)
  | _, _ => nileq
  end.

Notation foldeqs := (fold_right conseqs nileq).

Lemma conseqs_combine sigma s1 s2 t1 t2:
  sigma • (lambda lambda s1) ≡ sigma • (lambda lambda t1) /\ sigma • (lambda lambda s2) ≡ sigma • (lambda lambda t2) <-> sigma • (lambda lambda g s1 s2) ≡ sigma • (lambda lambda g t1 t2).
Proof.
  cbn; split.
  - intros [H1 H2]; do 2 (eapply equiv_lam_elim in H1; eapply equiv_lam_elim in H2). now rewrite H1, H2.
  - intros H1; do 2 eapply equiv_lam_elim in H1. Injection H1. Injection H. now rewrite H0, H2.
Qed.

Lemma foldeqs_lambda_lambda E:
  exists s t, foldeqs E = (lambda lambda s, lambda lambda t).
Proof.
  induction E as [|[s t]]; cbn; (eauto 2).
  - do 2 eexists; reflexivity.
  - destruct IHE as (s'&t'&IH).
    do 2 (destruct s; try solve [do 2 eexists; reflexivity]).
    do 2 (destruct t; try solve [do 2 eexists; reflexivity]).
    rewrite IH; do 2 eexists; reflexivity.
Qed.

Lemma foldeqs_correct sigma E:
  (forall s1 s2, (s1, s2) ∈ E -> (exists t, s1 = lambda lambda t) /\ (exists t, s2 = lambda lambda t)) ->
  (sigma •₊ left_side E) ≡₊ (sigma •₊ right_side E) <->
  (sigma • fst (foldeqs E) ≡ sigma • snd (foldeqs E)).
Proof.
  induction E as [| [s t]]; simplify.
  - cbn; firstorder.
  - intros H. apply id in H as H'. specialize (H' s t) as ([t1 H1]&[t2 H2]); lauto; subst.
    cbn. specialize (foldeqs_lambda_lambda E) as (u&v&H'); rewrite H' in *.
    mp IHE; (eauto 2). intros; eapply H; firstorder. cbn in IHE.
    cbn; unfold left_side, right_side in *.
    split; [intros [H1 H2] % equiv_lstep_cons_inv| intros H1]; do 2 eapply equiv_lam_elim in H1.
    + destruct IHE as [IHE _]; rewrite H1; mp IHE; (eauto 1);
        do 2 eapply equiv_lam_elim in IHE; now rewrite IHE.
    + Injection H1. Injection H0. rewrite H3.
      destruct IHE as [_ ->]; (eauto 2). now rewrite H2.
Qed.

Lemma foldeqs_typing Gamma E:
  Gamma ⊢₊₊(2) E : repeat (alpha → alpha → alpha) (length E) -> Gamma ⊢₂(2) (foldeqs E) : alpha → alpha → alpha.
Proof.
  remember (repeat (alpha → alpha → alpha) (| E |)) as L. induction 1 in HeqL |- *; cbn.
  - repeat econstructor.
  - do 2 (destruct s; try solve [repeat econstructor]).
    do 2 (destruct t; try solve [repeat econstructor]).
    specialize (foldeqs_lambda_lambda E) as (u&v&H'); rewrite H' in *.
    cbn in HeqL. injection HeqL as -> ->. mp IHeqs_ordertyping; (eauto 2).
    inv H0. inv H4. inv H. inv H4. destruct IHeqs_ordertyping as [T1 T2]. inv T1. inv H4.
    inv T2. inv H4. repeat econstructor; (eauto 2).
Qed.

Lemma Goldfarb : H10 ⪯ OU 2 ag.
Proof.
  unshelve eexists.
  - intros E. unshelve econstructor.
    exact (Gamma__deq E). 1: eapply fst. 2: eapply snd.
    1 - 2: eapply foldeqs, (H10_to_SOU E).
    exact (alpha → alpha → alpha).
    all: eapply foldeqs_typing; cbn -[Gamma__deq].
    all: eapply H10_to_SOU.
  - intros E. split.
    + intros H % H10_SU. destruct H as (Delta & sigma & H1 & H2).
      exists Delta. exists sigma. intuition. eapply foldeqs_correct, equiv_pointwise_eqs; (eauto 2).
      cbn. intros s1 s2 (d&H3&H4) % in_flat_map.
      destruct d; cbn in H4; intuition.
      all: change s1 with (fst (s1, s2)); rewrite <-?H, <-?H0.
      all: change s2 with (snd (s1, s2)); rewrite <-?H, <-?H0.
      all: cbn; (eauto 2).
    + intros (Delta & sigma & T & EQ). eapply SU_H10. exists Delta, sigma.
      intuition.  eapply equiv_eqs_pointwise; (eauto 1); eapply foldeqs_correct; (eauto 2).
      cbn. intros s1 s2 (d&H3&H4) % in_flat_map.
      destruct d; cbn in H4; intuition.
      all: change s1 with (fst (s1, s2)); rewrite <-?H1, <-?H0.
      all: change s2 with (snd (s1, s2)); rewrite <-?H1, <-?H0.
      all: cbn; (eauto 2).
Qed.


Require Export tacticsDed.
Require Export struct_ex.

(* G \a F |- (H\a G) \a (H \a F) *)
(* example of derived rule in L *)
Definition Geach_main_Back :
 forall (I J A W:Set)(r:resource W) (F G H : Form I J
 A)(a:I)(ext:extension I J)eqdecI eqdecJ,
 (in_extension (L1 a) ext)->
 natded  eqdecI eqdecJ ext (res r (Backslash a G F))
 (Backslash a (Backslash a H  G)
 (Backslash a H  F)).
intros.
backI 0.
backI 1.
z_root.
structH H0.
ebackE;[idtac|axiom].
ebackE;axiom.
Qed.


From iris.heap_lang Require Import notation proofmode.
(*From iris_examples.concurrent_stacks Require Import specs.*)

Definition simple_leq : val :=
    rec: "simple_leq" "a" "b" :=
    let: "c" := #0 in
    if: "a" ≤ "b"
    then "c" <- "a"
    else "c" <- "b".

Definition simple_plus : val :=
    rec: "simple_plus" "a" "b" :=
    let: "c" := "a" + "b" in
    "c".

Definition lam_simple_plus : val := λ: "a" "b" "c",
    "c" <- "a" + "b".

Section simple_arith.
Context `{!heapGS Σ} (N : namespace).
Implicit Types l : loc.

Theorem lam_simple_plus_spec a b c:
    {{{ True }}} lam_simple_plus #a #b #c {{{ RET #(); ⌜c = a + b⌝}}}.

Theorem simple_arith a b :
    {{{ True }}} simple_plus (of_val (#a : nat)) (of_val #(b : nat)) {{{ c, RET c; ⌜c = a + b⌝ }}}.
Proof.

Qed.

Theorem simple_leq_spec a b :
    {{{ ⌜a ≤ b⌝ }}} simple_leq (of_val #a) (of_val #b) {{{ c, RET c; ⌜c = #a⌝ }}}.
Proof. iIntros (Φ) "H HΦ". wp_rec. do 2 wp_let.

End simple_arith.


Require Export prosa.results.edf.rta.bounded_nps.
Require Export prosa.analysis.facts.preemption.task.nonpreemptive.
Require Export prosa.analysis.facts.preemption.rtc_threshold.nonpreemptive.

From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq path fintype bigop.

(** * RTA for Fully Non-Preemptive EDF *)
(** In this module we prove the RTA theorem for the fully non-preemptive EDF model. *)

(** Throughout this file, we assume the EDF priority policy, ideal uni-processor
    schedules, and the basic (i.e., Liu & Layland) readiness model. *)
Require Import prosa.model.priority.edf.
Require Import prosa.model.processor.ideal.
Require Import prosa.model.readiness.basic.

(** Furthermore, we assume the fully non-preemptive task model. *)
Require Import prosa.model.task.preemption.fully_nonpreemptive.

(** ** Setup and Assumptions *)

Section RTAforFullyNonPreemptiveEDFModelwithArrivalCurves.

  (** Consider any type of tasks ... *)
  Context {Task : TaskType}.
  Context `{TaskCost Task}.
  Context `{TaskDeadline Task}.

  (**  ... and any type of jobs associated with these tasks. *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** Consider any arrival sequence with consistent, non-duplicate arrivals. *)
  Variable arr_seq : arrival_sequence Job.
  Hypothesis H_arrival_times_are_consistent : consistent_arrival_times arr_seq.
  Hypothesis H_arr_seq_is_a_set : arrival_sequence_uniq arr_seq.

  (** Consider an arbitrary task set ts, ... *)
  Variable ts : list Task.

  (** ... assume that all jobs come from this task set, ... *)
  Hypothesis H_all_jobs_from_taskset : all_jobs_from_taskset arr_seq ts.

  (** ... and the cost of a job cannot be larger than the task cost. *)
  Hypothesis H_valid_job_cost:
    arrivals_have_valid_job_costs arr_seq.

  (** Let max_arrivals be a family of valid arrival curves, i.e., for
     any task [tsk] in ts [max_arrival tsk] is (1) an arrival bound of
     [tsk], and (2) it is a monotonic function that equals 0 for the
     empty interval delta = 0. *)
  Context `{MaxArrivals Task}.
  Hypothesis H_valid_arrival_curve : valid_taskset_arrival_curve ts max_arrivals.
  Hypothesis H_is_arrival_curve : taskset_respects_max_arrivals arr_seq ts.

  (** Let [tsk] be any task in ts that is to be analyzed. *)
  Variable tsk : Task.
  Hypothesis H_tsk_in_ts : tsk \in ts.

  (** Next, consider any ideal non-preemptive uniprocessor schedule of this arrival sequence ... *)
  Variable sched : schedule (ideal.processor_state Job).
  Hypothesis H_nonpreemptive_sched : nonpreemptive_schedule  sched.
  Hypothesis H_jobs_come_from_arrival_sequence:
    jobs_come_from_arrival_sequence sched arr_seq.

  (** ... where jobs do not execute before their arrival or after completion. *)
  Hypothesis H_jobs_must_arrive_to_execute : jobs_must_arrive_to_execute sched.
  Hypothesis H_completed_jobs_dont_execute : completed_jobs_dont_execute sched.

  (** Assume we have sequential tasks, i.e, jobs from the
      same task execute in the order of their arrival. *)
  Hypothesis H_sequential_tasks : sequential_tasks sched.

  (** Next, we assume that the schedule is a work-conserving schedule... *)
  Hypothesis H_work_conserving : work_conserving arr_seq sched.

  (** ... and the schedule respects the policy defined by the
      job_preemptable function (i.e., jobs have bounded nonpreemptive
      segments). *)
  Hypothesis H_respects_policy : respects_policy_at_preemption_point arr_seq sched.

  (** ** Total Workload and Length of Busy Interval *)

  (** We introduce the abbreviation [rbf] for the task request bound function,
      which is defined as [task_cost(T) × max_arrivals(T,Δ)] for a task T. *)
  Let rbf := task_request_bound_function.

  (** Next, we introduce [task_rbf] as an abbreviation
      for the task request bound function of task [tsk]. *)
  Let task_rbf := rbf tsk.

  (** Using the sum of individual request bound functions, we define the request bound
     function of all tasks (total request bound function). *)
  Let total_rbf := total_request_bound_function ts.

  (** We also define a bound for the priority inversion caused by jobs with lower priority. *)
  Let blocking_bound :=
    \max_(tsk_o <- ts | (tsk_o != tsk) && (task_deadline tsk_o > task_deadline tsk))
     (task_cost tsk_o - ε).

  (** Next, we define an upper bound on interfering workload received from jobs
       of other tasks with higher-than-or-equal priority. *)
  Let bound_on_total_hep_workload A Δ :=
    \sum_(tsk_o <- ts | tsk_o != tsk)
     rbf tsk_o (minn ((A + ε) + task_deadline tsk - task_deadline tsk_o) Δ).

  (** Let L be any positive fixed point of the busy interval recurrence. *)
  Variable L : duration.
  Hypothesis H_L_positive : L > 0.
  Hypothesis H_fixed_point : L = total_rbf L.

  (** ** Response-Time Bound *)

  (** To reduce the time complexity of the analysis, recall the notion of search space. *)
  Let is_in_search_space := is_in_search_space ts tsk L.

  (** Consider any value R, and assume that for any given arrival offset A in the search space,
      there is a solution of the response-time bound recurrence which is bounded by R. *)
  Variable R: nat.
  Hypothesis H_R_is_maximum:
    forall A,
      is_in_search_space A ->
      exists F,
        A + F = blocking_bound + (task_rbf (A + ε) - (task_cost tsk - ε))
                + bound_on_total_hep_workload A (A + F) /\
        F + (task_cost tsk - ε) <= R.

  (** Now, we can leverage the results for the abstract model with bounded nonpreemptive segments
     to establish a response-time bound for the more concrete model of fully nonpreemptive scheduling. *)

  Let response_time_bounded_by := task_response_time_bound arr_seq sched.

  Theorem uniprocessor_response_time_bound_fully_nonpreemptive_edf:
    response_time_bounded_by tsk R.
  Proof.
    case: (posnP (task_cost tsk)) => [ZERO|POS].
    { intros j ARR TSK.
      have ZEROj: job_cost j = 0.
      { move: (H_valid_job_cost j ARR) => NEQ.
        rewrite /valid_job_cost TSK ZERO in NEQ.
          by apply/eqP; rewrite -leqn0.
      }
        by rewrite /job_response_time_bound /completed_by ZEROj.
    }
    eapply uniprocessor_response_time_bound_edf_with_bounded_nonpreemptive_segments with (L0 := L).
    all: eauto 2 with basic_facts.
  Qed.

End RTAforFullyNonPreemptiveEDFModelwithArrivalCurves.


Require Import ExtLib.Structures.Monad.
Require Import ExtLib.Structures.Monoid.

Set Universe Polymorphism.
Set Printing Universes.

Class MonadWriter@{d c s} (T : Type@{s}) (M : Monoid T)
            (m : Type@{d} -> Type@{c}) : Type :=
{ tell : T -> m unit
; listen : forall {A : Type@{d}}, m A -> m (A * T)%type
; pass : forall {A : Type@{d}}, m (A * (T -> T))%type -> m A
}.

Arguments tell {T MT m _} _ : rename.
Arguments listen {T MT m _ _} _ : rename.
Arguments pass {T MT m _} {_} _ : rename.
Arguments MonadWriter {T} MT _ : rename.

Definition listens@{d c s}
           {m : Type@{d} -> Type@{c}}
           {S : Type@{s}}
           {Monad_m : Monad m}
           {Monoid_S : Monoid S}
           {Writer_m : MonadWriter Monoid_S m}
           {A B : Type@{d}} (f : S -> B) (c : m A) : m (A * B)%type :=
  liftM (fun x => (fst x, f (snd x))) (listen c).

Definition censor@{d c s}
           {m : Type@{d} -> Type@{c}}
           {S : Type@{s}}
           {Monad_m : Monad m}
           {Monoid_S : Monoid S}
           {Writer_m : MonadWriter Monoid_S m}
           {A : Type@{d}} (f : S -> S) (c : m A) : m A :=
  pass (liftM (fun x => (x, f)) c).


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(*   Author: Yu Guo <aciclo@gmail.com>                                        *)
(*                                        Computer Science Department, USTC   *)
(*                                                                            *)
(*          Bihong Zhang <sa614257@mail.ustc.edu.cn                           *)
(*                                        School of Software Engineer, USTC   *)
(*                                                                            *)
(* ************************************************************************** *)

Require Import List.
Require Import ListEx.
Require Import Data.

Require Import Params.
Require Import Nand.
Require Import Dftl2.

(*  -------------------------------------------------------------

  Predicates for block no.

*)
Definition bvalid_logical_page_no (lpn: page_no) := blt_nat lpn (MAX_LOGICAL_BLOCKS * PAGES_PER_BLOCK).

Definition bvalid_logical_block_no (lbn: block_no) := blt_nat lbn MAX_LOGICAL_BLOCKS.

Definition valid_block_no (pbn: block_no):Prop := bvalid_block_no pbn = true.

Definition valid_page_no (ppn: page_no):Prop := bvalid_page_no ppn = true.

Definition valid_logic_block_no (lbn:block_no) :Prop := bvalid_logical_block_no lbn = true.

Definition valid_logic_page_no (lpn:page_no) :Prop := bvalid_logical_page_no lpn = true.

Definition valid_page_off (off: page_off):Prop := bvalid_page_off off = true.

Lemma valid_page_off_dec :
  forall off,
    valid_page_off off \/ ~ valid_page_off off.
Proof.
  intros.
  unfold valid_page_off.
  destruct (bvalid_page_off off).
  left; trivial.
  right.
  auto.
Qed.

(*  -------------------------------------------------------------

  Predicates for page state table

*)
Definition pst_domain_is_complete (pst: page_state_table) : Prop :=
  list_len pst  = PAGES_PER_BLOCK.

Definition pst_page_state (pst:page_state_table) (b:block) :Prop :=
  forall loc,
    valid_page_off loc
    -> match pst_get pst loc with
           | Some (ps_data lpn) => exists p,block_get_page b loc = Some p /\
                                          page_state p = ps_programmed /\
                                          (exists lbn loff,page_oob p = Some (lbn,loff) /\
                                                           lpn = lbn * PAGES_PER_BLOCK + loff)
           | Some (ps_trans gtd_loc) => exists p,block_get_page b loc = Some p /\
                                          page_state p = ps_programmed /\
                                          (exists gtd_loc',page_oob p = Some (gtd_loc',0) /\
                                                           gtd_loc  =  gtd_loc')
           | Some ps_erased => exists p,block_get_page b loc = Some p /\
                                          page_state p = ps_free
           | _ => True
       end.

Definition pst_shape (pst: page_state_table) (np: page_off) : Prop :=
  forall loc,
    valid_page_off loc
    -> (blt_nat loc np = false
        -> pst_get pst loc  = Some ps_erased)
       /\ (blt_nat loc np =  true
           -> ~pst_get pst loc = Some ps_erased).

Definition predicate_pst (pst:page_state_table) (b:block) : Prop :=
  pst_domain_is_complete pst /\ pst_page_state pst b.

(*  -------------------------------------------------------------

  Predicates for "block info"
  Mark: Now ignore the (oob)
*)

Definition block_coherent_data (bi:block_info) (b:block) :Prop :=
    bi_state bi = bs_data /\
    block_state b = bs_programmed /\
    bi_used_pages bi = next_page b /\
    (forall loc,
       valid_page_off loc
       -> exists p, block_get_page b loc = Some p /\
                    page_state p = ps_programmed).

Definition block_coherent_trans (bi:block_info) (b:block) :Prop :=
    bi_state bi = bs_trans /\
    block_state b = bs_programmed /\
    bi_used_pages bi = next_page b /\
    (forall loc,
       valid_page_off loc
       -> exists p, block_get_page b loc = Some p /\
                    page_state p = ps_programmed).

Definition block_coherent_erased (bi:block_info) (b:block) :Prop :=
    bi_state bi = bs_erased /\
    block_state b = bs_free /\
    bi_used_pages bi = next_page b /\
    bi_used_pages bi = 0 /\
    (forall loc,
       valid_page_off loc
       -> exists p, block_get_page b loc = Some p /\
                    page_state p = ps_free).

Definition block_coherent_partial (loc: page_off) (b: block): Prop :=
  next_page b = loc
  /\ block_state b = bs_programmed
  /\ (forall off,
        valid_page_off off
        -> (blt_nat off loc = true
            -> exists p, block_get_page b off = Some p
                         /\ page_state p = ps_programmed)
           /\ (blt_nat off loc = false
               -> exists p, block_get_page b off = Some p
                            /\ page_state p = ps_free)).

Definition chip_bi_coherent (c:chip) (pbn:block_no) (bi:block_info) :=
  exists b,chip_get_block c pbn = Some b
           /\ match (bi_state bi) with
                  | bs_erased => block_coherent_erased bi b
                  | bs_invalid => True
                  | bs_data   => block_coherent_data bi b /\ (exists pst ,bi_page_state bi = pst /\ predicate_pst pst b)
                  | bs_trans  => block_coherent_trans bi b /\ (exists pst ,bi_page_state bi = pst /\ predicate_pst pst b)
               end.

(*  -------------------------------------------------------------

  Predicates for free block queue

*)

Definition pbn_in_fbq (fbq: block_queue) (pbn: block_no) : Prop :=
  fbq_in fbq pbn = true.

Definition pbn_not_in_fbq (fbq: block_queue) (pbn: block_no) : Prop :=
  fbq_in fbq pbn = false.


Require Import List.
Export ListNotations.
Require Import PeanoNat.
Require Import Lia.

Require Import Ensembles.
Require Import Prop_Bi_Int_calcs.
Require Import Prop_Bi_Int_Kripke_sem.

Lemma Ax_valid : forall A, BIAxioms A ->
  (forall W R R_props val pers w, wforces W R R_props val pers w A).
Proof.
intros A Ax. inversion Ax ; destruct H ; subst ; destruct R_props ;
unfold R_refl in r ; unfold R_trans in r0 ; simpl ; intros ; auto.
- destruct H ; destruct H ; subst ; simpl ; intros ; auto. apply H2 ; auto. apply H0 ; auto. apply r0 with (v:=v0) ; auto.
- destruct H ; subst ; simpl ; intros ; auto.
- destruct H ; subst ; simpl ; intros ; auto ;  destruct H0 ; auto.
- destruct H ; destruct H ; subst ; simpl ; intros ; auto. destruct H4 ; auto. apply H0 ; auto.
  apply r0 with (v:=v0) ; auto.
- destruct H ; subst ; simpl ; intros ; auto. destruct H0. auto.
- destruct H ; subst ; simpl ; intros ; auto. destruct H0. auto.
- destruct H ; destruct H ; subst ; simpl ; intros ; auto. split.
  apply H0 ; auto. apply r0 with (v:=v0) ; auto. apply H2 ; auto.
- destruct H ; destruct H ; subst ; simpl ; intros ; auto.
  apply H0 with (v:=v0) (v0:=v0) ; auto. destruct H2. assumption.
  destruct H2. assumption.
- destruct H ; destruct H ; subst ; simpl ; intros ; auto.
  apply H0 ; auto. apply r0 with (v:=v0) ; auto. split. apply Persistence with (w:=v0) ; auto.
  auto.
- destruct H ; subst ; simpl ; intros ; auto.
  apply H2 with (v:=v1) ; auto. apply H0 ; auto. apply r0 with (v:=v1) ; auto. apply r0 with (v:=v0) ; auto.
- destruct H ; subst ; simpl ; intros ; auto.
  pose (@wforces_dec x0 W R (r, r0) val pers v). destruct o. auto.
  right. exists v. repeat split. apply r. assumption. assumption.
- destruct H ; subst ; simpl ; intros ; auto.
  destruct H0. destruct H0. destruct H1. exists x1 ; auto.
- destruct H ; destruct H ; subst ; simpl ; intros ; auto.
  destruct H0. destruct H0. destruct H1. destruct H1. destruct H1. destruct H3.
  exists x3. repeat split ; auto. apply r0 with (v:=x2) ; auto. intro.
  destruct H5. apply H4. auto. apply H2. apply Persistence with (w:=x3). auto.
  assumption.
- destruct H ; subst ; simpl ; intros ; auto.
  pose (@H0 v0 H1). pose (@wforces_dec x0 W R (r, r0) val pers v0). destruct o ; auto.
  exfalso. apply f. exists v0 ; repeat split ; auto.
- inversion H0.
Qed.

Theorem wSoundness0 : forall s, (wBIC_rules s) ->
        (loc_conseq (fst s) (Singleton _ (snd s))).
Proof.
intros s D. induction D.
(* Id *)
- inversion H. subst. simpl. intro. intros. exists A. split. apply In_singleton.
  apply H1. assumption.
(* Ax *)
- inversion H. subst. simpl. intro. intros. exists A. split. apply In_singleton.
  apply Ax_valid. assumption.
(* MP *)
- inversion H1. subst. simpl. assert (J1: loc_conseq Γ (Singleton (BPropF V) (A → B))).
  apply H0 with (prem:=(Γ, A → B)). apply in_eq. assert (J2: loc_conseq Γ (Singleton (BPropF V) (A))).
  apply H0 with (prem:=(Γ, A)). apply in_cons. apply in_eq.
  intro. intros.
  exists B. split. apply In_singleton. unfold loc_conseq in J1.
  pose (J1 W R R_props val pers w H2). destruct e. destruct H3. inversion H3. subst.
  pose (J2 W R R_props val pers w H2). destruct e. destruct H5. inversion H5.
  subst. apply H4. destruct R_props. apply r. assumption.
(* DNw *)
- inversion H1. subst. simpl. assert (J1: loc_conseq (Empty_set (BPropF V)) (Singleton (BPropF V) (A))).
  apply H0 with (prem:=(Empty_set (BPropF V), A)) ; apply in_eq.
  intro. intros. exists (Neg (wNeg A)). split. apply In_singleton.
  simpl in J1. simpl. intros. destruct H4. destruct H4. apply H5.
  assert (J2: (forall A : BPropF V, In _ (Empty_set _) A -> wforces W R R_props val  pers x A)).
  intros. inversion H6.
  pose (J1 W R R_props val pers x J2). destruct e. destruct H6. inversion H6. subst.
  assumption.
Qed.

Lemma list_disj_witn : forall W R R_props val  pers w l,
    (wforces W R R_props val  pers w (list_disj l)) ->
    (exists A : BPropF V, (List.In A l) /\ wforces W R R_props val  pers w A).
Proof.
induction l.
- simpl. intros. inversion H.
- simpl. intros. destruct H.
  * exists a. split. apply in_eq. assumption.
  * apply IHl in H. destruct H. destruct H. exists x. split ; try assumption. apply in_cons ; auto.
Qed.

Theorem wSoundness : forall (Γ Δ : @Ensemble (BPropF V)), wpair_derrec (Γ, Δ) -> (loc_conseq Γ Δ).
Proof.
intros Γ Δ wpair. destruct wpair. destruct H. destruct H0. simpl in H0.
simpl in H1. apply wSoundness0 in H1. simpl in H1. intro. intros. unfold loc_conseq in H1.
pose (H1 W R R_props val pers w H2). destruct e. destruct H3. inversion H3. subst.
induction x.
- simpl in H1. exfalso. simpl in H3. simpl in H4. inversion H4.
- simpl in IHx. simpl in H3. simpl in H4. destruct H4.
  * exists a. split. apply H0. apply in_eq. assumption.
  * apply list_disj_witn in H4. destruct H4. destruct H4. exists x0. split.
    apply H0. apply in_cons. 2: assumption. assumption.
Qed.

Theorem sSoundness0 : forall s, (sBIC_rules s) ->
        (glob_conseq (fst s) (Singleton _ (snd s))).
Proof.
intros s D. induction D.
(* Ids *)
- inversion H. subst. simpl. intro. intros. exists A. split. apply In_singleton.
  apply H1. assumption.
(* Axs *)
- inversion H. subst. simpl. intro. intros. exists A. split. apply In_singleton.
  apply Ax_valid. assumption.
(* MPs *)
- inversion H1. subst. simpl. assert (J1: glob_conseq Γ (Singleton (BPropF V) (A → B))).
  apply H0 with (prem:=(Γ, A → B)). apply in_eq. assert (J2: glob_conseq Γ (Singleton (BPropF V) (A))).
  apply H0 with (prem:=(Γ, A)). apply in_cons. apply in_eq.
  intro. intros.
  exists B. split. apply In_singleton. unfold glob_conseq in J1.
  pose (J1 W R R_props val pers H2 w). destruct e. destruct H3. inversion H3. subst.
  pose (J2 W R R_props val pers H2 w). destruct e. destruct H5. inversion H5.
  subst. apply H4. destruct R_props. apply r. assumption.
(* DNs *)
- inversion H1. subst. simpl. assert (J1: glob_conseq (Γ) (Singleton (BPropF V) (A))).
  apply H0 with (prem:=(Γ, A)) ; apply in_eq.
  intro. intros. exists (Neg (wNeg A)). split. apply In_singleton.
  simpl in J1. simpl. intros. destruct H4. destruct H4. apply H5.
  pose (J1 W R R_props val pers H2 x). destruct e. destruct H6. inversion H6. subst.
  assumption.
Qed.

Theorem sSoundness : forall (Γ Δ : @Ensemble (BPropF V)), spair_derrec (Γ, Δ) -> (glob_conseq Γ Δ).
Proof.
intros Γ Δ gpair. destruct gpair. repeat destruct p. destruct H. destruct H0. simpl in H0.
simpl in H1. apply sSoundness0 in H1. simpl in H1. intro. intros.
induction x.
- simpl in H1. exfalso. pose (H1 W R R_props val pers H2 w). destruct e. destruct H3.
  inversion H3. subst. auto.
- pose (H1 W R R_props val pers H2 w). destruct e. destruct H3. inversion H3. subst.
  simpl in H1. simpl in H4. destruct H4.
  * exists a. split. apply H0. apply in_eq. assumption.
  * apply list_disj_witn in H4. destruct H4. destruct H4. exists x0. split.
    apply H0. apply in_cons. assumption. assumption.
Qed.


Require Import
        Essentials.Facts_Tactics
        Essentials.Notations
        Essentials.Types.
Require Import Metrics.Mappings.
Require Import Metrics.Complete_UltraMetric.
Require Import Metrics.CBULt.Product.
Require Import Categories.Category.Main.
Require Import
        Categories.Ext_Cons.Prod_Cat.Prod_Cat.
Require Import MCat.MCat.

Local Open Scope order_scope.
Local Open Scope metric_scope.
Local Open Scope lattice_scope.

Section MCat_Prod.
  Context {L : MLattice} (M M' : MCat L).

  (** Product of two M-categories is an M-category. *)
  Program Definition MCat_Prod : MCat L :=
    {|
      MC_Obj := M * M';
      MC_Hom :=
        fun A B =>
          product_CUM
            (MC_Hom M (fst A) (fst B))
            (MC_Hom M' (snd A) (snd B));
      MC_compose :=
        fun a b c =>
          {|
            NE_fun :=
              fun w =>
                (MC_compose M (fst (fst w), (fst (snd w))),
                 MC_compose M' (snd (fst w), (snd (snd w))))
          |};
      MC_id := fun _ => (MC_id M, MC_id M')
    |}.

  Local Ltac lub2ub t :=
    eapply PO_Trans;
    [|apply (lub_ub _ _ t)].

  Next Obligation.
  Proof.
    apply lub_lst; intros [].
    {
      eapply PO_Trans; [apply NE_non_expansive|].
      apply lub_lst; intros []; cbn.
      + do 2 (lub2ub true); trivial.
      + lub2ub false; lub2ub true; trivial.
    }
    {
      eapply PO_Trans; [apply NE_non_expansive|].
      apply lub_lst; intros []; cbn.
      + lub2ub true; lub2ub false; trivial.
      + do 2 (lub2ub false); trivial.
    }
  Defined.

  Next Obligation.
  Proof.
    rewrite (MC_assoc M).
    rewrite (MC_assoc M').
    trivial.
  Defined.

  Next Obligation.
  Proof.
    rewrite (MC_assoc_sym M).
    rewrite (MC_assoc_sym M').
    trivial.
  Defined.

  Next Obligation.
  Proof.
    rewrite (MC_id_unit_left M).
    rewrite (MC_id_unit_left M').
    trivial.
  Defined.

  Next Obligation.
  Proof.
    rewrite (MC_id_unit_right M).
    rewrite (MC_id_unit_right M').
    trivial.
  Defined.

End MCat_Prod.

(** A simple test showing that product of two M-categories has as its
underlying category the product of the underlying categories of
the input M-categories. *)
Goal (∀ L (M M' : MCat L), (M × M')%category = (@MCat_Prod L M M')).
  exact (fun _ _ _ => eq_refl).
Abort.