(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import fintype generic_quotient.
From mathcomp Require Import div tuple bigop ssralg poly polydiv finmap.

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

Import GRing.Theory.

Section MoreLogic.

Fact aux_equivb (P : Prop) (b c : bool) : reflect P b -> b = c -> reflect P c.
Proof. by move => reflect_P_b b_eq_c ; rewrite b_eq_c in reflect_P_b. Qed.

Variables (A B C : Prop).

Lemma if_iff_compat_l : B <-> C -> (A -> B) <-> (A -> C).
Proof. by move=> h; split => h1 h2; apply/h/h1. Qed.

Lemma if_iff_compat_r : B <-> C -> (B -> A) <-> (C -> A).
Proof. by move=> h; split => h1 h2; apply/h1/h. Qed.

End MoreLogic.

Section MoreNatTheory.

Lemma lt_predn n : (n.-1 < n) = (n != 0).
Proof. by case: n => [//|n]; rewrite ltnSn. Qed.

Fact n_eq1 n : n != 0 -> n < 2 -> n = 1.
Proof. by case: n => [?|[?|[]]]. Qed.

Fact leq_npred m n : m > 0 -> (m <= n.-1) = (m < n).
Proof. by move: m n => [|m] [|n]. Qed.

Fact predn_sub m n : (m - n).-1 = (m.-1 - n).
Proof. by case: m => //= m; rewrite subSKn. Qed.

Lemma geq_subn m n : m <= n -> m - n = 0.
Proof. by rewrite -subn_eq0 => /eqP. Qed.

Lemma ltn_subLR m n p : 0 < p -> (m - n < p) = (m < n + p).
Proof. by case: p => // p _; rewrite addnS !ltnS leq_subLR. Qed.

Lemma leq_subRL m n p : 0 < n -> (n <= p - m) = (m + n <= p).
Proof. by case: n => // n _; rewrite addnS ltn_subRL. Qed.

Fact ltpredn a b c : a != 0 -> ((a + b).-1 < c + b) = (a.-1 < c).
Proof. by rewrite -lt0n => a_gt0; rewrite !prednK ?ltn_addr // leq_add2r. Qed.

Lemma leq_leq_subRL m n p : m <= p -> (n <= p - m) = (m + n <= p).
Proof. by move=> ?; case: n => [|n]; rewrite ?leq0n ?addn0 ?leq_subRL. Qed.

Lemma leq_ltn_subLR m n p : n <= m -> (m - n < p) = (m < n + p).
Proof.
move=> le_nm; case: p => [|p]; last by rewrite ltn_subLR.
by rewrite addn0 ltn0 ltnNge le_nm.
Qed.

Lemma ltnpredn m n : (m < n.-1) = (m.+1 < n).
Proof. by case: n => [//|n]; rewrite succnK. Qed.

Lemma ltn_subCl m n p : 0 < p -> 0 < n -> (m - n < p) = (m - p < n).
Proof. by move=> ??; rewrite !ltn_subLR // addnC. Qed.

Lemma leq_ltn_subCl m n p : n <= m -> p <= m -> (m - n < p) = (m - p < n).
Proof. by move=> ??; rewrite !leq_ltn_subLR // addnC. Qed.

Lemma ltn_subCr m n p : (p < m - n) = (n < m - p).
Proof. by rewrite !ltn_subRL // addnC. Qed.

Lemma leq_subCr m n p : 0 < p -> 0 < n -> (p <= m - n) = (n <= m - p).
Proof. by move=> ??; rewrite !leq_subRL // addnC. Qed.

Lemma leq_leq_subCr m n p : n <= m -> p <= m -> (p <= m - n) = (n <= m - p).
Proof. by move=> ??; rewrite !leq_leq_subRL // addnC. Qed.

Lemma leq_subCl m n p : (m - n <= p) = (m - p <= n).
Proof. by rewrite !leq_subLR // addnC. Qed.

Lemma cross_leq_add m n p q :
(m <= n)%N -> (n + p <= m + q)%N -> (p <= q)%N.
Proof.
move=> leq_mn; rewrite addnC -leq_subLR => h.
by rewrite (leq_trans _ h) // -addnBA // leq_addr.
Qed.

End MoreNatTheory.

Section MoreSeq.

Section GeneralBaseType.
Variable (T : Type).

Lemma nseqS (n : nat) (x : T) : nseq n.+1 x = rcons (nseq n x) x.
Proof. by elim: n => //= n <-. Qed.

Definition nrcons (n : nat) (x : T) := iter n (fun s => rcons s x).

Lemma nseq_cat (n : nat) (x : T) (s : seq T) : s ++ nseq n x = nrcons n x s.
Proof.
elim: n => [|n ih]; first by rewrite cats0.
by rewrite nseqS -rcons_cat ih.
Qed.

Lemma addn_nseq (m n : nat) (x : T) : (nseq m x) ++ (nseq n x) = nseq (m + n) x.
Proof. by elim: m => // m ih; rewrite /= ih. Qed.

Lemma nrcons_cons (n : nat) (x : T) (s : seq T) (z : T) :
  nrcons n z (x :: s) = x :: nrcons n z s.
Proof.
move: x s z; elim: n => // n ih x s z /=.
by rewrite ih rcons_cons.
Qed.

Lemma rcons_nrcons (n : nat) (x : T) (s : seq T) :
  rcons (nrcons n x s) x = nrcons n.+1 x s.
Proof. by []. Qed.

Fact head_rev (s : seq T) (x : T) : head x (rev s) = last x s.
Proof. by case/lastP: s => [//= |t y]; rewrite rev_rcons last_rcons //=. Qed.

Fact last_rev (s : seq T) (x : T) : last x (rev s) = head x s.
Proof. case: s => [//= |t y /=]; rewrite rev_cons last_rcons //=. Qed.

Lemma rev_nseq (n : nat) (x : T) : rev (nseq n x) = nseq n x.
Proof. by elim: n => // n; rewrite {1}nseqS rev_rcons => ->. Qed.

Lemma rev_ncons (n : nat) (x : T) (s : seq T) :
  rev (ncons n x s) = rev s ++ nseq n x.
Proof. by rewrite -cat_nseq rev_cat rev_nseq. Qed.

(* Lemma nth_nrcons (x0 : T) (n : nat) (s : seq T) (x : T) (i : nat) : *)
(*  nth x0 (nrcons n x s) i = if (i < (size s) then nth x0 s i) else *)
(*  if ( < i) *)

(* nth_rcons *)
(*    forall (T : Type) (x0 : T) (s : seq T) (x : T) (n : nat), *)
(*    nth x0 (rcons s x) n = *)
(*    (if (n < size s)%N then nth x0 s n else if n == size s then x *)
(*    else x0) *)

Lemma rcons_set_nth (x y : T) (s : seq T) : (set_nth y s (size s) x) = rcons s x.
Proof. by elim: s => //= a s <-. Qed.

Fact set_nthS (e : seq T) (i : nat) (x y : T) :
  (size e <= i)%N -> set_nth x e i y = set_nth x (rcons e x) i y.
Proof.
move: {2}(i - size e)%N (erefl (i - size e))%N x y => n.
move: e i; elim: n.
  move=> e i.
  move/eqP; rewrite subn_eq0 => leq_ie x y leq_ei.
  have -> : i = size e by apply/eqP; rewrite eqn_leq; apply/andP.
  move=> {leq_ie} {leq_ei} {i}; move: x y.
  elim: e => // a e ihe x y /=.
  by rewrite ihe.
move=> n ihn e.
elim: e.
  move=> i /=. rewrite subn0 => -> x y _ //=.
  by rewrite set_nth_nil.
move=> a e ihe i h x y ltaei.
move: h ltaei.
case: i => //= i.
rewrite subSS => h.
rewrite ltnS=> ltaei.
congr cons.
by rewrite ihe.
Qed.

(* to be replaced by set_nth_over *)
Lemma set_nth_nrcons (e : seq T) (i : nat) (x y : T) :
  (size e <= i)%N -> (set_nth x e i y) = rcons (nrcons (i - (size e)) x e) y.
Proof.
move: {2}(i - size e)%N (erefl (i - size e))%N x y => n.
move: e i; elim: n => [e i|n ihn e].
  move/eqP; rewrite subn_eq0 => h x y leq_ei.
  have -> : i = size e by apply/eqP; rewrite eqn_leq; apply/andP.
  rewrite subnn /=.
  by move=> {h} {leq_ei}; elim: e => //= a e ->.
elim: e => [i|a e ihe i h x y ltaei].
  rewrite subn0 => -> x y _.
  by rewrite set_nth_nil -cat_nseq cats1 -nseq_cat cat0s.
move: h ltaei; case: i => //= i.
rewrite subSS => h; rewrite ltnS => ltaei.
by rewrite ihe // -rcons_cons nrcons_cons.
Qed.

Lemma set_nth_over (e : seq T) (i : nat) (x y : T) :
  (size e <= i)%N -> (set_nth x e i y) =
                     rcons (e ++ (nseq (i - (size e))%N x)) y.
Proof.
by move=> h; rewrite set_nth_nrcons //; congr rcons; rewrite nseq_cat.
Qed.

Lemma set_nth_nseq (i j : nat) (x y z : T) :
  (i <= j)%N -> set_nth x (nseq j y) i z = (rcons (nseq i y) z) ++ (nseq (j - i).-1 y).
Proof.
move: i x y z; elim: j => [|j ih] i x y z; first by rewrite leqn0 => /eqP ->.
case: i => [_|i leq_ij] //=.
by rewrite ih.
Qed.

Lemma set_nth_rcons (i : nat) (e : seq T) (a x y : T) :
  (i < size e)%N -> set_nth a (rcons e y) i x = rcons (set_nth a e i x) y.
Proof.
move: i x y; elim: e => //.
move=> b e ih i; elim: i => //.
move=> i ih2 x y /=.
by rewrite ltnS => lt_ie ; rewrite ih.
Qed.

(* Fact fv_nquantify (m n i : nat) (f : formula F) :  *)
(* (m <= i < m+n)%N -> i \notin formula_fv (nquantify m n Exists f). *)
(* Proof. *)
(* rewrite formula_vf_nquantify. *)
(* by rewrite formula_vf_mnquantify -mnfsetE in_fsetD negb_and negbK => ->. *)
(* Qed. *)

Lemma set_nth_catr (i : nat) (e1 e2 : seq T) (x y : T) :
    (size e1 <= i)%N ->
    set_nth x (e1 ++ e2) i y = e1 ++ (set_nth x e2 (i - (size e1)) y).
Proof.
move: i e2 y; elim/last_ind: e1 => [i e2 y _ |e1 b ih i e2 y]; rewrite ?subn0 //.
rewrite size_rcons=> h; rewrite cat_rcons.
rewrite ih; last by rewrite ltnW.
by rewrite cat_rcons -[(i - size e1)%N]prednK ?subn_gt0 // subnS.
Qed.

Lemma set_nth_catl (i : nat) (e1 e2 : seq T) (x y : T) :
  (i < size e1)%N -> set_nth x (e1 ++ e2) i y = set_nth x e1 i y ++ e2.
Proof.
move: i e1 y; elim/last_ind : e2 => [i e1| e2 z ih i e1] y h; rewrite ?cats0 //.
rewrite -rcons_cat set_nth_rcons ?size_cat ?(leq_trans h) // ?leq_addr //.
by rewrite ih // rcons_cat //.
Qed.

Lemma set_nth_cat (i : nat) (e1 e2 : seq T) (x y : T) :
  set_nth x (e1 ++ e2) i y = if (i < size e1)%N then set_nth x e1 i y ++ e2
                             else e1 ++ (set_nth x e2 (i - (size e1)) y).
Proof.
have [leq_e1i|lt_ie1] := leqP (size e1) i; first by rewrite set_nth_catr.
by rewrite set_nth_catl.
Qed.

Lemma rcons_is_cat (e : seq T) (x : T) : rcons e x = e ++ [::x].
Proof. by rewrite -cat_rcons cats0. Qed.

Lemma take_rcons (i : nat) (e : seq T) (x : T) :
  take i (rcons e x) = if (i <= size e)%N then take i e
                       else rcons (take i e) x.
Proof.
have [leq_ie|lt_ei] := leqP i (size e); last first.
  by rewrite take_oversize ?size_rcons // take_oversize // ltnW.
rewrite rcons_is_cat take_cat.
rewrite leq_eqVlt in leq_ie.
move/orP : leq_ie => [/eqP eq_ie | ->] => //.
by rewrite eq_ie ltnn subnn take_size cats0.
Qed.

Lemma set_nth_takeC (i : nat) (e : seq T) (j : nat) (x y : T) :
  (j < i)%N -> set_nth y (take i e) j x = take i (set_nth y e j x).
Proof.
move=> lt_ji.
have [leq_ei|lt_ie] := leqP (size e) i.
by rewrite ?take_oversize // ;
        last by rewrite size_set_nth geq_max; apply/andP; split.
move: i j lt_ji lt_ie; elim: e => // a e ihe i.
elim: i => // i ihi j; elim: j => // j ihj.
rewrite ltnS => lt_ji.
by rewrite /= ltnS => lt_ie; rewrite ihe.
Qed.

Lemma set_nth_take (i : nat) (e : seq T) (j : nat) (x y : T) :(i <= j)%N ->
set_nth x (take i e) j y
                      = rcons ((take i (set_nth x e j y)) ++ (nseq (j - i) x)) y.
Proof.
move: i j; elim: e => // [i j leq_ij | a e ihe i].
- rewrite //= !set_nth_nil -cat_nseq take_cat size_nseq.
  rewrite leq_eqVlt in leq_ij.
  move/orP : leq_ij => [/eqP eq_ij|lt_ij].
    by rewrite -eq_ij ltnn subnn /= !cats0 -rcons_is_cat.
  rewrite lt_ij -rcons_is_cat -{2}[j](@subnKC i); last by rewrite ltnW.
  rewrite -addn_nseq take_size_cat ?size_nseq // addn_nseq.
  by rewrite subnKC; last by rewrite ltnW.
- elim: i => [j _| i ihi j].
    by rewrite subn0 !take0 /= set_nth_nil rcons_is_cat cat_nseq.
  elim: j => // j ihj.
  by rewrite ltnS => lt_iSj /=; rewrite ihe.
Qed.

End GeneralBaseType.

Section WithEqType.

Variables (T : eqType) (a1 a2 : pred T) (s : seq T).

Lemma sub_filter :
    subpred a1 a2 -> {subset [seq x <- s | a1 x] <= [seq x <- s | a2 x]}.
Proof.
move=> sub_a1_a2 x ; rewrite !mem_filter.
by move/andP => [a1x ->] ; rewrite andbT sub_a1_a2.
Qed.

Lemma sub_map_filter (U : eqType) (f : T -> U) :
subpred a1 a2 -> {subset [seq f x | x <- s & a1 x] <= [seq f x | x <- s & a2 x]}.
Proof.
move=> sub_a1_a2 x.
move/mapP => [y hy] eq_x_fy ; apply/mapP ; exists y => //.
exact: sub_filter.
Qed.

End WithEqType.

End MoreSeq.

Section MoreSeqEqType.

Variable (T : eqType).

Local Notation "x =p y"  := (perm_eq x y) (at level 70, no associativity).

Lemma perm_eq_nil (s : seq T) : (s =p [::]) = (s == [::]).
Proof.
apply/idP/idP ; last by move/eqP ->.
move => H ; apply/eqP.
by apply: perm_eq_small.
Qed.

Lemma rem_cons (s : seq T) (a : T) : rem a (a :: s) = s.
Proof. by rewrite /= eqxx. Qed.

Lemma rcons_nil (a : T) : rcons [::] a = [:: a].
Proof. by rewrite -cats1 cat0s. Qed.

Fact cat_nil (s1 s2 : seq T) : s1 ++ s2 == [::] = ((s1 == [::]) && (s2 == [::])).
Proof. by case: s1 => //= ->. Qed.

Lemma rem_is_nil (x : T) (s : seq T) : rem x s == [::] -> ((s == [::]) || (s == [:: x])).
Proof. by case: s => //= y s; rewrite eqseq_cons; case: (y == x). Qed.

Lemma undup_catl (s1 s2 : seq T) :
  undup ((undup s1) ++ s2) = undup (s1 ++ s2).
Proof.
elim: s1 => // x s /= ih.
have [x_in_s | /negbTE x_notin_s] := boolP (x \in s).
  by rewrite mem_cat x_in_s.
rewrite mem_cat x_notin_s /= !ih mem_cat.
have [x_in_s2 | /negbTE x_notin_s2] := boolP (x \in s2).
  by rewrite orbT.
by rewrite orbF mem_undup x_notin_s.
Qed.

Lemma in_rcons (s : seq T) (x y : T) :
  (x \in rcons s y) = (x == y) || (x \in s).
Proof. by elim: s => // z s ih; rewrite rcons_cons !in_cons ih orbCA. Qed.

(* not used *)
(* Lemma undup_rlast (s : seq T) (x : T) : *)
(*   undup (rcons s x) = rcons (rem x (undup s)) x. *)
(* Proof. *)
(* elim: s => // y s ih. *)
(* rewrite rcons_cons /= in_rcons ih. *)
(* have [ <- | neq_xy] := eqVneq x y. *)
(*   rewrite eqxx fun_if /= eqxx. *)
(*   have [x_in_s | x_notin_s] := boolP (x \in s) => //. *)
(*   by rewrite rem_id // mem_undup. *)
(* rewrite eq_sym. *)
(* move/negbTE : neq_xy => neq_xy ; rewrite neq_xy. *)
(* have [y_in_s | y_notin_s] := boolP (y \in s) => //. *)
(* by rewrite /= eq_sym neq_xy rcons_cons. *)
(* Qed. *)

Lemma undup_catr (s1 s2 : seq T) :
  undup (s1 ++ (undup s2)) = undup (s1 ++ s2).
Proof.
elim: s1 => // [| x s ih]; first by rewrite !cat0s //undup_id // undup_uniq.
by rewrite /= ih !mem_cat mem_undup.
Qed.

Lemma subset_cons (x : T) (s1 s2 : seq T) :
  {subset x :: s1 <= s2} <-> (x \in s2) /\ {subset s1 <= s2}.
Proof.
split => [subx12 | [x_in_s2 sub12] y].
  split; first by rewrite subx12 // mem_head.
  move=> y y_in_s1.
  by rewrite subx12 // in_cons y_in_s1 orbT.
rewrite in_cons => /orP [/eqP -> | y_in_s1] //.
by rewrite sub12.
Qed.

Lemma undup_cat (s1 s2 : seq T) :
  sub_mem (mem s1) (mem s2) -> undup (s1 ++ s2) = undup s2.
Proof.
elim: s1 => // x s1 ih /=.
move/subset_cons => [x_in_s2 sub12].
by rewrite ih // mem_cat x_in_s2 orbT.
Qed.

Example undup_cat_ss (s : seq T) : undup (s ++ s) = undup s.
Proof. exact: undup_cat. Qed.

(* Fact undup_uniq (x : R) (s : seq T) :  *)
(* undup (s ++ (x :: s2)) = if x \in s then . *)
(* x \in s => undup s = rem x s. *)

Fact undup_cat_1312 (s1 s2 s3 : seq T) :
  undup ((s1 ++ s3) ++ s2 ++ s3) = undup (s1 ++ s2 ++ s3).
Proof.
elim: s1 => // [|x s1 /= ->].
  rewrite !cat0s undup_cat // => x.
  by rewrite mem_cat => ->; rewrite orbT.
by rewrite !mem_cat orbACA orbb !orbA.
Qed.

Lemma rem_undup (x : T) (s : seq T) :
  rem x (undup s) = undup (filter (predC1 x) s).
Proof.
elim: s => // y s /=.
have [<- | neq_xy] := eqVneq x y.
  rewrite eqxx fun_if /= eqxx => <-.
  have [x_in_s | x_notin_s] := boolP (x \in s) => //.
  by rewrite rem_id // mem_undup.
rewrite eq_sym neq_xy /=.
have [y_in_s | /negbTE y_notin_s] := boolP (y \in s); rewrite mem_filter.
  by rewrite y_in_s andbT /= eq_sym neq_xy.
rewrite /= eq_sym ; move/negbTE : neq_xy => ->.
by rewrite y_notin_s andbF => ->.
Qed.

Local Open Scope ring_scope.

Lemma set_nth_id (e : seq T) (i : nat) (a x : T)
  : (i < size e)%N -> (set_nth x e i (nth a e i)) = e.
Proof.
move: e x; elim: i => [| i ih] e x; first by rewrite lt0n size_eq0; case: e.
by case: e => //= b e; rewrite ltnS => h; rewrite ih.
Qed.

Lemma set_nth_nth (e : seq T) (i : nat) (a : T) :
  set_nth a e i (nth a e i) = e ++ (nseq (i.+1 - (size e) ) a).
Proof.
have [lt_ie|leq_ei] := ltnP i (size e).
by rewrite set_nth_id //; move: lt_ie; rewrite -subn_eq0=> /eqP->; rewrite cats0.
by rewrite set_nth_over // rcons_cat subSn // nseqS nth_default //.
Qed.

End MoreSeqEqType.

Section MoreFinmap.

Open Local Scope fset_scope.

Lemma finSet_ind (T : choiceType) (P : {fset T} -> Prop) :
  P fset0 -> (forall s x, P s -> P (x |` s)) -> forall s, P s.
Proof.
move=> Hfset0 HfsetU s.
move: {2}(#|`s|) (erefl #|`s|) => r.
move: s; elim: r => [s| r ih s hs]; first by move/cardfs0_eq ->.
have s_neq0 : s != fset0 by rewrite -cardfs_gt0 hs.
move: s_neq0 hs => /fset0Pn [x x_in_s].
rewrite -(fsetD1K x_in_s) cardfsU1 in_fsetD1 x_in_s eqxx [in LHS]/= add1n.
move/eqP; rewrite eqSS; move/eqP => hs.
by apply: HfsetU; apply: ih.
Qed.

Lemma neq_fset10 (i : nat) : ([fset i] == fset0) = false.
Proof.
apply/negbTE; rewrite -fproper0 fproperEcard cardfs0 cardfs1 andbT.
by apply/fsubsetP => j; rewrite in_fset0.
Qed.

End MoreFinmap.

Section MoreRelation.

Variables (T : eqType) (P : pred T) (sT : subType P) (r : equiv_rel T).

Definition sub_r (x y : sT) := r (val x) (val y).

Lemma sub_r_refl : reflexive sub_r.
Proof. by rewrite /sub_r. Qed.

Lemma sub_r_sym : symmetric sub_r.
Proof. by move=> x y; rewrite /sub_r equiv_sym. Qed.

Lemma sub_r_trans : transitive sub_r.
Proof. by move=> x y z hyx; apply: equiv_trans. Qed.

Fail Check [equiv_rel of sub_r].

Canonical sub_r_equiv := EquivRel sub_r sub_r_refl sub_r_sym sub_r_trans.

Check [equiv_rel of sub_r].

End MoreRelation.

Section TestMoreRelation.

Variables (T : eqType) (P : pred T) (sT : subType P) (r : equiv_rel T).
Definition r2 := @sub_r _ _ sT r.
Check [equiv_rel of r].
Check [equiv_rel of r2].

End TestMoreRelation.

Section MoreBigop.

Lemma big_morph_in (R1 R2 : Type)
  (f : R2 -> R1) (id1 : R1) (op1 : R1 -> R1 -> R1)
  (id2 : R2) (op2 : R2 -> R2 -> R2) (D : pred R2) :
  (forall x y, x \in D -> y \in D -> op2 x y \in D) ->
  id2 \in D ->
  {in D &, {morph f : x y / op2 x y >-> op1 x y}} ->
  f id2 = id1 ->
  forall  (I : Type) (r : seq I) (P : pred I) (F : I -> R2),
  all D [seq F x | x <- r & P x] ->
  f (\big[op2/id2]_(i <- r | P i) F i) = \big[op1/id1]_(i <- r | P i) f (F i).
Proof.
move=> Dop2 Did2 f_morph f_id I r P F.
elim: r => [|x r ihr /= DrP]; rewrite ?(big_nil, big_cons) //.
set b2 := \big[_/_]_(_ <- _ | _) _; set b1 := \big[_/_]_(_ <- _ | _) _.
have fb2 : f b2 = b1 by rewrite ihr; move: (P x) DrP => [/andP[]|].
case: (boolP (P x)) DrP => //= Px /andP[Dx allD].
rewrite f_morph ?fb2 // /b2 {b2 fb2 ihr b1 x Px Dx f_morph f_id}.
elim: r allD => [|x r ihr /=]; rewrite ?(big_nil, big_cons) //.
by case: (P x) => //= /andP [??]; rewrite Dop2 // ihr.
Qed.

Variables (R : Type) (idx : R).

Fact big_ord_exchange_cond {op : Monoid.law idx} {a b : nat}
   (P : pred nat) (F : nat -> R) :
  \big[op/idx]_(i < a | P i && (i < b)) F i =
  \big[op/idx]_(i < b | P i && (i < a)) F i.
Proof.
wlog le_b_a : a b / b <= a => [hwlog|].
  have /orP [le_a_b|le_b_a] := leq_total a b; last exact: hwlog.
  by symmetry; apply: hwlog.
rewrite big_ord_narrow_cond /=; apply: eq_big => // i.
by rewrite (leq_trans _ le_b_a) ?andbT.
Qed.

Fact big_ord_exchange {op : Monoid.law idx} {a b : nat} (F : nat -> R) :
  \big[op/idx]_(i < a | i < b) F i =
  \big[op/idx]_(i < b | i < a) F i.
Proof. exact: (big_ord_exchange_cond xpredT). Qed.

Fact big_ord1 (op : Monoid.law idx) (F : nat -> R) :
  \big[op/idx]_(i < 1) F i = F 0.
Proof. by rewrite big_ord_recl big_ord0 Monoid.mulm1. Qed.

Lemma big_nat_widen_l (op : Monoid.law idx)
     (m1 m2 n : nat) (P : pred nat) (F : nat -> R) :
   m2 <= m1 ->
   \big[op/idx]_(m1 <= i < n | P i) F i =
   \big[op/idx]_(m2 <= i < n | P i && (m1 <= i)) F i.
Proof.
move=> le_m2m1; have [ltn_m1n|geq_m1n] := ltnP m1 n; last first.
  rewrite big_geq // big_nat_cond big_pred0 // => i.
  by apply/negP => /and3P[/andP [_ /leq_trans]]; rewrite leqNgt => ->.
rewrite [RHS](@big_cat_nat _ _ _ m1) // 1?ltnW //.
rewrite [X in op X]big_nat_cond [X in op X]big_pred0; last first.
  by move=> i; have [] := ltnP i m1; rewrite ?(andbT, andbF).
rewrite Monoid.mul1m [LHS]big_nat_cond [RHS]big_nat_cond.
by apply/eq_bigl => i; have [] := ltnP i m1; rewrite ?(andbT, andbF).
Qed.

Lemma big_mknat  (op : Monoid.law idx)  (a b : nat) (F : nat -> R) :
  \big[op/idx]_(i < b | a <= i) F i = \big[op/idx]_(a <= i < b) F i.
Proof.
rewrite -(big_mkord (fun i => a <= i) F).
by rewrite -(big_nat_widen_l _ _ predT) ?leq0n.
Qed.

End MoreBigop.

Section MoreCoef.

Open Scope ring_scope.

Lemma coefMD_wid (R : ringType) (p q : {poly R}) (m n i : nat) :
  i < m -> i < n ->
  (p * q)`_i = \sum_(j1 < m) \sum_(j2 < n | (j1 + j2)%N == i) p`_j1 * q`_j2.
Proof.
move=> m_big n_big; rewrite pair_big_dep.
pose tom := widen_ord m_big; pose ton := widen_ord n_big.
rewrite (reindex (fun j : 'I_i.+1 => (tom j, ton (rev_ord j)))) /=.
  rewrite coefM; apply: eq_big => //= j.
  by rewrite -maxnE (maxn_idPr _) ?eqxx ?leq_ord.
exists (fun k : 'I__ * 'I__ => insubd ord0 k.1) => /=.
  by move=> j _; apply/val_inj; rewrite val_insubd ltn_ord.
move=> [k1 k2] /=; rewrite inE /= {}/ton eq_sym => /eqP i_def.
apply/eqP; rewrite xpair_eqE -!val_eqE /= ?val_insubd i_def !ltnS.
by rewrite leq_addr eqxx /= subSS addKn.
Qed.

Lemma coefMD (R : ringType) (p q : {poly R}) (i : nat) :
 (p * q)`_i = \sum_(j1 < size p)
              \sum_(j2 < size q | (j1 + j2)%N == i) p`_j1 * q`_j2.
Proof.
rewrite (@coefMD_wid _ _ _ i.+1 i.+1) //=.
rewrite (bigID (fun j1 :'I__ => j1 < size p)) /=.
rewrite [X in _ + X]big1 ?addr0; last first.
  move=> j1; rewrite -ltnNge => j1_big.
  by rewrite big1 // => j2 _; rewrite nth_default ?mul0r.
rewrite (big_ord_exchange
 (fun j1 => \sum_(j2 < i.+1 | (j1 + j2)%N == i) p`_j1 * q`_j2)) /=.
rewrite big_mkcond /=; apply: eq_bigr => j1 _; rewrite ltnS.
have [j1_small|j1_big] := leqP; last first.
  rewrite big1 // => j2; rewrite eq_sym => /eqP i_def.
  by rewrite i_def -ltn_subRL subnn ltn0 in j1_big.
rewrite (bigID (fun j2 :'I__ => j2 < size q)) /=.
rewrite [X in _ + X]big1 ?addr0; last first.
  move=> j2; rewrite -ltnNge => /andP[_ j2_big].
  by rewrite [q`__]nth_default ?mulr0.
rewrite (big_ord_exchange_cond
 (fun j2 => (j1 + j2)%N == i) (fun j2 => p`_j1 * q`_j2)) /=.
rewrite big_mkcondr /=; apply: eq_bigr => k; rewrite ltnS.
have [//|j2_big] := leqP; rewrite eq_sym=> /eqP i_def.
by rewrite i_def addnC -ltn_subRL subnn ltn0 in j2_big.
Qed.

End MoreCoef.

Local Open Scope ring_scope.

Section MoreComUnitRingTheory.
Variable (R : comUnitRingType).

Lemma eq_divr (a b c d : R) : b \is a GRing.unit -> d \is a GRing.unit ->
  (a / b == c / d) = (a * d == c * b).
Proof.
move=> b_unit d_unit; pose canM := (can2_eq (mulrVK _) (mulrK _)).
by rewrite canM // mulrAC -canM ?unitrV ?invrK.
Qed.

Lemma mulr_div (x1 y1 x2 y2 : R) :
  (y1 \is a GRing.unit) ->
  (y2 \is a GRing.unit) -> x1 / y1 * (x2 / y2) = x1 * x2 / (y1 * y2).
Proof. by move=> y1_unit y2_unit; rewrite mulrACA -invrM ?[y2 * _]mulrC. Qed.

Lemma addr_div (x1 y1 x2 y2 : R) :
  y1 \is a GRing.unit -> y2 \is a GRing.unit ->
  x1 / y1 + x2 / y2 = (x1 * y2 + x2 * y1) / (y1 * y2).
Proof.
move => y1_unit y2_unit.
by rewrite mulrDl [X in (_ * y1) / X]mulrC -!mulr_div ?divrr // !mulr1.
Qed.

End MoreComUnitRingTheory.

Section MoreFieldTheory.

Variable (K : fieldType).

Lemma eq_divf (a b c d : K) : b != 0 -> d != 0 ->
  (a / b == c / d) = (a * d == c * b).
Proof. by move=> b_neq0 d_neq0; rewrite eq_divr ?unitfE. Qed.

Lemma eq_divfC (a b c d : K) : a != 0 -> c != 0 ->
  (a / b == c / d) = (a * d == c * b).
Proof.
move=> ??; rewrite -invf_div -[c / d]invf_div (inj_eq (can_inj (@invrK _))).
by rewrite eq_divf // eq_sym [a * d]mulrC [b * c]mulrC.
Qed.

Lemma eq_divf_mul (a b c d : K) : a / b != 0 -> a / b = c / d -> a * d = c * b.
Proof.
have [->| d_neq0 ab0 /eqP] := eqVneq d 0.
  by rewrite !invr0 !mulr0 => /negPf ab0 /eqP; rewrite ab0.
rewrite eq_divf //; first by move/eqP.
by apply: contraNneq ab0 => ->; rewrite invr0 mulr0.
Qed.

End MoreFieldTheory.

Local Notation "p ^ f" := (map_poly f p).

Section AuxiliaryResults.

Variable (R : ringType).
Implicit Types (p : {poly R}).

Lemma map_poly_mul (c : R) p : p ^ ( *%R c) = c *: p.
Proof. by apply/polyP => i; rewrite coefZ coef_map_id0 ?mulr0. Qed.

Lemma lead_coefMXn p (n : nat) : lead_coef (p * 'X^n) = lead_coef p.
Proof. by rewrite lead_coef_Mmonic ?monicXn //. Qed.

Lemma size_polyMXn p (n : nat) : p != 0 -> size (p * 'X^n) = (size p + n)%N.
Proof. by move=> ?; rewrite size_Mmonic ?monicXn // size_polyXn addnS. Qed.

Lemma widen_poly (E : nat -> R) (a b : nat) : a <= b ->
  (forall j, a <= j < b -> E j = 0) ->
  \poly_(i < a) E i = \poly_(i < b) E i.
Proof.
move=> leq_a_b E_eq0; apply/polyP => k; rewrite !coef_poly.
have [lt_ka|le_ak] := ltnP k a; first by rewrite (leq_trans lt_ka).
by have [lt_kb|//] := ifPn; rewrite E_eq0 // le_ak lt_kb.
Qed.

Lemma deriv_sum (T : Type) (s : seq T) (F : T -> {poly R}) (P : pred T):
  deriv (\sum_(i <- s | P i) F i) = \sum_(i <- s | P i) deriv (F i).
Proof. by apply: big_morph; [exact: derivD|exact: deriv0]. Qed.

Lemma poly_rcons (s : seq R) : Poly (rcons s 0) = Poly s.
Proof.
elim: s => [|a l ihs].
+ rewrite rcons_nil; apply/val_inj => /=.
  by rewrite polyseq_cons nil_poly polyC0 eqxx.
+ rewrite rcons_cons; apply/val_inj => /=.
  by rewrite ihs.
Qed.

Lemma poly_cat_nseq (s : seq R) (n : nat) : Poly (s ++ (nseq n 0)) = Poly s.
Proof.
elim: n => [|n ihn] ; first by rewrite cats0.
by rewrite nseqS -rcons_cat poly_rcons ihn.
Qed.

Lemma coef0M (p q : {poly R}) : (p * q)`_0 = p`_0 * q`_0.
Proof. by rewrite coefM big_ord_recl big_ord0 addr0. Qed.

Variable (K : fieldType).

(* p : {poly K} can be generalize ? *)
Fact modp_sumn (I : Type) (r : seq I) (P : pred I)
               (F : I -> {poly K}) (p : {poly K}) :
               (\sum_(i <- r | P i) F i) %% p = \sum_(i <- r | P i) (F i %% p).
Proof. by rewrite (big_morph ((@modp _)^~ p) (modp_add _) (mod0p _) _). Qed.

Fact modp_mul2 (p q m : {poly K}): ((p %% m) * q) %% m = (p * q) %% m.
Proof. by rewrite mulrC modp_mul mulrC. Qed.

End AuxiliaryResults.

Module InjMorphism.

Section ClassDef.

Variables (R S : ringType).

Record class_of (f : R -> S) : Type :=
  Class {base : rmorphism f; mixin : injective f}.
Local Coercion base : class_of >-> rmorphism.

Structure map (phRS : phant (R -> S)) := Pack {apply; _ : class_of apply}.
Local Coercion apply : map >-> Funclass.

Variables (phRS : phant (R -> S)) (f g : R -> S) (cF : map phRS).

Definition class := let: Pack _ c as cF' := cF return class_of cF' in c.

Definition clone fM of phant_id g (apply cF) & phant_id fM class :=
  @Pack phRS f fM.

Definition pack (fM : injective f) :=
  fun (bF : GRing.RMorphism.map phRS) fA & phant_id (GRing.RMorphism.class bF) fA =>
  Pack phRS (Class fA fM).

Canonical additive := GRing.Additive.Pack phRS class.
Canonical rmorphism := GRing.RMorphism.Pack phRS class.

End ClassDef.

Module Exports.
Notation injmorphism f := (class_of f).
Coercion base : injmorphism >-> GRing.RMorphism.class_of.
Coercion mixin : injmorphism >-> injective.
Coercion apply : map >-> Funclass.
Notation InjMorphism fM := (pack fM id).
Notation "{ 'injmorphism' fRS }" := (map (Phant fRS))
  (at level 0, format "{ 'injmorphism'  fRS }") : ring_scope.
Notation "[ 'injmorphism' 'of' f 'as' g ]" := (@clone _ _ _ f g _ _ idfun id)
  (at level 0, format "[ 'injmorphism'  'of'  f  'as'  g ]") : form_scope.
Notation "[ 'injmorphism' 'of' f ]" := (@clone _ _ _ f f _ _ id id)
  (at level 0, format "[ 'injmorphism'  'of'  f ]") : form_scope.
Coercion additive : map >-> GRing.Additive.map.
Canonical additive.
Coercion rmorphism : map >-> GRing.RMorphism.map.
Canonical rmorphism.
End Exports.

End InjMorphism.
Include InjMorphism.Exports.

Section InjectiveTheory.

Lemma raddf_inj (R S : zmodType) (f : {additive R -> S}) :
   (forall x, f x = 0 -> x = 0) -> injective f.
Proof.
move=> f_inj x y /eqP; rewrite -subr_eq0 -raddfB => /eqP /f_inj /eqP.
by rewrite subr_eq0 => /eqP.
Qed.

Variable (R S : ringType) (f : {injmorphism R -> S}).

Lemma rmorph_inj : injective f. Proof. by case: f => [? []]. Qed.

Lemma rmorph_eq (x y : R) : (f x == f y) = (x == y).
Proof. by rewrite (inj_eq (rmorph_inj)). Qed.

Lemma rmorph_eq0 (x : R) : (f x == 0) = (x == 0).
Proof. by rewrite -(rmorph0 f) (inj_eq (rmorph_inj)). Qed.

Definition map_poly_injective : injective (map_poly f).
Proof.
move=> p q /polyP eq_pq; apply/polyP=> i; have := eq_pq i.
by rewrite !coef_map => /rmorph_inj.
Qed.

Canonical map_poly_is_injective := InjMorphism map_poly_injective.

End InjectiveTheory.
Hint Resolve rmorph_inj.

Canonical polyC_is_injective (R : ringType) := InjMorphism (@polyC_inj R).

Canonical comp_is_injmorphism (R S T : ringType)
  (f : {injmorphism R -> S}) (g : {injmorphism S -> T}) :=
  InjMorphism (inj_comp (@rmorph_inj _ _ g) (@rmorph_inj _ _ f)).

(* Hack to go around a bug in canonical structure resolution *)
Definition fmorph (F R : Type) (f : F -> R) := f.
Canonical fmorph_is_injmorphism (F : fieldType) (R : ringType)
  (f : {rmorphism F -> R}) :=
  InjMorphism (fmorph_inj f : injective (fmorph f)).


Require Import ExtLib.Tactics.
Require Import ExtLib.Data.POption.
Require Import MirrorCore.Views.Ptrns.
Require Import MirrorCore.Views.View.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.SymI.
Require Import MirrorCore.syms.SymProd.

Set Implicit Arguments.
Set Strict Implicit.
Set Maximal Implicit Insertion.
Set Universe Polymorphism.

Section FuncView.
  Variables func A : Set.
  Variable FV : PartialView func A.
  Variable typ : Set.
  Variable RType_typ : RType typ.
  Variable Sym_func : RSym func.
  Variable Sym_A : RSym A.

(*  Definition FuncView := PartialView func A. *)

  Definition func_equiv (f : func) (a : A) : Prop :=
    forall t, symAs a t = symAs f t.

  Definition FuncViewOk : Type :=
    PartialViewOk FV func_equiv.

  Variable FVO : FuncViewOk.

  Theorem fv_ok : forall f a, f_view f = pSome a <-> f_insert a = f.
  Proof. exact (@pv_ok _ _ _ _ FVO). Qed.

  Theorem fv_compat : forall (a : A) t,
      symAs a t = symAs (f_insert a) t.
  Proof. exact (@pv_compat _ _ _ _ FVO). Qed.

  Lemma fv_okL f a (H : f_view f = pSome a) :
    f_insert a = f.
  Proof using FVO.
    apply fv_ok; assumption.
  Qed.

  Variable RTypeOk_typ : RTypeOk.

  Theorem fv_compat_typ
  : forall a, typeof_sym (f_insert a) = typeof_sym a.
  Proof using RTypeOk_typ FVO.
    intros.
    generalize (fv_compat a).
    unfold symAs. intros.
    generalize dependent (symD a).
    generalize dependent (symD (f_insert a)).
    destruct (typeof_sym a).
    { destruct (typeof_sym (f_insert a)).
      { intros.
        specialize (H t).
        rewrite type_cast_refl in H; eauto.
        destruct (type_cast t t0); try solve [ inversion H ].
        inversion H. subst.
        f_equal. symmetry. assumption. }
      { intros.
        specialize (H t).
        rewrite type_cast_refl in H; eauto.
        inversion H. } }
    { intros.
      destruct (typeof_sym (f_insert a)); auto.
      specialize (H t).
      rewrite type_cast_refl in H. inversion H.
      eauto. }
  Defined.

  Theorem fv_compat_val
  : forall (a : A),
        symD a = match fv_compat_typ a in _ = T
                       return match T with
                              | Some t => typD t
                              | None => unit:Type
                              end
                 with
                 | eq_refl => symD (f_insert a)
                 end.
  Proof using FVO.
    intros.
    assert (typeof_sym a = None \/ exists t, typeof_sym a = Some t).
    { clear. destruct (typeof_sym a); eauto. }
    destruct H.
    { generalize (symD a).
      generalize (symD (f_insert a)).
      generalize (fv_compat_typ a).
      rewrite H.
      intro. rewrite e.
      clear. destruct y; destruct y; reflexivity. }
    { destruct H.
      generalize (fv_compat a x).
      unfold symAs.
      generalize dependent (symD a).
      generalize dependent (symD (f_insert a)).
      generalize (fv_compat_typ a).
      destruct e.
      rewrite H.
      setoid_rewrite type_cast_refl; eauto.
      intros.
      inv_all. assumption. }
  Qed.

  Lemma fv_typeof_sym f p t v
    (Hview : f_view f = pSome p) (Hfunc : symAs f t = Some v) :
    typeof_sym p = Some t.
  Proof using FVO.
    destruct (fv_ok f p) as [H _].
    specialize (H Hview); subst.
    rewrite <- fv_compat in Hfunc.
    unfold symAs in Hfunc.
    generalize dependent (symD p).
    destruct (typeof_sym p); intros; [|congruence].
    forward.
  Defined.

  Global Instance Injective_exprD'_f_insert (a : A) (t : typ) (v : typD t)
  : Injective (symAs (f_insert a) t = Some v) :=
  { result := symAs a t = Some v
  ; injection := fun H => _
  }.
  Proof.
    rewrite fv_compat; assumption.
  Defined.

  Lemma symAs_finsertI (t : typ) (f : A)
        (P : option (typD t) -> Prop)
        (H : P (symAs f t)) :
    P (symAs (f_insert f) t).
  Proof.
    rewrite <- fv_compat; assumption.
  Qed.

End FuncView.

Theorem FuncViewOk_id {T typ} (RT : RType typ) (RS : RSym T)
: @FuncViewOk T T (@PartialView_id T) typ _ _ _.
Proof.
  constructor.
  { split. inversion 1. reflexivity.
    intros; subst; reflexivity. }
  { simpl. unfold func_equiv. reflexivity. }
Defined.

(*
Global Instance PartialView_FuncView {A B} : FuncView A B -> PartialView A B :=
  fun x => x.
*)

Existing Class FuncViewOk.
Export MirrorCore.Views.View.

Hint Extern 0 (PartialViewOk ?X _) =>
  match goal with
  | H : FuncViewOk _ _ _ |- _ => eexact H
  end : typeclass_instances.


(* Adequacy of Operational Semantics vs. Sampling Semantics *)

(* We don't bother with soundness, which is (or should be) dull *)

Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Program.
Require Import EqNat.

Require Import LiftedTypes.
Require Import MyReals.

Require Import Types.
Require Import Syntax.
Require Import SamplingSemantics.
Require Import Substitutions.
Require Import OperationalSemantics.

(* false_invert: a tactic from SF *)
(* false_invert proves any goal provided there is at least one *)
(* hypothesis H in the context that can be proved absurd by calling *)
(* inversion H. *)

Ltac false_invert :=
  intros;
  match goal with
    [ H:_ |- _ ] => solve [ inversion H ]
  end.

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

(* The Logical Relation *)

(* The relation will be defined compositionally in Otype. *)

(* First we build some combinators for the different cases. *)

Definition EqReal : (den_Mtype Real_type) ->
                    (den_Mtype Real_type) -> Prop :=
  fun v1 v2 => (v1 = v2).

(* Combinators for Mtypes:  *)

Function Real_Rel
         (d : (den_Mtype Real_type))
         (val : (Val nil (Stype Real_type)))
  :=
    exists n, val = constexp n /\ d = n.

Function Prod_Rel {ma mb : Mtype}
         (RA : (den_Mtype ma) -> (Val nil (Stype ma)) -> Prop)
         (RB : (den_Mtype mb) -> (Val nil (Stype mb)) -> Prop)
         (d  : (den_Mtype (Prod_type ma mb)))
         (val : (Val nil (Stype (Prod_type ma mb))))
  :=
    exists e1 e2, val = prodval e1 e2 /\
                  (RA (fst d) e1) /\ (RB (snd d) e2).

Fixpoint Mtype_Rel (m : Mtype)
  : (den_typeS (Stype m)) -> (Val nil (Stype m)) -> Prop :=
  match m with
  | Empty_type => fun v1 v2 => True
  | Real_type => Real_Rel
  | Prod_type m1 m2 => Prod_Rel (Mtype_Rel m1) (Mtype_Rel m2)
  end.

(* General recipe for lifting a relation *)
(* (liftRel o R d e) iff d is bottom or d = lift(a) and e evaluates to *)
(* a value v such (Rel a v) holds*)

Function lift_Rel {o : Otype} (R : (den_typeS o) -> (Val nil o) -> Prop)
: (lifted (den_typeS o)) -> (Exp nil o) -> Prop :=
  fun d e =>
    match d with
      | bottom => True
      | lift a => exists v, ev e v /\ R a v
    end.

Definition Fun_Rel {o1 o2}
           (Rel1 : (den_typeS o1) -> (Val [] o1) -> Prop)
           (Rel2 : (lifted (den_typeS o2)) -> (Exp [] o2) -> Prop)
           (f1 : (den_typeS o1) -> (lifted (den_typeS o2)))
           (val1 : Val nil (Funtype o1 o2))
: Prop :=
  exists e, val1 = absexp e /\
  forall (a1 : den_typeS o1) (val2: Val [] o1),
    (Rel1 a1 val2) ->
    (Rel2 (f1 a1) (ap_Se (subst1 val2) e)).

Definition Meas_Rel
           (m : Mtype)
           (s : den_typeS (Meastype m))
           (c : Val nil (Meastype m)) : Prop :=
  forall (u:Unit),
    match (s u) with
      | bottom => True
      | lift (a,w) => exists c', evs u c c' w /\ Mtype_Rel m a c'
    end.

(* Now the main relation simply branches depending on its Otype argument: *)

Fixpoint Rel {o : Otype} : (den_typeS o) -> (Val nil o) -> Prop :=
  match o with
  | Stype m => Mtype_Rel m
  | Funtype o1 o2 => Fun_Rel (@Rel o1)  (lift_Rel (@Rel o2))
  | Meastype m => Meas_Rel m
  end.

(* Extend the relation to environments based on a type environment G *)

Fixpoint Rel_Env {G} : (den_env G) -> (Subst G nil) -> Prop :=
  match G with
    | nil => fun r s => True
    | (o :: G') => fun (r : den_env (o::G')) s =>
                     Rel (fst r) (hd_subst s)
                     /\ Rel_Env (snd r) (tl_subst s)
  end.

Lemma lookup_preserves_Rel : forall G (o : Otype)
                       (var : Var G o)
                       (r : den_env G)
                       (s : Subst G nil),
    Rel_Env r s -> Rel (apply_env r var) (s _ var).
Proof.
  intros.
  induction G as [| o' G'].
  (* G = [] *)
  inversion var.
  (* G = o' :: G' *)
  induction var as [| G''].
  (* var = var_0 *)
  simpl.
  inversion H.
  apply H0.
  (* var = var_S v' *)
  apply (IHvar (snd r) (tl_subst s)).
  apply H.
  intros.
  apply IHG'.
  apply H0.
Qed.

Hint Resolve lookup_preserves_Rel.

Lemma extend_env_preserves_Rel :
  forall (o: Otype) G r (s : Subst G nil) (d : den_typeS o) (val: Val nil o),
    Rel_Env r s -> Rel d val
    -> Rel_Env (cons_env d r) (cons_subst val s).
Proof.
  intros.
  simpl.
  split.
  apply H0.
  apply H.
Qed.

Lemma bind_preserves_Rel :
  forall m m'
         (s1 : den_typeS (Meastype m))
         (f : (den_typeS (Stype m))
              -> lifted (den_typeS (Meastype m')))
         c1 c2,
    Meas_Rel m s1 c1 ->
    Fun_Rel (Rel ) (lift_Rel (Meas_Rel m')) f c2 ->
    Meas_Rel m' (bindopS s1 f) (bindval c1 c2).
Proof.
  intros.
  unfold Meas_Rel.
  intros.
  destruct (bindopS s1 f u) as [|b]  eqn: f_u; try false_invert; auto.
  unfold bindopS in f_u.
  destruct (s1 (left_half u)) eqn: s1_uL; try false_invert; simpl in *; auto.

  destruct b.
  unfold prod_curry in f_u.
  destruct p.
  destruct (f d0) as [| s2] eqn: f_d; try false_invert; auto.
  simpl in f_u.
  destruct (s2 (right_half u)) as [| b'] eqn: s2_uR; try false_invert; simpl in *; auto.
  unfold prod_curry in f_u.
  destruct b'.
  inversion f_u; clear f_u.
  (* rewrite H2 in *. *)
  subst.

  (* now we have all the denotations, next let's work on the
     reductions *)

  (* First reduction: evs (left_half u) c1 c3 *)
  unfold Meas_Rel in H.
  specialize (H (left_half u)).
  rewrite s1_uL in H; simpl in H.
  inversion H as [c3]; clear H.
  inversion H1 as [Red1a Red1b]; clear H1.

  (* second reduction: ev (appexp (valexp c2) (valexp c3)) c4 *)
  (* c2: is a function, so it has to be an abstraction *)

  unfold Fun_Rel in H0.
  inversion H0 as [e]; clear H0.
  inversion H; clear H.
  specialize (H1 _ _ Red1b).
  unfold lift_Rel in H1.
  rewrite f_d in *; simpl in *.
  inversion H1 as [c4]; clear H1.
  inversion H; clear H.

  assert (Red2: ev (appexp (valexp c2) (valexp c3)) c4).
  assert (Red2a: ev (valexp c2) c2) by apply ev_val.
  assert (Red2b: ev (valexp c3) c3) by apply ev_val.
  rewrite H0 in *.
  apply (ev_app Red2a Red2b H1).

  (* now for the last step *)
  unfold Meas_Rel in H2.
  specialize (H2 (right_half u)).
  rewrite s2_uR in *.
  inversion H2 as [c5]; clear H2.
  inversion H as [Red3a Red3b]; clear H.
  exists c5.
  split.
  apply (evs_bind Red1a Red2 Red3a).
  apply Red3b.
Qed.

Hint Resolve bind_preserves_Rel.

Lemma bind_preserves_Rel' :
  forall m m'
         (s1 : den_typeS (Meastype m))
         (f : (den_typeS (Stype m))
              -> lifted (den_typeS (Meastype m')))
         c1 c2,
    Meas_Rel m s1 c1 ->
    Fun_Rel (Rel ) (lift_Rel (Meas_Rel m')) f c2 ->
    Meas_Rel m' (bindopS s1 f) (bindval c1 c2).
Proof.
  intros.
  unfold Meas_Rel.
  intros.
  destruct (bindopS s1 f u) as [|b]  eqn: f_u; try false_invert; auto.
  unfold bindopS in f_u.
  destruct (s1 (left_half u)) eqn: s1_uL; try false_invert; simpl in *; auto.

  destruct b.
  unfold prod_curry in f_u.
  destruct p.
  destruct (f d0) as [| s2] eqn: f_d; try false_invert; auto.
  simpl in f_u.
  destruct (s2 (right_half u)) as [| b'] eqn: s2_uR; try false_invert; simpl in *; auto.
  unfold prod_curry in f_u.
  destruct b'.
  inversion f_u; clear f_u.
  subst.

  (* now we have all the denotations, next let's work on the
     reductions *)

  (* First reduction: evs (left_half u) c1 c3 *)
  unfold Meas_Rel in H.
  specialize (H (left_half u)).
  rewrite s1_uL in H; simpl in H.
  inversion H; clear H.
  inversion H1 as [Red1a Red1b]; clear H1.

  (* second reduction: ev (appexp (valexp c2) (valexp c3)) c4 *)
  (* c2: is a function, so it has to be an abstraction *)

  unfold Fun_Rel in H0.
  inversion H0 as [e]; clear H0.
  inversion H; clear H.

  specialize (H1 _ _ Red1b).
  unfold lift_Rel in H1.
  rewrite f_d in *; simpl in *.
  inversion H1; clear H1.
  inversion H; clear H.

  (* finish unfolding *)
  unfold Meas_Rel in H2.
  specialize (H2 (right_half u)).
  rewrite s2_uR in *.
  inversion H2; clear H2.
  inversion H.

  (* Now patch the pieces together.  Coq is actually good at this! *)

  subst.
  eauto using evs_bind, ev_app, ev_val.

  (* split. *)
  (* eapply evs_bind. *)
  (* eassumption. *)

  (* eapply ev_app. *)
  (* subst. *)
  (* apply ev_val. *)
  (* apply ev_val. *)
  (* eassumption. *)
  (* eassumption. *)
  (* assumption. *)
Qed.

Lemma return_preserves_Rel :
  forall m (v : den_typeS (Stype m)) (c : Val nil (Stype m)),
         Rel v c ->
         Meas_Rel m (returnopS v) (returnval c).
Proof.
  intros.
  unfold returnopS.
  unfold Meas_Rel.
  intros.
  exists c.
  split.
  apply evs_return.
  apply H.
Qed.

Hint Resolve return_preserves_Rel.

Lemma unif_preserves_Rel :
  Meas_Rel _ uniformopS uniformval.
Proof.
  unfold Meas_Rel.
  intros.
  unfold uniformopS.
  exists (constexp (unit_real u)).
  split.
  apply evs_unif.
  unfold Mtype_Rel.
  unfold Real_Rel.
  eauto.
Qed.

Hint Resolve unif_preserves_Rel.

Lemma dist_preserves_Rel :
  forall r,
    Meas_Rel _ (distvalS r) (distval (constexp r)).
Proof.
  intros.
  unfold Meas_Rel.
  intros.
  simpl.
  eexists.
  split.
  apply evs_dist.
  unfold Real_Rel.
  eauto.
Qed.

(* This should really be of the form
  forall d v, Rel d v -> Meas_Rel _ (distvalS d) (distval v)

 *)

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

(* The Fundamental Theorem *)

Definition Fun_Thm_Exp G o  (exp: Exp G o) :=
  forall
         (r : den_env G)
         (s : Subst G nil),
    Rel_Env r s
    -> lift_Rel (@Rel o) (den_expS exp r) (ap_Se s exp).

Definition Fun_Thm_Val G o   (val: Val G o):=
  forall

         (r : den_env G)
         (s : Subst G nil),
    Rel_Env r s
    -> @Rel o (den_valS val r) (ap_Sv s val).

(* Tactics for proving the fundamental theorem *)

(* Ltac helpers *)
Ltac invert_ex :=
  repeat
    match goal with
    | [ H : exists _, _ |- _ ] => inversion H; clear H; intuition
    end.

Ltac solve_ex := invert_ex; try (eexists; intuition).

Ltac auto_specialize :=
  repeat
    match goal with
    | [ H : forall x : ?a, _, v : ?a |- _ ] => specialize H with (x:=v)
    | [ H : ?a -> _, v : ?a |- _ ] =>
      let Hv := fresh H in
      apply H in v as Hv; clear H
    end.

Ltac destruct_lift :=
  match goal with
  | [ H : lift_Rel _ ?x _ |- _ ] =>
    match x with
    | bottom => fail 1
    | lift _ => fail 1
    | _ => destruct x
    end
  end.

Theorem Fund_Thm: forall G o exp, @Fun_Thm_Exp G o exp.
Proof.
  apply (exp_val_rec Fun_Thm_Exp Fun_Thm_Val);
  unfold Fun_Thm_Exp;
  unfold Fun_Thm_Val;
  simpl; intros;
  try solve [auto_specialize; eauto;
                  repeat destruct_lift;
                  unfold Prod_Rel, lift_Rel in *;
                  solve_ex; subst; eauto].

  { (* appexp e e0 *)
    auto_specialize.
    repeat destruct_lift; eauto.
    simpl in *.
    invert_ex.
    destruct (d0 d) eqn: d0_d; unfold lift_Rel; auto.
    unfold Fun_Rel in *.
    invert_ex.
    subst.
    auto_specialize.
    rewrite d0_d in *.
    simpl in H4.
    invert_ex.
    eauto.
    }

  (* Now on to values: *)

  { (* varexp *)
    apply lookup_preserves_Rel.
    assumption.
  }

  { (* absexp *)
    unfold Fun_Rel.
    solve_ex.
    replace (ap_Se (subst1 val2) (ap_Se (shift_subst s) e))
    with (ap_Se (cons_subst val2 s) e)
      by (rewrite <- cSS_subst1, <- ap_cSS_e; auto).
    auto.
    }

  { (* distval *)
    auto_specialize.
    unfold Real_Rel in H1.
    invert_ex.
    subst.
    rewrite H1.
    apply dist_preserves_Rel.
    }

  { (* obsval *)
    auto_specialize.
    unfold Real_Rel in *.
    invert_ex.
    unfold Meas_Rel.
    intros.
    simpl.
    exists unitval.
    subst.
    rewrite H0,H2.
    auto.
  }

Qed.


Require Export Db.Spec.
Require Export Db.Tactics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Export Coq.Program.Equality.
Require Export Coq.Program.Tactics.

Create HintDb ws.
#[export]
Hint Constructors wsIx : ws.

Local Tactic Notation "crush'" tactic(T) :=
  cbn; intros;
  repeat
    (cbn;
     repeat crushDbSyntaxMatchH;
     crushRewriter;
     T);
  auto.

Lemma ap_wks {X Y} {vrX: Vr X} {wkX: Wk X} {vrY: Vr Y} {wkY: Wk Y}
  {apXY: Ap X Y} {apWkXY: LemApWk X Y} {apYY: Ap Y Y}
  {apCompXY: LemApComp X Y Y} {apWkYY: LemApWk Y Y} :
  ∀ (δ: Dom) (x: X), @wks X _ _ δ x = x[@wkms Y _ _ δ].
Proof.
  induction δ; crush' rewrite ?ap_wk, ?ap_comp.
  f_equal; extensionality i;
    cbn; now rewrite ap_wk.
Qed.

Definition ap_id'      := @ap_id.
Definition ap_comp'    := @ap_comp.
Definition ap_vr'      := @ap_vr.
Definition ap_lift'    := @ap_lift.
Definition ap_wk'      := @ap_wk.
Definition ap_wks'     := @ap_wks.
Definition comp_up'    := @comp_up.
Definition lift_vr'    := @lift_vr.
Definition ap_liftSub' := @ap_liftSub.

Arguments ap_id _ _ {_ _} x.
Arguments ap_comp' _ _ _ {_ _ _ _ _ _} x ξ ζ.
Arguments ap_vr' _ _ {_ _ _ _ _} ξ i.
Arguments ap_lift' _ _ _ {_ _ _ _ _ _ _} ζ x.
Arguments ap_wk' _ _ {_ _ _ _ _ _} x.
Arguments ap_wks' _ _ {_ _ _ _ _ _ _ _ _} δ x.
Arguments comp_up' _ _ {_ _ _ _ _ _} ξ ζ.
Arguments lift_vr' _ _ {_ _ _} i.
Arguments ap_liftSub' _ _ {_ _ _ _} t ξ.

(** *** Domains *)

Lemma dunion_assoc (δ₁ δ₂ δ₃: Dom) :
  δ₁ ∪ (δ₂ ∪ δ₃) = (δ₁ ∪ δ₂) ∪ δ₃.
Proof. induction δ₃; cbn; congruence. Qed.

Section Lemmas.

  Local Ltac crush :=
    crush' rewrite ?ap_vr, ?comp_up.

  (* Injectivity is closed under up. *)
  Lemma InjSubIxUp (ξ: Sub Ix) :
    Inj ξ → Inj (ξ ↑).
  Proof.
    intros ? [|?] [|?] ?; cbn in *;
      auto; discriminate.
  Qed.

  (* The following lemmas have more generic versions, but we stick to the
     specialized Ix versions to make proof search easier. *)
  Section Indices.

    Context {X: Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.

    (* Up commutes with lift. *)
    Lemma up_liftSub (ξ: Sub Ix) : ⌈ξ⌉↑ = ⌈ξ↑⌉.
    Proof.
      extensionality i; destruct i;
        cbn; now rewrite ?wk_vr.
    Qed.

    Lemma ups_liftSub (δ: Dom) :
      ∀ (ξ: Sub Ix), ⌈ξ⌉ ↑⋆ δ = ⌈ξ ↑⋆ δ⌉.
    Proof.
      induction δ; cbn; intros.
      - reflexivity.
      - now rewrite ?IHδ, ?up_liftSub.
    Qed.
    (* (* Lifting the identity yields the identity. *) *)
    (* Lemma liftSub_id : ⌈idm Ix⌉ = idm X. *)
    (* Proof. reflexivity. Qed. *)

    (* The weakening substitution is just the lifted
         weakening renaming. *)
    Lemma liftSub_wkm : ⌈@wkm Ix _ _⌉ = @wkm X _ _.
    Proof. extensionality i; crush. Qed.

    Lemma liftSub_wkms (δ: Dom) : ⌈@wkms Ix _ _ δ⌉ = @wkms X _ _ δ.
    Proof.
      extensionality i; induction δ; cbn in *.
      - reflexivity.
      - rewrite <- IHδ; cbn.
        rewrite wk_vr; reflexivity.
    Qed.

    Context {apX : Ap X X}.
    Context {apVrX: LemApVr X X}.

    Lemma liftSub_comp (ξ ζ: Sub Ix) :
      @liftSub Ix _ X _  _ (ξ >=> ζ) = ⌈ξ⌉ >=> ⌈ζ⌉.
    Proof. extensionality i; crush. Qed.

    (* Up commutes with the composition with a lifting
       on the left-hand side .*)
    Lemma up_comp_lift (ξ: Sub Ix) (ζ: Sub X):
      (⌈ξ⌉ >=> ζ)↑ = ⌈ξ↑⌉ >=> ζ↑.
    Proof. extensionality i; destruct i; crush. Qed.

  End Indices.

  Section Weakening.

    Context {X: Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.

    Lemma up_idm : up (idm X) = idm X.
    Proof.
      extensionality i; destruct i; cbn;
        now rewrite ?wk_vr.
    Qed.

    Lemma ups_idm (δ: Dom) : ups (idm X) δ = idm X.
    Proof.
      induction δ; cbn;
        now rewrite ?IHδ, ?up_idm.
    Qed.

    Lemma ups_dunion (ξ: Sub X) δ₁ δ₂ :
       ξ ↑⋆ (δ₁ ∪ δ₂) = (ξ ↑⋆ δ₁) ↑⋆ δ₂.
    Proof. induction δ₂; crush. Qed.

    Lemma ups_up (ξ : Sub X) δ : (ξ ↑⋆ δ) ↑ = ξ ↑⋆ (S δ).
    Proof. reflexivity. Qed.

    Lemma wkm_snoc0 : wkm · vr 0 = idm X.
    Proof. extensionality i; destruct i; crush. Qed.

    Lemma wkms_zero : wkms 0 = idm X.
    Proof. reflexivity. Qed.

    Lemma apply_ups_wks (ξ: Sub X) (δ: Dom) (i: Ix) :
      (ξ ↑⋆ δ) (wks δ i) = wks δ (ξ i).
    Proof. induction δ; crush. Qed.

    Lemma wks_comm δ (ξ: Sub X) :
      ∀ i, wks δ (ξ i) = (ξ ↑⋆ δ) (wks δ i).
    Proof. induction δ; crush. Qed.

    (* Point-wise the weakening substitution is the
       variable injection of the weakening action on
       indices. *)
    Lemma apply_wkms (δ: Dom) (i: Ix) :
      @wkms X _ _ δ i = vr (wks δ i).
    Proof. induction δ; crush. Qed.

    Context {apX : Ap X X}.
    Context {apWkX: LemApWk X X}.

    Lemma apply_up_def_O (ζ: Sub X) :
      (ζ ↑) 0 = vr 0.
    Proof. crush. Qed.

    Lemma apply_up_def_S (ζ: Sub X) :
      ∀ (i: Ix), (ζ ↑) (S i) = (ζ i)[wkm].
    Proof. crush. Qed.

    Lemma up_def (ζ: Sub X) :
      ζ ↑ = (ζ >=> wkm) · vr 0.
    Proof. extensionality i; destruct i; crush. Qed.

    Lemma wkms_succ (δ: Dom) : wkms (S δ) = wkms δ >=> @wkm X _ _.
    Proof. extensionality i; crush. Qed.

  End Weakening.

  Section Application.

    Context {X: Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.
    Context {apX : Ap X X}.

    Section Het.
      Context {S: Type}.
      Context {vrS : Vr S}.
      Context {wkS : Wk S}.
      Context {apXS: Ap X S}.

      Lemma comp_id_right (ζ: Sub X) :
        ζ >=> idm S = ζ.
      Proof. extensionality i; crush. Qed.

    End Het.

    Context {apVrX: LemApVr X X}.

    Lemma comp_id_left (ζ: Sub X) :
      @idm X _ >=> ζ = ζ.
    Proof. extensionality i; crush. Qed.

    Lemma comp_snoc (ζ₁ ζ₂: Sub X) t :
      (ζ₁ · t) >=> ζ₂ = (ζ₁ >=> ζ₂) · t[ζ₂].
    Proof. extensionality i; destruct i; reflexivity. Qed.

    Context {apWkX: LemApWk X X}.
    Context {apCompX: LemApComp X X X}.

    Lemma apply_wk_ap (x: X) (ζ: Sub X) :
      (wk x)[ζ] = x[wkm >=> ζ].
    Proof. now rewrite ap_wk. Qed.

    Lemma apply_wks_ap δ (x: X) (ζ: Sub X) :
      (wks δ x)[ζ] = x[wkms δ >=> ζ].
    Proof. now rewrite ap_wks, ap_comp. Qed.

    (* Always try to associate to the left in rewriting. *)
    Lemma comp_assoc (ζ₁ ζ₂ ζ₃: Sub X) :
      ζ₁ >=> (ζ₂ >=> ζ₃) = (ζ₁ >=> ζ₂) >=> ζ₃.
    Proof. extensionality i; crush. Qed.

    Lemma wkms_comm δ (ξ: Sub X) :
      ξ      >=> wkms δ =
      wkms δ >=> (ξ ↑⋆ δ).
    Proof.
      pose proof apply_wkms.
      pose proof apply_ups_wks.
      pose proof ap_wks.
      extensionality i; crush.
    Qed.

    Lemma wkm_comm (ξ: Sub X) :
      ξ   >=> wkm =
      wkm >=> ξ↑.
    Proof. apply (wkms_comm 1). Qed.

    Context {Y: Type}.
    Context {vrY: Vr Y}.
    Context {wkY: Wk Y}.
    Context {apXY: Ap X Y}.
    Context {compUpX : LemCompUp X Y}.

    Lemma comp_ups (ξ: Sub X) (ζ: Sub Y) (δ: Dom) :
      (ξ >=> ζ) ↑⋆ δ  = (ξ ↑⋆ δ) >=> (ζ ↑⋆ δ).
    Proof. induction δ; crush. Qed.

  End Application.

  Section BetaInteraction.

    Context {X : Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.
    Context {apX : Ap X X}.
    Context {apWkX: LemApWk X X}.
    Context {apVrX: LemApVr X X}.
    Context {apCompX: LemApComp X X X}.

    Lemma beta_comm δ (ζ₁ ζ₂: Sub X) :
      beta δ ζ₁  >=> ζ₂  =
      (ζ₂ ↑⋆ δ)  >=> beta δ (ζ₁ >=> ζ₂).
    Proof.
      extensionality i. crush. revert ζ₁ ζ₂ i.
      induction δ; crush.
      destruct i; crush.
      rewrite ap_wk, ap_comp; crush.
      f_equal; extensionality j; crush.
    Qed.

    Lemma apply_beta_wks (δ: Dom) :
      ∀ (ξ: Sub X) i, beta δ ξ (wks δ i) = vr i.
    Proof. induction δ; crush. Qed.

    Lemma wkms_beta_cancel δ (ξ: Sub X) :
      wkms δ >=> beta δ ξ = idm X.
    Proof.
      pose proof apply_wkms.
      pose proof apply_beta_wks.
      extensionality i; crush.
    Qed.

    Lemma beta1_comm (x : X) (ζ: Sub X) :
      beta1 x >=> ζ  =
      (ζ ↑)   >=> beta1 x[ζ].
    Proof. apply (beta_comm 1). Qed.

    Lemma wkm_beta1_cancel (x: X) :
      wkm >=> beta1 x = idm X.
    Proof. apply (wkms_beta_cancel 1). Qed.

  End BetaInteraction.

  Section Misc.

    Context {X: Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.
    Context {apX: Ap X X}.
    Context {apVrX: LemApVr X X}.

    Lemma wkm_snoc_cancel (ζ: Sub X) t : wkm >=> (ζ · t) = ζ.
    Proof. extensionality i; destruct i; crush. Qed.

    Lemma snoc_eta_red (ζ: Sub X) : (wkm >=> ζ) · ζ 0 = ζ.
    Proof. extensionality i; destruct i; crush. Qed.

  End Misc.

  (* This subsection contains pointful variables of the pointfree lemmas of the
     previous subsection. These are intended to be user-facing. The Db.Inst
     module populates the infrastructure database with these lemmas and some
     others such that it results in a terminating rewrite system (hopefully). *)
  Section Pointful.

    Context {T X: Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.
    Context {apTX: Ap T X}.
    Context {apXX: Ap X X}.
    Context {apCompTX: LemApComp T X X}.
    Context {apVrX: LemApVr X X}.
    Context {apWkX: LemApWk X X}.
    Context {apCompX: LemApComp X X X}.
    Context {compUpX: LemCompUp X X}.

    Local Ltac crushPointful :=
      (* (* Convert renamings into substitutions *) *)
      (* rewrite <- ?ap_liftSub; *)
      (* Go point-free *)
      rewrite ?ap_comp; f_equal;
      (* Flow ups outside *)
      rewrite <- ?comp_up, <- ?comp_ups;
      (* (* Convert lifted weakening renaming into weakening substitution *) *)
      (* rewrite <- ?liftSub_wkm; *)
      (* Apply the point-free lemmas *)
      rewrite ?wkm_comm,
              ?wkm_beta1_cancel,
              ?beta1_comm;
      (* Get rid of identities *)
      rewrite ?up_idm, ?ups_idm, ?ap_id;
      reflexivity.

    Lemma apply_wkm_comm (t: T) (ξ: Sub X) :
      t[ξ][wkm] = t[wkm][ξ↑].
    Proof. crushPointful. Qed.

    Lemma apply_wkm_beta1_cancel (t: T) (x: X) :
      t[wkm][beta1 x] = t.
    Proof. crushPointful. Qed.

    Lemma apply_beta1_comm (t: T) (x: X) (ζ: Sub X) :
      t[beta1 x][ζ] = t[ζ↑][beta1 x[ζ]].
    Proof. crushPointful. Qed.

    (* 1 up variant *)
    Lemma apply_wkm_up_comm (t: T) (ξ: Sub X) :
      t[ξ↑][wkm↑] = t[wkm↑][ξ↑↑].
    Proof. crushPointful. Qed.

    Lemma apply_wkm_beta1_up_cancel (t: T) (x: X) :
      t[wkm↑][(beta1 x)↑] = t.
    Proof. crushPointful. Qed.

    Lemma apply_beta1_up_comm (t: T) (x: X) (ζ: Sub X) :
      t[(beta1 x)↑][ζ↑] = t[ζ↑↑][(beta1 x[ζ])↑].
    Proof. crushPointful. Qed.

    (* 2 ups variant *)
    Lemma apply_wkm_up2_comm (t: T) (ξ: Sub X) :
      t[ξ↑↑][wkm↑↑] = t[wkm↑↑][ξ↑↑↑].
    Proof. crushPointful. Qed.

    Lemma apply_wkm_beta1_up2_cancel (t: T) (x: X) :
      t[wkm↑↑][(beta1 x)↑↑] = t.
    Proof. crushPointful. Qed.

    Lemma apply_beta1_up2_comm (t: T) (x: X) (ζ: Sub X) :
      t[(beta1 x)↑↑][ζ↑↑] = t[ζ↑↑↑][(beta1 x[ζ])↑↑].
    Proof. crushPointful. Qed.

    (* δ ups variant *)
    Lemma apply_wkm_ups_comm (δ: Dom) (t: T) (ξ: Sub X) :
      t[ξ ↑⋆ δ][wkm ↑⋆ δ] = t[wkm ↑⋆ δ][ξ↑ ↑⋆ δ].
    Proof. crushPointful. Qed.

    Lemma apply_wkm_beta1_ups_cancel (δ: Dom) (t: T) (x: X) :
      t[wkm ↑⋆ δ][beta1 x ↑⋆ δ] = t.
    Proof. crushPointful. Qed.

    Lemma apply_beta1_ups_comm (δ: Dom) (t: T) (x: X) (ζ: Sub X) :
      t[beta1 x ↑⋆ δ][ζ ↑⋆ δ] = t[ζ↑ ↑⋆ δ][beta1 x[ζ] ↑⋆ δ].
    Proof. crushPointful. Qed.

  End Pointful.

End Lemmas.

Ltac crushDbLemmasMatchH :=
  match goal with
    | H: context[@ap ?X ?X ?vrX _ ?ξ (@vr ?X ?vrX ?i)] |- _ =>
      replace (@ap X X vrX _ ξ (@vr X vrX i)) with (ξ i) in H by
          refine (eq_sym (ap_vr ξ i))

    | |- context[@up ?X ?vrX ?wkX ?ζ O        ] =>
      change (@up X vrX wkX ζ O) with (@vr X vrX O)
    | |- context[@up _ _ ?wkX (idm _)         ] => rewrite (@up_idm _ _ wkX)
    | |- context[@ups _ _ ?wkX (idm _) ?δ     ] => rewrite (@ups_idm _ _ wkX δ)
    | |- context[@ap ?X ?X ?vrX _ ?ξ (@vr ?X ?vrX ?i)] =>
      replace (@ap X X vrX _ ξ (@vr X vrX i)) with (ξ i) by
          refine (eq_sym (ap_vr ξ i))
  end.

Ltac crushDbLemmasRewriteH :=
  rewrite
    ?dunion_assoc, ?ups_dunion, ?comp_up, ?comp_ups,
    (* ?up_liftSub, ?ups_liftSub, *)
    (* ?ap_liftSub, ?liftSub_wkm, ?liftSub_wkms, ?ap_lift, *)
    <- ?ap_comp,
    ?apply_wkm_comm,     ?apply_wkm_beta1_cancel,     ?apply_beta1_comm,
    ?apply_wkm_up_comm,  ?apply_wkm_beta1_up_cancel,  ?apply_beta1_up_comm,
    ?apply_wkm_up2_comm, ?apply_wkm_beta1_up2_cancel, ?apply_beta1_up2_comm,
    ?apply_wkm_ups_comm, ?apply_wkm_beta1_ups_cancel, ?apply_beta1_ups_comm.

    (* Print liftSub_wkm. *)

    (* Unset Printing Notations. *)
    (* Set Printing Implicit. *)
    (* Print ups_idm. *)

    (* | [|- context[(@liftSub Ix _ ?X _ _ ?ξ)↑]] => replace (@liftSub Ix _ X _ _ ξ)↑ *)
    (*                                                 with (@liftSub Ix _ X _ _ ξ↑) by *)
    (*                                                   exact (eq_sym (up_liftSub ξ)) *)
    (* | [|- context[@liftSub Ix _ ?X _ _ ?ξ ↑⋆ ?δ]] => replace (@liftSub Ix _ X _ _ ξ ↑⋆ δ) *)
    (*                                                 with (@liftSub Ix _ X _ _ (ξ ↑⋆ δ)) by *)
    (*                                                   exact (eq_sym (ups_liftSub δ ξ)) *)

  (* liftSub_id : ⌈idm Ix⌉ = idm X. *)
  (* liftSub_wkm  ⌈@wkm Ix _ _⌉ = @wkm X _ _. *)
  (* liftSub_wkms  ⌈@wkms Ix _ _ δ⌉ = @wkms X _ _ δ. *)


Set Implicit Arguments.

Require Import RelationClasses.
Require Import List.

From sflib Require Import sflib.

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

Require Import ITreeLang.

Module Opt3.

  Record t :=
    mk_opt3
      {
        gdata: Type;
        bot_g: gdata;
        expr_g: gdata -> Inst.expr -> gdata;
        inst_g: gdata -> Inst.t -> gdata;
        join_g: gdata -> gdata -> gdata;

        le_g: gdata -> gdata -> Prop;
        le_g_PreOrder: PreOrder le_g;
        le_g_PartialOrder: PartialOrder eq le_g;

        bot_g_spec: forall gd, le_g bot_g gd;

        expr_g_inc: forall ex gd, le_g gd (expr_g gd ex);
        expr_g_mon: forall ex gd1 gd2 (LE: le_g gd1 gd2), le_g (expr_g gd1 ex) (expr_g gd2 ex);
        expr_g_big: forall ex gd (BIG: le_g (expr_g bot_g ex) gd), expr_g gd ex = gd;

        inst_g_inc: forall gd i, le_g gd (inst_g gd i);
        inst_g_mon: forall gd1 gd2 i (LE: le_g gd1 gd2), le_g (inst_g gd1 i) (inst_g gd2 i);
        inst_g_big: forall gd i (BIG: le_g (inst_g bot_g i) gd), inst_g gd i = gd;
        inst_g_skip: forall gd, inst_g gd (Inst.skip) = gd;

        join_g_refl: forall a, join_g a a = a;
        join_le_g_l: forall a b, le_g a (join_g a b);
        join_le_g_r: forall a b, le_g b (join_g a b);
        join_g_mon: forall a b c d (LE1: le_g a c) (LE2: le_g b d), le_g (join_g a b) (join_g c d);

        datum: Type;
        data := list datum;
        analyze: block -> data;

        update_g: gdata -> datum -> gdata;
        update_g_inc: forall g d, le_g g (update_g g d);
        update_g_mon: forall a b d (LE: le_g a b), le_g (update_g a d) (update_g b d);

        intro_inst: gdata -> datum -> Inst.t;
      }
  .

  Global Program Instance le_g_PreOrder_i: forall T, PreOrder (le_g T).
  Next Obligation.
  Proof.
    eapply PreOrder_Reflexive. Unshelve. apply (le_g_PreOrder T).
  Qed.
  Next Obligation.
  Proof.
    eapply PreOrder_Transitive. Unshelve. apply (le_g_PreOrder T).
  Qed.

  Global Program Instance le_g_PartialOrder_i: forall T, PartialOrder eq (le_g T).
  Next Obligation.
  Proof.
    assert (Antisymmetric (gdata T) eq (le_g T)).
    { eapply partial_order_antisym. eapply (le_g_PartialOrder T). }
    unfold relation_equivalence, relation_conjunction.
    unfold predicate_equivalence, predicate_intersection.
    unfold pointwise_lifting, pointwise_extension.
    i. split; i.
    - split.
      + clarify. refl.
      + unfold flip. clarify. refl.
    - des. eapply antisymmetry; eauto.
  Qed.

End Opt3.

Section OPT.

  Variable O3: Opt3.t.

  Let gdata: Type := Opt3.gdata O3.
  Let bot_g: gdata := Opt3.bot_g O3.
  Let expr_g: gdata -> Inst.expr -> gdata := Opt3.expr_g O3.
  Let inst_g: gdata -> Inst.t -> gdata := Opt3.inst_g O3.
  Let join_g: gdata -> gdata -> gdata := Opt3.join_g O3.

  Fixpoint block_g (gd: gdata) (blk: block) : gdata :=
    match blk with
    | nil => gd
    | cons hd tl =>
      match hd with
      | inst i =>
        let gd1 := inst_g gd i in
        block_g gd1 tl

      | ite ex b1 b2 =>
        let gd1 := block_g gd b1 in
        let gd2 := block_g gd b2 in
        let gd3 := join_g gd1 gd2 in
        let gd4 := expr_g gd3 ex in
        block_g gd4 tl

      | while ex b =>
        let gd1 := block_g gd b in
        let gd2 := expr_g gd1 ex in
        block_g gd2 tl
      end
    end
  .

  Let le_g: gdata -> gdata -> Prop := Opt3.le_g O3.
  Let le_g_PreOrder: PreOrder le_g := Opt3.le_g_PreOrder O3.
  Let le_g_PartialOrder: PartialOrder eq le_g := Opt3.le_g_PartialOrder O3.

  Global Program Instance le_g_PreOrder_i: PreOrder le_g.
  Global Program Instance le_g_PartialOrder_i: PartialOrder eq le_g.

  Definition lt_g gd1 gd2 := (le_g gd1 gd2) /\ (gd1 <> gd2).

  Global Program Instance lt_g_Transitive_i: Transitive lt_g.
  Next Obligation.
  Proof.
    unfold lt_g in *. des. split.
    - etrans; eauto.
    - ii. clarify. hexploit (partial_order_antisym le_g_PartialOrder). i.
      assert (AS: y = z).
      { eapply antisymmetry; eauto. }
      apply H1; auto.
  Qed.

  Lemma le_g_lt_g:
    forall a b c (LE: le_g a b) (LT: lt_g b c), lt_g a c.
  Proof.
    i. unfold lt_g in *. des. split.
    - etrans; eauto.
    - ii. clarify. assert (AS: b = c).
      { eapply antisymmetry; eauto. }
      clarify.
  Qed.

  Lemma le_g_lt_g2:
    forall a b c (LE: lt_g a b) (LT: le_g b c), lt_g a c.
  Proof.
    i. unfold lt_g in *. des. split.
    - etrans; eauto.
    - ii. clarify. assert (AS: c = b).
      { eapply antisymmetry; eauto. }
      clarify.
  Qed.

  Let bot_g_spec: forall gd, le_g bot_g gd := Opt3.bot_g_spec O3.

  Let expr_g_inc: forall ex gd, le_g gd (expr_g gd ex) := Opt3.expr_g_inc O3.
  Let expr_g_mon: forall ex gd1 gd2 (LE: le_g gd1 gd2), le_g (expr_g gd1 ex) (expr_g gd2 ex) := Opt3.expr_g_mon O3.
  Let expr_g_big: forall ex gd (BIG: le_g (expr_g bot_g ex) gd), expr_g gd ex = gd := Opt3.expr_g_big O3.

  Let inst_g_inc: forall gd i, le_g gd (inst_g gd i) := Opt3.inst_g_inc O3.
  Let inst_g_mon: forall gd1 gd2 i (LE: le_g gd1 gd2), le_g (inst_g gd1 i) (inst_g gd2 i) := Opt3.inst_g_mon O3.
  Let inst_g_big: forall gd i (BIG: le_g (inst_g bot_g i) gd), inst_g gd i = gd := Opt3.inst_g_big O3.
  Let inst_g_skip: forall gd, inst_g gd (Inst.skip) = gd := Opt3.inst_g_skip O3.

  Let join_g_refl: forall a, join_g a a = a := Opt3.join_g_refl O3.
  Let join_le_g_l: forall a b, le_g a (join_g a b) := Opt3.join_le_g_l O3.
  Let join_le_g_r: forall a b, le_g b (join_g a b) := Opt3.join_le_g_r O3.
  Let join_g_mon: forall a b c d (LE1: le_g a c) (LE2: le_g b d), le_g (join_g a b) (join_g c d) := Opt3.join_g_mon O3.

  Lemma block_g_inst:
    forall gd (i: Inst.t) blk, block_g gd (cons i blk) = block_g (inst_g gd i) blk.
  Proof. ss. Qed.

  Lemma block_g_ite:
    forall gd ex b1 b2 blk, block_g gd (cons (ite ex b1 b2) blk) = block_g (expr_g (join_g (block_g gd b1) (block_g gd b2)) ex) blk.
  Proof. ss. Qed.

  Lemma block_g_while:
    forall gd ex b blk, block_g gd (cons (while ex b) blk) = block_g (expr_g (block_g gd b) ex) blk.
  Proof. ss. Qed.

  Lemma block_g_inc:
    forall blk gd, le_g gd (block_g gd blk).
  Proof.
    induction blk using block_ind2; i; ss; eauto.
    - refl.
    - etrans. 2: eapply IHblk. eapply inst_g_inc.
    - etrans. 2: eapply IHblk3. etrans. 2: eapply expr_g_inc. etrans. 2: eapply join_le_g_l. eauto.
    - etrans. 2: eapply IHblk2. etrans. 2: eapply expr_g_inc. eauto.
  Qed.

  Lemma block_g_mon:
    forall blk gd1 gd2 (LE: le_g gd1 gd2),
      le_g (block_g gd1 blk) (block_g gd2 blk).
  Proof.
    induction blk using block_ind2; i; ss; eauto.
    eapply IHblk3. eapply expr_g_mon. eapply join_g_mon; eauto.
  Qed.

  Lemma block_g_big:
    forall blk gd (BIG: le_g (block_g bot_g blk) gd),
      (block_g gd blk) = gd.
  Proof.
    induction blk using block_ind2; i; ss; eauto.
    - rewrite inst_g_big.
      2:{ etrans. 2: eapply BIG. eapply block_g_inc. }
      eapply IHblk. etrans. 2: eapply BIG. eapply block_g_mon. eapply bot_g_spec.
    - rewrite IHblk1.
      2:{ etrans. 2: eapply BIG. etrans. 2: eapply block_g_inc. etrans. 2: eapply expr_g_inc. apply join_le_g_l. }
      rewrite IHblk2.
      2:{ etrans. 2: eapply BIG. etrans. 2: eapply block_g_inc. etrans. 2: eapply expr_g_inc. apply join_le_g_r. }
      rewrite join_g_refl. rewrite expr_g_big.
      2:{ etrans. 2: eapply BIG. etrans. 2: eapply block_g_inc. eapply expr_g_mon. eapply bot_g_spec. }
      eapply IHblk3. etrans. 2: eapply BIG. eapply block_g_mon. eapply bot_g_spec.
    - rewrite IHblk1.
      2:{ etrans. 2: eapply BIG. etrans. 2: eapply block_g_inc. etrans. 2: eapply expr_g_inc. refl. }
      rewrite expr_g_big.
      2:{ etrans. 2: eapply BIG. etrans. 2: eapply block_g_inc. eapply expr_g_mon. eapply bot_g_spec. }
      eapply IHblk2. etrans. 2: eapply BIG. eapply block_g_mon. eapply bot_g_spec.
  Qed.

  Lemma block_g_add_block:
    forall b1 b2 gd, block_g gd (add_block b1 b2) = block_g (block_g gd b1) b2.
  Proof.
    induction b1 using block_ind2; i; ss; eauto.
  Qed.

  Let datum: Type := Opt3.datum O3.
  Let data := Opt3.data O3.
  Let analyze: block -> data := Opt3.analyze O3.

  Let update_g: gdata -> datum -> gdata := Opt3.update_g O3.
  Definition update_gs: gdata -> data -> gdata :=
    fun gd ds => fold_left update_g ds gd.

  Let update_g_inc: forall g d, le_g g (update_g g d) := Opt3.update_g_inc O3.
  Let update_g_mon: forall a b d (LE: le_g a b), le_g (update_g a d) (update_g b d) := Opt3.update_g_mon O3.

  Lemma update_gs_inc: forall ds g, le_g g (update_gs g ds).
  Proof.
    induction ds; i; ss. refl.
    etrans. 2: eapply IHds. eapply update_g_inc.
  Qed.

  Lemma update_gs_mon: forall ds a b (LE: le_g a b), le_g (update_gs a ds) (update_gs b ds).
  Proof.
    induction ds; i; ss. eapply IHds. eapply update_g_mon. auto.
  Qed.

  Let intro_inst: gdata -> datum -> Inst.t := Opt3.intro_inst O3.
  Fixpoint intro_insts (g: gdata) (ds: data) : block :=
    match ds with
    | [] => nil
    | d :: tl =>
      cons (intro_inst g d) (intro_insts (update_g g d) tl)
    end.

  (* "scope" of each global data is limited to each while-body *)
  Fixpoint opt (gd: gdata) (blk: block) : block :=
    match blk with
    | nil => nil
    | cons hd tl =>
      match hd with
      | inst i =>
        let utl := opt gd tl in
        cons hd utl
      | ite c b1 b2 =>
        let ub1 := opt gd b1 in
        let ub2 := opt gd b2 in
        let utl := opt gd tl in
        cons (ite c ub1 ub2) utl
      | while c b =>
        let ds := analyze b in
        let ugd := update_gs gd ds in
        let ub := opt ugd b in
        let utl := opt gd tl in
        add_block (intro_insts gd ds) (cons (while c ub) utl)
      end
    end
  .

  Lemma opt_add_comm:
    forall b1 b2 gd,
      opt gd (add_block b1 b2) = add_block (opt gd b1) (opt gd b2).
  Proof.
    induction b1 using block_ind2; i; ss.
    - f_equal. eauto.
    - f_equal. eauto.
    - rewrite add_block_assoc. f_equal. rewrite cons_add_block_comm. f_equal. eauto.
  Qed.

  Lemma opt_eval_inst:
    forall gd blk (i: Inst.t), opt gd (cons i blk) = cons i (opt gd blk).
  Proof. ss. Qed.

  Lemma opt_eval_ite:
    forall gd e b1 b2 blk,
      opt gd (cons (ite e b1 b2) blk) =
      cons (ite e (opt gd b1) (opt gd b2)) (opt gd blk).
  Proof. ss. Qed.

  Lemma opt_eval_while:
    forall gd e b blk,
      opt gd (cons (while e b) blk) =
      add_block (intro_insts gd (analyze b))
                (cons (while e (opt (update_gs gd (analyze b)) b)) (opt gd blk)).
  Proof. ss. Qed.

  (* gdata = global data from the original code *)
  Inductive match_code3 (gd: gdata): block -> block -> Prop :=
  | match_code3_nil
    :
      match_code3 gd nil nil

  | match_code3_inst
      (i_same: Inst.t) b_src b_tgt

      (GD: le_g (inst_g gd i_same) gd)
      (MC0: match_code3 gd b_src b_tgt)
    :
      match_code3 gd (cons i_same b_src) (cons i_same b_tgt)

  | match_code3_ite
      (s_src s_tgt: stmt) b_src b_tgt
      e (sb1 sb2 tb1 tb2: block)

      (SSRC: s_src = ite e sb1 sb2)
      (STGT: s_tgt = ite e tb1 tb2)

      (MC0: match_code3 gd b_src b_tgt)
      (MCT: match_code3 gd sb1 tb1)
      (MCF: match_code3 gd sb2 tb2)
    :
      match_code3 gd (cons s_src b_src) (cons s_tgt b_tgt)

  | match_code3_while
      (s_src s_tgt: stmt) b_src b_tgt src tgt
      e (sb tb: block)

      (SSRC: s_src = while e sb)
      (STGT: s_tgt = while e tb)

      (SRC: src = cons s_src b_src)
      (TGT: tgt = cons s_tgt b_tgt)

      (MC0: match_code3 gd b_src b_tgt)
      (MCL: match_code3 (update_gs gd (analyze sb)) sb tb)
    :
      match_code3 gd src tgt

  | match_code3_opt
      src tgt
      gd1 ds

      (GD: le_g gd gd1)
      (mc0: match_code3 gd src tgt)
    :
      match_code3 gd src (add_block (intro_insts gd1 ds) tgt)
  .

  Lemma mc_add_block
        src1 src2 tgt1 tgt2 gd
        (MC1: match_code3 gd src1 tgt1)
        (MC2: match_code3 gd src2 tgt2)
    :
      match_code3 gd (add_block src1 src2) (add_block tgt1 tgt2).
  Proof.
    depgen src2. depgen tgt2. induction MC1; i; ss; clarify.
    - econs 2; eauto.
    - econs 3; eauto.
    - rewrite ! cons_add_block_comm. econs 4; eauto.
    - rewrite add_block_assoc. econs 5; eauto.
  Qed.

  Lemma mc_mon_gdata
        src tgt gd1 gd2
        (GD: le_g (block_g gd1 src) gd1)
        (LE: le_g gd1 gd2)
        (MC: match_code3 gd2 src tgt)
    :
      match_code3 gd1 src tgt.
  Proof.
    depgen gd1. induction MC; i; ss; clarify.
    - econs 1.
    - econs 2; eauto.
      { etrans. 2: eapply GD0. etrans. 2: eapply block_g_inc. refl. }
      eapply IHMC; eauto. etrans. 2: eapply GD0. eapply block_g_mon. eapply inst_g_inc.
    - econs 3; eauto.
      + eapply IHMC1; eauto. etrans. 2: eapply GD. eapply block_g_mon. etrans. 2: eapply expr_g_inc.
        etrans. 2: eapply join_le_g_l. eapply block_g_inc.
      + eapply IHMC2; eauto. etrans. 2: eapply GD. etrans. 2: eapply block_g_inc. etrans. 2: eapply expr_g_inc.
        eapply join_le_g_l.
      + eapply IHMC3; eauto. etrans. 2: eapply GD. etrans. 2: eapply block_g_inc. etrans. 2: eapply expr_g_inc.
        eapply join_le_g_r.
    - ss. econs 4; eauto.
      + eapply IHMC1; eauto. etrans. 2: eapply GD. eapply block_g_mon. etrans. 2: eapply expr_g_inc. eapply block_g_inc.
      + eapply IHMC2; eauto.
        * rewrite block_g_big. refl. etrans. 2: eapply update_gs_inc. etrans. 2: eapply GD.
          etrans. 2: eapply block_g_inc. etrans. 2: eapply expr_g_inc. eapply block_g_mon. eapply bot_g_spec.
        * eapply update_gs_mon. auto.
    - econs 5; eauto. etrans; eauto.
  Qed.

  Lemma opt_mc0:
    forall src gd (GD: le_g (block_g gd src) gd), match_code3 gd src (opt gd src).
  Proof.
    induction src using block_ind2; i; ss.
    - econs 1.
    - econs 2; eauto.
      { etrans. 2: eapply GD. eapply block_g_inc. }
      eapply IHsrc. etrans. 2: eapply GD. eapply block_g_mon. eapply inst_g_inc.
    - econs 3; eauto.
      + eapply IHsrc3. etrans. 2: eapply GD. eapply block_g_mon.
        etrans. 2: eapply expr_g_inc. etrans. 2: eapply join_le_g_l. eapply block_g_inc.
      + eapply IHsrc1. etrans. 2: eapply GD. etrans. 2: eapply block_g_inc.
        etrans. 2: eapply expr_g_inc. eapply join_le_g_l.
      + eapply IHsrc2. etrans. 2: eapply GD. etrans. 2: eapply block_g_inc.
        etrans. 2: eapply expr_g_inc. eapply join_le_g_r.
    - econs 5; eauto. refl. econs 4; eauto.
      + eapply IHsrc2. etrans. 2: eapply GD. eapply block_g_mon. etrans. 2: eapply expr_g_inc. eapply block_g_inc.
      + eapply IHsrc1. rewrite block_g_big. refl.
        etrans. 2: eapply update_gs_inc. etrans. 2: eapply GD. etrans. 2: eapply block_g_inc.
        etrans. 2: eapply expr_g_inc. eapply block_g_mon. eapply bot_g_spec.
  Qed.

  Lemma opt_mc:
    forall src gd (GD: lt_g (block_g bot_g src) gd), match_code3 gd src (opt gd src).
  Proof.
    i. eapply opt_mc0. rewrite block_g_big. refl. unfold lt_g in GD. des; auto.
  Qed.

End OPT.


Require Import CoqChess.Util.All.

Inductive Player :=
  | White : Player
  | Black : Player.

#[export]
Instance Player_Discrete : Discrete Player.
Proof.
  constructor; unfold decision; decide equality.
Defined.

Definition opp : Player -> Player :=
  fun p =>
    match p with
    | White => Black
    | Black => White
    end.

Lemma opp_invol : forall p, opp (opp p) = p.
Proof.
  intro p; destruct p; reflexivity.
Qed.

Lemma opp_inj : forall p p',
  opp p = opp p' -> p = p'.
Proof.
  intros p p' Hpp'.
  destruct p, p'; auto.
Qed.

Lemma player_id_or_opp : forall p p',
  p = p' \/ opp p = p'.
Proof.
  destruct p, p'; auto.
Qed.

Lemma player_id_or_opp_r_t : forall p p',
  { p = p' } + { p = opp p' }.
Proof.
  intros.
  destruct p, p'; auto.
Defined.

Lemma opp_no_fp : forall p, opp p <> p.
Proof.
  destruct p; discriminate.
Qed.


Require Import VST.floyd.proofauto.
Require Import cprogs.sumarray2_prog.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(* Some definitions relating to the functional spec of this particular program.  *)
Definition sum_Z : list Z -> Z := fold_right Z.add 0.

Lemma sum_Z_app:
  forall a b, sum_Z (a++b) =  sum_Z a + sum_Z b.
Proof.
  intros. induction a; simpl; omega.
Qed.


Require Import Arith Bool String.

Infix "==s" := string_dec (no associativity, at level 50).
Infix "==nat" := eq_nat_dec (no associativity, at level 50).
Infix "<nat" := le_gt_dec (no associativity, at level 50).

Notation "f $ x" := (f x) (at level 60, right associativity, only parsing).

Ltac invert x := inversion x; subst; clear x.

(* This tactic due to Clement Pit-Claudel with some minor additions by JDP to
   allow the result to be named: https://pit-claudel.fr/clement/MSc/#org96a1b5f *)
Inductive Learnt {A: Type} (a: A) :=
| AlreadyKnown : Learnt a.

Ltac learn_tac fact name :=
  lazymatch goal with
  | [ H: Learnt fact |- _ ] =>
    fail 0 "fact" fact "has already been learnt"
  | _ => let type := type of fact in
        lazymatch goal with
        | [ H: @Learnt type _ |- _ ] =>
          fail 0 "fact" fact "of type" type "was already learnt through" H
        | _ => let learnt := fresh "Learn" in
              pose proof (AlreadyKnown fact) as learnt; pose proof fact as name
        end
  end.

Tactic Notation "learn" constr(fact) := let name := fresh "H" in learn_tac fact name.
Tactic Notation "learn" constr(fact) "as" simple_intropattern(name) := learn_tac fact name.

Ltac nicify_hypotheses :=
  repeat match goal with
         | [ H : ex _ |- _ ] => invert H
         | [ H : Some _ = Some _ |- _ ] => invert H
         | [ H : ?x = ?x |- _ ] => clear H
         | [ H : ?x = ?x -> _ |- _ ] => assert (x = x) as ?EQ by reflexivity; apply H in EQ; clear H
         | [ H : _ /\ _ |- _ ] => invert H
         end.

Ltac nicify_goals :=
  repeat match goal with
         | [ |- _ /\ _ ] => split
         | [ |- Some _ = Some _ ] => f_equal
         | [ |- S _ = S _ ] => f_equal
         end.

Ltac kill_bools :=
  repeat match goal with
         | [ H : _ && _ = true |- _ ] => apply andb_prop in H
         | [ H : _ || _ = false |- _ ] => apply orb_false_elim in H
         end.

Ltac substpp :=
  repeat match goal with
         | [ H1 : ?x = Some _, H2 : ?x = Some _ |- _ ] =>
           let EQ := fresh "EQ" in
           learn H1 as EQ; rewrite H2 in EQ; invert EQ
         | _ => idtac
         end.

Ltac simplify := intros; simpl in *;
                 repeat (nicify_hypotheses; nicify_goals; kill_bools; substpp);
                 simpl in *.

Ltac restrict x := destruct x; simplify; try discriminate; try congruence; eauto.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************)
(*                       QUEUE.v                     *)
(*                     Yijia CHEN                    *)
(*                                                   *)
(*****************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Require Import Arith.
Require Import Comp.

Section QUEUE_DEF.

Variable Domain : Set.

Variable err : Domain.

Variable weight : Domain -> nat.

(**********************************************)
(* max(d1,d2) = d1 if weight(d1) > weight(d2) *)
(*            = d2 otherwise                  *)
(* so if weight(d1) == weight(d2)             *)
(*    then max(d1,d2) = d2                    *)
(**********************************************)

Let max (d1 d2 : Domain) : Domain :=
  if less (weight d2) (weight d1) then d1 else d2.

Inductive Queue : Set :=
  | empty : Queue
  | push : Domain -> Queue -> Queue.

Fixpoint queue_length (q : Queue) : nat :=
  match q with
  | empty => 0
  | push d q' => S (queue_length q')
  end.

(************************************************)
(*  pop_ele(q) = the oldest element in q        *)
(*               with minimal weight            *)
(************************************************)

Fixpoint pop_ele (q : Queue) : Domain :=
  match q with
  | empty => err
  | push d q' =>
      match q' with
      | empty => d
      | push d' p'' => max d (pop_ele q')
      end
  end.

(************************************************)
(*  pop_que(q) = q - pop_ele(q)                 *)
(************************************************)

Fixpoint pop_que (q : Queue) : Queue :=
  match q with
  | empty => empty
  | push d q' =>
      match q' with
      | empty => empty
      | push _ _ =>
          if less (weight d) (weight (pop_ele q'))
          then q'
          else push d (pop_que q')
      end
  end.

(************************************************)
(*  del_que(q,P) = q - {e | Pe}                 *)
(************************************************)

Fixpoint del_que (q1 : Queue) : Queue -> (Domain -> Prop) -> Prop :=
  match q1 with
  | empty =>
      fun q2 : Queue =>
      match q2 with
      | empty => fun P : Domain -> Prop => True
      | push d2 q2' => fun P : Domain -> Prop => False
      end
  | push d1 q1' =>
      fun (q2 : Queue) (P : Domain -> Prop) =>
      (P d1 -> del_que q1' q2 P) /\
      (~ P d1 ->
       match q2 with
       | empty => False
       | push d2 q2' => d1 = d2 /\ del_que q1' q2' P
       end)
  end.

(************************************************)
(*  push_ram(q,a) = q + a (randomly)            *)
(************************************************)

Fixpoint push_ram (q1 q2 : Queue) {struct q2} : Domain -> Prop :=
  match q1, q2 with
  | empty, empty => fun d : Domain => False
  | empty, push d2 q2' => fun d : Domain => d2 = d /\ q2' = empty
  | push d1 q1', empty => fun d : Domain => False
  | push d1 q1', push d2 q2' =>
      fun d : Domain =>
      (d2 = d -> q2' = q1) /\ (d2 <> d -> d1 = d2 /\ push_ram q1' q2' d)
  end.

End QUEUE_DEF.