Require Import Classical.
Require Import ClassicalChoice.
Require Import Relation_Definitions.
Require Import Relation_Definitions_Implicit.
Require Import Ensembles.
Require Import EnsemblesImplicit.
Require Import Proj1SigInjective.
Require Import InverseImage.

Unset Standard Proposition Elimination Names.

Section ZL'.

Variable T:Type.
Variable R:relation T.
Hypothesis ord:order R.
Definition chain (S: Ensemble T) : Prop :=
  forall x y:T, In S x -> In S y -> (R x y \/ R y x).
Definition maximal (x:T) : Prop :=
  forall y:T, R x y -> x = y.
Variable chain_sup: forall S: Ensemble T, chain S ->
  { x:T | (forall y:T, In S y -> R y x) /\
    (forall z:T, (forall y:T, In S y -> R y z) -> R x z) }.
Variable inflation: forall x:T,
  { y:T | R x y /\ x <> y /\ forall z:T, R x z -> R z y ->
                                     z = x \/ z = y }.

Inductive tower : Ensemble T :=
  | sup_intro: forall (S: Ensemble T), Included S tower ->
      forall c:chain S,
      In tower (proj1_sig (chain_sup S c))
  | inflation_intro: forall x:T, In tower x ->
      In tower (proj1_sig (inflation x)).

Lemma tower_is_chain: chain tower.
Proof.
unfold chain.
intros.
revert x H.
induction H0.
intros.
case (classic (forall y:T, In S y -> R y x)).
right.
apply (proj2_sig (chain_sup S c)).
assumption.

intro.
apply not_all_ex_not in H2.
destruct H2.
apply imply_to_and in H2.
destruct H2.
left.
apply (ord_trans ord) with x0.
pose proof (H0 x0 H2 x H1).
tauto.
apply (proj2_sig (chain_sup S c)).
assumption.

pose proof (proj2_sig (inflation x)).
simpl in H0.
destruct H0.
destruct H1.
remember (proj1_sig (inflation x)) as x'.

assert (forall y:T, In tower y -> R y x \/ R x' y).
intros.
induction H3.
case (classic (forall x0:T, In S x0 -> R x0 x)).
left.
apply (proj2_sig (chain_sup S c)).
assumption.

right.
apply not_all_ex_not in H5.
destruct H5.
apply imply_to_and in H5.
destruct H5.
apply (ord_trans ord) with x0.
pose proof (H4 x0).
tauto.
apply (proj2_sig (chain_sup S c)).
assumption.

assert (In tower x').
rewrite Heqx'.
apply inflation_intro.
assumption.

destruct IHtower0.
assert (In tower (proj1_sig (inflation x0))).
apply inflation_intro.
assumption.
case (IHtower (proj1_sig (inflation x0)) H6).
left.
assumption.
intro.
pose proof (proj2_sig (inflation x0)).
simpl in H8.
assert (x = x0 \/ x = proj1_sig (inflation x0)).
apply H8.
assumption.
assumption.
case H9.
right.
rewrite Heqx'.
rewrite H10.
apply (ord_refl ord).
left.
rewrite H10.
apply (ord_refl ord).
right.
apply (ord_trans ord) with x0.
assumption.
apply (proj2_sig (inflation x0)).

intros.
case (H3 x0 H4).
left.
apply (ord_trans ord) with x.
assumption.
assumption.
right.
assumption.
Qed.

(* can now show the given hypotheses are contradictory *)
Lemma ZL': False.
Proof.
pose proof (proj2_sig (chain_sup tower tower_is_chain)).
simpl in H.
remember (proj1_sig (chain_sup tower tower_is_chain)) as x0.
assert (In tower x0).
rewrite Heqx0.
constructor 1.
auto with sets.

pose (x' := proj1_sig (inflation x0)).
assert (In tower x').
constructor 2.
assumption.

pose proof (proj2_sig (inflation x0)).
simpl in H2.
destruct H2.
destruct H3.
contradict H3.
apply (ord_antisym ord).
assumption.
destruct H.
apply H.
assumption.
Qed.

End ZL'.

Arguments chain [T].
Arguments maximal [T].

Section ZL.

(* get rid of the need for a sup function and immediate successors *)

Variable T:Type.
Variable R:relation T.
Hypothesis ord: order R.
Hypothesis ub_of_chain: forall S:Ensemble T, chain R S ->
  exists x:T, forall y:T, In S y -> R y x.

Definition chains := {S:Ensemble T | chain R S}.
Definition chains_ord := (fun S1 S2:chains =>
  Included (proj1_sig S1) (proj1_sig S2)).

Lemma chains_order: order chains_ord.
Proof.
constructor.
unfold reflexive.
unfold chains_ord.
auto with sets.

unfold transitive.
unfold chains_ord.
auto with sets.

unfold antisymmetric.
unfold chains_ord.
intros.
apply proj1_sig_injective.
auto with sets.
Qed.

Require Export EnsemblesSpec.

Definition chains_sup_def : forall F: Ensemble chains,
  chain chains_ord F -> chains.
refine (fun F H => exist _ [ x:T | exists S:chains, In F S /\
                             In (proj1_sig S) x ] _).
red; intros.
destruct H0.
destruct H1.
destruct H0.
destruct H1.
pose proof (H x0 x1).
destruct x0.
destruct x1.
simpl in H0.
destruct H0.
simpl in H1.
destruct H1.
apply H2 in H0.
unfold chains_ord in H0.
simpl in H0.
destruct H0.
apply c0.
apply H0.
exact H3.
exact H4.

apply c.
exact H3.
apply H0.
exact H4.
assumption.
Defined.

Lemma chains_sup_correct: forall (F:Ensemble chains)
  (P:chain chains_ord F), let U := chains_sup_def F P in
    (forall S:chains, In F S -> chains_ord S U) /\
    (forall T:chains, (forall S:chains, In F S -> chains_ord S T) ->
      chains_ord U T).
Proof.
intros.
split.
intros.
unfold chains_ord.
unfold Included.
intros.
unfold U.
simpl.
constructor.
exists S.
auto.
intros.
unfold chains_ord.
unfold Included.
intros.
unfold U in H0.
simpl in H0.
destruct H0.
destruct H0.
destruct H0.
apply H in H0.
apply H0.
assumption.
Qed.

Definition chains_sup (F:Ensemble chains) (P:chain chains_ord F) :=
  let U := chains_sup_def F P in
  exist (fun U:chains =>
    (forall S:chains, In F S -> chains_ord S U) /\
    (forall T:chains, (forall S:chains, In F S -> chains_ord S T) ->
      chains_ord U T))
  (chains_sup_def F P) (chains_sup_correct F P).

Theorem ZornsLemma: exists x:T, maximal R x.
Proof.
pose proof (ZL' chains chains_ord chains_order chains_sup).

apply NNPP.
unfold maximal.
dintuition.
assert (forall x:T, ~ forall y:T, R x y -> x = y).
apply not_ex_all_not.
exact H0.
assert (forall x:T, exists y:T, ~ (R x y -> x = y)).
intro.
apply not_all_ex_not.
apply H1.
assert (forall x:T, exists y:T, R x y /\ x <> y).
intro.
pose proof (H2 x).
destruct H3.
apply imply_to_and in H3.
exists x0.
assumption.
clear H0 H1 H2.

assert (forall x:chains, exists y:chains,
  chains_ord x y /\ x <> y /\ forall z:chains, chains_ord x z ->
  chains_ord z y -> z = x \/ z = y).
intro.
destruct x.
pose proof (ub_of_chain x c).
destruct H0.
pose proof (H3 x0).
destruct H1.

pose (x' := Add x x1).
assert (chain R x').
unfold chain.
intros.
case H2.
case H4.
intros.
apply c.
assumption.
assumption.
intros.
destruct H5.
left.
apply ord_trans with x0.
apply H0.
assumption.
apply H1.
intros.
destruct H5.
case H4.
right.
apply ord_trans with x0.
apply H0.
assumption.
apply H1.
intros.
destruct H5.
left.
apply ord_refl.

exists (exist _ x' H2).
split.
unfold chains_ord.
simpl.
unfold Included.
intros.
constructor.
assumption.

split.
intuition.
injection H4.
intro.
assert (In x x1).
rewrite H1.
constructor 2.
auto with sets.
contradict H6.
apply ord_antisym.
assumption.
apply H0.
assumption.

intros.
destruct z.
unfold chains_ord in H4.
simpl in H4.
unfold chains_ord in H5.
simpl in H5.

case (classic (In x2 x1)).
right.
apply subset_eq_compatT.
apply Extensionality_Ensembles.
split.
assumption.
unfold Included.
intros.
case H7.
exact H4.
intros.
destruct H8.
assumption.

left.
apply subset_eq_compatT.
apply Extensionality_Ensembles.
split.
unfold Included.
intros.
assert (In x' x3).
apply H5.
assumption.
inversion H8.
assumption.
destruct H9.
contradiction H6.
assumption.

apply choice in H0.
destruct H0 as [f].
apply H.
intro.
apply exist with (f x).
apply H0.
Qed.

End ZL.

Arguments ZornsLemma [T].

Require Import Quotients.

Section ZL_preorder.

Variable T:Type.
Variable R:relation T.
Hypothesis Rpreord: preorder R.
Hypothesis ub_of_chain: forall S:Ensemble T, chain R S ->
  exists x:T, forall y:T, In S y -> R y x.

Definition premaximal (x:T) : Prop :=
  forall y:T, R x y -> R y x.

Lemma ZornsLemmaForPreorders: exists x:T, premaximal x.
Proof.
pose (Requiv (x y:T) := R x y /\ R y x).
assert (equivalence Requiv).
constructor.
red; intros.
split; apply preord_refl; trivial.
red; intros.
destruct H.
destruct H0.
split; apply preord_trans with y; trivial.
red; intros.
destruct H.
split; trivial.

pose (Rquo := quotient Requiv).
let Hnew:=fresh"_H" in
  unshelve refine (let Hnew:=_ in
     let inducedR := induced_function2arg R H H Hnew in
     let inducedR_prop := induced_function2arg_correct R H H Hnew in _).
intros.
assert (True_rect (R a1 b1) = True_rect (R a2 b2)).
apply Extensionality_Ensembles; split; red; intros.
destruct x.
red in H2.
simpl in H2.
red; simpl.
apply preord_trans with a1; trivial.
apply H0.
apply preord_trans with b1; trivial.
apply H1.
destruct x.
red in H2; simpl in H2.
red; simpl.
apply preord_trans with a2; trivial.
apply H0.
apply preord_trans with b2; trivial.
apply H1.
assert (True_rect (R a1 b1) I = True_rect (R a2 b2) I).
rewrite H2; trivial.
simpl in H3.
assumption.
clearbody inducedR_prop.
fold inducedR in inducedR_prop.

assert (exists x:Rquo, maximal inducedR x).
apply ZornsLemma.
constructor.
red; intros xbar.
destruct (quotient_projection_surjective xbar) as [x []].
rewrite inducedR_prop.
apply preord_refl; trivial.
red; intros xbar ybar zbar ? ?.
destruct (quotient_projection_surjective xbar) as [x].
destruct H2.
destruct (quotient_projection_surjective ybar) as [y].
destruct H2.
destruct (quotient_projection_surjective zbar) as [z].
destruct H2.
rewrite inducedR_prop in H0, H1.
rewrite inducedR_prop.
apply preord_trans with y; trivial.
red; intros xbar ybar ? ?.
destruct (quotient_projection_surjective xbar) as [x].
destruct H2.
destruct (quotient_projection_surjective ybar) as [y].
destruct H2.
rewrite inducedR_prop in H0, H1.
unfold quotient_projection.
apply subset_eq_compatT.
apply R_impl_equality_of_equiv_class; trivial.
split; trivial.

intros Sbar ?.
pose (S := inverse_image (quotient_projection _) Sbar).
unshelve refine (let H1:=ub_of_chain S _ in _).
red; intros.
pose proof (H0 (quotient_projection _ x) (quotient_projection _ y)).
rewrite 2 inducedR_prop in H3.
destruct H1.
destruct H2.
apply H3; trivial.

destruct H1.
exists (quotient_projection _ x).
intros ybar ?.
destruct (quotient_projection_surjective ybar) as [y].
destruct H3.
rewrite inducedR_prop.
apply H1.
constructor; exact H2.

destruct H0 as [xbar].
destruct (quotient_projection_surjective xbar) as [x].
destruct H1.
exists x.
red; intros.
red in H0.
unshelve refine (let H2:=H0 (quotient_projection Requiv y) _ in _).
rewrite inducedR_prop.
assumption.
unfold quotient_projection in H2.
injection H2; intros.
assert (In (equiv_class Requiv x) y).
rewrite H3.
constructor; apply equiv_refl; trivial.
destruct H4.
apply H4.
Qed.

End ZL_preorder.

Arguments premaximal [T].


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

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


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

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


Require Import List.
Require Import Util Var Val Exp Envs Map CSet AutoIndTac IL AllInRel.
Require Import SmallStepRelations StateType NonParametricBiSim.

Set Implicit Arguments.
Unset Printing Records.

(** * Divergence *)

CoInductive diverges S `{StateType S} : S -> Prop :=
| DivergesI σ σ'
  : step σ EvtTau σ'
    -> diverges σ'
    -> diverges σ.

Lemma diverges_reduction_closed S `{StateType S} (σ σ':S)
: diverges σ -> star2 step σ nil σ'  -> diverges σ'.
Proof.
  intros. general induction H1; eauto using diverges.
  invt diverges; relsimpl. eauto.
Qed.

Lemma diverges_never_activated S `{StateType S} (σ:S)
: activated σ -> diverges σ -> False.
Proof.
  intros. invt diverges; relsimpl.
Qed.

Lemma diverges_never_terminates S `{StateType S} (σ:S)
: normal2 step σ -> diverges σ -> False.
Proof.
  intros. invt diverges; relsimpl.
Qed.

Lemma neither_diverges S `{StateType S} (σ:S)
  (H0 : ~ (exists σ' : S, star2 step σ nil σ' /\ normal2 step σ'))
  (H1 : ~ (exists σ' : S, star2 step σ nil σ' /\ activated σ'))
  : diverges σ.
Proof.
  revert σ H0 H1. cofix f.
  intros. destruct (@step_dec _ H σ).
  - inv H2; dcr.
    destruct x.
    + exfalso. eapply H1; eexists σ; split; eauto using star2_refl.
      do 2 eexists; eauto.
    + econstructor. eauto. eapply f; intro; dcr.
      * eapply H0; eexists; split; eauto. eapply star2_silent; eauto.
      * eapply H1; eexists; split; eauto. eapply star2_silent; eauto.
  - exfalso. eapply H0; eexists σ; split; eauto using star2_refl.
Qed.

(** ** Bisimilarity preserves silent divergence *)

Lemma bisim_sound_diverges S `{StateType S} S' `{StateType S'} (σ:S) (σ':S')
: bisim σ σ' -> diverges σ -> diverges σ'.
Proof.
  revert σ σ'. cofix COH; intros.
  inv H1.
  - eapply plus2_destr_nil in H4. dcr.
    econstructor. eauto.
    eapply COH; eauto.
    eapply bisim_reduction_closed_both; try eapply H1;
      eauto using star2_refl, star2_silent.
  - eapply diverges_reduction_closed in H3.
    + exfalso. eapply (diverges_never_activated H5); eauto.
    + eapply H2.
  - eapply diverges_reduction_closed in H4.
    + exfalso. eapply (diverges_never_terminates H6); eauto.
    + eapply H2.
Qed.

(** ** Silently diverging programs are bisimlar *)

Lemma bisim_complete_diverges S `{StateType S} S' `{StateType S'} (σ:S) (σ':S')
: diverges σ -> diverges σ' -> bisim σ σ'.
Proof.
  revert σ σ'. cofix COH; intros.
  inv H1; inv H2.
  econstructor. econstructor; eauto. econstructor; eauto.
  eapply COH; eauto.
Qed.

Require Import paco1.

Inductive div_gen S `{StateType S} (r:S -> Prop) : S -> Prop :=
| DivergesIGen σ σ'
  : step σ EvtTau σ'
    -> r σ'
    -> div_gen r σ.

Definition div {S} `{StateType S} r (σ1:S)
  := paco1 (@div_gen S _ ) r σ1.

Hint Unfold div.

Lemma div_diverges {S} `{StateType S} (σ:S)
  : div bot1 σ <-> diverges σ.
Proof.
  split; intros.
  - revert σ H0. cofix CIH. intros.
    destruct H0. destruct SIM.
    econstructor; eauto.
    eapply CIH. edestruct LE; eauto. isabsurd.
  - revert σ H0. pcofix CIH; intros.
    destruct H1. pfold. econstructor; eauto.
Qed.


(**************************************************************************)
(*  This is part of STATES, it is distributed under the terms of the      *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2015: Jean-Guillaume Dumas, Dominique Duval            *)
(*             Burak Ekici, Damien Pous.                                  *)
(**************************************************************************)

Require Import Relations Morphisms.
Require Import Program.
Require Memory Terms Decorations.
Set Implicit Arguments.
Require Import ZArith.
Open Scope Z_scope.
Require Import Bool.

Module Make(Import M: Memory.T).
Module Export AxiomsExp := Decorations.Make(M).

 Definition pure_id k A B (x y: term A B) := is (k, epure) x /\ x=y.
 Definition idem A B (x y: term A B) := x=y.

 Coercion is_true: bool >-> Sortclass.

 Reserved Notation "x === y" (at level 80).
 Reserved Notation "x ~== y" (at level 80).
 Reserved Notation "x ==~ y" (at level 80).
 Reserved Notation "x ~~ y"  (at level 80).

 Inductive ss: forall X Y, relation (term X Y) :=
  | ssrefl: forall X Y (f: term X Y), f === f
  | sssym: forall X Y, Symmetric (@ss X Y)
  | sstrans: forall X Y, Transitive (@ss X Y)
  | assoc: forall X Y Z T (f: term X Y) (g: term Y Z) (h: term Z T), f o (g o h) === (f o g) o h
  | ids: forall X Y (f: term X Y), f o id === f
  | idt: forall X Y (f: term X Y), id o f === f
  | replsubs: forall X Y Z, Proper (@ss X Y ==> @ss Y Z ==> @ss X Z) comp
  | replsubsp: forall X Y Z, Proper (@ss X Z ==> @ss Y Z ==> @ss (X*Y) Z) pair
  | replsubscp: forall X Y Z, Proper (@ss Z X ==> @ss Z Y ==> @ss Z (X+Y)) copair
  | wstoss: forall X Y k (f g: term X Y), RO k f -> RO k g -> f ~== g -> f === g
  | effect: forall X Y (f g: term Y X), forget o f === forget o g -> f ~== g -> f === g (* effect measure - Dumas et al.'12 *)
  | local_global: forall X (f g: term unit X), (forall i: Loc, lookup i o f ~== lookup i o g) -> f === g
  | fst_lpair_eq: forall X Y' Y (f1: term Y X) (f2: term Y' X), RO epure f1 -> RO epure f2 -> pi1 o pair f1 f2 === f1
  | snd_lpair_eq: forall X Y' Y (f1: term Y X) (f2: term Y' X), RO epure f1 -> RO epure f2 -> pi2 o pair f1 f2 === f2
  | swtoss: forall X Y k (f g: term X Y), PPG k f -> PPG k g -> f ==~ g -> f === g
  | eeffect: forall X Y (f g: term Y X), (f o (empty X) === g o (empty X)) -> f ==~ g -> f === g (* dual effect measure - Dumas et al.'14 *)
  | elocal_global: forall X (f g: term X Empty_set), (forall t: EName, f o tag t ==~ g o tag t) -> f === g (* dual to eq3 *)
  | ss_lcopair_eq: forall X X' Y k (f1: term Y X) (f2: term Y X'), PPG k f1 -> (copair f1 f2) o in2 === f2
 (* | tcomp: forall X Y Z (f: Y -> Z) (g: X -> Y), tpure f o tpure g  === tpure (fun x => f (g x)) *)
       (*IMP Assumptions*)
  | imp_loopiter: forall (b: term (unit+unit) unit) (f : term unit unit), lpi b f === (copair ((lpi b f) o f) id) o b
  | imp1: forall (p q: Z) (f: Z*Z -> Z), tpure f o (pair (@constant Z p) (@constant Z q)) === (constant (f(p,q)))
  | imp2: forall (p q: Z) (f: Z*Z -> bool), f(p, q) = false -> (tpure f o (pair (@constant Z p) (@constant Z q))) === constant false
  | imp3: forall (p q: Z) (f: Z*Z -> bool), f(p, q) = true -> (tpure f o (pair (@constant Z p) (@constant Z q))) === constant true
  | imp4: forall (p q: bool) (f: bool*bool -> bool), f(p, q) = false -> (tpure f o (pair (@constant bool p) (@constant bool q))) === constant false
  | imp5: forall (p q: bool) (f: bool*bool -> bool), f(p, q) = true -> (tpure f o (pair (@constant bool p) (@constant bool q))) === constant true
  | imp6: forall X Y (f g: Y -> X), (forall x, f x = g x) -> tpure f === tpure g
  | tcomp: forall X Y Z (f: Z -> Y) (g: Y -> X), tpure (compose g f) === tpure g o tpure f
       (*\IMP Assumptions*)
 with ws: forall X Y, relation (term X Y) :=
  | wssym: forall X Y, Symmetric (@ws X Y)
  | wstrans: forall X Y, Transitive (@ws X Y)
  | wsassoc: forall X Y Z T (f: term X Y) (g: term Y Z) (h: term Z T), f o (g o h) ~== (f o g) o h
  | wssubs: forall A B C, Proper (@ws C B ==> @idem B A ==> @ws C A) comp
  | pwsrepl: forall A B C k (g: term C B), (PURE k g) -> Proper (@ws B A ==> @ws C A) (comp g)
  | wwtows: forall X Y k (f g: term X Y), PPG k f -> PPG k g -> f ~~ g -> f ~== g
  | ws_unit: forall X (f g: term unit X), f ~== g
  | ax1: forall i, lookup i o update i ~== (@id Z)
  | ax2: forall i j, i<>j -> lookup j o update i ~== lookup j o (@forget Z)
  | sstows: forall  X Y (f g: term X Y), f === g -> f ~== g
  | lpair_ueq: forall X Y' Y (f1: term (Y*Y') X) (f2: term (Y*Y') X), (pi1 o f1 ~== pi1 o f2) -> (pi2 o f1 ~== pi2 o f2) -> f1 ~== f2
 with sw: forall X Y, relation (term X Y) :=
  | swsym: forall X Y, Symmetric (@sw X Y)
  | swtrans: forall X Y, Transitive (@sw X Y)
  | swassoc: forall X Y Z T (f: term X Y) (g: term Y Z) (h: term Z T), f o (g o h) ==~ (f o g) o h
  | swrepl : forall A B C, Proper (@idem C B ==> @sw B A ==> @sw C A) comp
  | pswsubs : forall A B C k, Proper (@sw C B ==> @pure_id k B A ==> @sw C A) comp
  | wwtosw: forall X Y k (f g: term X Y), RO k f -> RO k g -> f ~~ g -> f ==~ g
  | sw_empty: forall X (f g: term X Empty_set), f ==~ g
  | eax1: forall e: EName, untag e o tag e ==~ (@id unit)
  | eax2: forall (e1 e2: EName), e1 <> e2 -> untag e2 o tag e1 ==~ (empty unit) o tag e1
  | sstosw: forall  X Y (f g: term X Y), f === g -> f ==~ g
  | sw_downcast: forall X Y (f: term X Y), f ==~ (@downcast X Y f)
  | sw_lcopair_eq: forall X X' Y k (f1: term Y X) (f2: term Y X'), PPG k f1 -> (copair f1 f2) o in1 ==~ f1
  | lcopair_ueq: forall  X X' Y (f g: term Y (X+X')), (f o in1 ==~ g o in1) -> (f o in2 ==~ g o in2) -> f ==~ g
 with ww: forall X Y, relation (term X Y) :=
  | wwsym: forall X Y, Symmetric (@ww X Y)
  | wwtrans: forall X Y, Transitive (@ww X Y)
  | wstoww: forall X Y (f g: term X Y), f ~== g -> f ~~ g
  | swtoww: forall X Y (f g: term X Y), f ==~ g -> f ~~ g
  | sstoww: forall X Y (f g: term X Y), f === g -> f ~~ g
 where "x === y" := (ss x y)
   and "x ~== y" := (ws x y)
   and "x ==~ y" := (sw x y)
   and "x ~~ y" := (ww x y).

 Instance Eqss: forall X Y, Equivalence (@ss X Y).
 Proof. constructor; intro. apply ssrefl. apply sssym. apply sstrans. Qed.

 Instance Eqws: forall X Y, Equivalence (@ws X Y).
 Proof. constructor; intro. apply sstows. apply ssrefl. apply wssym. apply wstrans. Qed.

 Instance Eqsw: forall X Y, Equivalence (@sw X Y).
 Proof. constructor; intro. apply sstosw. apply ssrefl. apply swsym. apply swtrans. Qed.

 Instance Eqww: forall X Y, Equivalence (@ww X Y).
 Proof. constructor; intro. apply sstoww. apply ssrefl. apply wwsym. apply wwtrans. Qed.

 Instance Sub_ss_ww: forall X Y, subrelation (@ss X Y) (@ww X Y).
 Proof. intros. constructor. apply sstoww. apply sssym. assumption. Qed.

 Instance Sub_ss_sw: forall X Y, subrelation (@ss X Y) (@sw X Y).
 Proof. constructor. apply sstosw. apply sssym. exact H. Qed.

 Instance Sub_ss_ws: forall X Y, subrelation (@ss X Y) (@ws X Y).
 Proof. constructor. apply sstows. apply sssym. exact H. Qed.

 Existing Instance wssubs.
 Existing Instance pwsrepl.
 Existing Instance swrepl.
 Existing Instance pswsubs.
 Existing Instance replsubs.
 Existing Instance replsubsp.
 Existing Instance replsubscp.

 Lemma ss_unit: forall X (f: term unit X), RO ctc f -> f === forget.
 Proof. intros X f H. apply (@wstoss _ _ ctc). exact H. decorate. apply ws_unit. Qed.

 Lemma ss_empty: forall X (f: term X Empty_set), PPG rw f -> f === (@empty X).
 Proof. intros X f H. apply (@swtoss _ _ rw). exact H. edecorate. apply sw_empty. Qed.

End Make.


(** Formalization of a Predicative System F

In this file, we define our formalization of predicative System F
by providing:

  * Coq datatypes for kinds, terms, types and environments ;
  * a decidable structural equality predicate over types ;
  * helper functions for shifting de Bruijn indices of type and
    term variables in terms and types ;
  * helper functions for substitutions of type and term variables
    in terms and types ;
  * helper functions for accessing kinds and types of type and
    term variables in an environment ;
  * logical and decidable predicates for the wellformedness of
    types and environments ;
  * a kinding logical predicate altogether with a kinding
    algorithm ;
  * a typing logical predicate altogether with a typing
    algorithm.

The correctness properties that we expect from the decidable
predicates and the kinding and typing algorithms are stated and
proved in Correctness.v. *)

Require Import Arith.

Section DataTypes.

  (** A kind is entirely defined by its level in the kind hierarchy. *)
  Definition kind := nat.

  (** Inductive definition of types. *)
  Inductive typ :=
  | tvar : nat -> typ
  | tarr : typ -> typ -> typ
  | tall : kind -> typ -> typ
  .

  (** Inductive definition of terms. *)
  Inductive term :=
  | var   : nat -> term
  | abs   : typ -> term -> term
  | app   : term -> term -> term
  | abs_t : kind -> term -> term
  | app_t : term -> typ -> term
  .

  (** Inductive definition of environments. *)
  Inductive env : Set :=
  | empty : env
  | evar  : typ -> env -> env
  | etvar : kind -> env -> env
  .

End DataTypes.

Section Equality.

  Open Scope bool.

  (** Structural equality over types. *)
  Fixpoint beq_typ (T1 : typ) (T2 : typ) : bool :=
    match (T1, T2) with
      | (tvar X, tvar Y)           => beq_nat X Y
      | (tarr T1 T2, tarr T1' T2') => beq_typ T1 T1' && beq_typ T2 T2'
      | (tall K T, tall K' T')     => beq_nat K K' && beq_typ T T'
      | _                          => false
    end.

End Equality.

Section Shifting.

  (** [tshift X T] shifts by one the de Bruijn index of all type
      variables in type [T] with index greater than or equal to
      [X] at the current level. *)
  Fixpoint tshift (X : nat) (T : typ) {struct T} : typ :=
  match T with
  | tvar Y     => tvar (if le_gt_dec X Y then S Y else Y)
  | tarr T1 T2 => tarr (tshift X T1) (tshift X T2)
  | tall K T0  => tall K (tshift (S X) T0)
  end.

  (** [shift x t] shifts by one the de Bruijn index of all term
      variables in term [t] with index greater than or equal to
      [x] at the current level. *)
  Fixpoint shift (x : nat) (t : term) {struct t} : term :=
    match t with
      | var y      => var (if le_gt_dec x y then S y else y)
      | abs T t0   => abs T (shift (S x) t0)
      | app t1 t2  => app (shift x t1) (shift x t2)
      | abs_t K t0 => abs_t K (shift x t0)
      | app_t t0 T => app_t (shift x t0) T
    end.

  (** [shift_typ X t] shifts by one the de Bruijn index of all
      type variables in every type present in the term [t] with
      index greater than or equal to [X] at the current level. *)
  Fixpoint shift_typ (X : nat) (t : term) {struct t} : term :=
    match t with
      | var y      => var y
      | abs T t0   => abs (tshift X T) (shift_typ X t0)
      | app t1 t2  => app (shift_typ X t1) (shift_typ X t2)
      | abs_t K t0 => abs_t K (shift_typ (S X) t0)
      | app_t t0 T => app_t (shift_typ X t0) (tshift X T)
    end.

End Shifting.

Section Substitution.

  (** [tsubst T X T'] replaces occurrences of the type variable
      of de Bruijn index [X] in the type [T] by the type [T'] and
      decreases by one the index of all type variables of greater
      index. *)
  Fixpoint tsubst (T : typ) (X : nat) (T' : typ) {struct T} : typ :=
    match T with
      | tvar Y =>
        match lt_eq_lt_dec Y X with
          | inleft (left _)  => tvar Y
          | inleft (right _) => T'
          | inright _        => tvar (Y - 1)
        end
      | tarr T1 T2 => tarr (tsubst T1 X T') (tsubst T2 X T')
      | tall K T0  => tall K (tsubst T0 (S X) (tshift 0 T'))
    end.

  (** [subst t x t'] replaces occurrences of the variable of de Bruijn
      index [x] in the term [t] by the term [t'] and decreases by one
      the index of all variables of greater index. *)
  Fixpoint subst (t : term) (x : nat) (t' : term) {struct t} : term :=
    match t with
      | var y =>
        match lt_eq_lt_dec y x with
          | inleft (left _)  => var y
          | inleft (right _) => t'
          | inright _        => var (y - 1)
        end
      | abs T t0   => abs T (subst t0 (S x) (shift 0 t'))
      | app t1 t2  => app (subst t1 x t') (subst t2 x t')
      | abs_t K t0 => abs_t K (subst t0 x (shift_typ 0 t'))
      | app_t t0 T => app_t (subst t0 x t') T
    end.

  (** [subst_typ t X T] replaces occurrences of the type variable of de
      Bruijn index [X] in the term [t] by the type [T] and decreases by
      one the index of all type variables of greater index. *)
  Fixpoint subst_typ (t : term) (X : nat) (T : typ) {struct t} : term :=
    match t with
      | var y       => var y
      | abs T0 t0   => abs (tsubst T0 X T) (subst_typ t0 X T)
      | app t1 t2   => app (subst_typ t1 X T) (subst_typ t2 X T)
      | abs_t K t0  => abs_t K (subst_typ t0 (S X) (tshift 0 T))
      | app_t t0 T0 => app_t (subst_typ t0 X T) (tsubst T0 X T)
    end.

End Substitution.

Section EnvironmentAccess.

  (** [get_kind e i] returns the [i]-th kind in environment [e], if it
      exists. *)
  Fixpoint get_kind (e : env) (i : nat) : option kind :=
    match e with
      | empty      => None
      | evar _ e'  => get_kind e' i
      | etvar K e' =>
        match i with
          | 0    => Some K
          | S i' => get_kind e' i'
        end
    end.

  (** [get_typ e i] returns the [i]-th type in environment [e], if it
      exists. *)
  Fixpoint get_typ (e : env) (i : nat) : option typ :=
    match e with
      | empty => None
      | etvar _ e' => option_map (tshift 0) (get_typ e' i)
      | evar T e' =>
        match i with
          | 0    => Some T
          | S i' => get_typ e' i'
        end
    end.

End EnvironmentAccess.

Section Wellformedness.

  (** Wellformedness of types expressed as a logical property. *)
  Fixpoint wf_typ (e : env) (T : typ) : Prop :=
    match T with
      | tvar X     => get_kind e X <> None
      | tarr T1 T2 => wf_typ e T1 /\ wf_typ e T2
      | tall K T0  => wf_typ (etvar K e) T0
    end.

  (** Wellformedness of environments expressed as a logical property. *)
  Fixpoint wf_env (e : env) : Prop :=
    match e with
      | empty      => True
      | evar T e'  => wf_typ e' T /\ wf_env e'
      | etvar K e' => wf_env e'
    end.

  Open Scope bool.

  (** Wellformedness of types expressed as a decidable predicate. *)
  Fixpoint bwf_typ (e : env) (T : typ) : bool :=
    match T with
      | tvar X =>
        match get_kind e X with
          | None   => false
          | Some _ => true
        end
      | tarr T1 T2 => bwf_typ e T1 && bwf_typ e T2
      | tall K T0  => bwf_typ (etvar K e) T0
    end.

  (** Wellformedness of environments expressed as a decidable predicate. *)
  Fixpoint bwf_env (e : env) : bool :=
    match e with
      | empty      => true
      | evar T e'  => bwf_typ e' T && bwf_env e'
      | etvar _ e' => bwf_env e'
    end.

End Wellformedness.

Section Kinding.

  (** Kinding expressed as a logical property. *)
  Inductive kinding : env -> typ -> kind -> Prop :=
  | k_tvar (e : env) (X : nat) (Kp Kq : kind) :
      wf_env e ->
      get_kind e X = Some Kp ->
      Kp <= Kq ->
      kinding e (tvar X) Kq
  | k_tall (e : env) (T : typ) (Kp Kq : kind) :
      kinding (etvar Kq e) T Kp ->
      kinding e (tall Kq T) (S (max Kp Kq))
  | k_tarr (e : env) (T1 T2 : typ) (Kp Kq : kind) :
      kinding e T1 Kp ->
      kinding e T2 Kq ->
      kinding e (tarr T1 T2) (max Kp Kq)
  .

  (** [kind_of e T] provides a minimal kind for type [T] in
      environment [e], if [T] is kindable in [e]. *)
  Fixpoint kind_of (e : env) (T : typ) : option kind :=
    match T with
      | tvar X => if bwf_env e then get_kind e X else None
      | tarr T1 T2 =>
        match kind_of e T1 with
          | None    => None
          | Some K1 =>
            option_map (fun K2 => max K1 K2)
                       (kind_of e T2)
        end
      | tall K T0 =>
        option_map (fun K' => S (max K' K))
                   (kind_of (etvar K e) T0)
    end.

End Kinding.

Section Typing.

  (** Typing expressed as a logical property. *)
  Inductive typing : env -> term -> typ -> Prop :=
  | t_var (e : env) (X : nat) (T : typ) :
      wf_env e ->
      get_typ e X = Some T ->
      typing e (var X) T
  | t_abs (e : env) (T1 T2 : typ) (t : term) :
      wf_typ e T1 ->
      typing (evar T1 e) t T2 ->
      typing e (abs T1 t) (tarr T1 T2)
  | t_app (e : env) (T1 T2 : typ) (t1 : term) (t2 : term) :
      typing e t1 (tarr T1 T2) ->
      typing e t2 T1 ->
      typing e (app t1 t2) T2
  | t_abs_t (e : env) (K : kind) (t : term) (T : typ) :
      typing (etvar K e) t T ->
      typing e (abs_t K t) (tall K T)
  | t_app_t (e : env) (K : kind) (t : term) (T1 T2 : typ) :
      typing e t (tall K T1) ->
      kinding e T2 K ->
      typing e (app_t t T2) (tsubst T1 0 T2)
  .

  (** [type_of e t] provides a type for term [t] in environment [e],
      if [t] is typable in [e]. *)
  Fixpoint type_of (e : env) (t : term) : option typ :=
    match t with
      | var x => if bwf_env e then get_typ e x else None
      | abs T t' =>
        match type_of (evar T e) t' with
          | Some T' => if bwf_typ e T then Some (tarr T T') else None
          | None => None
        end
      | app t1 t2 =>
        match type_of e t1 with
          | Some (tarr T1 T2) =>
            match type_of e t2 with
              | Some T1' =>
                if beq_typ T1 T1'
                then Some T2
                else None
              | _ => None
            end
          | _ => None
      end
      | abs_t K t' =>
        option_map (fun T => tall K T)
                   (type_of (etvar K e) t')
      | app_t t' T =>
        match type_of e t' with
          | Some (tall K T') =>
            match kind_of e T with
              | Some K' =>
                if leb K' K
                then Some (tsubst T' 0 T)
                else None
              | None => None
            end
          | _ => None
        end
    end.

End Typing.


(** This file defines the kernel of a homomorphism [cong_ker], the
    image of a homomorphism [in_image_hom], and it proves the first
    isomorphism theorem [isomorphic_first_isomorphism]. The first
    identification theorem [id_first_isomorphism] follows. *)

Require Import
  HoTT.Types.Forall
  HoTT.Types.Sigma
  HoTT.Types.Universe
  HoTT.HSet
  HoTT.HIT.quotient
  HoTT.Classes.interfaces.canonical_names
  HoTTClasses.theory.ua_isomorphic
  HoTTClasses.theory.ua_subalgebra
  HoTTClasses.theory.ua_quotient_algebra.

Import
  algebra_notations
  quotient_algebra_notations
  subalgebra_notations
  isomorphic_notations.

(** The following section defines the kernel of a homomorphism
    [cong_ker], and shows that it is a congruence.*)

Section cong_ker.
  Context
    {σ : Signature} {A B : Algebra σ} `{IsHSetAlgebra B}
    (f : ∀ s, A s → B s) `{!IsHomomorphism f}.

  Definition cong_ker (s : Sort σ) : relation (A s)
    := λ (x y : A s), f s x = f s y.

(* Leave the following results about [cong_ker] opaque because they
   are h-props. *)

  Global Instance equiv_rel_ker (s : Sort σ)
    : EquivRel (cong_ker s).
  Proof.
    repeat constructor.
    - intros x y. exact inverse.
    - intros x y z. exact concat.
  Qed.

  Lemma path_ap_operation_ker_related {w : SymbolType σ}
    (β : Operation B w) (a b : FamilyProd A (dom_symboltype w))
    (R : for_all_2_family_prod A A cong_ker a b)
    : ap_operation β (map_family_prod f a)
      = ap_operation β (map_family_prod f b).
  Proof.
    induction w.
    - reflexivity.
    - destruct a as [x a], b as [y b], R as [r R].
      cbn. destruct r. by apply IHw.
  Qed.

  Global Instance ops_compatible_ker : OpsCompatible A cong_ker.
  Proof.
    intros u a b R.
    unfold cong_ker.
    destruct (path_homomorphism_ap_operation f u a)^.
    destruct (path_homomorphism_ap_operation f u b)^.
    by apply path_ap_operation_ker_related.
  Qed.

  Global Instance is_congruence_ker : IsCongruence A cong_ker
    := BuildIsCongruence A cong_ker.

End cong_ker.

(** The next section defines an "in image predicate", [in_image_hom].
    It gives rise to the homomorphic image of a homomorphism. *)

Section in_image_hom.
  Context
    `{Funext} {σ : Signature} {A B : Algebra σ}
    (f : ∀ s, A s → B s) {hom : IsHomomorphism f}.

  Definition in_image_hom (s : Sort σ) (y : B s) : hProp
    := merely (hfiber (f s) y).

  Lemma closed_under_op_in_image_hom {w : SymbolType σ}
    (α : Operation A w) (β : Operation B w) (P : OpPreserving f α β)
    : ClosedUnderOp B in_image_hom β.
  Proof.
    induction w.
    - exact (tr (α; P)).
    - intro y.
      refine (Trunc_rec _). intros [x p].
      apply (IHw (α x)).
      by destruct p.
  Qed.

  Lemma is_closed_under_ops_in_image_hom
    : IsClosedUnderOps B in_image_hom.
  Proof.
    intro u. eapply closed_under_op_in_image_hom, hom.
  Qed.

  Global Instance is_subalgebra_predicate_in_image_hom
    : IsSubalgebraPredicate B in_image_hom
    := BuildIsSubalgebraPredicate is_closed_under_ops_in_image_hom.
End in_image_hom.

(** The folowing section proves the first isomorphism theorem,
    [isomorphic_first_isomorphism] and the first identification
    theorem [id_first_isomorphism]. *)

Section first_isomorphism.
  Context
    `{Univalence} {σ} {A B : Algebra σ} `{IsHSetAlgebra B}
    (f : ∀ s, A s → B s) {hom : IsHomomorphism f}.

(** The homomorphism [def_first_isomorphism] is informally given by

    <<
      def_first_isomorphism s (class_of _ x) := f s x.
    >>
*)

  Definition def_first_isomorphism (s : Sort σ)
    : (A / cong_ker f) s → (B & in_image_hom f) s.
  Proof.
    refine (quotient_rec (cong_ker f s) (λ x, (f s x; tr (x; idpath))) _).
    intros x y p.
    now apply path_sigma_hprop.
  Defined.

  Lemma oppreserving_first_isomorphism {w : SymbolType σ}
    (α : Operation A w)
    (β : Operation B w)
    (γ : Operation (A / cong_ker f) w)
    (C : ClosedUnderOp B (in_image_hom f) β)
    (P : OpPreserving f α β)
    (G : ComputeOpQuotient A (cong_ker f) α γ)
    : OpPreserving def_first_isomorphism γ
        (op_subalgebra B (in_image_hom f) β C).
  Proof.
    induction w.
    - apply path_sigma_hprop.
      generalize dependent γ.
      refine (quotient_ind_prop (cong_ker f t) _ _). intros x G.
      destruct P.
      apply (classes_eq_related (cong_ker f t) _ _ (G tt)).
    - refine (quotient_ind_prop (cong_ker f t) _ _). intro x.
      apply (IHw (α x) (β (f t x)) (γ (class_of _ x))).
      + exact (P x).
      + intro a. exact (G (x,a)).
  Qed.

(* Leave [is_homomorphism_first_isomorphism] opaque because
   [IsHomomorphism] is an hprop when [B] is a set algebra. *)

  Global Instance is_homomorphism_first_isomorphism
    : IsHomomorphism def_first_isomorphism.
  Proof.
    intro u. apply (oppreserving_first_isomorphism (u^^A)).
    - apply hom.
    - apply compute_op_quotient.
  Qed.

  Definition hom_first_isomorphism
    : Homomorphism (A / cong_ker f) (B & in_image_hom f)
    := BuildHomomorphism def_first_isomorphism.

  Global Instance embedding_first_isomorphism (s : Sort σ)
    : IsEmbedding (hom_first_isomorphism s).
  Proof.
    apply isembedding_isinj_hset.
    refine (quotient_ind_prop (cong_ker f s) _ _). intro x.
    refine (quotient_ind_prop (cong_ker f s) _ _). intros y p.
    apply related_classes_eq.
    exact (p..1).
  Qed.

  Global Instance surjection_first_isomorphism (s : Sort σ)
    : IsSurjection (hom_first_isomorphism s).
  Proof.
    apply BuildIsSurjection.
    intros [x M].
    refine (Trunc_rec _ M). intros [y Y].
    apply tr.
    exists (class_of _ y).
    now apply path_sigma_hprop.
  Qed.

  Global Instance is_isomorphism_first_isomorphism
    : IsIsomorphism hom_first_isomorphism.
  Proof.
    intro s. apply isequiv_surj_emb; exact _.
  Qed.

  Theorem isomorphic_first_isomorphism
    : A / cong_ker f ≅ B & in_image_hom f.
  Proof.
    exact (BuildIsomorphic def_first_isomorphism).
  Defined.

(* The first identification theorem [id_first_isomorphism] is an
   h-prop, so we can leave it opaque. *)

  Corollary id_first_isomorphism : A / cong_ker f = B & in_image_hom f.
  Proof.
    exact (id_isomorphic isomorphic_first_isomorphism).
  Qed.
End first_isomorphism.

(** The next section gives a specialization of the first isomorphism
    theorem, where the homomorphism is surjective. *)

Section first_isomorphism_surjection.
  Context
    `{Univalence} {σ} {A B : Algebra σ} `{IsHSetAlgebra B}
    (f : ∀ s, A s → B s) `{!IsHomomorphism f} {S : ∀ s, IsSurjection (f s)}.

  Global Instance is_isomorphism_inc_first_isomorphism_surjection
    : IsIsomorphism (hom_inc_subalgebra B (in_image_hom f)).
  Proof.
    apply is_isomorphism_inc_improper_subalgebra. apply S.
  Qed.

(** The homomorphism [hom_first_isomorphism_surjection] is the
    composition of two isomorphisms, so it is an isomorphism. *)

  Definition hom_first_isomorphism_surjection
    : Homomorphism (A / cong_ker f) B
    := hom_compose
          (hom_inc_subalgebra B (in_image_hom f))
          (hom_first_isomorphism f).

  Theorem isomorphic_first_isomorphism_surjection : A / cong_ker f ≅ B.
  Proof.
    exact (BuildIsomorphic hom_first_isomorphism_surjection).
  Defined.

  Corollary id_first_isomorphism_surjection : (A / cong_ker f) = B.
  Proof.
    exact (id_isomorphic isomorphic_first_isomorphism_surjection).
  Qed.
End first_isomorphism_surjection.

(** The next section specializes the first isomorphism theorem to the
    case where the homomorphism is injective. It proves that an
    injective homomorphism is an isomorphism between its domain
    and its image. *)

Section first_isomorphism_inj.
  Context
    `{Univalence} {σ} {A B : Algebra σ} `{IsHSetAlgebra B}
    (f : ∀ s, A s → B s) `{!IsHomomorphism f} (inj : ∀ s, isinj (f s)).

  Global Instance is_isomorphism_quotient_first_isomorphism_inj
    : IsIsomorphism (hom_quotient (cong_ker f)).
  Proof.
    apply is_isomorphism_quotient. intros s x y p. apply inj, p.
  Qed.

(** The homomorphism [hom_first_isomorphism_inj] is the
    composition of two isomorphisms, so it is an isomorphism. *)

  Definition hom_first_isomorphism_inj
    : Homomorphism A (B & in_image_hom f)
    := hom_compose
          (hom_first_isomorphism f)
          (hom_quotient (cong_ker f)).

  Definition isomorphic_first_isomorphism_inj : A ≅ B & in_image_hom f
    := BuildIsomorphic hom_first_isomorphism_inj.

  Definition id_first_isomorphism_inj : A = B & in_image_hom f
    := id_isomorphic isomorphic_first_isomorphism_inj.

End first_isomorphism_inj.


Require Import FunctionalExtensionality.
Require Import Program.
Require Import Category.
Require Import Coq.
Require Import Co.

Set Universe Polymorphism.

Definition monoic (C:Category) {a b} (m:b → a) := forall {c} {f g:c → b}, f ∘ m = g ∘ m -> f = g.

Definition epi (C:Category) {a b} (m:a → b) := forall {c} {f g:b → c}, m ∘ f = m ∘ g -> f = g.

Definition epiIsCoMonoic : forall C, @epi C = @monoic (co C).
  unfold epi, monoic.
  cbn.
  reflexivity.
Defined.

Definition idMonoic {A} : monoic Coq (fun a:A=>a).
  compute in *.
  intros ? f g ?.
  rewrite (eta_expansion f).
  rewrite (eta_expansion g).
  trivial.
Defined.

Definition constNotMonoic : exists A B (b:B), ~monoic Coq (fun _:A => b).
  exists nat.
  exists nat.
  exists 0.
  compute.
  intro h.
  specialize (h nat S (const 0) eq_refl).
  compute in *.
  specialize (equal_f h 0).
  congruence.
Defined.

Definition injectiveIsMonoic {A B} {i:A->B} : (forall a a', i a = i a' -> a = a') <-> monoic Coq i.
  compute.
  constructor.
  - intros h ? f g h'.
    extensionality x.
    specialize (equal_f h' x); intro h''.
    specialize (h (f x) (g x)).
    intuition.
  - intros h a a' h'.
    specialize (h A (const a) (const a')).
    compute in *.
    refine ((fun h'' => equal_f h'' a) (h _)).
    extensionality x.
    apply h'.
Defined.

Require Import Classical_Pred_Type.
Require ClassicalFacts.
Axiom prop_ext : ClassicalFacts.prop_extensionality.

Definition surjectiveIsEpi {A B} {s:A->B} : (forall b, exists a, s a = b) <-> epi Coq s.
  compute.
  constructor.
  - intros h ? f g h'.
    extensionality x.
    specialize (equal_f h'); intro h''.
    destruct (h x) as [x' h'''].
    clear h h'.
    specialize (h'' x').
    rewrite h''' in *.
    apply h''.
  - intros h.
    apply not_ex_not_all.
    intros [b h'].
    specialize (not_ex_all_not _ _ h'); clear h'; intro h'.
    specialize (h Prop (fun b' => b' = b) (fun _ => False)).
    compute in *.
    refine ((fun h'' => _) (h _)). {
      specialize (equal_f h'' b); clear h''; intro h''.
      rewrite <- h''.
      reflexivity.
    }
    clear h.
    extensionality x.
    specialize (h' x).
    apply prop_ext.
    intuition.
Defined.


(* Definition of Salsa according to Bernstein's paper
"The Salsa20 family of stream ciphers", http://cr.yp.to/snuffle/salsafamily-20071225.pdf*)

Require Import compcert.lib.Coqlib.
Require Import Coq.Strings.String.
Require Import VST.msl.Extensionality.
Require Import List. Import ListNotations.

Require Import compcert.lib.Integers.
Require Import sha.functional_prog.
Require Import tweetnacl20140427.Salsa20.
Require Import tweetnacl20140427.tweetNaclBase. (*for bind, combinelist*)

Definition Step1 (x:list int): option (list int):=
match x with [x0; x1; x2; x3; x4; x5; x6; x7; x8; x9; x10; x11; x12; x13; x14; x15]
=>
 let y3 := Int.xor x3 (Int.rol (Int.add x15 x11) (Int.repr 7)) in
 let y4 := Int.xor x4 (Int.rol (Int.add x0 x12) (Int.repr 7)) in
 let y9 := Int.xor x9 (Int.rol (Int.add x5 x1) (Int.repr 7)) in
 let y14 := Int.xor x14 (Int.rol (Int.add x10 x6) (Int.repr 7)) in
 Some [x0; x1; x2; y3;
       y4; x5; x6; x7;
       x8; y9; x10; x11;
       x12; x13; y14; x15]
| _ => None
 end.
Definition test1_in := map x2i
  ([ "61707865"; "04030201"; "08070605"; "0c0b0a09";
     "100f0e0d"; "3320646e"; "01040103"; "06020905";
     "00000007"; "00000000"; "79622d32"; "14131211";
     "18171615"; "1c1b1a19"; "201f1e1d"; "6b206574"])%string.
Definition test1_out1 := map x2i ([
"61707865"; "04030201"; "08070605"; "95b0c8b6";
"d3c83331"; "3320646e"; "01040103"; "06020905";
"00000007"; "91b3379b"; "79622d32"; "14131211";
"18171615"; "1c1b1a19"; "130804a0"; "6b206574"])%string.

Goal Step1 test1_in = Some(test1_out1). reflexivity. Qed.

Definition Step2 (x:list int): option (list int):=
match x with [x0; x1; x2; x3; x4; x5; x6; x7; x8; x9; x10; x11; x12; x13; x14; x15]
=>
 let y2 := Int.xor x2 (Int.rol (Int.add x10 x14) (Int.repr 9)) in
 let y7 := Int.xor x7 (Int.rol (Int.add x15 x3) (Int.repr 9)) in
 let y8 := Int.xor x8 (Int.rol (Int.add x0 x4) (Int.repr 9)) in
 let y13 := Int.xor x13 (Int.rol (Int.add x5 x9) (Int.repr 9)) in
 Some [x0; x1; y2; x3;
       x4; x5; x6; y7;
       y8; x9; x10; x11;
       x12; y13; x14; x15]
| _ => None
 end.

Definition test1_out2 := map x2i ([
"61707865"; "04030201"; "dc64a31d"; "95b0c8b6";
"d3c83331"; "3320646e"; "01040103"; "a45e5d04";
"71572c6d"; "91b3379b"; "79622d32"; "14131211";
"18171615"; "bb230990"; "130804a0"; "6b206574"])%string.
Goal Step2 test1_out1 = Some(test1_out2). reflexivity. Qed.

Definition Step3 (x:list int): option (list int):=
match x with [x0; x1; x2; x3; x4; x5; x6; x7; x8; x9; x10; x11; x12; x13; x14; x15]
=>
 let y1 := Int.xor x1 (Int.rol (Int.add x9 x13) (Int.repr 13)) in
 let y6 := Int.xor x6 (Int.rol (Int.add x14 x2) (Int.repr 13)) in
 let y11 := Int.xor x11 (Int.rol (Int.add x3 x7) (Int.repr 13)) in
 let y12 := Int.xor x12 (Int.rol (Int.add x4 x8) (Int.repr 13)) in
 Some [x0; y1; x2; x3;
       x4; x5; y6; x7;
       x8; x9; x10; y11;
       y12; x13; x14; x15]
| _ => None
 end.

Definition test1_out3 := map x2i ([
"61707865"; "cc266b9b"; "dc64a31d"; "95b0c8b6";
"d3c83331"; "3320646e"; "95f3bcee"; "a45e5d04";
"71572c6d"; "91b3379b"; "79622d32"; "f0a45550";
"f3e4deb6"; "bb230990"; "130804a0"; "6b206574"])%string.
Goal Step3 test1_out2 = Some(test1_out3). reflexivity. Qed.

Definition Step4 (x:list int): option (list int):=
match x with [x0; x1; x2; x3;  x4; x5; x6; x7; x8; x9; x10; x11; x12; x13; x14; x15]
=>
 let y0 := Int.xor x0 (Int.rol (Int.add x8 x12) (Int.repr 18)) in
 let y5 := Int.xor x5 (Int.rol (Int.add x13 x1) (Int.repr 18)) in
 let y10 := Int.xor x10 (Int.rol (Int.add x2 x6) (Int.repr 18)) in
 let y15 := Int.xor x15 (Int.rol (Int.add x7 x11) (Int.repr 18)) in
 Some [y0; x1; x2; x3;
       x4; y5; x6; x7;
       x8; x9; y10; x11;
       x12; x13; x14; y15]
| _ => None
 end.

Definition test1_out4 := map x2i ([
"4dfdec95"; "cc266b9b"; "dc64a31d"; "95b0c8b6";
"d3c83331"; "e78e794b"; "95f3bcee"; "a45e5d04";
"71572c6d"; "91b3379b"; "f94fe453"; "f0a45550";
"f3e4deb6"; "bb230990"; "130804a0"; "a272317e"])%string.
Goal Step4 test1_out3 = Some(test1_out4). reflexivity. Qed.

Definition transp (x:list int): option (list int):=
match x with [x0; x1; x2; x3;  x4; x5; x6; x7; x8; x9; x10; x11; x12; x13; x14; x15]
=> Some [x0; x4; x8; x12;
         x1; x5; x9; x13;
         x2; x6; x10; x14;
         x3; x7; x11; x15]
| _ => None
 end.
Definition test1_out := map x2i ([
"4dfdec95"; "d3c83331"; "71572c6d"; "f3e4deb6";
"cc266b9b"; "e78e794b"; "91b3379b"; "bb230990";
"dc64a31d"; "95f3bcee"; "f94fe453"; "130804a0";
"95b0c8b6"; "a45e5d04"; "f0a45550"; "a272317e"])%string.
Goal transp test1_out4 = Some(test1_out). reflexivity. Qed.

Definition snuffleStep x :=
  bind (Step1 x) (fun y => bind (Step2 y) (fun z => bind (Step3 z) Step4)).

Definition snuffleRound x := bind (snuffleStep x) transp.

Goal snuffleRound test1_in = Some test1_out. reflexivity. Qed.

Definition test1_round2 := map x2i ([
"ba2409b1"; "1b7cce6a"; "29115dcf"; "5037e027";
"37b75378"; "348d94c8"; "3ea582b3"; "c3a9a148";
"825bfcb9"; "226ae9eb"; "63dd7748"; "7129a215";
"4effd1ec"; "5f25dc72"; "a6c3d164"; "152a26d8"])%string.
Goal snuffleRound test1_out = Some(test1_round2). reflexivity. Qed.

Fixpoint Snuffle n x :=
  match n with O => Some x | S m => bind (Snuffle m x) snuffleRound end.

Goal Snuffle 1 = snuffleRound. extensionality. reflexivity. Qed.
Goal Snuffle 2 test1_in = Some(test1_round2). reflexivity. Qed.

Definition test1_round20 := map x2i ([
"58318d3e"; "0292df4f"; "a28d8215"; "a1aca723";
"697a34c7"; "f2f00ba8"; "63e9b0a1"; "27250e3a";
"b1c7f1f3"; "62066edc"; "66d3ccf1"; "b0365cf3";
"091ad09e"; "64f0c40f"; "d60d95ea"; "00be78c9"])%string.
Goal Snuffle 20 test1_in = Some(test1_round20). reflexivity. Qed.

Lemma snuffleRound_length r l:
  snuffleRound r = Some l -> length l = 16%nat /\ length r = 16%nat.
Proof. intros.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H. inv H.
destruct r; simpl in H; inv H.
split; trivial.
Qed.

Lemma snuffleRound_Zlength r l (R: snuffleRound r = Some l):
      Zlength l = 16 /\ Zlength r = 16.
Proof.
  do 2 rewrite Zlength_correct.
  destruct (snuffleRound_length _ _ R) as [A B].
  rewrite A, B; split; reflexivity.
Qed.

Lemma Snuffle_length r: forall i l, Snuffle i r = Some l -> length r = 16%nat -> length l = 16%nat.
Proof. induction i; simpl; intros. inv H; trivial.
remember (Snuffle i r) as s. symmetry in Heqs; destruct s; inv H.
apply snuffleRound_length in H2. apply H2.
Qed.

Lemma Snuffle_Zlength r i l (SN:Snuffle i r = Some l)
      (R:Zlength r = 16): Zlength l= 16.
Proof.
  rewrite Zlength_correct.
  rewrite (Snuffle_length _ _ _ SN); trivial.
  rewrite Zlength_correct in R.  apply Nat2Z.inj; auto.
Qed.
Opaque Snuffle.


Require Import hybrid.examples.room_heating.conc.

Require Import Coq.Program.Program.

Ltac ref := reflexivity.

Module RHS <: RoomHeatingSpec.

  Definition n := 3.

  Lemma nPos : (n > 0)%nat.
  Proof. compute. auto with arith. Qed.

  Definition off := vec_of_list [21:Q; 21:Q; 21:Q].
  Definition on := vec_of_list [20:Q; 20:Q; 20:Q].
  Definition get := vec_of_list [18:Q; 18:Q; 18:Q].
  Definition diff := vec_of_list [1:Q; 1:Q; 1:Q].

  Definition initHeaters := vec_of_list [true; true; false].
  Definition initTemp := vec_of_list [20:Q; 20:Q; 20:Q].

  Lemma on_lt_off : Vforall2n (fun on off => on < off) on off.
  Proof.
    apply Vforall2n_intro. intros.
    do 3 (destruct i; [vm_compute; trivial | idtac]).
    simpl in ip. elimtype False. omega.
  Qed.

End RHS.

Module RHSex := RoomHeatingConcrete RHS.


Require Import List Omega.

Require Import big_vs_small.
Require Import bigstep.
Require Import coinduction.
Require Import datatypes.
Require Import MminusN.
Require Import MminusNoo.
Require Import Ndiv2oo.
Require Import smallstep.
Require Import streams_vs_lists.
Require Import UndefNoo.

(**************** COPY Machine ***************)

Definition Copy: Spec := (0, one , 0, W zero) ::
                         (0, zero, 1,      R) ::
                         (1, one , 1,      R) ::
                         (1, B   , 2,      R) ::
                         (2, one , 2,      R) ::
                         (2, B   , 3,  W one) ::
                         (3, one , 3,      L) ::
                         (3, B   , 4,      L) ::
                         (4, one , 5,      L) ::
                         (4, zero, 6,  W one) ::
                         (5, one , 5,      L) ::
                         (5, zero, 0,      R) ::
                         (6, one , 6,      L) ::
                         (6, zero, 6,  W one) ::
                         (6, B   , 7,      R) :: nil.

(**************** LOOP part *********************************************)

Lemma Copy_loop_5L_sf: forall n l r,
      sf Copy (pair ((app_ls (ones n) (Cons zero l)))
                    (Cons one r))
              4
              (pair l
                    (Cons zero (app_ls (ones (S n)) r)))
              5.
destruct n; intros.

simpl. apply sfI with 5 (pair l (Cons zero (Cons one r))).
apply s1L. auto. apply sf0.

apply sfI with 5 (pair (app_ls (ones n) (Cons zero l))
                       (Cons one (Cons one r))).
apply s1L. auto.

generalize n l r; clear n l r.
induction n; intros.

simpl. apply sfI with 5 (pair l (Cons zero (Cons one (Cons one r)))).
apply s1L. auto. apply sf0.

apply sfI with 5 (pair (app_ls (ones n) (Cons zero l))
                       (Cons one (Cons one (Cons one r)))).
apply s1L. auto.
assert (app_ls (ones (S (S (S n)))) r =
       (app_ls (ones (S (S n))) (Cons one r))).
simpl. rewrite ones_comm. reflexivity.
rewrite H; clear H. apply IHn.
Qed.

Lemma Copy_loop_1and2R_sf: forall n l r p,
      p = 1 \/ p = 2 ->
      sf Copy (pair l (app_ls (ones n) r)) p
              (pair (app_ls (ones n) l) r) p.
induction n; intros; simpl.

apply sf0.

inversion_clear H.

rewrite H0; clear H0.
apply sfI with 1 (pair (Cons one l) (app_ls (ones n) r)).
apply s1R. auto.
rewrite <- ones_comm. apply IHn. tauto.

rewrite H0; clear H0.
apply sfI with 2 (pair (Cons one l) (app_ls (ones n) r)).
apply s1R. auto.
rewrite <- ones_comm. apply IHn. tauto.
Qed.

Lemma Copy_loop_3L_sf: forall n l r,
      sf Copy (pair (app_ls (ones n) l) (Cons one r)) 3
              (pair l (app_ls (ones n) (Cons one r))) 3.
induction n; intros; simpl.

apply sf0.

apply sfI with 3 (pair (app_ls (ones n) l)
                       (Cons one (Cons one r))).
apply s1L. auto.
rewrite <- ones_comm. apply IHn.
Qed.

Lemma Copy_loop_generalized_sf: forall j k n,
      n = j+k ->
      sf Copy (pair (app_ls (ones j) (app_ls (zeros (S k)) Bs))
                    (Cons B (app_ls (ones (S k)) Bs)))
               3
              (pair (app_ls (zeros (S n)) Bs)
                    (Cons B (app_ls (ones (S n)) Bs)))
               3.
induction j; intros.

simpl in H |-*. rewrite H. apply sf0.

apply sfI with 4 (pair (app_ls (ones j) (app_ls (zeros (S k)) Bs))
                       (Cons one (Cons B (app_ls (ones (S k)) Bs)))).
apply s1L. auto.

apply sf_trans with (pair (app_ls (zeros k) Bs)
                          (Cons zero (app_ls (ones (S j))
                                   (Cons B (app_ls (ones (S k)) Bs)))))
                    5.
apply Copy_loop_5L_sf.

apply sfI with 0 (pair (Cons zero (app_ls (zeros k) Bs))
                       (app_ls (ones (S j))
                               (Cons B (app_ls (ones (S k)) Bs)))).
apply s1R. auto.

apply sfI with 0 (pair (Cons zero (app_ls (zeros k) Bs))
                       (Cons zero (app_ls (ones j)
                                  (Cons B (app_ls (ones (S k)) Bs))))).
apply s1W. auto.

apply sfI with 1 (pair (Cons zero (Cons zero (app_ls (zeros k) Bs)))
                       (app_ls (ones j)
                               (Cons B (app_ls (ones (S k)) Bs)))).
apply s1R. auto.

apply sf_trans with (pair (app_ls (ones j) (Cons zero
                                  (Cons zero (app_ls (zeros k) Bs))))
                           (Cons B (app_ls (ones (S k)) Bs)))
                    1.
apply Copy_loop_1and2R_sf. tauto.

apply sfI with 2 (pair (Cons B (app_ls (ones j) (Cons zero (Cons zero
                                                (app_ls (zeros k) Bs)))))
                       (app_ls (ones (S k)) Bs)).
apply s1R. auto.

apply sfI with 2 (pair (Cons one (Cons B (app_ls (ones j) (Cons zero (Cons zero
                                                 (app_ls (zeros k) Bs))))))
                       (app_ls (ones k) Bs)).
apply s1R. auto.

apply sf_trans with (pair (app_ls (ones k) (Cons one (Cons B (app_ls
                                  (ones j) (Cons zero (Cons zero
                                           (app_ls (zeros k) Bs)))))))
                          Bs)
                    2.
apply Copy_loop_1and2R_sf. tauto.

apply sfI with 3 (pair (app_ls (ones k) (Cons one (Cons B (app_ls
                               (ones j) (Cons zero (Cons zero
                                        (app_ls (zeros k) Bs)))))))
                       (Cons one Bs)).
apply s1W. auto.

rewrite ones_comm.
apply sfI with 3 (pair (app_ls (ones k) (Cons B (app_ls (ones j)
                               (Cons zero (Cons zero (app_ls (zeros k) Bs))))))
                       (Cons one (Cons one Bs))).
apply s1L. auto.

apply sf_trans with (pair (Cons B (app_ls (ones j) (Cons zero
                                  (Cons zero (app_ls (zeros k) Bs)))))
                          (app_ls (ones k) (Cons one (Cons one Bs))))
                    3.
apply Copy_loop_3L_sf.

rewrite ones_comm.
apply sfI with 3 (pair (app_ls (ones j) (Cons zero (Cons zero
                                        (app_ls (zeros k) Bs))))
                       (Cons B ((Cons one (app_ls (ones k)
                                                  (Cons one Bs)))))).
apply s1L. auto.

do 2 rewrite zeros_step2. rewrite ones_comm. do 2 rewrite ones_step2.
apply IHj. omega.
Qed.

Lemma Copy_loop_sf: forall n,
      sf Copy (pair (app_ls (ones n) (Cons zero Bs))
                    (Cons B (Cons one Bs)))
               3
              (pair (app_ls (zeros (S n)) Bs)
                    (Cons B (app_ls (ones (S n)) Bs)))
               3.
rewrite zeros_step. change (Cons one Bs) with (app_ls (ones 1) Bs).
intro. apply Copy_loop_generalized_sf. omega.
Qed.

(*************** BEGIN part *****************************************)

Lemma Copy_begin_sf: forall n,
      sf Copy (pair Bs
                    (app_ls (ones (S n)) Bs))
               0
              (pair (app_ls (ones n) (Cons zero Bs))
                    (Cons B (Cons one Bs)))
               3.
intro. simpl.

apply sfI with 0 (pair Bs (Cons zero (app_ls (ones n) Bs))).
apply s1W. auto.

apply sfI with 1 (pair (Cons zero Bs) (app_ls (ones n) Bs)).
apply s1R. auto.

apply sf_trans with (pair (app_ls (ones n) (Cons zero Bs)) Bs)
                    1.
apply Copy_loop_1and2R_sf. tauto.

apply sfI with 2 (pair (Cons B (app_ls (ones n) (Cons zero Bs))) Bs).
apply s1R. auto.

apply sfI with 3 (pair (Cons B (app_ls (ones n) (Cons zero Bs)))
                       (Cons one Bs)).
apply s1W. auto.

apply sfI with 3 (pair (app_ls (ones n) (Cons zero Bs))
                       (Cons B (Cons one Bs))).
apply s1L. auto.

apply sf0.
Qed.

(*************** END part *******************************************)

Lemma Copy_end_6W_sf: forall n r,
      sf Copy (pair (app_ls (zeros n) Bs) (Cons one r)) 6
              (pair Bs (app_ls (ones n) (Cons one r))) 6.
induction n; intros; simpl.

apply sf0.

apply sfI with 6 (pair (app_ls (zeros n) Bs) (Cons zero (Cons one r))).
apply s1L. auto.

apply sfI with 6 (pair (app_ls (zeros n) Bs) (Cons one (Cons one r))).
apply s1W. auto.

rewrite <- ones_comm. apply IHn.
Qed.

Lemma Copy_end: forall n,
      bf Copy (pair (app_ls (zeros n) (Cons zero Bs))
                    (Cons B (Cons one (app_ls (ones n) Bs))))
              3
              (pair Bs
                    (Cons one (app_ls (ones n)
                                      (Cons B (Cons one
                                              (app_ls (ones n) Bs))))))
              7.
destruct n; intros; simpl.

apply bfL with 4; simpl; auto.
apply bfW with 6 one; simpl; auto.
apply bfL with 6; simpl; auto.
apply bfR with 7; simpl; auto.
rewrite <- unfold_Bs. apply bfH.
unfold is_value; auto.

apply bfL with 4; simpl; auto.
apply bfW with 6 one; simpl; auto.

rewrite zeros_comm2. apply bfL with 6; simpl; auto.
apply bfW with 6 one; simpl; auto.

apply sf_to_bf with (pair Bs
                          (app_ls (ones n) (Cons one (Cons one (Cons B
                                           (Cons one (Cons one (app_ls
                                           (ones n) Bs))))))))
                    6.

apply Copy_end_6W_sf.

do 2 rewrite ones_comm. apply bfL with 6; simpl; auto.
apply bfR with 7; simpl; auto.
rewrite <- unfold_Bs. apply bfH.
unfold is_value. auto.
Qed.

(****************** Main proof ******************************)

Theorem Copy_stops: forall n,
        bf Copy (pair Bs (app_ls (ones (S n)) Bs))
                0
                (pair Bs (app_ls (ones (S n))
                                 (Cons B (app_ls (ones (S n)) Bs))))
                7.
intro.

(* Decompositions via small-step + Begin, Loop, End *)

apply sf_to_bf with (pair (app_ls (ones n) (Cons zero Bs))
                          (Cons B (Cons one Bs)))
                    3.
apply Copy_begin_sf.

apply sf_to_bf with (pair (app_ls (zeros n) (Cons zero Bs))
                          (Cons B (Cons one (app_ls (ones n) Bs))))
                    3.
rewrite zeros_comm. rewrite ones_step2. apply Copy_loop_sf.

simpl. apply Copy_end.
Qed.


Require Import List String FunctionalExtensionality Ensembles
        Common.ilist ADTNotation.StringBound Program Schema
        Heading Tuple.

(* A relation is a collection of tuples (described by a proposition)
   which satisfy the schema constraints. *)

Record Relation (RelationSchema : Schema) :=
  { rel : Ensemble (@IndexedTuple (schemaHeading RelationSchema));
    constr :
      match (schemaConstraints RelationSchema) with
        | Some Constr =>
         forall tup tup',
           rel tup -> rel tup' -> Constr tup tup'
        | None => True
      end
  }.

Definition UnConstrRelation (RelationSchema : Heading) :=
  Ensemble (@IndexedTuple RelationSchema).

Definition UnIndexedTupleIn {heading}
           (rel : Ensemble (@IndexedTuple heading))
           (tup : @Tuple heading):=
  exists n, rel {|tupleIndex := n;
                  indexedTuple := tup |}.


Require Import Coq.Classes.RelationClasses.
Require Import Coq.Relations.Relation_Definitions.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.MinimunLogic.Syntax.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Module Semantics.

Definition impp {worlds: Type} {R: Relation worlds} (X: Ensemble worlds) (Y: Ensemble worlds): Ensemble worlds :=
  fun m => forall n, m <= n -> X n -> Y n.

Lemma impp_closed {worlds: Type} {R: Relation worlds} {po_R: PreOrder Krelation}:
  forall (X: Ensemble worlds) (Y: Ensemble worlds),
    upwards_closed_Kdenote X ->
    upwards_closed_Kdenote Y ->
    upwards_closed_Kdenote (impp X Y).
Proof.
  intros.
  hnf; intros.
  hnf in H2 |- *.
  intros ? ?; apply H2.
  etransitivity; eauto.
Qed.

End Semantics.

Module SemanticsMono.

Program Definition impp {worlds: Type} {R: Relation worlds} {po_R: PreOrder Krelation} (X Y: MonoEnsemble worlds): MonoEnsemble worlds :=
  Semantics.impp X Y.
Next Obligation.
  apply (@Semantics.impp_closed worlds R po_R);
  apply (proj2_sig _).
Defined.

End SemanticsMono.

Class KripkeMinimunSemantics (L: Language) {minL: MinimunLanguage L} (MD: Model) {kMD: KripkeModel MD} (M: Kmodel) {R: Relation (Kworlds M)} (SM: Semantics L MD) : Type := {
  denote_impp: forall x y, Same_set _ (Kdenotation M (x --> y)) (Semantics.impp (Kdenotation M x) (Kdenotation M y))
}.

Lemma sat_impp {L: Language} {minL: MinimunLanguage L} {MD: Model} {kMD: KripkeModel MD} {M: Kmodel} {R: Relation (Kworlds M)} {SM: Semantics L MD} {kminSM: KripkeMinimunSemantics L MD M SM}: forall m x y, KRIPKE: M , m |= x --> y <-> (forall n, m <= n -> KRIPKE: M , n |= x -> KRIPKE: M , n |= y).
Proof.
  intros; simpl.
  unfold satisfies.
  destruct (denote_impp x y).
  split; [apply H | apply H0].
Qed.


Module Type Machine.
Parameter Conf : Type.
Parameter Rel : Conf -> Conf -> Prop.
End Machine.

Module MetaTheory (mod : Machine).
Import mod.
Require Import List.
Import ListNotations.
Require Import Relations.

Infix "==>" := Rel(at level 80, no associativity).

Definition trc := clos_refl_trans Conf Rel.

Infix "=>>" := trc (at level 80, no associativity).

Lemma trc_refl c : c =>> c.
Proof. apply rt_refl. Qed.

Lemma trc_step c1 c2 : c1 ==> c2 -> c1 =>> c2.
Proof. apply rt_step. Qed.

Lemma trc_step_trans c1 c2 c3 : c1 =>> c2 -> c2 ==> c3 -> c1 =>> c3.
Proof. intros. eapply rt_trans; eauto using rt_step. Qed.

Lemma trc_step_trans' c1 c2 c3 : c1 ==> c2 -> c2 =>> c3 -> c1 =>> c3.
Proof. intros. eapply rt_trans; eauto using rt_step. Qed.

Lemma trc_trans c1 c2 c3 : c1 =>> c2 -> c2 =>> c3 -> c1 =>> c3.
Proof. apply rt_trans. Qed.

Hint Resolve trc_step trc_step_trans.
Hint Immediate trc_refl.

Lemma trc_ind' :
forall P : Conf -> Conf -> Prop,
(forall c : Conf, P c c) ->
(forall c1 c2 c3 : Conf, c1 ==> c2 -> c2 =>> c3 -> P c2 c3 -> P c1 c3) ->
forall c c0 : Conf, c =>> c0 -> P c c0.
Proof.
  intros X Y Z c1 c2 S. unfold trc in S. rewrite -> clos_rt_rt1n_iff in S.
  induction S; eauto. rewrite <- clos_rt_rt1n_iff in S. eauto.
Qed.

Fixpoint tuple (ts : list Type) : Type :=
  match ts with
    | []       => unit
    | t :: ts' => (t * tuple ts')%type
  end.

Inductive SetCom : list Type -> Type :=
| BaseSet : Conf -> Prop -> SetCom nil
| ExSet {t ts} : (t -> SetCom ts) -> SetCom (t :: ts).

Definition funtail {t ts A} (x : t) (f : forall (args : tuple (t :: ts)),  A args)
: forall (args : tuple ts), A (x, args) :=
  fun xs => f (x, xs).

Fixpoint mkSetCom {ts} (C : tuple ts -> Conf) (P : tuple ts -> Prop) : SetCom ts :=
  match ts return (tuple ts -> Conf) -> (tuple ts -> Prop) -> SetCom ts with
    | nil => fun C P => BaseSet (C tt) (P tt)
    | t :: ts' => fun C P => @ExSet t ts'  (fun x => @mkSetCom ts' (funtail x C) (funtail x P))
  end C P.

Fixpoint getConf {ts} (S : SetCom ts) : tuple ts -> Conf :=
  match S with
    | BaseSet C P => fun xs => C
    | ExSet _ _ ex => fun xs =>  let (x, xs') := xs in  getConf (ex x) xs'
  end.

Fixpoint getProp {ts} (S : SetCom ts) : tuple ts -> Prop :=
  match S with
    | BaseSet C P => fun xs => P
    | ExSet _ _ ex => fun xs => let (x, xs') := xs in getProp (ex x) xs'
  end.

Lemma getConf_sound ts (C : tuple ts -> Conf) P x : getConf (mkSetCom C P) x = C x.
Proof.
  intros. induction ts; destruct x. reflexivity. simpl. apply (IHts (funtail a0 C)).
Qed.

Lemma getProp_sound ts (C : tuple ts -> Conf) P x : getProp (mkSetCom C P) x = P x.
Proof.
  intros. induction ts;destruct x. reflexivity. simpl. apply (IHts _ (funtail a0 P)).
Qed.

Fixpoint  SetComElem  {ts} (C : Conf) (S : SetCom ts) : Prop :=
  match S with
      | BaseSet C' P => C' = C /\ P
      | ExSet _ _ e => exists x, SetComElem C (e x)
  end.

Lemma set_com_elem {ts} (C : Conf) (S : SetCom ts) :
  SetComElem C S <-> exists xs, getConf S xs = C /\ getProp S xs.
Proof.
  split; intros.
  * induction S.
    - exists tt. assumption.

    - simpl in H. destruct H. apply H0 in H.
      decompose [ex and] H.  exists (x, x0). auto.
  * induction S.
    - decompose [ex and] H. simpl in *. tauto.
    - decompose [ex and] H. simpl. destruct x.
      exists t0. apply H0. exists t1. tauto.
Qed.

Inductive ConfSet : Type :=
  | Sing {ts} : SetCom ts -> ConfSet
  | Empty : ConfSet
  | Union : ConfSet -> ConfSet -> ConfSet.

Fixpoint ConfElem (C : Conf) (S : ConfSet) : Prop :=
  match S with
    | Sing _ s => SetComElem C s
    | Empty => False
    | Union S1 S2 => ConfElem C S1 \/  ConfElem C S2
  end.

Notation "{| C | P |}" := (Sing (mkSetCom C P)) (at level 70, no associativity).
Infix "∈" := ConfElem (at level 80, no associativity).
Infix "∪" := Union (at level 76, left associativity).

Notation "S ⊆ T" := (forall x, x ∈ S -> x ∈ T) (at level 80, no associativity).
Notation "S == T" := (S ⊆ T /\ T ⊆ S) (at level 80, no associativity).

Lemma mkSetComCompl' {ts} (S : SetCom ts) : {| getConf S | getProp S |} == Sing S.
Proof.
  simpl. split; intros; induction S; auto; simpl in *; destruct H; eexists; apply H0; apply H.
Qed.

Lemma sing_set_elem {ts} (C' : Conf) (C : tuple ts -> Conf) P :
  C' ∈ {| C | P |} <-> exists xs, C xs = C' /\ P xs.
Proof.
  simpl. rewrite set_com_elem. split; intro H; decompose [ex and] H; eexists;
  rewrite getConf_sound in *; rewrite getProp_sound in *; split; eassumption.
Qed.

Notation "{ x .. y , C | P }" := (Sing (ExSet ( fun x =>  .. (ExSet (fun y => BaseSet C P)) ..  )))
(at level 70, x binder, y binder, no associativity).

Notation "{, C | P }" := (Sing (BaseSet C  P))
(at level 70, no associativity).

Lemma union_incll S T : S ⊆ S ∪ T.
Proof. simpl. auto. Qed.

Lemma union_inclr S T : T ⊆ S ∪ T.
Proof. simpl. auto. Qed.

Hint Resolve union_incll union_inclr.

Definition active (c : Conf) := exists c', c ==> c'.

(* normal form, an irreducible configuration *)

Definition nf (c : Conf) := forall c', ~ (c ==> c').

Hint Unfold active nf.

Lemma nf_trc c c' : nf c -> c =>> c' -> c = c'.
Proof.
  intros R S. destruct S using trc_ind'. reflexivity. autounfold in *. apply R in H. contradiction.
Qed.

Inductive barred (P : ConfSet) : Conf -> Prop :=
| barred_here c : c ∈ P -> barred P c
| barred_next c : (forall c', c ==> c' -> barred P c') -> active c -> barred P c.

Notation "C <| P" := (barred P C) (at level 80, no associativity).

Lemma barred_if c (P Q : ConfSet) : c <| P -> P ⊆ Q -> c <| Q.
Proof.
  intros. induction H. apply barred_here. auto.
  apply barred_next; assumption.
 Qed.

Definition NF (C : ConfSet) := forall c, c ∈ C -> nf c.

Proposition barred_closed c1 c2 P :
  NF P -> c1 <| P -> c1 =>> c2
  -> exists c3, c2 =>> c3 /\ c3 ∈ P.
Proof.
  intros A B S. generalize dependent B. induction S using trc_ind';intros.
  - induction B.
    + eauto.
    + destruct H1. specialize (H0 _ H1). decompose [ex and] H0. eauto using trc_step_trans'.
  - induction B.
    + apply A in H0. autounfold in *. apply H0 in H. contradiction.
    + eauto.
Qed.

Definition Barred (P Q : ConfSet) : Prop := forall c, c ∈ P -> c <| Q.
Hint Unfold Barred.

Infix "<<|" := Barred (at level 80, no associativity).

Proposition Barred_closed c1 c2 P C:
  NF P -> C <<| P -> c1 ∈ C -> c1 =>> c2
  -> exists c3, c2 =>> c3 /\ c3 ∈ P.
Proof.
  intros. eapply barred_closed;eauto.
Qed.

Lemma Barred_refl_if P Q : P ⊆ Q ->  P <<| Q.
Proof.
  unfold Barred. intros. apply barred_here. auto.
Qed.

Lemma Barred_if P P' Q Q' : P <<| Q -> P' ⊆ P -> Q ⊆ Q' -> P' <<| Q'.
Proof. unfold Barred. intros. eapply barred_if; eauto. Qed.

Lemma Barred_trans P Q R : P <<| Q -> Q <<| R -> P <<| R.
Proof.
  intros B1 B2.
  unfold Barred in *.
  intros. apply B1 in H. clear B1.

  induction H. apply B2. assumption.
  apply barred_next. intros. apply H0. assumption. assumption.
Qed.

Lemma Barred_union_left P PQ Q : P <<| PQ -> Q <<| PQ -> P ∪ Q <<| PQ.
Proof.
  unfold Barred. intros. auto. simpl in H1. destruct H1; auto.
Qed.

Lemma Barred_union P P' Q Q' : P <<| P' -> Q <<| Q' -> P ∪ Q <<| P' ∪ Q'.
Proof.
  intros. apply Barred_union_left; eauto using Barred_if.
Qed.

Definition Reach (P Q : ConfSet) : Prop := forall c2, c2 ∈ Q -> exists c1, c1 ∈ P /\ c1 =>> c2.
Hint Unfold Reach.

Notation "P >>> Q" := (Reach P Q) (at level 80, no associativity).

Lemma Reach_refl_if P Q : Q ⊆ P -> P >>> Q.
Proof.
  unfold Reach. intros. exists c2.  split. auto. apply trc_refl.
Qed.

Lemma Reach_if P P' Q Q' : P >>> Q -> P ⊆ P' -> Q' ⊆ Q -> P' >>> Q'.
Proof.
  unfold Reach. intros. apply H1 in H2. apply H in H2. decompose [ex and] H2. eexists. split; eauto.
Qed.

Lemma Reach_trans P Q R : P >>> Q -> Q >>> R -> P >>> R.
Proof.
  unfold Reach. intros. apply H0 in H1. decompose [ex and] H1.
  apply H in H3. decompose [ex and] H3. eexists. split. eassumption.
  eapply trc_trans; eassumption.
Qed.

Lemma Reach_union P P' Q Q' : P >>> P' -> Q >>> Q' -> P ∪ Q >>> P' ∪ Q'.
Proof.
  unfold Reach. intros. auto. destruct H1; [apply H in H1| apply H0 in H1];
  decompose [ex and] H1; eauto.
Qed.

Definition Bidir P Q := P >>> Q /\ P <<| Q.
Hint Unfold Reach.

Notation "P =|> Q" := (Bidir P Q) (at level 80, no associativity).

Lemma bidir_refl_iff P Q : P == Q -> P =|> Q.
Proof. split;[apply Reach_refl_if| apply Barred_refl_if]; tauto. Qed.

Lemma bidir_iff P P' Q Q' : P =|> Q -> P == P' -> Q == Q' -> P' =|> Q'.
Proof.
  intros. destruct H. split; [eapply Reach_if| eapply Barred_if]; eauto; try tauto.
Qed.

Lemma bidir_refl P :  P =|> P.
Proof. apply bidir_refl_iff. auto. Qed.

Lemma bidir_trans P Q R : P =|> Q -> Q =|> R -> P =|> R.
Proof.
  unfold Bidir. intros. destruct H. destruct H0.
  split. eapply Reach_trans; eassumption. eapply Barred_trans; eassumption.
Qed.

Lemma bidir_union P P' Q Q' : P =|> P' -> Q =|> Q' -> P ∪ Q =|> P' ∪ Q'.
Proof.
  unfold Bidir. intros. split. apply Reach_union; tauto. apply Barred_union; tauto.
Qed.

Lemma Reach_step ts (C C' : tuple ts -> Conf) (P P' : tuple ts -> Prop) T:
  (forall x, P' x -> C x  ==> C' x) -> (forall x, P' x -> P x) ->  {| C | P |} ∪ T >>> {| C' | P' |} ∪ T.
Proof.
  unfold Reach. intros. destruct H1.
  * rewrite sing_set_elem in H1. decompose [ex and] H1. subst. exists (C x). split.
    - left. rewrite sing_set_elem. exists x. auto.
    - apply trc_step. auto.
  * exists c2. split; auto.
Qed.

Lemma Reach_barred ts (C C' : tuple ts -> Conf) (P P' : tuple ts -> Prop) T:
  (forall x, P x -> C x  <| {| C' | P' |} ∪ T) ->  {| C | P |} ∪ T <<| {| C' | P' |} ∪ T.
Proof.
  unfold Barred. intros. destruct H0.
  * rewrite sing_set_elem in H0. decompose [ex and] H0. subst. auto.
  * left. right. auto.
Qed.

Theorem bidir_step  ts (C C' : tuple ts -> Conf) (P P' : tuple ts -> Prop) T:
  (forall x, P' x -> C x  ==> C' x) -> (forall x, P' x -> P x) -> (forall x, P x -> C x  <| {| C' | P' |} ∪ T)
  ->  {| C | P |} ∪ T =|> {| C' | P' |} ∪ T.
Proof.
  unfold Bidir. intros. auto using Reach_step, Reach_barred.
Qed.

(* The above lemma cannot be used directly in a proof
calculation. Therefore, we reformulat it using [getProp] and [getConf]
instead of the [ {| C | P |} ] construction. *)

Lemma union_sub_left S1 S2 T : S1 ⊆ S2 -> S1 ∪ T ⊆ S2 ∪ T .
Proof.
  intros. simpl in *. destruct H0; auto.
Qed.

Lemma union_eq_left S1 S2 T : S1 == S2 -> S1 ∪ T == S2 ∪ T .
Proof.
  simpl in *; split;intros; destruct H0; solve [left; destruct H; auto| right; destruct H; auto].
Qed.

Lemma union_sub_eq S1 S2 : S1 == S2 -> S1 ⊆ S2 .
Proof.
  intros. simpl in *. destruct H. auto.
Qed.

Lemma set_eq_ref S T : S == T -> T == S.
Proof.
  intros. destruct H. split; auto.
Qed.

Corollary bidir_step' ts (S S' : SetCom ts) T :
  (forall x, getProp S' x -> getConf S x  ==> getConf S' x) ->
  (forall x, getProp S' x -> getProp S x) ->
  (forall x, getProp S x -> getConf S x  <| Sing S' ∪ T) ->
  Sing S ∪ T =|> Sing S' ∪ T.
Proof.
  intros.
  assert ({| getConf S | getProp S |} ∪ T =|> {| getConf S' | getProp S' |} ∪ T).
  apply bidir_step; auto. intros. eapply barred_if. apply H1. auto. apply union_sub_left.
  apply union_sub_eq. apply set_eq_ref. apply mkSetComCompl'.
  eapply bidir_iff. eassumption.
  apply union_eq_left. apply mkSetComCompl'.
  apply union_eq_left. apply mkSetComCompl'.
Qed.

Ltac bidir_iff := intros; eapply bidir_iff; eauto; simpl; tauto.

(* The following lemmas are for guiding the proof search *)

Lemma bidir_step_simp ts (S S' : SetCom ts) :
  (forall x, getProp S' x -> getConf S x  ==> getConf S' x) ->
  (forall x, getProp S' x -> getProp S x) ->
  (forall x, getProp S x -> getConf S x  <| Sing S') ->
  Sing S =|> Sing S'.
Proof.
  intros. assert (Sing S ∪ Empty =|> Sing S' ∪ Empty).
  apply bidir_step'; auto; intros. eapply barred_if. eauto. simpl; tauto. bidir_iff.
Qed.

Lemma bidir_assoc1 S1 S2 S T : S1 ∪ (S ∪ T) =|> S2 ∪ (S ∪ T) -> (S1 ∪ S) ∪ T =|> (S2 ∪ S) ∪ T.
Proof. bidir_iff. Qed.

Lemma bidir_assoc2 S1 S2 S T : S1 ∪ (S ∪ T) =|> S2 ∪ (S ∪ T) -> (S ∪ S1) ∪ T =|> (S ∪ S2) ∪ T.
Proof. bidir_iff. Qed.

Lemma bidir_comm S1 S2 T : S1 ∪ T =|> S2 ∪ T -> T ∪ S1 =|> T ∪ S2.
Proof. bidir_iff. Qed.

End MetaTheory.