(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype.
Require Import bigops ssralg poly polydiv orderedalg zmodp polydiv.

Reserved Notation "a ^`"(at level 3, format "a ^`").
(* Reserved Notation "a ^`( n )" (at level 3, format "a ^`( n )"). *)
(* Reserved Notation "a ^`N( n )" (at level 3, format "a ^`N( n )"). *)

Import GRing.Theory.
Import OrderedRing.Theory.

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

Open Scope ring_scope.

Section ExtraRelative.

Variable R : oFieldType.

Implicit Types a b c : R.
Implicit Types x y z t : R.

Import GRing.Theory.
Import OrderedRing.Theory.

End ExtraRelative.

Section PolyOrder.

Variable F : oFieldType.

Implicit Types a b c : F.
Implicit Types x y z t : F.
Implicit Types p q r : {poly F}.

Notation "a ^`( n )" := (derivn a n).
Notation "a ^`" := (deriv a).

End PolyOrder.

Section PolyReal.

Variable R : oFieldType.

Implicit Types a b c : R.
Implicit Types x y z t : R.
Implicit Types p q r : {poly R}.

Hypothesis ivt : poly_ivt R.

Lemma polyrealN0_sign : forall p a b,
  (forall x, a <= x <= b -> ~~ root p x) ->
  exists s, (forall x, a <= x <= b -> \s (p.[x]) = s).
Proof.
rewrite /root=> p a b np0; exists (\s p.[a]); move=> x laxb; move:(np0 _ laxb).
case: (ltrgtP p.[x] 0)=> [spx npx0|spx npx0|]; last by move->; rewrite eqxx.
  case: (ltrP p.[a] 0)=> spa; first by rewrite !ltr0_sign.
  case/andP:laxb=>lax lxb; case:(@ivt (-p) a x)=> //.
    by rewrite !horner_opp !oppr_cp0 spa ltrE.
  move=> y; case/andP=> lay lyx; rewrite /root horner_opp oppr_eq0.
  by rewrite (negPf (np0 _ _))// lay/= (ler_trans lyx).
case: (lerP p.[a] 0)=> spa; last by rewrite !gtr0_sign.
case/andP:laxb=>lax lxb; case:(@ivt p a x)=> //; first by rewrite spa ltrE.
move=> y; case/andP=> lay lyx; rewrite /root.
by rewrite (negPf (np0 _ _))// lay/= (ler_trans lyx).
Qed.

Lemma divpf_spec : forall p q,
  p = (((scalp p q)^-1)%:P * (p %/ q)) * q + ((scalp p q)^-1)%:P * (p %% q).
Proof.
move=> p q; apply/eqP.
rewrite -(inj_eq (@mulfI _ (scalp p q)%:P  _)); last first.
  by rewrite polyC_eq0 scalp_id.
rewrite mulr_addr !mulrA -!polyC_mul divff ?scalp_id// polyC1 !mul1r.
by rewrite divp_spec.
Qed.

Lemma maxdivpf : forall p a, p != 0 ->
  exists q : {poly R},
    exists2 n,  (q.[a] != 0) & (p = q * ('X - a%:P)^+n).
Proof.
move=> p; move: {-2}p (erefl (size p)); elim: (size p)=> {p} [p sp|n ihn p sp].
  by move=> a; move/eqP: sp; rewrite size_poly_eq0; move/eqP->; rewrite eqxx.
move=> a p0.
case pa0: (root p a); first last.
  by exists p; exists 0%N; rewrite /root in pa0; rewrite ?pa0// expr0 mulr1.
move: pa0; rewrite root_factor_theorem.
move/dvdpPc=> [c] [q] [c0]; move/eqP.
rewrite -(inj_eq (@mulfI _ c^-1%:P  _)); last by rewrite polyC_eq0 invr_eq0.
rewrite mulrA -polyC_mul [_^-1*_]mulrC divff// polyC1 mul1r mulrA=> hp.
case q0 : (q == 0); first by move: hp p0; rewrite (eqP q0) mulr0 mul0r=> ->.
move:sp; rewrite (eqP hp) size_mul_id; last 2 first.
- by rewrite mulf_neq0// ?polyC_eq0 ?invr_eq0 ?c0// q0.
- by rewrite -size_poly_eq0 size_XMa.
rewrite size_XMa size_mul_id ?polyC_eq0 ?invr_eq0 ?c0// ?q0//.
rewrite size_polyC invr_eq0 c0 add1n addnS addn1 //=.
move/eqP; rewrite eqSS; move/eqP; move/ihn=> ihnq.
case: (ihnq a)=> [|r [m ra0 Pq]]; first by rewrite q0.
exists ((c^-1)%:P * r); exists m.+1.
  by rewrite horner_lin mulf_neq0 // invr_eq0.
by rewrite Pq -!mulrA -exprSr.
Qed.

Lemma divpf_eq0 : forall p q, q != 0 -> (p %/ q == 0) = (size p < size q)%N.
Proof.
move=> p q q0; apply/idP/idP=> hpq; last by rewrite divp_size.
case p0: (p == 0); first by rewrite (eqP p0) size_poly0 lt0n size_poly_eq0.
case: (divp_spec p q); rewrite (eqP hpq) mul0r add0r=> hpmpq.
apply: leq_ltn_trans (modp_spec p _); rewrite // -hpmpq size_mul_id ?p0//.
   by rewrite size_polyC scalp_id //=.
by rewrite polyC_eq0 scalp_id.
Qed.

Lemma poly_divXMa : forall (a:R) (P : {poly R} -> Prop),
  (forall k, P k%:P) ->
  (forall p n k, p.[a] != 0 -> P p ->
    P (p * ('X - a%:P)^+(n.+1) + k%:P)%R)
  -> forall p, P p.
Proof.
move=> a P Pk Pq p.
move: {-2}p (leqnn (size p)); elim: (size p)=> {p} [|n ihn] p spn.
  move: spn; rewrite leqn0 size_poly_eq0; move/eqP->; rewrite -polyC0.
  exact: Pk.
case: (leqP (size p) 1)=> sp1; first by rewrite [p]size1_polyC ?sp1//.
case: (@divpf_spec p ('X - a%:P))=> ->.
set q := (_%:P * _); set c := (_%:P * _).
rewrite [c]size1_polyC; first last.
  rewrite (leq_trans (size_mul _ _))// size_polyC invr_eq0 scalp_id.
  rewrite addnC addn1 /= -ltnS (leq_trans (modp_spec _ _)) // ?size_XMa//.
  by rewrite -size_poly_eq0 size_XMa.
case: (@maxdivpf q a (mulf_neq0 _ _)).
- by rewrite polyC_eq0 invr_eq0 scalp_id.
- by rewrite divpf_eq0 -?size_poly_eq0 size_XMa// -leqNgt sp1.
move=> r [m ra0 hqr]; rewrite hqr -mulrA -exprSr.
apply: Pq=> //; apply: ihn.
rewrite (leq_trans (_ : size r <= size q)%N)//.
  have xam : ('X - a%:P) ^+ m != 0.
    elim:m {hqr}=>[|m ihm]; rewrite ?expr0 ?oner_eq0//.
    by rewrite exprS mulf_neq0// -size_poly_eq0 size_XMa.
  rewrite hqr size_mul_id //; last first.
    by move: ra0; apply: contra; move/eqP->; rewrite horner0.
  rewrite -[size (('X-_)^+_)]prednK; last by rewrite lt0n size_poly_eq0.
  by rewrite addnC leq_addl.
rewrite (leq_trans (size_mul _ _))// size_polyC invr_eq0 scalp_id //=.
by rewrite size_divp -?size_poly_eq0 size_XMa//= subn1 -ltnS (ltn_predK sp1).
Qed.

Lemma nth_root : forall x n, x > 0 -> exists2 y, y>0 & y^+(n.+1) = x.
Proof.
move=> x n l0x.
case: (ltrgtP x 1)=> hx; last by exists 1; rewrite ?hx ?ltr01// exp1rn.
  case: (@ivt ('X ^+ n.+1 - x%:P) 0 1); first by rewrite ler01.
    rewrite ?(horner_lin,horner_exp).
    by rewrite exprS mul0r sub0r exp1rn oppr_cp0 subr_ge0 ltrE// ltrE.
  move=> y; case/andP=> [l0y ly1]; rewrite /root ?(horner_lin,horner_exp).
  rewrite subr_eq0; move/eqP=> hyx; exists y=> //; rewrite ltr_neqAle l0y.
  rewrite eq_sym andbT; apply/eqP=> y0; move: hyx; rewrite y0.
  by rewrite exprS mul0r=> x0; move: l0x; rewrite -x0 lerr.
case: (@ivt ('X ^+ n.+1 - x%:P) 0 x); first by rewrite ltrE.
  rewrite ?(horner_lin,horner_exp) exprS mul0r sub0r.
  by rewrite oppr_cp0 subr_ge0 ltrE//= lef_exprS// ltrE.
move=> y; case/andP=> l0y lyx; rewrite /root ?(horner_lin,horner_exp).
rewrite subr_eq0; move/eqP=> hyx; exists y=> //; rewrite ltr_neqAle l0y.
rewrite eq_sym andbT; apply/eqP=> y0; move: hyx; rewrite y0.
by rewrite exprS mul0r=> x0; move: l0x; rewrite -x0 lerr.
Qed.

Lemma poly_cont : forall x p e, e > 0 -> exists2 d,
  d > 0 & forall y, |y - x| < d -> |p.[y] - p.[x]| < e.
Proof.
move=> x; elim/(@poly_divXMa x).
  move=> e ep; exists 1; rewrite ?ltr01// => y hy.
  by rewrite !hornerC subrr absr0.
move=> p n k pxn0 Pp e ep.
case: (Pp (|p.[x]|/2%:R)).
  by rewrite mulf_cp0p// -?invf_le0 ?gtf0Sn// absrE.
move=> d' d'p He'.
case: (@nth_root (e / ((3%:R/2%:R)*|p.[x]|)) n).
  by rewrite mulf_cp0p// -invf_le0 ?mulf_cp0p// -?invf_le0 ?gtf0Sn// absrE.
move=> d dp rootd.
exists (minr d d'); first by rewrite ltr_minr dp.
move=> y. rewrite ltr_minr. case/andP=> hxye hxye'.
move: (ler_lt_trans (subr_abs_le _ _) (He' _ hxye')).
rewrite ler_subr absr_opp.
rewrite (_:forall x, x / 2%:R + x = (3%:R / 2%:R)*x); last first.
  move=> a; apply/eqP; rewrite -(inj_eq (@mulfI _ 2%:R _))// ?charor//.
  rewrite mulr_addr mulrA mulrAC divff ?charor// -mulr_addl -{1}[1]mulr1n.
  by rewrite -natr_add add1n !mulrA [2%:R*_*_]mulrAC divff ?charor// mul1r.
move=> hpypx.
have:= (He' _ hxye'); rewrite addrC.
move/(ler_lt_trans (subr_abs_le _ _)).
rewrite absr_opp -subr_ge0 addrAC subr_ge0.
rewrite (_:forall x, x - x / 2%:R = x / 2%:R); last first.
  move=> a; apply/eqP.
  rewrite -(inj_eq (@mulfI _ 2%:R _))// ?charor//.
  rewrite mulr_addr mulrN mulrA mulrAC divff ?charor//.
  rewrite mulr_natl mul1r -subr_eq0 -addrA -oppr_add -{2}[a]mulr1n.
  by rewrite -mulrSr subrr.
move=> hpxpy.
rewrite !(horner_lin,horner_exp). rewrite subrr [0^+_]exprS mul0r mulr0 add0r.
rewrite -addrA subrr addr0 !absf_mul mulrC.
move: hxye; rewrite absf_exp (lef_expS2 n)// ?absrE//; last by rewrite ltrE.
rewrite -(@ltf_mulpr _ (|p.[y]|)); last first.
  apply: ler_lt_trans hpxpy; rewrite mulr_cp0p// ?absrE//.
  by rewrite -invf_ge0 ltrE// gtf0Sn.
move/ltr_trans=> -> //; rewrite rootd mulrC mulrA mulrAC -{1}[e]mul1r.
rewrite ltf_mulp// lef_divpr; first by rewrite mul1r.
by rewrite !mulf_cp0p// -?invf_le0 ?lt0fSn// ?absrE// gtf0Sn.
Qed.

Notation "a ^`( n )" := (derivn a n).
Notation "a ^`" := (deriv a).

Lemma derivPn : forall n p, (p ^+ n.+1)^` = (p^+n) * (p^`) *+ n.+1.
Proof.
elim=> [|n ihn] p; first by rewrite expr1 expr0 mul1r mulr1n.
by rewrite exprS deriv_mul ihn !mulrnAr mulrA -exprS mulrC -mulrS.
Qed.

Lemma deriv_opp: forall p, (-p)^` = -(p^`).
Proof.
move=> p; rewrite -mulN1r deriv_mul mulN1r.
by rewrite [-1]size1_polyC ?size_opp ?size_poly1// derivC mul0r add0r.
Qed.

Definition derivE :=  (derivC,derivX,deriv_amulX,deriv_mul,deriv_add,
  deriv_mulr,deriv_opp,derivXn,derivPn).

(* Lemma size_poly_ind : forall K : {poly R} -> Prop, *)
(*   K 0 ->  *)
(*   (forall p sp, size p = sp.+1 ->   *)
(*     forall q, (size q <= sp)%N -> K q -> K p) *)
(*   -> forall p, K p. *)
(* Proof. *)
(* move=> K K0 ihK p. *)
(* move: {-2}p (leqnn (size p)); elim: (size p)=> {p} [|n ihn] p spn. *)
(*   by move: spn; rewrite leqn0 size_poly_eq0; move/eqP->. *)
(* case spSn: (size p == n.+1). *)
(*   move/eqP:spSn; move/ihK=> ihKp; apply: (ihKp 0)=>//. *)
(*   by rewrite size_poly0. *)
(* by move:spn; rewrite leq_eqVlt spSn /= ltnS; by move/ihn.  *)
(* Qed. *)

(* Lemma size_poly_indW : forall K : {poly R} -> Prop, *)
(*   K 0 ->  *)
(*   (forall p sp, size p = sp.+1 ->   *)
(*     forall q, size q = sp -> K q -> K p) *)
(*   -> forall p, K p. *)
(* Proof. *)
(* move=> K K0 ihK p. *)
(* move: {-2}p (leqnn (size p)); elim: (size p)=> {p} [|n ihn] p spn. *)
(*   by move: spn; rewrite leqn0 size_poly_eq0; move/eqP->. *)
(* case spSn: (size p == n.+1). *)
(*   move/eqP:spSn; move/ihK=> ihKp; case: n ihn spn ihKp=> [|n] ihn spn ihKp. *)
(*     by apply: (ihKp 0)=>//; rewrite size_poly0. *)
(*   apply: (ihKp 'X^n)=>//; first by rewrite size_polyXn. *)
(*   by apply: ihn; rewrite size_polyXn. *)
(* by move:spn; rewrite leq_eqVlt spSn /= ltnS; by move/ihn.  *)
(* Qed. *)

Definition has_lt_roots_in p n a b :=
  forall (t : seq R), size t == n -> uniq t ->
    (forall x, x \in t -> (a < x < b) && (p.[x] == 0))
    -> p == 0.

Lemma poly_ltsp_roots : forall p a b, has_lt_roots_in p (size p) a b.
Proof.
rewrite /has_lt_roots_in.
move=> p; move: {-2}p (erefl (size p)); elim: (size p)=> {p} [|n ihn] p spSn.
  by move/eqP: spSn; rewrite size_poly_eq0; move/eqP->.
move=> a b t; rewrite spSn=> st /=.
case: t st=> // x s /=.
rewrite eqSS => ss /=; case/andP=> xins us hs.
move: (hs x); rewrite inE eqxx /= => hx.
case/andP: (hx is_true_true)=> haxb hpx.
case: (ltngtP (size p) 1)=> p1; first 2 last.
- by rewrite [p]size1_polyC ?p1// hornerC -polyC_eq0 -size1_polyC// p1 in hpx.
- by move: p1; rewrite ltnS leqn0 size_poly_eq0.
case: (divpf_spec p ('X - x%:P)).
move: (hpx); rewrite [_==_]root_factor_theorem=> dvdxp.
move: (dvdxp); rewrite /dvdp; move/eqP ->.
rewrite mulr0 addr0; set q : {poly R} := _*(_ %/ _)=> hpq.
rewrite hpq mulf_eq0 -[_-_==_]size_poly_eq0 size_XMa orbF.
have sqn : size q = n.
  rewrite size_mul_id.
  - rewrite size_polyC invr_eq0 scalp_id /=.
    by rewrite size_divp -?size_poly_eq0 size_XMa//= spSn subn1.
  - by rewrite -size_poly_eq0 size_polyC invr_eq0 scalp_id.
  - by rewrite divpf_eq0  -?size_poly_eq0 size_XMa//= -leqNgt.
apply: (ihn _ _ a b s)=> //; first by rewrite sqn.
move=> y yins.
case exy: (y == x); first by move: xins; rewrite -(eqP exy) yins.
have := (hs y); rewrite inE exy /= yins hpq.
rewrite horner_mul horner_add horner_opp hornerX hornerC mulf_eq0.
by rewrite subr_eq0 exy orbF=> hq; apply: hq.
Qed.

Lemma ivt_sign : forall (p : {poly R}) (a b : R),
  a <= b -> \s p.[a] * \s p.[b] == -1 -> exists2 x : R, a < x < b & root p x.
Proof.
move=> p a b hab.
rewrite muls_eqA// mulrN1; case/andP; move/eqP=> hpapb pb0.
case: (@ivt (((\s p.[b]) ?* 1)%:P *p) a b)=> //.
   rewrite -{1}hpapb !horner_lin -!smulr_mul !mul1r -smulNr.
   by rewrite -!absrP oppr_cp0 !absrE.
move=> c; case/andP=> lac lcb; rewrite /root.
rewrite !horner_lin mulf_eq0 smul1_eq0 (negPf pb0) /= => pc0.
exists c=> //. rewrite !ltr_neqAle lac lcb !andbT.
apply/andP; split.
  move: pb0; rewrite -hpapb -eqr_oppC oppr0; apply: contra.
  by move/eqP->; rewrite (eqP pc0) signr0.
by move: pb0; apply: contra; move/eqP<-; rewrite (eqP pc0) signr0.
Qed.

Lemma rolle_weak : forall a b p, a < b ->
  (p.[a] == 0) && (p.[b] == 0) ->
  exists2 c, a < c < b & (p^`.[c] == 0 \/ p.[c] == 0).
Proof.
move=> a b p lab; case/andP=> pa0 pb0.
case p0: (p == 0).
  rewrite (eqP p0); exists ((a+b)/2%:R); first exact: midf_lt.
  by left; rewrite derivC horner0 eqxx.
case: (@maxdivpf p a)=> [|p' []]; first by rewrite p0.
case; first by rewrite expr0 mulr1=> p'a0 pp'; rewrite -pp' pa0 in p'a0.
move=> n p'a0 hpp'.
case: (@maxdivpf p' b)=> [|q []].
  by move:p'a0; apply: contra; move/eqP->; rewrite hornerC.
case; first rewrite expr0 mulr1=> qb0 p'q.
  move: (pb0); rewrite hpp' p'q ?(horner_lin,horner_exp) mulf_eq0.
  by rewrite orbC expf_eq0 subr_eq0 eq_sym ltrWN// andbF orFb (negPf qb0).
move=> m qb0 hp'q; rewrite hpp' hp'q.
case: (inF3P (\s q.[a] * \s q.[b])); first 2 last.
- move/eqP=> sqasb; case: (@ivt_sign q a b)=> //; first exact: ltrW.
  move=> c lacb rqc; exists c=> //; right.
  by rewrite !(horner_lin,horner_exp) (eqP rqc) !mul0r.
- move/eqP; rewrite mulf_eq0 !signr_cp0 (negPf qb0) orbF; move/eqP=> qa0.
  by move: p'a0; rewrite hp'q ?(horner_lin,horner_exp) qa0 mul0r eqxx.
- move/eqP; rewrite muls_eqA// mulr1; case/andP; move/eqP=> sab sbn0.
  rewrite !derivE subr0 !mulr1 mulr_addl !exprS.
  set xan := (_^+n); set xbm := (_^+m).
  rewrite !mulrnAr !mulrA ![_*xbm]mulrC -!mulrA [q*_]mulrC -!mulrnAr.
  rewrite ![_*(_*xan)]mulrA ![_*xan]mulrC !mulrA [xbm*_]mulrC.
  rewrite -![(_*_)*_*_]mulrA [_*(q*+_)]mulrC -![(_*_)*_+(_*_)*_]mulr_addr.
  set r := _ + _ + _.
  case: (@ivt_sign (((\s q.[b]) ?* 1)%:P * r) a b); first exact: ltrW.
  rewrite !horner_mul !hornerC !signr_mul !signr_smul !signr1 !mulr1.
  rewrite mulrAC !mulrA mulss signr_cp0 qb0 mul1r.
  rewrite /r !horner_add !horner_mul.
  rewrite !horner_add !hornerX !horner_opp !hornerC.
  rewrite !subrr !(mul0r,mulr0,add0r,addr0).
  rewrite !horner_mulrn !signr_mul !signr_mulrn sab.
  rewrite mulrAC !mulrA mulss signr_cp0 qb0 mul1r.
  rewrite -oppr_sub signr_opp mulNr mulss signr_cp0.
  by rewrite subr_eq0 [b == _]eq_sym ltrE.
move=> c lacb; rewrite /root horner_mul hornerC mulf_eq0.
rewrite smul1_eq0 signr_cp0 (negPf qb0) orFb=> rc0.
by exists c=> //; left; rewrite !horner_mul !mulf_eq0 rc0 !orbT.
Qed.

Lemma rolle : forall a b p, a < b ->
  (p.[a] == 0) && (p.[b] == 0) ->
  exists2 c, a < c < b & (p^`.[c] == 0).
Proof.
move=> a b p lab; case/andP=> pa0 pb0.
have := @poly_ltsp_roots p a b.
elim: (size p) a b lab pa0 pb0=> [|n ihn] a b lab pa0 pb0 max_roots;
  first rewrite (eqP (@max_roots [::] _ _ _)) //=.
  by exists ((a+b)/2%:R); first exact: midf_lt; rewrite derivC horner0.
case: (@rolle_weak a b p); rewrite // ?pa0 ?pb0 //=.
move=> c; case/andP=>lac lcb [] pc0; first by exists c; rewrite // lac.
suff: exists2 d : R, a < d < c & (p^`).[d] == 0.
  case=> [d]; case/andP=> lad ldc p'd0.
  by exists d; rewrite // lad andTb (ltr_trans ldc).
apply: ihn=> //.
move=> t stn ut Pt; apply: (max_roots (c::t))=> //=.
  rewrite ut andbT; apply/negP=> cint.
  by move: (Pt c cint); rewrite lerr andbF.
move=> x; rewrite inE; case/orP; first by move/eqP->; rewrite lac lcb.
by move/Pt; case/andP; case/andP=> -> lxc ->; rewrite (ltr_trans  lxc).
Qed.

Lemma mvt : forall a b p, a < b ->
  exists2 c, a < c < b & p.[b] - p.[a] = p^`.[c] * (b - a).
Proof.
move=> a b p lab.
pose q := (p.[b] - p.[a])%:P*('X - a%:P) - (b - a)%:P*(p - p.[a]%:P).
case: (@rolle a b q)=> //.
  by rewrite /q !horner_lin !(subrr,mulr0) mulrC subrr eqxx.
move=> c lacb q'x0; exists c=> //.
move: q'x0; rewrite /q !derivE !(mul0r,add0r,subr0,mulr1).
by rewrite !horner_lin mulrC subr_eq0; move/eqP.
Qed.

Lemma deriv_sign : forall a b p,
  (forall x, a < x < b -> p^`.[x] >= 0)
  -> (forall x y, (a < x < b) && (a < y < b)
    ->  x < y -> p.[x] <= p.[y] ).
Proof.
move=> a b p Pab x y; case/and3P; case/andP=> lax lxb lay lyb lxy.
rewrite -subr_ge0; case: (@mvt x y p)=> //.
move=> c; case/andP=> lxc lcy ->; rewrite mulr_cp0p//.
  by rewrite Pab// (ltr_trans lax)// (ltr_trans lcy).
by rewrite subr_ge0 ltrE.
Qed.

(* Definition signs lp := *)
(*   let fix loop lp n := *)
(*     if n is n.+1 then *)

(*       else *)

End PolyReal.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__8__2.
Require Export lemma__ABCequalsCBA.
Require Export lemma__angleorderrespectscongruence.
Require Export lemma__angleorderrespectscongruence2.
Require Export lemma__betweennotequal.
Require Export lemma__collinear4.
Require Export lemma__collinearorder.
Require Export lemma__doublereverse.
Require Export lemma__equalanglessymmetric.
Require Export lemma__inequalitysymmetric.
Require Export lemma__lessthancongruence.
Require Export lemma__lessthancongruence2.
Require Export lemma__ray4.
Require Export lemma__rightangleNC.
Require Export logic.
Require Export proposition__16.
Require Export proposition__19.
Definition lemma__legsmallerhypotenuse : forall A B C, (euclidean__defs.Per A B C) -> ((euclidean__defs.Lt A B A C) /\ (euclidean__defs.Lt B C A C)).
Proof.
intro A.
intro B.
intro C.
intro H.
assert (* Cut *) (euclidean__defs.Per C B A) as H0.
- apply (@lemma__8__2.lemma__8__2 A B C H).
- assert (exists D, (euclidean__axioms.BetS C B D) /\ ((euclidean__axioms.Cong C B D B) /\ ((euclidean__axioms.Cong C A D A) /\ (euclidean__axioms.neq B A)))) as H1 by exact H0.
destruct H1 as [D H2].
destruct H2 as [H3 H4].
destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
assert (* Cut *) (euclidean__axioms.nCol A B C) as H9.
-- apply (@lemma__rightangleNC.lemma__rightangleNC A B C H).
-- assert (euclidean__axioms.Triangle A B C) as H10 by exact H9.
assert (* Cut *) (~(euclidean__axioms.Col A C B)) as H11.
--- intro H11.
assert (* Cut *) (euclidean__axioms.Col A B C) as H12.
---- assert (* Cut *) ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col B A C) /\ ((euclidean__axioms.Col A B C) /\ (euclidean__axioms.Col B C A))))) as H12.
----- apply (@lemma__collinearorder.lemma__collinearorder A C B H11).
----- destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
exact H19.
---- apply (@euclidean__tactics.Col__nCol__False A B C H10 H12).
--- assert (* Cut *) (euclidean__axioms.Triangle A C B) as H12.
---- apply (@euclidean__tactics.nCol__notCol A C B H11).
---- assert (* Cut *) ((euclidean__defs.LtA C A B A B D) /\ (euclidean__defs.LtA B C A A B D)) as H13.
----- apply (@proposition__16.proposition__16 A C B D H12 H3).
----- assert (* Cut *) (A = A) as H14.
------ destruct H13 as [H14 H15].
apply (@logic.eq__refl Point A).
------ assert (* Cut *) (C = C) as H15.
------- destruct H13 as [H15 H16].
apply (@logic.eq__refl Point C).
------- assert (* Cut *) (D = D) as H16.
-------- destruct H13 as [H16 H17].
apply (@logic.eq__refl Point D).
-------- assert (* Cut *) (~(B = C)) as H17.
--------- intro H17.
assert (* Cut *) (euclidean__axioms.Col A B C) as H18.
---------- right.
right.
left.
exact H17.
---------- apply (@H11).
-----------apply (@euclidean__tactics.not__nCol__Col A C B).
------------intro H19.
apply (@euclidean__tactics.Col__nCol__False A B C H10 H18).

--------- assert (* Cut *) (euclidean__axioms.neq B D) as H18.
---------- destruct H13 as [H18 H19].
assert (* Cut *) ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C D))) as H20.
----------- apply (@lemma__betweennotequal.lemma__betweennotequal C B D H3).
----------- destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
exact H21.
---------- assert (* Cut *) (euclidean__defs.Out B A A) as H19.
----------- destruct H13 as [H19 H20].
apply (@lemma__ray4.lemma__ray4 B A A).
------------right.
left.
exact H14.

------------ exact H8.
----------- assert (* Cut *) (euclidean__defs.Out B C C) as H20.
------------ destruct H13 as [H20 H21].
apply (@lemma__ray4.lemma__ray4 B C C).
-------------right.
left.
exact H15.

------------- exact H17.
------------ assert (* Cut *) (euclidean__defs.Out B D D) as H21.
------------- destruct H13 as [H21 H22].
apply (@lemma__ray4.lemma__ray4 B D D).
--------------right.
left.
exact H16.

-------------- exact H18.
------------- assert (* Cut *) (euclidean__axioms.Cong B A B A) as H22.
-------------- destruct H13 as [H22 H23].
apply (@euclidean__axioms.cn__congruencereflexive B A).
-------------- assert (* Cut *) (euclidean__axioms.Cong B D B C) as H23.
--------------- destruct H13 as [H23 H24].
assert (* Cut *) ((euclidean__axioms.Cong B D B C) /\ (euclidean__axioms.Cong B C B D)) as H25.
---------------- apply (@lemma__doublereverse.lemma__doublereverse C B D B H5).
---------------- destruct H25 as [H26 H27].
exact H26.
--------------- assert (* Cut *) (euclidean__axioms.Cong A D A C) as H24.
---------------- destruct H13 as [H24 H25].
assert (* Cut *) ((euclidean__axioms.Cong A D A C) /\ (euclidean__axioms.Cong A C A D)) as H26.
----------------- apply (@lemma__doublereverse.lemma__doublereverse C A D A H7).
----------------- destruct H26 as [H27 H28].
exact H27.
---------------- assert (* Cut *) (~(euclidean__axioms.Col A B D)) as H25.
----------------- intro H25.
assert (* Cut *) (euclidean__axioms.Col C B D) as H26.
------------------ right.
right.
right.
right.
left.
exact H3.
------------------ assert (* Cut *) (euclidean__axioms.Col D B C) as H27.
------------------- destruct H13 as [H27 H28].
assert (* Cut *) ((euclidean__axioms.Col B C D) /\ ((euclidean__axioms.Col B D C) /\ ((euclidean__axioms.Col D C B) /\ ((euclidean__axioms.Col C D B) /\ (euclidean__axioms.Col D B C))))) as H29.
-------------------- apply (@lemma__collinearorder.lemma__collinearorder C B D H26).
-------------------- destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
exact H37.
------------------- assert (* Cut *) (euclidean__axioms.Col D B A) as H28.
-------------------- destruct H13 as [H28 H29].
assert (* Cut *) ((euclidean__axioms.Col B A D) /\ ((euclidean__axioms.Col B D A) /\ ((euclidean__axioms.Col D A B) /\ ((euclidean__axioms.Col A D B) /\ (euclidean__axioms.Col D B A))))) as H30.
--------------------- apply (@lemma__collinearorder.lemma__collinearorder A B D H25).
--------------------- destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
exact H38.
-------------------- assert (* Cut *) (euclidean__axioms.neq B D) as H29.
--------------------- destruct H13 as [H29 H30].
assert (* Cut *) ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C D))) as H31.
---------------------- apply (@lemma__betweennotequal.lemma__betweennotequal C B D H3).
---------------------- destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
exact H18.
--------------------- assert (* Cut *) (euclidean__axioms.neq D B) as H30.
---------------------- destruct H13 as [H30 H31].
apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B D H29).
---------------------- assert (* Cut *) (euclidean__axioms.Col B C A) as H31.
----------------------- destruct H13 as [H31 H32].
apply (@euclidean__tactics.not__nCol__Col B C A).
------------------------intro H33.
apply (@euclidean__tactics.Col__nCol__False B C A H33).
-------------------------apply (@lemma__collinear4.lemma__collinear4 D B C A H27 H28 H30).

----------------------- assert (* Cut *) (euclidean__axioms.Col A B C) as H32.
------------------------ destruct H13 as [H32 H33].
assert (* Cut *) ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col A B C) /\ ((euclidean__axioms.Col B A C) /\ (euclidean__axioms.Col A C B))))) as H34.
------------------------- apply (@lemma__collinearorder.lemma__collinearorder B C A H31).
------------------------- destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
exact H39.
------------------------ apply (@H11).
-------------------------apply (@euclidean__tactics.not__nCol__Col A C B).
--------------------------intro H33.
apply (@euclidean__tactics.Col__nCol__False A B C H10 H32).

----------------- assert (* Cut *) (euclidean__defs.CongA A B D A B C) as H26.
------------------ exists A.
exists D.
exists A.
exists C.
split.
------------------- exact H19.
------------------- split.
-------------------- exact H21.
-------------------- split.
--------------------- exact H19.
--------------------- split.
---------------------- exact H20.
---------------------- split.
----------------------- exact H22.
----------------------- split.
------------------------ exact H23.
------------------------ split.
------------------------- exact H24.
------------------------- apply (@euclidean__tactics.nCol__notCol A B D H25).
------------------ assert (* Cut *) (euclidean__defs.CongA A B C A B D) as H27.
------------------- destruct H13 as [H27 H28].
apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric A B D A B C H26).
------------------- assert (* Cut *) (euclidean__defs.LtA B C A A B C) as H28.
-------------------- destruct H13 as [H28 H29].
apply (@lemma__angleorderrespectscongruence.lemma__angleorderrespectscongruence B C A A B D A B C H29 H27).
-------------------- assert (* Cut *) (euclidean__defs.Lt A B A C) as H29.
--------------------- destruct H13 as [H29 H30].
apply (@proposition__19.proposition__19 A B C H10 H28).
--------------------- assert (* Cut *) (euclidean__defs.LtA C A B A B C) as H30.
---------------------- destruct H13 as [H30 H31].
apply (@lemma__angleorderrespectscongruence.lemma__angleorderrespectscongruence C A B A B D A B C H30 H27).
---------------------- assert (* Cut *) (~(euclidean__axioms.Col B A C)) as H31.
----------------------- intro H31.
assert (* Cut *) (euclidean__axioms.Col A B C) as H32.
------------------------ destruct H13 as [H32 H33].
assert (* Cut *) ((euclidean__axioms.Col A B C) /\ ((euclidean__axioms.Col A C B) /\ ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col B C A) /\ (euclidean__axioms.Col C A B))))) as H34.
------------------------- apply (@lemma__collinearorder.lemma__collinearorder B A C H31).
------------------------- destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
exact H35.
------------------------ apply (@H11).
-------------------------apply (@euclidean__tactics.not__nCol__Col A C B).
--------------------------intro H33.
apply (@euclidean__tactics.Col__nCol__False A B C H10 H32).

----------------------- assert (* Cut *) (euclidean__defs.CongA B A C C A B) as H32.
------------------------ destruct H13 as [H32 H33].
apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA B A C).
-------------------------apply (@euclidean__tactics.nCol__notCol B A C H31).

------------------------ assert (* Cut *) (euclidean__defs.LtA B A C A B C) as H33.
------------------------- destruct H13 as [H33 H34].
apply (@lemma__angleorderrespectscongruence2.lemma__angleorderrespectscongruence2 C A B A B C B A C H30 H32).
------------------------- assert (* Cut *) (~(euclidean__axioms.Col C B A)) as H34.
-------------------------- intro H34.
assert (* Cut *) (euclidean__axioms.Col A B C) as H35.
--------------------------- destruct H13 as [H35 H36].
assert (* Cut *) ((euclidean__axioms.Col B C A) /\ ((euclidean__axioms.Col B A C) /\ ((euclidean__axioms.Col A C B) /\ ((euclidean__axioms.Col C A B) /\ (euclidean__axioms.Col A B C))))) as H37.
---------------------------- apply (@lemma__collinearorder.lemma__collinearorder C B A H34).
---------------------------- destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
exact H45.
--------------------------- apply (@H11).
----------------------------apply (@euclidean__tactics.not__nCol__Col A C B).
-----------------------------intro H36.
apply (@euclidean__tactics.Col__nCol__False A B C H10 H35).

-------------------------- assert (* Cut *) (euclidean__axioms.Triangle C B A) as H35.
--------------------------- apply (@euclidean__tactics.nCol__notCol C B A H34).
--------------------------- assert (* Cut *) (euclidean__defs.CongA C B A A B C) as H36.
---------------------------- destruct H13 as [H36 H37].
apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA C B A H35).
---------------------------- assert (* Cut *) (euclidean__defs.LtA B A C C B A) as H37.
----------------------------- destruct H13 as [H37 H38].
apply (@lemma__angleorderrespectscongruence.lemma__angleorderrespectscongruence B A C A B C C B A H33 H36).
----------------------------- assert (* Cut *) (euclidean__defs.Lt C B C A) as H38.
------------------------------ destruct H13 as [H38 H39].
apply (@proposition__19.proposition__19 C B A H35 H37).
------------------------------ assert (* Cut *) (euclidean__axioms.Cong C B B C) as H39.
------------------------------- destruct H13 as [H39 H40].
apply (@euclidean__axioms.cn__equalityreverse C B).
------------------------------- assert (* Cut *) (euclidean__defs.Lt B C C A) as H40.
-------------------------------- destruct H13 as [H40 H41].
apply (@lemma__lessthancongruence2.lemma__lessthancongruence2 C B C A B C H38 H39).
-------------------------------- assert (* Cut *) (euclidean__axioms.Cong C A A C) as H41.
--------------------------------- destruct H13 as [H41 H42].
apply (@euclidean__axioms.cn__equalityreverse C A).
--------------------------------- assert (* Cut *) (euclidean__defs.Lt B C A C) as H42.
---------------------------------- destruct H13 as [H42 H43].
apply (@lemma__lessthancongruence.lemma__lessthancongruence B C C A A C H40 H41).
---------------------------------- split.
----------------------------------- exact H29.
----------------------------------- exact H42.
Qed.


Require Import SetoidClass.
Require Import Views.BasicSetoids.
Require Import Views.Setof.
Require Import Views.Tactics.
Require Import Views.EquivalenceClasses.
Require Import Views.Inhabited.

Section TPRStructures.
  Context {A} `{A_setoid : Setoid A}.
  Context (op : A -> A -> A -> Prop).

  Class CTPRRespectful :=
    {
      tpr_morph :> Proper (equiv ==> equiv ==> equiv ==> Basics.impl) op
    }.

  Section TPRRespectfulIff.
    Context `{CTPRRespectful}.
    Program Instance tpr_iff_morph :
       Proper (equiv ==> equiv ==> equiv ==> iff) op.
    Obligation 1.
     repeat intro; split; rewr auto.
    Qed.
  End TPRRespectfulIff.
  Existing Instance tpr_iff_morph.

  Class CTPRAssociative :=
    {
      assoc_assoc_l : forall x y z xyz xy, op x y xy -> op xy z xyz ->
           exists yz, op y z yz /\ op x yz xyz;
      assoc_assoc_r : forall x y z xyz yz, op y z yz -> op x yz xyz ->
           exists xy, op x y xy /\ op xy z xyz
    }.

  Class CTPRCommutative :=
    {
      comm_commut :> forall x y xy, op x y xy -> op y x xy
    }.

  Class CTPRAssociativeCommutative :=
    {
      ac_assoc : forall x y z xyz xy, op x y xy -> op xy z xyz ->
           exists yz, op y z yz /\ op x yz xyz;
      ac_commut :> CTPRCommutative
    }.

  Section AssociativeCommutativeIsAssociative.
    Context `{CTPRAssociativeCommutative}.
    Program Instance assoccomm_is_assoc : CTPRAssociative.
    Hint Resolve ac_assoc.
    Hint Resolve comm_commut.
    Obligation 1.
     eauto.
    Qed.
    Obligation 2.
     apply comm_commut in H0.
     apply comm_commut in H1.
     destruct (ac_assoc _ _ _ _ _ H0 H1) as [x0].
     exists x0.
     intuition.
    Qed.
  End AssociativeCommutativeIsAssociative.

  Class CTPRFunctional :=
    {
      func_functional :> forall x y xy xy', op x y xy -> op x y xy' ->
                 xy == xy'
    }.

  Class CTPRTotal :=
    {
      tot_total :> forall x y, exists xy, op x y xy
    }.

  Class CTPRTotalRespectfulFunction :=
    {
      trf_total :> CTPRTotal;
      trf_respectful :> CTPRRespectful;
      trf_functional :> CTPRFunctional
    }.

  Section UnitSet.
    Context (unit : Setof A).
    Class CTPRLeftUnit :=
     {
      lunit_exists : forall a, exists i, i ∈ unit /\ op i a a;
      lunit_min : forall i a b, i ∈ unit -> op i a b -> a == b
     }.

    Class CTPRRightUnit :=
     {
      runit_exists : forall a, exists i, i ∈ unit /\ op a i a;
      runit_min : forall i a b, i ∈ unit -> op a i b -> a == b
     }.

    Class CTPRTwoSidedUnit :=
     {
      tsu_lunit :> CTPRLeftUnit;
      tsu_runit :> CTPRRightUnit
     }.
  End UnitSet.

  Section RespectfulFunctional.
  Context `{op_resp : CTPRRespectful} `{op_func : CTPRFunctional}.
  Section UniqueUnit.
    Context (unit : A).
    Class CTPRUniqueLeftUnit :=
     {
      ulunit :> forall a, op unit a a
     }.
    Hint Resolve ulunit.
    Instance ULU_LU `{CTPRUniqueLeftUnit} : CTPRLeftUnit (singleton unit).
      split; intuition.
      exists unit; intuition.
      eexists; split; reflexivity.
      eapply func_functional; eauto.
      singleel; rewr auto.
    Qed.

    Class CTPRUniqueRightUnit :=
     {
      urunit :> forall a, op a unit a
     }.
    Hint Resolve urunit.
    Instance URU_RU `{CTPRUniqueRightUnit} : CTPRRightUnit (singleton unit).
      split; intuition.
      exists unit; intuition.
      eexists; split; reflexivity.
      eapply func_functional; eauto.
      singleel; rewr auto.
    Qed.
  End UniqueUnit.
  Class CTPRLeftUniquelyUnital : Prop :=
    {
     the_ulunit : A;
     the_ulunit_is_unit : CTPRUniqueLeftUnit the_ulunit
    }.
  End RespectfulFunctional.
  Section TotalRespectful.
      Context `{op_total : CTPRTotal} `{op_resp : CTPRRespectful}.
      Context `{Ainh : Inhabited A}.
      Context (unit : Setof A) `{LU : CTPRLeftUnit unit}.
      Instance LU_ULU : CTPRLeftUniquelyUnital.
       inversion Ainh.
       destruct (lunit_exists unit inhabitant) as [i].
       exists i.
       constructor; intro.
       destruct (tot_total i a) as [b].
       generalize (lunit_min unit i a b); intuition.
       ssubst; trivial.
      Qed.
   End TotalRespectful.

End TPRStructures.
Existing Instance assoccomm_is_assoc.

    Ltac tpr_assoc :=
      match goal with
       | [ H1 : ?R ?y ?z ?yz, H2 : ?R ?x ?yz ?xyz |- _] =>
           lazymatch goal with
           | [ _ : R x y ?xy, _ : R ?xy z xyz |- _] => fail
           | _ => let H := fresh in assert
                       (H : exists xy, R x y xy /\ R xy z xyz) by
                           (apply assoc_assoc_r with yz; auto with *);
                       let xy := fresh x y in destruct H as [xy H]; destruct H
                  end
       | [ H1 : ?R ?x ?y ?xy, H2 : ?R ?xy ?z ?xyz |- _] =>
           lazymatch goal with
           | [ _ : R y z ?yz, _ : R x ?yz xyz |- _] => fail
           | _ => let H := fresh in assert
                       (H : exists yz, R y z yz /\ R x yz xyz) by
                           (apply assoc_assoc_l with xy; auto with *);
                       let yz := fresh y z in destruct H as [yz H]; destruct H
                  end end.

    Ltac tpr_func :=
      match goal with
       | [ H1 : ?R ?x ?y ?z, H2 : ?R ?x ?y ?z0 |- _ ] =>
            lazymatch goal with
              | [_ : z == z0 |- _] => fail
              | _ => let H := fresh in assert (z == z0) as H by
                  (eapply func_functional; eauto with *) end
              end.

Section TPROptionTotal.

  Context {A} `{A_setoid : Setoid A}.
  Context (op : A -> A -> A -> Prop).

  Hypothesis choose_op : forall a b,
    (exists c, op a b c) \/ (~exists c, op a b c).

  Notation "? A" := (option A) (at level 0).
  (* Remark: option type is a setoid in BasicSetoids. *)

  Notation "! a" := (Some a) (at level 0).
  Inductive opt_tprlift :  ? A -> ? A -> ? A -> Prop :=
    | opt_tprbasic : forall a b c, op a b c -> opt_tprlift !a !b !c
    | opt_tprlnone : forall x, opt_tprlift None x None
    | opt_tprrnone : forall x, opt_tprlift x None None
    | opt_tprundef : forall a b, (forall c, ~ op a b c) ->
       opt_tprlift !a !b None.
   Hint Constructors opt_tprlift.

  Ltac optlift_tac :=
    try constructor; repeat intro;
    repeat (match goal with [x : option A |- _] => destruct x end);
    simpl in *;
    repeat (match goal with [H : opt_tprlift _ _ _ |- _] => inversion H; subst; clear H; auto with * end).

  Lemma opt_trplift_spec : forall x y z, op x y z <-> opt_tprlift !x !y !z.
   intuition.
   inversion H; subst; auto.
  Qed.

  Instance opt_trplift_total : CTPRTotal opt_tprlift.
    optlift_tac; try solve [exists None; constructor].

    destruct (choose_op a0 a).
     destruct H.
     exists !x; constructor; trivial.

     exists None.
     constructor.
     intro.
     contradict H.
     exists c; trivial.
  Qed.

  Section Respectful.
    Context {op_respectful : CTPRRespectful op}.
    Instance opt_tprlift_respectful : CTPRRespectful opt_tprlift.
     optlift_tac; constructor; try rewr auto.
      intro.
      use_foralls; rewr auto.
    Qed.
  End Respectful.

  Section Functional.
    Context {op_functional : CTPRFunctional op}.
    Instance opt_tprlift_functional : CTPRFunctional opt_tprlift.
      optlift_tac; firstorder.
    Qed.
  End Functional.

  Section Associative.
    Context {op_assoc : CTPRAssociative op}.
    Context {op_respectful : CTPRRespectful op}.
    Context {op_functional : CTPRFunctional op}.
    Hint Resolve assoc_assoc_l.
    Hint Resolve assoc_assoc_r.
    Instance opt_tprlift_associative : CTPRAssociative opt_tprlift.
      optlift_tac;
      try (solve [try tpr_assoc;
      eexists; split; constructor; eauto]);
      match goal with
       | |- context [ opt_tprlift (Some ?x) (Some ?y) _ ] =>
       destruct (choose_op x y);
       (splitup; eexists; split; constructor; eauto) ||
       (exists None; split; constructor; firstorder)
      end;
      repeat intro; tpr_assoc; try tpr_func;
      match goal with
       | H : forall _, ~ _ |- _ => eapply H; rewr eauto end.
    Qed.
  End Associative.

  Section Commutative.
    Context {op_commut : CTPRCommutative op}.
    Hint Resolve (comm_commut op).
    Instance opt_tprlift_commutative : CTPRCommutative opt_tprlift.
      optlift_tac; constructor; auto.
      intros; use_foralls; auto.
    Qed.
  End Commutative.

  (* The option lift does not preserve arbitrary unit sets,
     but it does preserve unique units. *)
  Section LeftUniqueUnit.
    Context unit {op_luunit : CTPRUniqueLeftUnit op unit}.
    Definition oplift_ulunit := !(unit).
    Hint Resolve (ulunit op).
    Program Instance opt_tprlift_uleftunit :
          CTPRUniqueLeftUnit opt_tprlift oplift_ulunit.
    Obligation 1.
     destruct a; constructor; auto.
    Qed.
  End LeftUniqueUnit.

  Section RightUniqueUnit.
    Context unit {op_ruunit : CTPRUniqueRightUnit op unit}.
    Definition oplift_urunit := !(unit).
    Hint Resolve (urunit op).
    Program Instance opt_tprlift_urightunit :
          CTPRUniqueRightUnit opt_tprlift oplift_urunit.
    Obligation 1.
     destruct a; constructor; auto.
    Qed.
  End RightUniqueUnit.
End TPROptionTotal.

Section TPRAddUnit.

  Context {A} `{A_setoid : Setoid A}.

  Inductive united :=
  | un_unit : united
  | un_some : A -> united.

  Notation "¹" := united.

  Coercion un_some : A >-> united.

  Inductive united_eq : united -> united -> Prop :=
  | uneq_unit : united_eq un_unit un_unit
  | uneq_some : forall a a', a == a' ->
          united_eq (un_some a) (un_some a').
  Hint Constructors united_eq.

  Ltac united_tac :=
   repeat match goal with
     | x : united |- _ => destruct x
     | H : united_eq _ _ |- _ => inversion_clear H
     | |- united_eq _ _ => constructor
     | |- @equiv united _ _ _ => constructor
     | H : @equiv united _ _ _ |- _ => inversion_clear H
     end.

  Program Instance united_setoid : Setoid united := {| equiv := united_eq |}.
  Obligation 1.
   split; repeat intro;
   united_tac; rewr intuition.
  Qed.

  Instance un_some_resp : Proper (equiv ==> equiv) un_some.
   repeat intro; united_tac; auto.
  Qed.

  Instance united_inhabited : StronglyInhabited united.
   firstorder.
  Qed.

  Context (op : A -> A -> A -> Prop).

  Inductive unop : ¹ -> ¹ -> ¹ -> Prop :=
   | unop_lift : forall a b c, op a b c -> unop a b c
   | unop_lunit : forall a a' : A, a == a' -> unop un_unit a a'
   | unop_runit : forall a a' : A, a == a' -> unop a un_unit a'
   | unop_uunit : unop un_unit un_unit un_unit.
  Hint Constructors unop.

  Ltac unop_tac := united_tac;
   repeat match goal with
     | H : unop _ _ _ |- _ => inversion_clear H
     end; auto.

  Lemma unop_spec : forall a b c, op a b c <-> unop a b c.
   intuition.
   inversion H; subst; trivial.
  Qed.

  Section Respectful.
    Context {op_respectful : CTPRRespectful op}.
    Instance unop_respectful : CTPRRespectful unop.
      split; repeat intro.
      unop_tac;
      constructor; rewr auto.
    Qed.
  End Respectful.
  Section Total.
    Context {op_total : CTPRTotal op}.
    Instance unop_total : CTPRTotal unop.
     split; repeat intro.
     unop_tac; try (solve [eexists; constructor; reflexivity]).
     destruct (tot_total op a0 a).
     eexists; eauto.
    Qed.
  End Total.
  Section Functional.
    Context {op_functional : CTPRFunctional op}.

    Instance unop_functional : CTPRFunctional unop.
     split; repeat intro; unop_tac; rewr firstorder.
    Qed.
  End Functional.

  Instance unop_ulunit : CTPRUniqueLeftUnit unop un_unit.
   firstorder; unop_tac; firstorder.
  Qed.
  Instance unop_urunit : CTPRUniqueRightUnit unop un_unit.
   firstorder; unop_tac; firstorder.
  Qed.
  Hint Resolve (ulunit unop).
  Hint Resolve (urunit unop).

  Section Associative.
    Context {op_respectful : CTPRRespectful op}.
    Context {op_associative : CTPRAssociative op}.
    Instance unop_associative : CTPRAssociative unop.
     split; repeat intro;
     unop_tac; repeat tpr_assoc;
     eexists; firstorder; constructor; rewr eauto.
    Qed.
  End Associative.

  Section Commutative.
    Context {op_commutative : CTPRCommutative op}.
    Instance unop_commutative : CTPRCommutative unop.
     firstorder; unop_tac; firstorder.
    Qed.
  End Commutative.
End TPRAddUnit.

Section FStructures.
  Context {A} `{A_setoid : Setoid A}.
  Context (op : A -> A -> A).
  Local Infix "*" := op.

  Class CFRespectful  :=
    {
      fop_morph :> Proper (equiv ==> equiv ==> equiv) op
    }.

  Class CFAssociative  :=
    {
      fop_assoc : forall x y z : A, (x * y) * z == x * (y * z)
    }.

  Class CFCommutative :=
    {
      fop_comm : forall x y : A, x * y == y * x
    }.

  Class CFLeftUnit (unit : A) :=
    {
      fop_lunit : forall x : A, unit * x == x
    }.

  Class CFRightUnit (unit : A) :=
    {
      fop_runit : forall x : A, x * unit == x
    }.
  Class CFUnit (unit : A) :=
    {
      fop_unit_left :> CFLeftUnit unit;
      fop_unit_right :> CFRightUnit unit
    }.

End FStructures.
Existing Instance fop_unit_left.
Existing Instance fop_unit_right.
Existing Instance fop_morph.

Section ECLift.
  Context
     {A} `{op_trf : CTPRTotalRespectfulFunction A}.
  Hint Resolve trf_total.
  Hint Resolve trf_respectful.
  Hint Resolve trf_functional.
  Section ECLiftParts.
    Context (x y : EC A).
    Definition op_lift_set : Setof A :=
      mkSetof (fun Z =>
           exists X, exists Y,
            X ∈ x /\ Y ∈ y /\ op X Y Z).

    Lemma op_lift_witness :
      exists w, forall x, x ∈ op_lift_set <-> x == w.
    simpl.
    destruct x as [sx wx].
    destruct wx as [X H].
    destruct y as [sy wy].
    destruct wy as [Y H0].
    destruct (tot_total op X Y) as [XY H1].
    simpl.
    exists XY.
    intuition.
     repeat destruct H2; intuition.
     apply func_functional with op X Y; eauto.

     use_foralls; intuition; rewr trivial.

     exists XY; intuition.
     use_foralls.
     eexists; eexists; intuition; eauto.
    Qed.
    Definition op_lift : EC A :=
      {| ec_set := op_lift_set;
         ec_witness := op_lift_witness |}.
  End ECLiftParts.

  Instance op_lift_resp :
     CFRespectful op_lift.
   split; simpl; repeat intro.
   split; intuition;
    destruct H1; repeat splitup;
    eexists; split; eauto;
    eexists; eexists; repeat split; eauto;
    rewr trivial.
  Qed.

  Lemma op_lift_spec : forall x y z, op x y z <-> (op_lift (make_EC x) (make_EC y)) z.
   simpl; intuition.
   eexists; intuition (try reflexivity).
   eexists; eexists; intuition eauto; eexists; split; reflexivity.

   repeat splitup; rewr auto.
  Qed.

  Section ECLiftAssociative.
    Context {op_ass : CTPRAssociative op}.

    Instance op_lift_ass :
      CFAssociative op_lift.
     constructor; split;
     simpl; intros; repeat splitup;
     repeat ssubst; tpr_assoc;
     eexists; repeat split; try reflexivity;
     eexists; eexists; repeat split; eauto;
     eexists; intuition; try reflexivity;
     eexists; eauto.
    Qed.
  End ECLiftAssociative.

  Section ECLiftCommutative.
    Context {op_comm : CTPRCommutative op}.
    Hint Resolve (comm_commut op).
    Instance op_lift_comm : CFCommutative op_lift.
     constructor; intros.
     split; simpl; intro;
      repeat splitup; ssubst;
      eexists; repeat split; try reflexivity;
      eexists; eexists; repeat split; eauto.
   Qed.
  End ECLiftCommutative.

  Section ECLiftUnit.
    Context `{A_Inhabited : Inhabited A}.
    Context (unit : Setof A) {op_unit : CTPRTwoSidedUnit op unit}.
    Program Definition ECl_unit : EC A := {| ec_set := unit |}.
    Obligation 1.
     destruct A_Inhabited.
     destruct (lunit_exists op unit inhabitant).
     exists x.
     intuition.
     destruct (tot_total op x x0).
     assert (x0 == x1) by (apply lunit_min with op unit x; auto with *).
     assert (x == x1) by (apply runit_min with op unit x0; auto with *).
     rewr auto.

     rewr auto.
    Qed.
    Instance op_lift_unit : CFUnit op_lift ECl_unit.
     repeat constructor; simpl; intros.
      destruct H; repeat splitup.
      rewrite <- (lunit_min op unit);
      eauto.
      rewr auto.

      exists a; firstorder.

      destruct H; repeat splitup.
      rewrite <- (runit_min op unit);
      rewr eauto.

      exists a; firstorder.
    Qed.
  End ECLiftUnit.
End ECLift.

Existing Instance op_lift_resp.
Existing Instance op_lift_ass.
Existing Instance op_lift_comm.


Require Import List.
Import ListNotations.

(* Borrow from CompCert *)
Require Import Cryptol.Coqlib.
Require Import Cryptol.Bitvectors.

Require Import Cryptol.AST.
Require Import Cryptol.Semantics.
Require Import Cryptol.Utils.
Require Import Cryptol.Builtins.
Require Import Cryptol.BuiltinSem.
Require Import Cryptol.BuiltinSyntax.
Require Import Cryptol.Values.
Require Import Cryptol.Bitstream.
Require Import Cryptol.Lib.
Require Import Cryptol.GlobalExtends.
Require Import Cryptol.GetEachN.

Require Import Cryptol.EvalTac.
Require Import Cryptol.Eager.

Require Import Cryptol.Prims.
Require Import SHA256.SHA256.

Definition w32 := tseq 32 tbit.

Definition Maj_spec (x y z : ext_val) : ext_val :=
  match x,y,z with
  | eseq x, eseq y, eseq z =>
    eseq (xor_ev (xor_ev (and_ev x y) (and_ev x z)) (and_ev y z))
  | _,_,_ => eseq nil
  end.

Lemma Maj_eval :
  forall x y z,
    has_type x w32 ->
    has_type y w32 ->
    has_type z w32 ->
    forall GE TE SE,
      wf_env ge GE TE SE ->
      forall ex ey ez res,
        eager_eval_expr GE TE SE ex (to_sval x) ->
        eager_eval_expr GE TE SE ey (to_sval y) ->
        eager_eval_expr GE TE SE ez (to_sval z) ->
        res = (to_sval (Maj_spec x y z)) ->
        eager_eval_expr GE TE SE (EApp (EApp (EApp (EVar Maj) ex) ey) ez) res.
Proof.
  intros. subst res.
  gen_global Maj.
  gen_global (28,"^").
  gen_global (26,"&&").
  e. e. e. ag.
  e. e. e.
  unfold w32 in *.
  inversion H. inversion H0. inversion H1. subst.
  use xor_eval. use xor_eval.
  use and_eval; try lv; try reflexivity; try eassumption.
  use and_eval; try lv; try reflexivity; try eassumption.
  reflexivity. eapply has_type_and; eauto.
  eapply has_type_and; eauto.
  use and_eval; try lv; try reflexivity; try eassumption.
  simpl. reflexivity.
  eapply has_type_xor.
  eapply has_type_and. eassumption.
  eassumption.
  eapply has_type_and; eassumption.
  eapply has_type_and; eassumption.
Qed.


Require Export P01.

(** **** Exercise: 2 stars (if_minus_plus)  *)
(** Prove the following hoare triple using [hoare_if_wp]: *)

Theorem if_minus_plus :
  {{fun st => True}}
  IFB (BLe (AId X) (AId Y))
    THEN (Z ::= AMinus (AId Y) (AId X))
    ELSE (Y ::= APlus (AId X) (AId Z))
  FI
  {{fun st => st Y = st X + st Z}}.
Proof.
  eapply hoare_consequence_pre.
  - apply hoare_if_wp.
    + (* THEN *)
      apply hoare_asgn.
    + (* ELSE *)
      apply hoare_asgn.
  - intros st H. simpl. split.
    + intros Htrue. apply leb_complete in Htrue.
      unfold assn_sub, t_update, beq_id. simpl.
      apply le_plus_minus. assumption.
    + intros Hfalse. unfold assn_sub, t_update, beq_id. reflexivity.
Qed.


Require Import Coq.Arith.EqNat.
Require Import Coq.Structures.Equalities.
Require Import Coq.Lists.List.
Require Import Coq.MSets.MSetInterface.
Require Import Coq.MSets.MSetWeakList.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Program.Equality.
Require Import Coq.Arith.PeanoNat.
Require Import MSetProperties.
Require Import Coq.Init.Specif.

Module TLC
       (Import VarTyp : BooleanDecidableType')
       (Import set : MSetInterface.S).

Module EqFacts := BoolEqualityFacts(VarTyp).

Module M := MSetWeakList.Make(VarTyp).
Export M.

Module MSetProperties := WPropertiesOn(VarTyp)(M).

Inductive STyp :=
  | STUnitT : STyp
  | STInt : STyp
  | STFun : STyp -> STyp -> STyp
  | STTuple : STyp -> STyp -> STyp.

Inductive SExp (A : Type) :=
  | STFVar  : A -> SExp A
  | STBVar  : nat -> SExp A
  | STUnit  : SExp A
  | STLit   : nat -> SExp A
  | STLam   : STyp -> SExp A -> SExp A
  | STLam'  : SExp A -> SExp A
  | STApp   : SExp A -> SExp A -> SExp A
  | STPair  : SExp A -> SExp A -> SExp A
  | STProj1 : SExp A -> SExp A
  | STProj2 : SExp A -> SExp A.

Definition Exp := forall A, SExp A.

Definition var : Type := VarTyp.t.

Definition vars := M.t.

(** Definitions borrowed from STLC_Tutorial **)

(* Contexts *)
Definition context (A : Type) := list (var * A).

Definition extend {A} (x : var) (a : A) (c : context A) : context A :=
  ((x,a) :: nil) ++ c.

Definition dom {A} (c : context A) : vars :=
  fold_right (fun el r => add (fst el) r) empty c.

(* Functions on contexts *)
Definition mapctx {A B} (f : A -> B) (c : context A) : context B :=
  map (fun p => (fst p, (f (snd p)))) c.

Lemma cons_to_push : forall {A} x v (E : context A),
  (x, v) :: E = extend x v E.
Proof. intros; unfold extend; simpl; reflexivity. Defined.

Lemma env_ind : forall {A} (P : context A -> Prop),
  (P nil) ->
  (forall E x v, P E -> P (extend x v E)) ->
  (forall E, P E).
Proof.
  unfold extend.
  induction E as [|(x,v)].
  assumption.
  pose (H0 _ x v IHE).
  now simpl in p.
Defined.

Lemma dom_map_id : forall (A B : Type) (E : context A) (f : A -> B),
  dom E = dom (mapctx f E).
Proof.
  unfold mapctx.
  intros.
  induction E.
  simpl; reflexivity.
  simpl in *.
  rewrite IHE.
  reflexivity.
Defined.

Lemma dom_union : forall (A : Type) (E G : context A) x,
  M.In x (dom (E ++ G)) <-> M.In x (M.union (dom E) (dom G)).
Proof.
  intros. generalize dependent G.
  induction E; intros.
  unfold dom at 2; simpl.
  unfold "<->".
  split; intros.
  apply MSetProperties.Dec.F.union_3.
  assumption.
  apply MSetProperties.Dec.F.union_1 in H.
  inversion H.
  inversion H0.
  assumption.
  simpl.
  destruct a.
  split; intros.
  simpl in *.
  assert (Ha : sumbool (VarTyp.eq v x) (not( VarTyp.eq v x))) by apply VarTyp.eq_dec.
  destruct Ha.
  apply MSetProperties.Dec.F.union_2.
  apply MSetProperties.Dec.F.add_iff.
  auto.
  rewrite (MSetProperties.Dec.F.add_neq_iff _ n) in H.
  assert (Ha : M.Equal (M.union (M.add v (dom E)) (dom G)) (M.add v (M.union (dom E) (dom G)))) by apply MSetProperties.union_add.
  apply Ha.
  apply IHE in H.
  unfold not in n.
  apply MSetProperties.Dec.F.add_2.
  assumption.
  simpl in *.
  apply MSetProperties.Dec.F.union_1 in H.
  destruct H.
  assert (Ha : sumbool (VarTyp.eq v x) (not( VarTyp.eq v x))) by apply VarTyp.eq_dec.
  destruct Ha.
  apply MSetProperties.Dec.F.add_iff; auto.
  rewrite (MSetProperties.Dec.F.add_neq_iff _ n) in H.
  apply MSetProperties.Dec.F.add_neq_iff; auto.
  apply IHE.
  apply MSetProperties.Dec.F.union_2; assumption.
  apply MSetProperties.Dec.F.add_iff.
  right.
  apply IHE.
  apply MSetProperties.Dec.F.union_3; assumption.
Defined.

Lemma list_impl_m : forall {A} Gamma x (v : A), List.In (x, v) Gamma -> M.In x (dom Gamma).
Proof.
  intros.
  induction Gamma.
  inversion H.
  simpl.
  destruct a.
  simpl in *.
  inversion H.
  apply MSetProperties.Dec.F.add_1.
  apply f_equal with (f := fst) in H0.
  simpl in H0.
  rewrite H0.
  reflexivity.
  apply MSetProperties.Dec.F.add_2.
  apply IHGamma; assumption.
Defined.

Ltac not_in_L x :=
  repeat rewrite dom_union; repeat rewrite M.union_spec;
  repeat match goal with
    | H: M.In x M.empty |- _ => inversion H
    | H:_ |- context [M.In x (dom nil)] => simpl
    | H:_ |- context [M.In x (dom ((?v, ?t) :: ?l))] => simpl; rewrite MSetProperties.Dec.F.add_iff
    | H: _ |- context [M.In ?v (dom ((x, ?t) :: ?l))] => simpl; rewrite MSetProperties.Dec.F.add_iff
    | H1: ~ ?l, H2: ?l |- _ => contradiction
    | H: ~ M.In ?y (M.singleton x) |- not (VarTyp.eq x ?y) => rewrite MSetProperties.Dec.F.singleton_iff in H; assumption
    | H: ~ M.In x (M.singleton ?y) |- not (VarTyp.eq x ?y) => rewrite MSetProperties.Dec.F.singleton_iff in H; unfold not; intros; apply H; symmetry; assumption
    | H: ~ M.In x (M.add ?v M.empty) |- _ => rewrite <- MSetProperties.singleton_equal_add in H
    | H: not (M.In x (dom ?l)) |- _ => rewrite dom_union in H; simpl in H
    | H: not (M.In x (M.union ?l1 ?l2)) |- _ =>
      rewrite M.union_spec in H
    | H: not (M.In x ?l3 \/ ?l) |- _ =>
      let l := fresh in
      let r := fresh in
      apply not_or_and in H; destruct H as [l r]
    | H: not (?l \/ M.In x ?l3) |- _ =>
      let l := fresh in
      let r := fresh in
      apply not_or_and in H; destruct H as [l r]
    | H: not (M.In x ?l1) |- not (M.In x ?l1) => assumption
    | H:_ |- ~ (x == ?v \/ M.In ?v ?l) => unfold not; intro HInv; inversion HInv as [HH | HH]
    | H:_ |- not (?A \/ ?B) => apply and_not_or; split
    | H1: ~ M.In x (M.singleton ?v), H2: ?v == x |- _ => exfalso; apply H1; apply MSetProperties.Dec.F.singleton_2; assumption
    | H1: ~ M.In x (M.singleton ?v), H2: x == ?v |- _ => exfalso; apply H1; apply MSetProperties.Dec.F.singleton_2; symmetry; assumption
    | H: not (M.In x ?l1) |- not (M.In x ?l2) =>
      unfold not; intros; apply H; repeat rewrite M.union_spec; auto 10
  end.

(* Ok *)

Inductive ok {A} : context A -> Prop :=
  | Ok_nil : ok nil
  | Ok_push : forall (E : context A) (v : var) (ty : A),
                ok E -> not (In v (dom E)) -> ok (extend v ty E).

Hint Constructors ok.

Lemma ok_app_l : forall {A} (E F : context A), ok (E ++ F) -> ok E.
Proof.
  intros A E; induction E; intros.
  apply Ok_nil.
  inversion H.
  subst.
  apply Ok_push.
  apply (IHE _ H2).
  not_in_L v.
Defined.

Lemma ok_app_r : forall {A} (E F : context A), ok (E ++ F) -> ok F.
Proof.
  intros A E.
  induction E; intros.
  - rewrite app_nil_l in H.
    auto.
  - inversion H; subst.
    apply (IHE _ H2).
Defined.

Lemma ok_remove : forall {A} (E F G : context A), ok (E ++ G ++ F) -> ok (E ++ F).
Proof.
  intros.
  induction E using env_ind.
  rewrite app_nil_l in *.
  now apply ok_app_r in H.
  unfold extend; rewrite <- app_assoc.
  apply Ok_push.
  apply IHE.
  unfold extend in H; rewrite <- app_assoc in H.
  inversion H; subst.
  assumption.
  unfold extend in H.
  inversion H; subst.
  rewrite dom_union in *.
  rewrite union_spec in *.
  unfold not; intros.
  apply H4.
  inversion H0.
  auto.
  right.
  rewrite dom_union; rewrite union_spec.
  auto.
Defined.

Lemma ok_extend_comm : forall {A} (E F : context A) x v,
               ok (F ++ E ++ (x, v) :: nil) ->
               ok (F ++ (x, v) :: nil ++ E).
Proof.
  intros A E F x v HOk.
  generalize dependent E.

  induction F using env_ind; intros.
  unfold extend; simpl.
  rewrite app_nil_l in HOk.
  apply Ok_push.
  now apply ok_app_l in HOk.
  induction E.
  unfold not; intros HInv; inversion HInv.
  simpl.
  rewrite <- app_comm_cons in HOk.
  inversion HOk; subst.
  apply IHE in H1.
  simpl in *.
  unfold not; intros H3; apply MSetProperties.Dec.F.add_iff in H3.
  inversion H3.
  rewrite H in H2.
  rewrite dom_union in H2.
  rewrite union_spec in H2.
  apply not_or_and in H2.
  inversion H2.
  simpl in H4.
  apply H4.
  apply MSetProperties.Dec.F.add_1.
  reflexivity.
  contradiction.
  unfold extend.
  rewrite <- app_assoc.
  apply Ok_push.
  apply IHF.
  inversion HOk.
  subst.
  assumption.
  rewrite dom_union.
  rewrite union_spec.
  unfold not; intros.
  inversion H.
  apply ok_app_l in HOk.
  inversion HOk.
  subst.
  contradiction.
  simpl in H0.
  apply MSetProperties.Dec.F.add_iff in H0.
  inversion H0.
  unfold extend in HOk.
  apply ok_remove in HOk.
  rewrite <- app_assoc in HOk.
  apply ok_remove in HOk.
  simpl in HOk.
  inversion HOk; subst.
  simpl in *.
  apply H6.
  apply MSetProperties.Dec.F.add_1.
  assumption.
  inversion HOk; subst.
  rewrite dom_union in H6; rewrite union_spec in H6.
  apply not_or_and in H6.
  inversion H6.
  rewrite dom_union in H3; rewrite union_spec in H3; apply not_or_and in H3.
  inversion H3.
  contradiction.
Defined.

Lemma ok_app_comm : forall {A} (E F : context A), ok (F ++ E) -> ok (E ++ F).
Proof.
  intros.
  generalize dependent H.
  generalize dependent F.
  dependent induction E using (@env_ind A).
  intros.
  rewrite app_nil_r in H.
  now simpl.
  intros.
  unfold extend in *.
  rewrite <- app_assoc.
  apply Ok_push.
  apply IHE.
  apply ok_remove in H.
  assumption.
  rewrite dom_union.
  rewrite union_spec.
  unfold not; intros.
  inversion H0.
  apply ok_app_r in H.
  inversion H; subst.
  contradiction.
  rewrite app_assoc in H.
  apply ok_app_l in H.
  rewrite <- app_nil_l in H.
  apply ok_extend_comm in H.
  rewrite app_nil_l in H.
  simpl in H.
  inversion H; subst.
  contradiction.
Defined.

Definition ok_app_and {A} (E F : context A) (H : ok (E ++ F)) : ok E /\ ok F :=
  conj (ok_app_l _ _ H) (ok_app_r _ _ H).

Lemma ok_middle_comm :
  forall {A} (E : context A) F G H, ok (E ++ F ++ G ++ H) -> ok (E ++ G ++ F ++ H).
Proof.
  intros.
  induction E.
  generalize dependent F.
  induction H; intros.
  rewrite app_nil_l in *.
  rewrite app_nil_r in *.
  now apply ok_app_comm.
  rewrite app_nil_l.
  rewrite app_assoc.
  apply ok_app_comm.
  rewrite <- app_comm_cons.
  destruct a.
  apply Ok_push.
  apply ok_app_comm.
  rewrite <- app_assoc.
  rewrite app_nil_l in H0.
  rewrite app_assoc in H0.
  apply ok_app_comm in H0.
  rewrite <- app_comm_cons in H0.
  inversion H0; subst.
  apply IHlist.
  rewrite app_nil_l.
  apply ok_app_comm in H3.
  now rewrite <- app_assoc in H3.
  rewrite app_nil_l in H0.
  rewrite app_assoc in H0.
  apply ok_app_comm in H0.
  rewrite <- app_comm_cons in H0.
  inversion H0; subst.
  not_in_L v.
  rewrite dom_union in H2; rewrite union_spec in H2; inversion H2; contradiction.
  intros.
  rewrite <- app_comm_cons.
  destruct a.
  apply Ok_push.
  apply IHE.
  rewrite <- app_comm_cons in H0.
  inversion H0.
  assumption.
  rewrite <- app_comm_cons in H0.
  inversion H0.
  subst.
  not_in_L v.
  rewrite dom_union in H5; rewrite union_spec in H5; inversion H5.
  contradiction.
  rewrite dom_union in H7; rewrite union_spec in H7; inversion H7.
  contradiction.
  contradiction.
Defined.

(** Target language **)
Fixpoint fv (sExp : SExp var) : vars :=
  match sExp with
    | STFVar _ v => singleton v
    | STBVar _ _ => empty
    | STUnit _ => empty
    | STLit _ _ => empty
    | STLam _ _ t => fv t
    | STLam' _ t => fv t
    | STApp _ t1 t2 => union (fv t1) (fv t2)
    | STPair _ t1 t2 => union (fv t1) (fv t2)
    | STProj1 _ t => fv t
    | STProj2 _ t => fv t
  end.

Fixpoint open_rec (k : nat) (u : SExp var) (t : SExp var) {struct t} : SExp var :=
  match t with
  | STBVar _ i => if Nat.eqb k i then u else (STBVar _ i)
  | STFVar _ x => STFVar _ x
  | STUnit _ => STUnit _
  | STLit _ x => STLit _ x
  | STLam _ ty t1 => STLam _ ty (open_rec (S k) u t1)
  | STLam' _ t1 => STLam' _ (open_rec (S k) u t1)
  | STApp _ t1 t2 => STApp _ (open_rec k u t1) (open_rec k u t2)
  | STPair _ t1 t2 => STPair _ (open_rec k u t1) (open_rec k u t2)
  | STProj1 _ t => STProj1 _ (open_rec k u t)
  | STProj2 _ t => STProj2 _ (open_rec k u t)
  end.

Definition open (t : SExp var) u := open_rec 0 u t.

(* Notation "[ z ~> u ] t" := (subst z u t) (at level 68). *)
Notation "{ k ~> u } t" := (open_rec k u t) (at level 67).
Notation "t ^ x" := (open t (STFVar var x)).
Notation "t ^^ u" := (open t u) (at level 67).

Lemma fv_distr :
  forall t1 t2 x n, In x (fv (open_rec n t2 t1)) ->
               In x (union (fv t1) (fv t2)).
Proof.
  intros.
  generalize dependent t2.
  generalize dependent n.
  induction t1; intros; simpl in *; rewrite union_spec in *; auto.
  - destruct (Nat.eqb n0 n); auto.
  - rewrite <- union_spec.
    eapply IHt1.
    apply H.
  - apply IHt1 in H.
    now rewrite union_spec in H.
  - rewrite union_spec.
    inversion H.
    rewrite or_comm at 1.
    rewrite <- or_assoc.
    left; rewrite or_comm; rewrite <- union_spec.
    eapply IHt1_1; apply H0.
    rewrite or_assoc.
    right; rewrite <- union_spec.
    eapply IHt1_2; apply H0.
  - rewrite union_spec.
    inversion H.
    rewrite or_comm at 1.
    rewrite <- or_assoc.
    left; rewrite or_comm; rewrite <- union_spec.
    eapply IHt1_1; apply H0.
    rewrite or_assoc.
    right; rewrite <- union_spec.
    eapply IHt1_2; apply H0.
  - rewrite <- union_spec.
    eapply IHt1; apply H.
  - rewrite <- union_spec.
    apply (IHt1 _ _ H).
Defined.

Inductive STTerm : SExp var -> Prop :=
  | STTerm_Var : forall x,
      STTerm (STFVar _ x)
  | STTerm_Unit : STTerm (STUnit _)
  | STTerm_Lit : forall n,
      STTerm (STLit _ n)
  | STTerm_Lam : forall L t1 ty,
      (forall x, not (In x L) -> STTerm (open t1 (STFVar _ x))) ->
      STTerm (STLam _ ty t1)
  | STTerm_Lam' : forall L t1,
      (forall x, not (In x L) -> STTerm (open t1 (STFVar _ x))) ->
      STTerm (STLam' _ t1)
  | STTerm_App : forall t1 t2,
      STTerm t1 ->
      STTerm t2 ->
      STTerm (STApp _ t1 t2)
  | STTerm_Pair : forall t1 t2,
      STTerm t1 ->
      STTerm t2 ->
      STTerm (STPair _ t1 t2)
  | STTerm_Proj1 : forall t,
      STTerm t ->
      STTerm (STProj1 _ t)
  | STTerm_Proj2 : forall t,
      STTerm t ->
      STTerm (STProj2 _ t).

Hint Constructors STTerm.

(* Tactics dealing with fresh variables, taken from STLC_Tutorial *)

Ltac gather_vars_with F :=
  let rec gather V :=
   (match goal with
    | H:?S
      |- _ =>
          let FH := constr:(F H) in
          match V with
          | empty => gather FH
          | context [FH] => fail 1
          | _ => gather (union FH V)
          end
    | _ => V
    end)
  in
  let L := gather (empty : vars) in
  eval simpl in L.

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => singleton x) in
  (*let C := gather_vars_with (fun (x : context PTyp) => dom x) in *)
  let D := gather_vars_with (fun (x : context STyp) => dom x) in
  (*let E := gather_vars_with (fun x : PExp => fv_source x) in *)
  let F := gather_vars_with (fun (x : SExp var) => fv x) in
  constr:(union A (union B (union D F))).

Ltac beautify_fset V :=
  let rec go Acc E :=
   (match E with
    | union ?E1 ?E2 => let Acc1 := go Acc E1 in
                    go Acc1 E2
    | empty => Acc
    | ?E1 => match Acc with
             | empty => E1
             | _ => constr:(union Acc E1)
             end
    end)
  in
  go (empty : vars) V.

Parameter var_fresh : forall L : vars, (sig (A := var) (fun x => not (In x L))).

Ltac pick_fresh_gen L Y :=
  let Fr := fresh "Fr" in
  let L := beautify_fset L in
  destruct (var_fresh L) as (Y, Fr).

Ltac pick_fresh x :=
  let L := gather_vars in (pick_fresh_gen L x).

Ltac apply_fresh_base_simple lemma gather :=
  let L0 := gather in
  let L := beautify_fset L0 in
  first
  [ apply (lemma L) | eapply (lemma L) ].

Ltac intros_fresh x :=
  first
  [ let Fr := fresh "Fr" x in
    intros x Fr
  | let x2 :=
     (match goal with
      | |- ?T -> _ =>
            match T with
            | var => fresh "y"
            | vars => fresh "ys"
            | list var => fresh "ys"
            | _ => fresh "y"
            end
      end)
    in
    let Fr := fresh "Fr" x2 in
    intros x2 Fr ].

Fixpoint fresh (L : vars) (n : nat) (xs : list var) : Prop :=
  match xs with
  | nil => match n with
           | 0 => True
           | S _ => False
           end
  | (x :: xs')%list =>
      match n with
      | 0 => False
      | S n' => (not (In x L)) /\ fresh (union L (singleton x)) n' xs'
      end
  end.

Ltac apply_fresh_base lemma gather var_name :=
  apply_fresh_base_simple lemma gather;
   try
    match goal with
    | |- _ -> not (In _ _) -> _ => intros_fresh var_name
    | |- _ -> fresh _ _ _ -> _ => intros_fresh var_name
    end.

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

Lemma open_rec_term_core :forall t j v i u, i <> j ->
  { j ~> v }t = { i ~> u }({ j ~> v }t) -> t = { i ~> u }t.
Proof.
  intro t; induction t; intros; simpl; auto.
  - simpl in *.
    case_eq (Nat.eqb i n); intros.
    case_eq (Nat.eqb j n); intros.
    exfalso. apply H. apply Nat.eqb_eq in H1.
    apply Nat.eqb_eq in H2. rewrite H1, H2.
    reflexivity.
    rewrite H2 in H0.
    unfold open_rec in H0.
    rewrite H1 in H0.
    assumption.
    reflexivity.
  - inversion H0.
    erewrite <- IHt.
    reflexivity.
    apply not_eq_S.
    apply H.
    apply H2.
  - inversion H0.
    erewrite <- IHt.
    reflexivity.
    apply not_eq_S.
    apply H.
    apply H2.
  - inversion H0.
    erewrite <- IHt1.
    erewrite <- IHt2.
    reflexivity.
    apply H.
    apply H3.
    apply H.
    apply H2.
  - inversion H0.
    erewrite <- IHt1.
    erewrite <- IHt2.
    reflexivity.
    apply H.
    apply H3.
    apply H.
    apply H2.
  - inversion H0.
    erewrite <- IHt.
    reflexivity.
    apply H.
    apply H2.
  - inversion H0.
    erewrite <- IHt.
    reflexivity.
    apply H.
    apply H2.
Defined.

(** Substitution on indices is identity on well-formed terms. *)

Lemma open_rec_term : forall t u,
  STTerm  t -> forall k, t =  { k ~> u }t.
Proof.
  induction 1; intros; simpl; auto.
  pick_fresh x.
  rewrite <- open_rec_term_core with (j := 0) (v := STFVar _ x).
  reflexivity.
  auto.
  simpl.
  unfold open in *.
  rewrite <- H0.
  reflexivity.
  unfold not; intros; apply Fr; rewrite union_spec; rewrite union_spec; left; left.
  assumption.
  pick_fresh x.
  rewrite <- open_rec_term_core with (j := 0) (v := STFVar _ x).
  reflexivity.
  auto.
  simpl.
  unfold open in *.
  rewrite <- H0.
  reflexivity.
  unfold not; intros; apply Fr; rewrite union_spec; rewrite union_spec; left; left.
  assumption.
  rewrite <- IHSTTerm1.
  rewrite <- IHSTTerm2.
  reflexivity.
  rewrite <- IHSTTerm1.
  rewrite <- IHSTTerm2.
  reflexivity.
  rewrite <- IHSTTerm.
  reflexivity.
  rewrite <- IHSTTerm.
  reflexivity.
Defined.

Hint Resolve open_rec_term.

Lemma open_app_eq : forall x E n F,
  not (In x (fv E)) ->
  not (In x (fv F)) ->
  (open_rec n (STFVar var x) E) = (open_rec n (STFVar var x) F) ->
  E = F.
Proof.
  intros x E.
  induction E; intros n' F HNotE HNotF HEqOpen.
  - simpl in *.
    induction F; try (inversion HEqOpen; auto).
    destruct (Nat.eqb n' n); auto.
    exfalso; apply HNotE.
    apply MSetProperties.Dec.F.singleton_2; inversion H0; reflexivity.
  - induction F; simpl in *; try (now (destruct (Nat.eqb n' n); inversion HEqOpen)).
    destruct (Nat.eqb n' n).
    exfalso; apply HNotF.
    apply MSetProperties.Dec.F.singleton_2; inversion HEqOpen; reflexivity.
    inversion HEqOpen.
    case_eq (Nat.eqb n' n); intros.
    case_eq (Nat.eqb n' n0); intros.
    apply f_equal.
    apply beq_nat_true in H.
    apply beq_nat_true in H0.
    now subst.
    rewrite H in HEqOpen.
    rewrite H0 in HEqOpen.
    inversion HEqOpen.
    rewrite H in HEqOpen.
    case_eq (Nat.eqb n' n0); intros;
    rewrite H0 in HEqOpen; inversion HEqOpen.
    reflexivity.
  - induction F; simpl in *; try (now inversion HEqOpen).
    destruct (Nat.eqb n' n); [ inversion HEqOpen | auto ].
  - induction F; simpl in *; try (now inversion HEqOpen).
    destruct (Nat.eqb n' n0); [ inversion HEqOpen | auto ].
  - induction F; simpl in *; try (now inversion HEqOpen).
    destruct (Nat.eqb n' n); inversion HEqOpen.
    inversion HEqOpen.
    apply f_equal.
    now apply (IHE (S n')).
  - induction F; simpl in *; try (now inversion HEqOpen).
    destruct (Nat.eqb n' n); inversion HEqOpen.
    inversion HEqOpen.
    apply f_equal.
    now apply (IHE (S n')).
  - induction F; simpl in *; try (now inversion HEqOpen).
    destruct (Nat.eqb n' n); inversion HEqOpen.
    rewrite IHE1 with (F := F1) (n := n'); try not_in_L x.
    rewrite IHE2 with (F := F2) (n := n'); try not_in_L x.
    reflexivity.
    not_in_L x.
    not_in_L x.
    now inversion HEqOpen.
    not_in_L x.
    not_in_L x.
    now inversion HEqOpen.
  - induction F; simpl in *; try (now inversion HEqOpen).
    destruct (Nat.eqb n' n); inversion HEqOpen.
    rewrite IHE1 with (F := F1) (n := n'); try not_in_L x.
    rewrite IHE2 with (F := F2) (n := n'); try not_in_L x.
    reflexivity.
    not_in_L x.
    not_in_L x.
    now inversion HEqOpen.
    not_in_L x.
    not_in_L x.
    now inversion HEqOpen.
  - induction F; simpl in *; try (now inversion HEqOpen).
    destruct (Nat.eqb n' n); inversion HEqOpen.
    apply f_equal.
    apply IHE with (n := n'); try not_in_L x.
    now inversion HEqOpen.
  - induction F; simpl in *; try (now inversion HEqOpen).
    destruct (Nat.eqb n' n); inversion HEqOpen.
    apply f_equal.
    apply IHE with (n := n'); try not_in_L x.
    now inversion HEqOpen.
Defined.

(* Typing rules *)

(* Typing rules of STLC, inspired by STLC_Tutorial *)
Inductive has_type_st : (context STyp) -> (SExp var) -> STyp -> Prop :=
  | STTyVar : forall (Gamma : context STyp) x ty,
                ok Gamma -> List.In (x,ty) Gamma -> has_type_st Gamma (STFVar _ x) ty
  | STTyUnit : forall Gamma, ok Gamma -> has_type_st Gamma (STUnit _) STUnitT
  | STTyLit : forall Gamma x, ok Gamma -> has_type_st Gamma (STLit _ x) STInt
  | STTyLam : forall L Gamma t A B,
                (forall x, not (In x L) ->
                      has_type_st (extend x A Gamma) (open t (STFVar _ x)) B) ->
                has_type_st Gamma (STLam _ A t) (STFun A B)
  | STTyLam' : forall L Gamma t A B,
                 (forall x, not (In x L) ->
                       has_type_st (extend x A Gamma) (open t (STFVar _ x)) B) ->
                 has_type_st Gamma (STLam' _ t) (STFun A B)
  | STTyApp : forall Gamma A B t1 t2, has_type_st Gamma t1 (STFun A B) ->
                             has_type_st Gamma t2 A -> has_type_st Gamma (STApp _ t1 t2) B
  | STTyPair : forall Gamma A B t1 t2, has_type_st Gamma t1 A ->
                              has_type_st Gamma t2 B ->
                              has_type_st Gamma (STPair _ t1 t2) (STTuple A B)
  | STTyProj1 : forall Gamma t A B, has_type_st Gamma t (STTuple A B) ->
                           has_type_st Gamma (STProj1 _ t) A
  | STTyProj2 : forall Gamma t A B, has_type_st Gamma t (STTuple A B) ->
                           has_type_st Gamma (STProj2 _ t) B.

Hint Constructors has_type_st.

(* Typing lemmas *)

Lemma typing_weaken : forall G E F t T,
   has_type_st (E ++ G) t T ->
   ok (E ++ F ++ G) ->
   has_type_st (E ++ F ++ G) t T.
Proof.
  intros.
  generalize dependent H0.
  remember (E ++ G) as H'.
  generalize dependent HeqH'.
  generalize dependent E.
  dependent induction H; intros; eauto.
  (* STTyVar *)
  - subst.
    apply STTyVar.
    assumption.
    apply in_app_or in H0.
    inversion H0.
    apply in_or_app; left; assumption.
    apply in_or_app; right; apply in_or_app; right; assumption.
  (* STTyLam *)
  - apply_fresh STTyLam as x.
    unfold open in *; simpl in *.
    subst.
    unfold extend; simpl.
    rewrite app_comm_cons.
    apply H0.
    not_in_L x.
    unfold extend; simpl; reflexivity.
    rewrite <- app_comm_cons.
    apply Ok_push.
    assumption.
    not_in_L x.
    rewrite dom_union in H6.
    rewrite union_spec in H6.
    inversion H6; exfalso; [apply H8 | apply H9]; auto.
  - apply_fresh STTyLam' as x.
    unfold open in *; simpl in *.
    subst.
    unfold extend; simpl.
    rewrite app_comm_cons.
    apply H0.
    not_in_L x.
    unfold extend; simpl; reflexivity.
    rewrite <- app_comm_cons.
    apply Ok_push.
    assumption.
    not_in_L x.
    rewrite dom_union in H6.
    rewrite union_spec in H6.
    inversion H6; exfalso; [apply H8 | apply H9]; auto.
Defined.

Lemma typing_strengthen : forall z U E F t T,
  not (In z (fv t)) ->
  has_type_st (E ++ ((z,U) :: nil) ++ F) t T ->
  has_type_st (E ++ F) t T.
Proof.
  intros.
  remember (E ++ ((z,U) :: nil) ++ F).

  generalize dependent Heql.
  generalize dependent E.

  induction H0; intros; auto.
  - subst; apply STTyVar.
    now apply ok_remove in H0.
    apply in_or_app.
    repeat apply in_app_or in H1.
    inversion H1.
    auto.
    apply in_app_or in H2.
    inversion H2.
    inversion H3.
    inversion H4.
    subst.
    exfalso; apply H; simpl.
    left; reflexivity.
    inversion H4.
    auto.
  - apply STTyUnit.
    subst.
    now apply ok_remove in H0.
  - apply STTyLit.
    subst.
    now apply ok_remove in H0.
  - subst.
    apply_fresh STTyLam as x.
    unfold extend in *; simpl in *.
    rewrite app_comm_cons.
    apply H1.
    not_in_L x.
    not_in_L z.
    apply fv_distr in H2.
    rewrite union_spec in H2.
    inversion H2.
    auto.
    assert (NeqXZ : not (In x (singleton z))) by (not_in_L x).
    simpl in H3.
    exfalso; apply NeqXZ.
    apply MSetProperties.Dec.F.singleton_2.
    apply MSetProperties.Dec.F.singleton_1 in H3.
    symmetry; assumption.
    rewrite app_comm_cons.
    reflexivity.
  - subst.
    apply_fresh STTyLam' as x.
    unfold extend in *; simpl in *.
    rewrite app_comm_cons.
    apply H1.
    not_in_L x.
    not_in_L z.
    apply fv_distr in H2.
    rewrite union_spec in H2.
    inversion H2.
    auto.
    assert (NeqXZ : not (In x (singleton z))) by (not_in_L x).
    simpl in H3.
    exfalso; apply NeqXZ.
    apply MSetProperties.Dec.F.singleton_2.
    apply MSetProperties.Dec.F.singleton_1 in H3.
    symmetry; assumption.
    rewrite app_comm_cons.
    reflexivity.
  - eapply STTyApp.
    subst.
    apply IHhas_type_st1; simpl in *; not_in_L z; reflexivity.
    subst.
    apply IHhas_type_st2; simpl in *; not_in_L z; reflexivity.
  - subst.
    apply STTyPair.
    apply IHhas_type_st1; simpl in *; not_in_L z; reflexivity.
    apply IHhas_type_st2; simpl in *; not_in_L z; reflexivity.
  - subst.
    eapply STTyProj1.
    apply IHhas_type_st.
    not_in_L z.
    reflexivity.
  - subst.
    eapply STTyProj2.
    apply IHhas_type_st.
    not_in_L z.
    reflexivity.
Defined.

Lemma has_type_env_comm : forall E F G H T t,
              has_type_st (E ++ F ++ G ++ H) t T ->
              has_type_st (E ++ G ++ F ++ H) t T.
Proof.
  intros.
  remember (E ++ F ++ G ++ H).
  generalize dependent Heql.
  generalize dependent E.
  generalize dependent F.
  generalize dependent G.
  dependent induction H0; intros; subst; auto.
  - apply STTyVar.
    apply ok_app_comm.
    rewrite <- app_assoc.
    apply ok_app_comm.
    rewrite <- app_assoc.
    apply ok_app_comm.
    rewrite <- app_assoc.
    now apply ok_middle_comm.
    apply in_app_or in H1.
    inversion H1.
    apply in_or_app; auto.
    apply in_or_app; right.
    apply in_app_or in H2.
    inversion H2.
    apply in_or_app.
    right; apply in_or_app; left.
    assumption.
    apply in_app_or in H3.
    inversion H3.
    apply in_or_app; auto.
    apply in_or_app; right; apply in_or_app; auto.
  - apply STTyUnit.
    now apply ok_middle_comm.
  - apply STTyLit.
    now apply ok_middle_comm.
  - apply_fresh STTyLam as x.
    unfold extend.
    rewrite app_assoc.
    apply H1.
    not_in_L x.
    unfold extend.
    rewrite <- app_assoc.
    reflexivity.
  - apply_fresh STTyLam' as x.
    unfold extend.
    rewrite app_assoc.
    apply H1.
    not_in_L x.
    unfold extend.
    rewrite <- app_assoc.
    reflexivity.
  - eapply STTyApp.
    apply IHhas_type_st1; reflexivity.
    apply IHhas_type_st2; reflexivity.
  - eapply STTyProj1; apply IHhas_type_st; reflexivity.
  - eapply STTyProj2; apply IHhas_type_st; reflexivity.
Defined.

Lemma has_type_env_comm_extend : forall Gamma x y v1 v2 E t,
              has_type_st (extend x v1 (extend y v2 Gamma)) t E ->
              has_type_st (extend y v2 (extend x v1 Gamma)) t E.
Proof.
  unfold extend.
  intros.
  rewrite <- app_nil_l with (l := ((x, v1) :: nil) ++ ((y, v2) :: nil) ++ Gamma) in H.
  apply has_type_env_comm in H.
  now rewrite app_nil_l in H.
Defined.

Lemma typing_weaken_extend : forall t T x v Gamma,
   has_type_st Gamma t T ->
   not (M.In x (dom Gamma)) ->
   has_type_st ((x,v) :: Gamma) t T.
Proof.
  intros.
  induction H; eauto.
  apply STTyVar.
  apply Ok_push; assumption.
  apply in_cons; assumption.
  apply STTyUnit.
  apply Ok_push; assumption.
  apply STTyLit.
  apply Ok_push; assumption.
  apply_fresh STTyLam as x; cbn.
  unfold extend in H1.
  apply has_type_env_comm_extend.
  apply H1.
  not_in_L y.
  not_in_L x.
  not_in_L y.
  apply_fresh STTyLam' as x; cbn.
  unfold extend in H1.
  apply has_type_env_comm_extend.
  apply H1.
  not_in_L y.
  not_in_L x.
  not_in_L y.
Defined.

Lemma typing_ok_env : forall Gamma E ty, has_type_st Gamma E ty -> ok Gamma.
Proof.
  intros.
  induction H; auto;
  pick_fresh x;
  assert (Ha: not (In x L)) by not_in_L x;
  pose (H0 _ Ha) as HInv;
  inversion HInv; auto.
Defined.

Lemma typing_gives_terms : forall Gamma E ty, has_type_st Gamma E ty -> STTerm E.
Proof.
  intros.
  induction H; auto.
  apply_fresh STTerm_Lam as x.
  apply H0.
  not_in_L x.
  apply_fresh STTerm_Lam' as x.
  apply H0.
  not_in_L x.
Defined.

End TLC.


Require Export Iron.Language.SystemF2Cap.Type.

(********************************************************************)
(* Constants *)
Inductive const : Type :=
  | CUnit   : const
  | CNat    : nat   -> const
  | CBool   : bool  -> const.
Hint Constructors const.

Fixpoint typeOfConst (c : const) : ty :=
  match c with
  | CUnit     => TUnit
  | CNat  _   => TNat
  | CBool _   => TBool
  end.

(* Primitive Operators *)
Inductive op1 : Type :=
  | OSucc   : op1
  | OIsZero : op1.
Hint Constructors op1.

(* Values *)
Inductive val : Type :=
  | VVar     : nat   -> val
  | VLoc     : nat   -> val
  | VBox     : exp   -> val
  | VLam     : ty    -> exp -> val
  | VLAM     : ki    -> exp -> val
  | VConst   : const -> val

(* Expressions *)
with     exp : Type :=
  | XVal     : val -> exp
  | XLet     : ty  -> exp -> exp -> exp
  | XApp     : val -> val -> exp
  | XAPP     : val -> ty  -> exp

  (* Pure operators *)
  | XOp1     : op1 -> val -> exp

  (* Region creation *)
  | XPrivate : list ty -> exp -> exp
  | XExtend  : ty  -> exp -> exp

  (* Effect reflection *)
  | XRun     : val -> exp

  (* Store operators *)
  | XAlloc   : ty  -> val -> exp
  | XRead    : ty  -> val -> exp
  | XWrite   : ty  -> val -> val -> exp.

Hint Constructors val.
Hint Constructors exp.

(********************************************************************)
(* Induction principle for expressions. *)
Lemma exp_mutind : forall
    (PX : exp -> Prop)
    (PV : val -> Prop)
 ,  (forall n,                                     PV (VVar   n))
 -> (forall l,                                     PV (VLoc   l))
 -> (forall x,          PX x                    -> PV (VBox   x))
 -> (forall t x,        PX x                    -> PV (VLam   t x))
 -> (forall k x,        PX x                    -> PV (VLAM   k x))
 -> (forall c,                                     PV (VConst c))
 -> (forall v,          PV v                    -> PX (XVal   v))
 -> (forall t x1 x2,    PX x1 -> PX x2          -> PX (XLet   t x1 x2))
 -> (forall v1 v2,      PV v1 -> PV v2          -> PX (XApp   v1 v2))
 -> (forall v t,        PV v                    -> PX (XAPP   v  t))
 -> (forall o v,        PV v                    -> PX (XOp1 o   v))
 -> (forall ts x,       PX x                    -> PX (XPrivate ts x))
 -> (forall t x,        PX x                    -> PX (XExtend  t x))
 -> (forall v,          PV v                    -> PX (XRun   v))
 -> (forall r v,        PV v                    -> PX (XAlloc r v))
 -> (forall r v,        PV v                    -> PX (XRead  r v))
 -> (forall r v1 v2,    PV v1 -> PV v2          -> PX (XWrite r v1 v2))
 ->  forall x, PX x.
Proof.
 intros PX PV.
 intros hVar hLoc hBox hLam hLAM hConst
        hVal hLet hApp hAPP hOp1
        hPrivate hExtend hRun
        hAlloc hRead hWrite.
 refine (fix  IHX x : PX x := _
         with IHV v : PV v := _
         for  IHX).

 (* expressions *)
 case x; intros.
 apply hVal.     apply IHV.
 apply hLet.     apply IHX. apply IHX.
 apply hApp.     apply IHV. apply IHV.
 apply hAPP.     apply IHV.
 apply hOp1.     apply IHV.
 apply hPrivate. apply IHX.
 apply hExtend.  apply IHX.
 apply hRun.     apply IHV.
 apply hAlloc.   apply IHV.
 apply hRead.    apply IHV.
 apply hWrite.   apply IHV. apply IHV.

 (* values *)
 case v; intros.
 apply hVar.
 apply hLoc.
 apply hBox. apply IHX.
 apply hLam. apply IHX.
 apply hLAM. apply IHX.
 apply hConst.
Qed.