(* In this final module, we define the minimum necessary qualities
   a type system (for the target calculus) needs to be able to
   ensure progress, preservation, and non-interference with our
   translation. *)

Require Import source_calculus.
Require Import target_calculus.
Require Import translation.
Require Import labels.
Require Import Autosubst.
Require Import List.

(* Following Pottier & Conchon, rather than define a particular
   type system, we simply call for a typing predicate defined over
   closed terms of the target calculus and an almost entirely
   abstract set of types that satisfies particular axioms. We encode
   this specification a typeclass. *)

Class TypeSystem
    (type : Type)
    (has_type : term -> type -> Prop)
    (lift_label : label -> type)
    (int : type)
    (pair : type -> type -> type)
:= {
  compositionality : forall e f t,
    is_closed e ->
    is_subexpr e f ->
    has_type f t ->
    exists u, has_type e u;
  subj_red : forall e f t,
    has_type e t -> full_step e f -> has_type f t;
  eta_type : forall e f t,
    has_type e t -> eta_eq e f -> has_type f t;
  progress : forall e t,
    has_type e t -> (exists f, cbn e f) \/ is_value e;
  labels1 : forall l, has_type (Label l) (lift_label l);
  labels2 : forall l m,
    has_type (Label l) (lift_label m) -> precedes l m;
  integers : forall v, has_type v int <-> exists k, v = (Const k);
  pairs1 : forall e f t u,
    has_type (Pair e f) (pair t u) -> has_type e t /\ has_type f u;
  pairs2 : forall e f t u,
    has_type e t -> has_type f u -> exists v, has_type (Pair e f) v
}.

(* For the remainder of this section, we assume we have a valid
   type system and show properties of it. *)
Parameter type : Type.
Parameter has_type : term -> type  -> Prop.
Parameter lift_label : label -> type.
Parameter int : type.
Parameter pair : type -> type -> type.
Parameter TS : TypeSystem type has_type lift_label int pair.

(* Our first goal is to show that this type system can be used
   to show progress and preservation for the source calculus -
   that is, programs whose translation is well-typed do not go wrong.
*)

(* Preservation is fairly straightforward to show, falling almost
   immediately out of preservation of the target calculus and
   simulation. *)

(* This lemma extends subject reduction from a single step to
   full sequences. *)
Lemma subj_red_star e f t :
  has_type e t -> star e f -> has_type f t.
Proof.
  induction 2.
  - assumption.
  - apply IHstar. eapply subj_red.
    + apply H.
    + assumption.
Qed.

(* This lemma shows subject reduction for the source calculus, based
   on the types of the terms' translations. *)
Theorem source_subj_red e f t :
  has_type ⦇e⦈ t ->
  source_calculus.full_step e f ->
  has_type ⦇f⦈ t.
Proof.
  intros. edestruct (simulation e f) as [u []] ; auto.
  assert (has_type u t) by eauto using subj_red_star.
  eapply eta_type ; eassumption.
Qed.

(* And, as before, we extend it to the reflexive transitive closure,
   completing our proof of preservation.*)
Lemma source_subj_red_star e f t :
  has_type ⦇e⦈ t ->
  source_calculus.star e f ->
  has_type ⦇f⦈ t.
Proof.
  induction 2.
  - assumption.
  - apply IHstar. eapply source_subj_red ; eauto.
Qed.

(* Progress, the proof of which follows, requires considerably
   more groundwork. *)

(* The following two lemmas are straightforward corollaries of
   compositionality, defined here for convenience when proving
   progress. *)
Lemma pair_types e f t :
  is_closed e ->
  is_closed f ->
  has_type (Pair e f) t ->
  exists u v, has_type e u /\ has_type f v.
Proof.
  intros.
  destruct (compositionality e (Pair e f) t) ;
    eauto using is_subexpr.
  destruct (compositionality f (Pair e f) t) ;
    eauto using is_subexpr.
Qed.

Lemma app_types e f t :
  is_closed e ->
  is_closed f ->
  has_type (App e f) t ->
  exists u v, has_type e u /\ has_type f v.
Proof.
  intros.
  destruct (compositionality e (App e f) t) ; eauto using is_subexpr.
  destruct (compositionality f (App e f) t) ; eauto using is_subexpr.
Qed.

(* The following lemma shows that if both halves of a translation
   are well typed, the translation is well-typed. *)
Lemma translate_etas e t u  :
  source_calculus.is_closed e ->
  has_type (eta_fst ⦇e⦈) t ->
  has_type (eta_snd ⦇e⦈) u ->
  exists v, has_type ⦇e⦈ v.
Proof.
  induction e ; simpl ; ainv ; eauto using pairs2, labels1.
Qed.

(* TODO: cite the private paper *)
(* We say a term s is appliable precisely when (App s t) can make
   CBN progress. From the definition of CBN, we see that this occurs
   precisely when it's of the form l1 : l2 : ... : ln : λ. s'. *)
Inductive appliable : prefix -> Prop :=
| AppliableAbs s : appliable (source_calculus.Abs s)
| AppliableLift s l :
    appliable s -> appliable (source_calculus.Label s l).

Lemma appliable_exist_cbn s t :
  appliable s ->
  exists u, source_calculus.cbn (source_calculus.App s t) u.
Proof.
  induction 1 ;
    eauto using source_calculus.cbn, source_calculus.step.
Qed.

(* If the first component of a value's translation makes progress
   when applied, the value is appliable. *)
Lemma translation_appliable s t u :
  cbn (App (eta_fst ⦇s⦈) t) u ->
  source_calculus.is_value s ->
  appliable s.
Proof.
  intro H. induction s ; ainv.
  - inversion H ; ainv.
  - constructor.
  - constructor. apply IHs ; auto.
Qed.

Lemma app_translation_val e1 e2 :
  ~is_value (App (eta_fst ⦇e1⦈) ⦇e2⦈).
Proof.
  intro. induction e1 ; ainv.
  apply IHe1. rewrite <- H1, <- H0. constructor.
Qed.

(* TODO: clean this proof up? *)
Lemma source_progress e t :
  source_calculus.is_closed e ->
  has_type ⦇e⦈ t ->
  (exists f, source_calculus.cbn e f) \/ source_calculus.is_value e.
Proof.
  revert t. induction e ; simpl ; ainv.
  - right. constructor.
  - right. constructor.
  - apply pair_types in H0. destruct H0 as [u [v []]].
    apply app_types in H. repeat destruct H.
    apply app_types in H1. repeat destruct H1.
    apply app_types in H0. repeat destruct H0.
    apply app_types in H0. repeat destruct H0.
    + assert (exists u, has_type ⦇e1⦈ u) by eauto using translate_etas.
      destruct H7. edestruct IHe1 ; eauto.
      * destruct H8. left. eauto using source_calculus.cbn.
      * apply app_types in H5. repeat destruct H5. apply progress in H9. destruct H9.
        { destruct H9. left. apply appliable_exist_cbn. eapply translation_appliable ; eauto. }
        { exfalso. eapply app_translation_val ; eassumption. }
        { constructor. }
        { constructor ; auto using translation_closed_fst, translation_closed. }
    + constructor.
    + now apply translation_closed_snd, translation_closed.
    + repeat constructor.
      now apply translation_closed_snd, translation_closed.
    + repeat constructor ;
        auto using translation_closed_fst, translation_closed.
    + now apply translation_closed_fst, translation_closed.
    + now apply translation_closed.
    + constructor.
    + constructor ;
        auto using translation_closed_fst, translation_closed.
    + repeat constructor ;
        auto using translation_closed_fst, translation_closed.
    + constructor ;
        auto using translation_closed_fst, translation_closed_snd,
        translation_closed, n_closed.
  - left. esplit. repeat constructor.
  - apply pair_types in H0. destruct H0 as [u [v []]].
    apply app_types in H0. repeat destruct H0.
    + assert (exists u, has_type ⦇e⦈ u) by eauto using translate_etas.
      destruct H3. edestruct IHe ; eauto.
      * destruct H4. left. eauto using source_calculus.cbn.
      * right. now constructor.
    + repeat constructor.
    + now apply translation_closed_snd, translation_closed.
    + now apply translation_closed_fst, translation_closed.
    + repeat constructor.
      now apply translation_closed_snd, translation_closed.
Qed.

(* Our final goal is showing that any type system satisfying the
   above axioms can be used to enforce non-interference in the
   source calculus - that is, we can translate a source calculus
   term and the type of the translated term will tell us the labels
   of the data that the term depends on. As per usual, this key
   theorem will require a number of auxillary lemmas. *)

(* As part of the proof of non-interference, we need to talk about
   source calculus terms of the form l1 : l2 : ... : ln : s. The
   function apply_labels takes a list of labels [l1;l2;...;ln] and
   a term s and produces such a term. *)
Fixpoint apply_labels (ls : list label) (e : prefix) : prefix :=
match ls with
| nil => e
| cons l ls => source_calculus.Label (apply_labels ls e) l
end.

(* The following series of lemmas encodes reasoning used by the
   Pottier & Conchon paper in their proof of non-interference:

   "...according to axiom 5 [integers], [eta_fst ⦇v⦈] cannot be a
    λ-abstraction. Considering v is a value, v must be of the form
    l1 : l2 : ... : ln : k, for some n ≥ 0."
*)
Lemma int_value_fst (v : prefix) :
  source_calculus.is_value v ->
  has_type (eta_fst ⦇v⦈) int ->
  exists ls k, v = apply_labels ls (source_calculus.Const k).
Proof.
  induction v ; simpl ; intros H H0 ; ainv.
  - now exists nil, k.
  - apply integers in H0. ainv.
  - edestruct IHv as [ls [k]] ; auto. subst.
    now exists (cons l ls), k.
Qed.

Lemma int_trans_fst_type (v : prefix) l :
  source_calculus.is_value v ->
  has_type ⦇v⦈ (pair int l) ->
  has_type (eta_fst ⦇v⦈) int.
Proof.
  destruct v ; simpl ; intros ; ainv.
  - apply integers ; eauto.
  - edestruct pairs1 ; eauto.
  - edestruct pairs1 ; eauto.
Qed.

Lemma int_value (v : prefix) l :
  source_calculus.is_value v ->
  has_type ⦇v⦈ (pair int l) ->
  exists ls k, v = apply_labels ls (source_calculus.Const k).
Proof.
  intros. apply int_value_fst.
  - assumption.
  - eapply int_trans_fst_type ; eassumption.
Qed.

(* This lemma tells us that if every label in a list of labels ls
   precedes some label L, then applying the label filter operation
   using the cone of L as the inclusion predicate on a term
   labeled with ls has no effect. That is, it encodes the following
   reasoning from Pottier & Conchon's non-inteference proof:

   "[if] every li is an element of ↓l [then] ⌊v⌋↓l equals v" *)
Lemma filter_list_const L ls k :
  (forall l, In l ls -> precedes l L) ->
  ⌊apply_labels ls (source_calculus.Const k)⌋(↓L)  =
  apply_labels ls (source_calculus.Const k).
Proof.
  intro H. induction ls as [|l ls] ; simpl.
  - reflexivity.
  - rewrite IHls.
    + unfold cone. destruct (precedes_dec l L) as [_|p] ; simpl.
      * reflexivity.
      * exfalso. apply p, H. simpl. tauto.
    + intros. apply H. simpl. tauto.
Qed.

(* lift_labels turns a list of labels into a target calculus
   term of label joinings *)
Fixpoint lift_labels (ls : list label) : term := match ls with
| nil => Label bottom
| cons l ls' => (Label l) @ (lift_labels ls')
end.

(* This lemma tells us that there exists a "max" label in a list of
   labels *)
Lemma join_labels ls :
  exists L, (star (lift_labels ls) (Label L)) /\
            (forall l, In l ls -> precedes l L).
Proof.
  induction ls as [|l ls] ; simpl.
  - exists bottom. split.
    + eauto using star.
    + inversion 1.
  - destruct IHls as [L [H0 H1]]. exists (join l L). split.
    + eapply star_trans.
       * apply app_star_r. eassumption.
       * apply star_step, FullStep_step. constructor.
    + intro l'. destruct (label_eq l l') ; subst ; ainv.
       * apply semilattice.precedes_join.
       * apply semilattice.precedes_join3. apply H1. tauto.
Qed.

(* this lemma tells us that the type of a list of labels, lifted
   to a target calculus term, is an upper bound on the labels in
   the list *)
Lemma labels_bound ls L :
  has_type (lift_labels ls) (lift_label L) ->
  forall l, (In l ls -> precedes l L).
Proof.
  destruct (join_labels ls) as [L' [H1 H2]]. intro Htype.
  assert (has_type (Label L') (lift_label L))
    by eauto using subj_red_star.
  assert (precedes L' L) by auto using labels2.
  intros. apply poset.transitivity with (b := L') ; auto.
Qed.

(* The form of a labeled constant's translation *)
Lemma int_value_translation ls k :
  ⦇apply_labels ls (source_calculus.Const k)⦈ =
  Pair (Const k) (lift_labels ls).
Proof.
  induction ls ; simpl.
  - reflexivity.
  - now rewrite IHls.
Qed.

Theorem non_interference (e v : source_calculus.prefix) (l : label) :
  is_term e ->
  has_type ⦇e⦈ (pair int (lift_label l)) ->
  source_calculus.star e v ->
  source_calculus.is_value v ->
  source_calculus.star (⌊e⌋↓l) v.
Proof.
  intros.
  assert (is_term v) by eauto using term_star.
  assert (has_type ⦇v⦈ (pair int (lift_label l))) as H4 by
    eauto using source_subj_red_star.
  assert (exists ls k, v = apply_labels ls (source_calculus.Const k))
    as [ls [k]] by eauto using int_value ; subst.
  rewrite int_value_translation in H4. apply pairs1 in H4.
  apply stability ; try assumption.
  now apply filter_list_const, labels_bound.
Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype finfun.
Require Import bigop finset ssralg fingroup zmodp matrix vector falgebra.

(*****************************************************************************)
(*  * Finite Group as an algebra                                             *)
(*    (galg F gT)       ==  the algebra generated by gT on F                 *)
(*****************************************************************************)

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

Reserved Notation "g %:FG"
  (at level 2, left associativity, format "g %:FG").

Open Local Scope ring_scope.
Import GRing.Theory.

Section GroupAlgebraDef.
Variables (F : fieldType) (gT : finGroupType).

Inductive galg : predArgType := GAlg of {ffun gT -> F}.

Definition galg_val A := let: GAlg f := A in f.

Canonical galg_subType := Eval hnf in [newType for galg_val].
Definition galg_eqMixin := Eval hnf in [eqMixin of galg by <:].
Canonical galg_eqType := Eval hnf in EqType galg galg_eqMixin.
Definition galg_choiceMixin := [choiceMixin of galg by <:].
Canonical galg_choiceType := Eval hnf in ChoiceType galg galg_choiceMixin.

Definition fun_of_galg A (i : gT) := galg_val A i.

Coercion fun_of_galg : galg >-> Funclass.

Lemma galgE : forall f, GAlg (finfun f) =1 f.
Proof. by move=> f i; rewrite /fun_of_galg ffunE. Qed.

Definition injG (g : gT) :=  GAlg ([ffun k => (k == g)%:R]).
Notation Local "g %:FG" := (injG g).

Implicit Types v: galg.

Definition g0 := GAlg 0.
Definition g1 := 1%g %:FG.
Definition opprg v :=  GAlg (-galg_val v).
Definition addrg v1 v2 := GAlg (galg_val v1 + galg_val v2).
Definition mulvg a v :=  GAlg ([ffun k => a * galg_val v k]).
Definition mulrg v1 v2 :=
 GAlg ([ffun g => \sum_(k : gT) (v1 k) * (v2 ((k^-1) * g)%g)]).

Lemma addrgA : associative addrg.
Proof.
by move=> *; apply: val_inj; apply/ffunP=> ?; rewrite !ffunE addrA.
Qed.
Lemma addrgC : commutative addrg.
Proof.
by move=> *; apply: val_inj; apply/ffunP=> ?; rewrite !ffunE addrC.
Qed.
Lemma addr0g : left_id g0 addrg.
Proof.
by move=> *; apply: val_inj; apply/ffunP=> ?; rewrite !ffunE add0r.
Qed.
Lemma addrNg : left_inverse g0 opprg addrg.
Proof.
by move=> *; apply: val_inj; apply/ffunP=> ?; rewrite !ffunE addNr.
Qed.

(* abelian group structure *)
Definition gAlgZmodMixin := ZmodMixin addrgA addrgC addr0g addrNg.
Canonical Structure gAlgZmodType :=
 Eval hnf in ZmodType galg gAlgZmodMixin.

Lemma GAlg_morph : {morph GAlg: x y / x + y}.
Proof. by move=> f1 f2; apply/eqP. Qed.

Lemma mulvgA : forall a b v, mulvg a (mulvg b v) = mulvg (a * b) v.
Proof.
by move=> *; apply: val_inj; apply/ffunP=> g; rewrite !ffunE mulrA.
Qed.

Lemma mulvg1 : forall v, mulvg 1 v = v.
Proof. by move=> v; apply: val_inj; apply/ffunP=> g; rewrite ffunE mul1r. Qed.

Lemma mulvg_addr : forall a u v, mulvg a (u + v) = (mulvg a u) + (mulvg a v).
Proof.
by move=> *; apply: val_inj; apply/ffunP=> g; rewrite !ffunE mulrDr.
Qed.

Lemma mulvg_addl : forall u a b, mulvg (a + b) u = (mulvg a u) + (mulvg b u).
Proof.
by move=> *; apply: val_inj; apply/ffunP=> g; rewrite !ffunE mulrDl.
Qed.

Definition gAlgLmodMixin := LmodMixin mulvgA mulvg1 mulvg_addr mulvg_addl.
Canonical gAlgLmodType := Eval hnf in LmodType F galg gAlgLmodMixin.

Lemma sum_fgE : forall I r (P : pred I) (E : I -> galg) i,
  (\sum_(k <- r | P k) E k) i = \sum_(k <- r | P k) E k i.
Proof.
move=> I r P E i.
by apply: (big_morph (fun A : galg => A i)) => [A B|]; rewrite galgE.
Qed.

Lemma mulrgA : associative mulrg.
Proof.
move=> x y z; apply: val_inj; apply/ffunP=> g; rewrite !ffunE; symmetry.
rewrite (eq_bigr (fun k => \sum_i x i * (y (i^-1 * k)%g * z (k^-1 * g)%g)))
 => [| *]; last by rewrite galgE big_distrl; apply: eq_bigr => *; rewrite mulrA.
rewrite exchange_big /=.
transitivity (\sum_j x j * \sum_i y (j^-1 * i)%g * z (i^-1 * g)%g).
  by apply: eq_bigr => i _; rewrite big_distrr /=.
apply: eq_bigr => i _; rewrite galgE (reindex (fun j => (i * j)%g)); last first.
  by exists [eta mulg i^-1] => /= j _; rewrite mulgA 1?mulgV 1?mulVg mul1g.
by congr (_ * _); apply: eq_bigr => *; rewrite mulgA mulVg mul1g invMg mulgA.
Qed.

Lemma mulr1g : left_id g1 mulrg.
Proof.
move=> x; apply: val_inj; apply/ffunP=> g.
rewrite ffunE (bigD1 1%g) //= galgE eqxx invg1.
by rewrite mul1g mul1r big1 1?addr0 // => i Hi; rewrite galgE (negbTE Hi) mul0r.
Qed.

Lemma mulrg1 : right_id g1 mulrg.
Proof.
move=> x; apply: val_inj; apply/ffunP=> g.
rewrite ffunE (bigD1 g) //= galgE mulVg eqxx mulr1.
by rewrite big1 1?addr0 // => i Hi; rewrite galgE -eq_mulVg1 (negbTE Hi) mulr0.
Qed.

Lemma mulrg_addl : left_distributive mulrg addrg.
Proof.
move=> x y z; apply: val_inj; apply/ffunP=> g; rewrite !ffunE -big_split /=.
by apply: eq_bigr => i _; rewrite galgE mulrDl.
Qed.

Lemma mulrg_addr : right_distributive mulrg addrg.
Proof.
move=> x y z; apply: val_inj; apply/ffunP=> g; rewrite !ffunE -big_split /=.
by apply: eq_bigr => i _; rewrite galgE mulrDr.
Qed.

Lemma nong0g1 : g1 != 0 :> galg.
Proof.
apply/eqP; case.
move/ffunP; move/(_ 1%g); rewrite !ffunE eqxx.
by move/eqP; rewrite oner_eq0.
Qed.

Definition gAlgRingMixin :=
  RingMixin mulrgA mulr1g mulrg1 mulrg_addl mulrg_addr nong0g1.
Canonical gAlgRingType := Eval hnf in RingType galg gAlgRingMixin.

Implicit Types x y : galg.

Lemma mulg_mulvl : forall a x y, a *: (x * y) = (a *: x) * y.
Proof.
move=> a x y; apply: val_inj; apply/ffunP=> g.
rewrite !ffunE big_distrr /=.
by apply: eq_bigr => i _; rewrite mulrA galgE.
Qed.

Lemma mulg_mulvr : forall a x y, a *: (x * y) = x * (a *: y).
Proof.
move=> a x y; apply: val_inj; apply/ffunP=> g.
rewrite !ffunE big_distrr /=.
by apply: eq_bigr => i _; rewrite galgE mulrCA.
Qed.

Canonical gAlgLalgType := Eval hnf in LalgType F galg mulg_mulvl.
Canonical gAlgAlgType := Eval hnf in AlgType F galg mulg_mulvr.

Lemma injGM : forall g h, (g * h)%g %:FG = (g %:FG) * (h %:FG).
Proof.
move=> g h; apply: val_inj; apply/ffunP=> k.
rewrite !ffunE (bigD1 g) //= !galgE eqxx mul1r.
rewrite big1 1?addr0 => [| i Hi]; last by rewrite !galgE (negbTE Hi) mul0r.
by rewrite -(inj_eq (mulgI (g^-1)%g)) mulgA mulVg mul1g.
Qed.

Fact gAlg_iso_vect : Vector.axiom #|gT| galg.
Proof.
exists (fun x => \row_(i < #|gT|) x (enum_val i)) => [k x y | ].
  by apply/rowP=> i; rewrite !mxE !galgE !ffunE.
exists (fun x : 'rV[F]_#|gT| => GAlg ([ffun k => (x 0 (enum_rank k))])) => x.
  by apply: val_inj; apply/ffunP=> i; rewrite ffunE mxE enum_rankK.
by apply/rowP=> i; rewrite // !mxE galgE enum_valK.
Qed.

Definition galg_vectMixin := VectMixin gAlg_iso_vect.
Canonical galg_vectType := VectType F galg galg_vectMixin.

Canonical galg_unitRingType := FalgUnitRingType galg.
Canonical galg_unitAlgFType := [unitAlgType F of galg].
Canonical gAlgAlgFType := [FalgType F of galg].

Variable G : {group gT}.

Definition gvspace: {vspace galg} := (\sum_(g in G) <[g%:FG]>)%VS.

Fact gspace_subproof : has_algid gvspace && (gvspace * gvspace <= gvspace)%VS.
Proof.
apply/andP; split.
  apply: has_algid1.
  rewrite /gvspace (bigD1 (1)%g) //=.
  apply: subv_trans (addvSl _ _).
  by apply/vlineP; exists 1; rewrite scale1r.
apply/prodvP=> u v Hu Hv.
case/memv_sumP: Hu => u_ Hu ->; rewrite big_distrl /=.
apply: memv_suml=> i Hi.
case/memv_sumP: Hv => v_ Hv ->; rewrite big_distrr /=.
apply: memv_suml=> j Hj.
rewrite /gvspace (bigD1 (i*j)%g) /=; last by apply: groupM.
apply: subv_trans (addvSl _ _).
case/vlineP: (Hu _ Hi)=> k ->; case/vlineP: (Hv _ Hj)=> l ->.
apply/vlineP; exists (k * l).
by rewrite -scalerAl -scalerAr scalerA injGM.
Qed.

Definition gaspace : {aspace galg} := ASpace gspace_subproof.

End GroupAlgebraDef.

Notation " g %:FG " := (injG _ g).


(* Banach-Tarski paradox. *)

Require Import Utf8 List Relations NPeano Wf_nat.
Import ListNotations.
Require Import Misc.

Inductive letter := la | lb.

Inductive free_elem := FE : letter → bool → free_elem.

Notation "'ạ'" := (FE la false).
Notation "'ạ⁻¹'" := (FE la true).
Notation "'ḅ'" := (FE lb false).
Notation "'ḅ⁻¹'" := (FE lb true).

Definition negf '(FE t d) := FE t (negb d).

Theorem letter_dec : ∀ l1 l2 : letter, {l1 = l2} + {l1 ≠ l2}.
Proof.
intros.
now destruct l1, l2; try (now left); right.
Defined.

Theorem free_elem_dec : ∀ e₁ e₂ : free_elem, { e₁ = e₂ } + { e₁ ≠ e₂ }.
Proof.
intros.
destruct e₁ as (t₁, d₁).
destruct e₂ as (t₂, d₂).
destruct (letter_dec t₁ t₂) as [H₁| H₁]; [ subst t₂ | ].
 destruct (Bool.bool_dec d₁ d₂) as [H₂| H₂]; [ subst d₂ | ].
  now left.

  right; intros H; apply H₂.
  now injection H.

 right; intros H; apply H₁.
 now injection H.
Qed.

Theorem letter_dec_diag : ∀ t, letter_dec t t = left (eq_refl _).
Proof.
intros t.
destruct (letter_dec t t) as [p| p]; [ | exfalso; now apply p ].
destruct t; refine (match p with eq_refl => eq_refl end).
Qed.

Definition letter_opp '(FE l₁ d₁) '(FE l₂ d₂) :=
  if letter_dec l₁ l₂ then
    if Bool.bool_dec d₁ d₂ then False else True
  else False.

Theorem letter_opp_dec : ∀ e₁ e₂,
  {letter_opp e₁ e₂} + {not (letter_opp e₁ e₂)}.
Proof.
intros.
destruct e₁ as (x₁, d₁).
destruct e₂ as (x₂, d₂); simpl.
destruct (letter_dec x₁ x₂) as [Hx| Hx].
 destruct (Bool.bool_dec d₁ d₂) as [Hd| Hd]; [ | left; constructor ].
 now right.

 now right.
Defined.

Theorem letter_opp_inv : ∀ x d, letter_opp (FE x d) (FE x (negb d)).
Proof.
intros.
unfold letter_opp.
rewrite letter_dec_diag, bool_dec_negb_r.
constructor.
Qed.

Theorem letter_opp_iff : ∀ x₁ d₁ x₂ d₂,
  letter_opp (FE x₁ d₁) (FE x₂ d₂)
  ↔ x₁ = x₂ ∧ d₂ = negb d₁.
Proof.
intros x₁ d₁ x₂ d₂.
split; intros H.
 unfold letter_opp in H.
 destruct (letter_dec x₁ x₂) as [H₁| H₁]; [ | easy ].
 split; [ easy | ].
 destruct (Bool.bool_dec d₁ d₂) as [H₂| H₂]; [ easy | ].
 now apply neq_negb, not_eq_sym.

 destruct H; subst x₂ d₂.
 apply letter_opp_inv.
Qed.

Theorem letter_opp_negf : ∀ e₁ e₂, letter_opp e₁ e₂ ↔ e₁ = negf e₂.
Proof.
intros.
destruct e₁ as (t₁, d₁).
destruct e₂ as (t₂, d₂).
split; intros H.
 apply letter_opp_iff in H.
 destruct H; subst t₂ d₂; simpl.
 now rewrite Bool.negb_involutive.

 injection H; intros; subst; simpl.
 rewrite letter_dec_diag, bool_dec_negb_l.
 constructor.
Qed.

Theorem no_fixpoint_negf : ∀ e, negf e ≠ e.
Proof.
intros * H.
destruct e as (t, d).
injection H.
apply Bool.no_fixpoint_negb.
Qed.

Theorem negf_involutive : ∀ e, negf (negf e) = e.
Proof.
intros (t, d); simpl.
now rewrite Bool.negb_involutive.
Qed.

Theorem letter_opp_negf_r : ∀ e, letter_opp e (negf e).
Proof.
intros.
apply letter_opp_negf.
now rewrite negf_involutive.
Qed.

Theorem letter_opp_sym : ∀ e₁ e₂, letter_opp e₁ e₂ → letter_opp e₂ e₁.
Proof.
intros * H.
apply letter_opp_negf in H.
subst e₁.
apply letter_opp_negf_r.
Qed.

Theorem negf_eq_eq : ∀ e₁ e₂, negf e₁ = negf e₂ → e₁ = e₂.
Proof.
intros e₁ e₂ Hn.
destruct e₁ as (t₁, d₁).
destruct e₂ as (t₂, d₂).
simpl in Hn.
injection Hn; intros H₁ H₂; subst.
now apply negb_eq_eq in H₁; subst d₁.
Qed.


From RelationAlgebra Require Import
     monoid
     kat
     kat_tac
     prop
     rel
     srel
     comparisons
     rewriting
     normalisation.

From Coinduction Require Import
	 coinduction rel tactics.

From CTree Require Import
	   CTree Eq.Shallow Eq.Equ.

Import CTree.
Import CTreeNotations.
Import EquNotations.
Open Scope ctree.

Set Implicit Arguments.
Set Primitive Projections.

#[local] Tactic Notation "step" "in" ident(H) := __step_in_equ H.

Section Visible.

  Context {E C : Type -> Type} {R : Type}.

  Notation S' := (ctree' E C R).
  Notation S  := (ctree  E C R).

  Definition SS : EqType :=
	{| type_of := S ; Eq := equ eq |}.

  Inductive visible_ : hrel S' S' :=
  | VisibleI {X} (c : C X) x k t :
    visible_ (observe (k x)) t ->
    visible_ (BrF false c k) t

  | VisibleV {X} (c : C X) (x : X) k1 k2 :
    (forall x, k1 x ≅ k2 x) ->
    visible_ (BrF true c k1) (BrF true c k2)

  | VisibleVis {X} (e : E X) k1 k2 :
    (forall x, k1 x ≅ k2 x) ->
    visible_ (VisF e k1) (VisF e k2)

  | VisibleRet r :
    visible_ (RetF r) (RetF r)
  .
  Hint Constructors visible_ : core.

  Definition visibleR : hrel S S :=
	  fun u v => visible_ (observe u) (observe v).

  #[local] Instance visible__equ_aux1 t :
	  Proper (going (equ eq) ==> flip impl) (visible_ t).
  Proof.
	  intros x x' equ TR.
	  inv equ; rename H into equ.
	  step in equ. cbn in equ.
	  dependent induction TR; intros; eauto; inv equ; try invert; auto;
	    (constructor; auto; etransitivity; [apply H | symmetry; auto]).
  Qed.

  #[local] Instance visible__equ_aux2 :
	  Proper (going (equ eq) ==> going (equ eq) ==> impl) visible_.
  Proof.
	  intros x x' xequ y y' yequ TR. rewrite <- yequ. clear yequ y'.
	  inv xequ; rename H into xequ.	step in xequ. cbn in xequ.
    revert x' xequ.
	  dependent induction TR; intros; eauto; inv xequ; try invert; auto.
    2, 3: constructor; auto; intros; rewrite <- H; symmetry; auto.
    econstructor. apply IHTR. rewrite REL. reflexivity.
  Qed.

  #[global] Instance visible__equ :
	  Proper (going (equ eq) ==> going (equ eq) ==> iff) visible_.
  Proof.
	  intros ? ? eqt ? ? equ; split; intros TR.
	  - eapply visible__equ_aux2; eauto.
	  - symmetry in equ; symmetry in eqt; eapply visible__equ_aux2; eauto.
  Qed.

  #[global] Instance visible_equ :
	  Proper (equ eq ==> equ eq ==> iff) visibleR.
  Proof.
	  intros ? ? eqt ? ? equ; unfold visibleR.
    rewrite eqt, equ. reflexivity.
  Qed.

  Definition visible : srel SS SS := {| hrel_of := visibleR : hrel SS SS |}.

End Visible.


Require Export ZArith.
Require Export List.
Require Export Bool.

Require Export sflib.

Tactic Notation "solve_by_inversion_step" tactic(t) :=
  match goal with
  | H : _ |- _ => solve [ inversion H; subst; t ]
  end
  || fail "because the goal is not solvable by inversion.".

Tactic Notation "solve" "by" "inversion" "1" :=
  solve_by_inversion_step idtac.
Tactic Notation "solve" "by" "inversion" "2" :=
  solve_by_inversion_step (solve by inversion 1).
Tactic Notation "solve" "by" "inversion" "3" :=
  solve_by_inversion_step (solve by inversion 2).
Tactic Notation "solve" "by" "inversion" :=
  solve by inversion 1.

Inductive ty: Type :=
| TyUnit: ty
| TyBool: ty
| TyChar: ty
| TyInt: ty
| TyPair: ty -> ty -> ty
| TyList: ty -> ty
| TyArrow: ty -> ty -> ty
.

Hint Constructors ty.

Inductive isComparable: ty -> Prop :=
| IsCompUnit: isComparable TyUnit
| IsCompBool: isComparable TyBool
| IsCompChar: isComparable TyChar
| IsCompInt: isComparable TyInt
| IsCompPair: forall Tfst Tsnd,
    isComparable Tfst ->
    isComparable Tsnd ->
    isComparable (TyPair Tfst Tsnd)
| IsCompList: forall Telem,
    isComparable Telem ->
    isComparable (TyList Telem)
.

Hint Constructors isComparable.

Inductive id: Type :=
| Id: nat -> id
.

Hint Constructors id.

Lemma eq_id_dec: forall (i1 i2: id), {i1 = i2} + {i1 <> i2}.
Proof.
  intros i1 i2.
  destruct i1 as [n1]. destruct i2 as [n2].
  destruct (eq_nat_dec n1 n2).
  auto.
  right. intros contra. inversion contra. auto.
Qed.

Lemma eq_id: forall T i (t0 t1: T),
    (if eq_id_dec i i then t0 else t1) = t0.
Proof.
  intros.
  destruct (eq_id_dec i i).
  - reflexivity.
  - exfalso. eauto.
Qed.

Lemma neq_id : forall T i0 i1 (t0 t1:T),
    i0 <> i1 ->
    (if eq_id_dec i0 i1 then t0 else t1) = t1.
Proof.
  intros.
  destruct (eq_id_dec i0 i1).
  - exfalso. eauto.
  - reflexivity.
Qed.

Inductive tm: Type :=
(* Error/Undefined *)
| TmError: tm

(* Unit *)
| TmUnit: tm

(* Bool *)
| TmTrue: tm
| TmFalse: tm
| TmNeg: tm -> tm
| TmAnd: tm -> tm -> tm
| TmOr: tm -> tm -> tm
| TmIf: tm -> tm -> tm -> tm

(* Char *)
| TmChar: nat -> tm

(* Integer *)
| TmInt: Z -> tm

(* Pair *)
| TmPair: tm -> tm -> tm
| TmFst: tm -> tm
| TmSnd: tm -> tm

(* List *)
| TmNil: tm
| TmCons: tm -> tm -> tm
| TmHead: tm -> tm
| TmTail: tm -> tm

(* Function *)
| TmLam: id -> ty -> tm -> tm
| TmApp: tm -> tm -> tm

(* Equality *)
| TmEq: tm -> tm -> tm

(* Variable *)
| TmVar: id -> tm

(* Local binding *)
| TmLet: id -> tm -> tm -> tm

(* Fixpoint binding *)
| TmFix: tm -> tm
.

Hint Constructors tm.

Inductive val: tm -> Prop :=
| ValError: val TmError

| ValUnit: val TmUnit

| ValTrue: val TmTrue
| ValFalse: val TmFalse

| ValChar: forall c,
    val (TmChar c)

| ValInt: forall z,
    val (TmInt z)

| ValPair: forall tfst tsnd,
    val (TmPair tfst tsnd)

| ValNil: val TmNil
| ValCons: forall thead ttail,
    val (TmCons thead ttail)

| ValLam: forall ipar Tpar tres,
    val (TmLam ipar Tpar tres)
.

Hint Constructors val.

Reserved Notation "'[' x0 '<-' t0 ']' t1" (at level 20).

Fixpoint subst (i: id) (s: tm) (t: tm): tm :=
  match t with
  | TmNeg tneg =>
    TmNeg ([i <- s] tneg)
  | TmAnd tleft tright =>
    TmAnd ([i <- s] tleft) ([i <- s] tright)
  | TmOr tleft tright =>
    TmOr ([i <- s] tleft) ([i <- s] tright)
  | TmIf tcond ttrue tfalse =>
    TmIf ([i <- s] tcond) ([i <- s] ttrue) ([i <- s] tfalse)

  | TmPair tfst tsnd =>
    TmPair ([i <- s] tfst) ([i <- s] tsnd)
  | TmFst tpair =>
    TmFst ([i <- s] tpair)
  | TmSnd tpair =>
    TmSnd ([i <- s] tpair)

  | TmCons thead ttail =>
    TmCons ([i <- s] thead) ([i <- s] ttail)
  | TmHead tlist =>
    TmHead ([i <- s] tlist)
  | TmTail tlist =>
    TmTail ([i <- s] tlist)

  | TmLam ipar Tpar tres =>
    TmLam ipar Tpar (if eq_id_dec i ipar then tres else [i <- s] tres)
  | TmApp tlam tapp =>
    TmApp ([i <- s] tlam) ([i <- s] tapp)

  | TmEq tleft tright =>
    TmEq ([i <- s] tleft) ([i <- s] tright)

  | TmVar ivar =>
    if eq_id_dec i ivar then s else t

  | TmLet ilet tlet tin =>
    TmLet ilet
          ([i <- s] tlet)
          (if eq_id_dec i ilet then tin else [i <- s] tin)

  | TmFix tfix =>
    TmFix ([i <- s] tfix)

  | _ => t
  end

where "'[' x '<-' t0 ']' t1" := (subst x t0 t1)
.

Definition Relation (X: Type): Type := X -> X -> Prop.

Reserved Notation " t0 '==>' t1 " (at level 40).

Inductive smst: Relation tm :=
| SmstNegStep: forall tneg0 tneg1,
    tneg0 ==> tneg1 ->
    TmNeg tneg0 ==> TmNeg tneg1
| SmstNegTrue:
    TmNeg TmTrue ==> TmFalse
| SmstNegFalse:
    TmNeg TmFalse ==> TmTrue
| SmstNegError:
    TmNeg TmError ==> TmError
| SmstAndLeftStep: forall tleft0 tleft1 tright,
    tleft0 ==> tleft1 ->
    TmAnd tleft0 tright ==> TmAnd tleft1 tright
| SmstAndLeftFalse: forall tright,
    TmAnd TmFalse tright ==> TmFalse
| SmstAndLeftError: forall tright,
    TmAnd TmError tright ==> TmError
| SmstAndRightStep: forall tright0 tright1,
    tright0 ==> tright1 ->
    TmAnd TmTrue tright0 ==> TmAnd TmTrue tright1
| SmstAndRightFalse:
    TmAnd TmTrue TmFalse ==> TmFalse
| SmstAndRightError:
    TmAnd TmTrue TmError ==> TmError
| SmstAndTrue:
    TmAnd TmTrue TmTrue ==> TmTrue
| SmstOrLeftStep: forall tleft0 tleft1 tright,
    tleft0 ==> tleft1 ->
    TmOr tleft0 tright ==> TmOr tleft1 tright
| SmstOrLeftTrue: forall tright,
    TmOr TmTrue tright ==> TmTrue
| SmstOrLeftError: forall tright,
    TmOr TmError tright ==> TmError
| SmstOrRightStep: forall tright0 tright1,
    tright0 ==> tright1 ->
    TmOr TmFalse tright0 ==> TmOr TmFalse tright1
| SmstOrRightTrue:
    TmOr TmFalse TmTrue ==> TmTrue
| SmstOrRightError:
    TmOr TmFalse TmError ==> TmError
| SmstOrFalse:
    TmOr TmFalse TmFalse ==> TmFalse
| SmstIfStep: forall tcond0 tcond1 ttrue tfalse,
    tcond0 ==> tcond1 ->
    TmIf tcond0 ttrue tfalse ==> TmIf tcond1 ttrue tfalse
| SmstIfTrue: forall ttrue tfalse,
    TmIf TmTrue ttrue tfalse ==> ttrue
| SmstIfFalse: forall ttrue tfalse,
    TmIf TmFalse ttrue tfalse ==> tfalse
| SmstIfError: forall ttrue tfalse,
    TmIf TmError ttrue tfalse ==> TmError

| SmstFstStep: forall tpair0 tpair1,
    tpair0 ==> tpair1 ->
    TmFst tpair0 ==> TmFst tpair1
| SmstFstPair: forall tfst tsnd,
    TmFst (TmPair tfst tsnd) ==> tfst
| SmstFstError:
    TmFst TmError ==> TmError
| SmstSndStep: forall tpair0 tpair1,
    tpair0 ==> tpair1 ->
    TmSnd tpair0 ==> TmSnd tpair1
| SmstSndPair: forall tfst tsnd,
    TmSnd (TmPair tfst tsnd) ==> tsnd
| SmstSndError:
    TmSnd TmError ==> TmError

| SmstHeadStep: forall tlist0 tlist1,
    tlist0 ==> tlist1 ->
    TmHead tlist0 ==> TmHead tlist1
| SmstHeadNil:
    TmHead TmNil ==> TmError
| SmstHeadCons: forall thead ttail,
    TmHead (TmCons thead ttail) ==> thead
| SmstHeadError:
    TmHead TmError ==> TmError
| SmstTailStep: forall tlist0 tlist1,
    tlist0 ==> tlist1 ->
    TmTail tlist0 ==> TmTail tlist1
| SmstTailNil:
    TmTail TmNil ==> TmError
| SmstTailCons: forall thead ttail,
    TmTail (TmCons thead ttail) ==> ttail
| SmstTailError:
    TmTail TmError ==> TmError

| SmstAppStep: forall tlam0 tlam1 tapp,
    tlam0 ==> tlam1 ->
    TmApp tlam0 tapp ==> TmApp tlam1 tapp
| SmstAppLam: forall ipar Tpar tres tapp,
    TmApp (TmLam ipar Tpar tres) tapp ==> [ipar <- tapp] tres
| SmstAppError: forall tapp,
    TmApp TmError tapp ==> TmError

| SmstEqLeftStep: forall tleft0 tleft1 tright,
    tleft0 ==> tleft1 ->
    TmEq tleft0 tright ==> TmEq tleft1 tright
| SmstEqLeftError: forall tright,
    TmEq TmError tright ==> TmError
| SmstEqRightStep: forall vleft tright0 tright1,
    val vleft ->
    vleft <> TmError ->
    tright0 ==> tright1 ->
    TmEq vleft tright0 ==> TmEq vleft tright1
| SmstEqRightError: forall vleft,
    val vleft ->
    vleft <> TmError ->
    TmEq vleft TmError ==> TmError
| SmstEqUnitTrue:
    TmEq TmUnit TmUnit ==> TmTrue
| SmstEqBoolTrue0:
    TmEq TmTrue TmTrue ==> TmTrue
| SmstEqBoolTrue1:
    TmEq TmFalse TmFalse ==> TmTrue
| SmstEqBoolFalse0:
    TmEq TmTrue TmFalse ==> TmFalse
| SmstEqBoolFalse1:
    TmEq TmFalse TmTrue ==> TmFalse
| SmstEqCharTrue: forall c0 c1,
    c0 = c1 ->
    TmEq (TmChar c0) (TmChar c1) ==> TmTrue
| SmstEqCharFalse: forall c0 c1,
    c0 <> c1 ->
    TmEq (TmChar c0) (TmChar c1) ==> TmFalse
| SmstEqIntTrue: forall z0 z1,
    z0 = z1 ->
    TmEq (TmInt z0) (TmInt z1) ==> TmTrue
| SmstEqIntFalse: forall z0 z1,
    z0 <> z1 ->
    TmEq (TmInt z0) (TmInt z1) ==> TmFalse
| SmstEqPair: forall tfst0 tsnd0 tfst1 tsnd1,
    TmEq (TmPair tfst0 tsnd0) (TmPair tfst1 tsnd1) ==>
    TmAnd (TmEq tfst0 tfst1) (TmEq tsnd0 tsnd1)
| SmstEqListNilTrue:
    TmEq TmNil TmNil ==> TmTrue
| SmstEqListFalse0: forall thead1 ttail1,
    TmEq TmNil (TmCons thead1 ttail1) ==> TmFalse
| SmstEqListFalse1: forall thead0 ttail0,
    TmEq (TmCons thead0 ttail0) TmNil ==> TmFalse
| SmstEqListCons: forall thead0 ttail0 thead1 ttail1,
    TmEq (TmCons thead0 ttail0) (TmCons thead1 ttail1) ==>
    TmAnd (TmEq thead0 thead1) (TmEq ttail0 ttail1)

| SmstLet: forall ilet tlet tin,
    TmLet ilet tlet tin ==> [ilet <- tlet] tin

| SmstFixStep: forall tfix0 tfix1,
    tfix0 ==> tfix1 ->
    TmFix tfix0 ==> TmFix tfix1
| SmstFixLam: forall ilam Tlam tlam,
    TmFix (TmLam ilam Tlam tlam) ==> [ilam <- TmFix (TmLam ilam Tlam tlam)] tlam
| SmstFixError:
    TmFix TmError ==> TmError

where "t0 '==>' t1" := (smst t0 t1)
.

Hint Constructors smst.

Inductive mlt {T: Type} (R: Relation T) : Relation T :=
  | mltRefl  : forall (t: T), mlt R t t
  | mltStep : forall (t0 t1 t2 : T),
                    R t0 t1 ->
                    mlt R t1 t2 ->
                    mlt R t0 t2.

Hint Constructors mlt.

Theorem mltLift: forall (T: Type) (R: Relation T) (t0 t1: T),
    R t0 t1 ->
    mlt R t0 t1.
Proof.
  intros T R t0 t1 smst.
  eauto.
Qed.

Theorem mltTrans: forall (T: Type) (R: Relation T) (t0 t1 t2: T),
    mlt R t0 t1 ->
    mlt R t1 t2 ->
    mlt R t0 t2.
Proof.
  intros T R t0 t1 t2 mlt0 mlt1.
  induction mlt0 as [t0|t0 t1].
  - auto.
  - eauto.
Qed.

Definition idPartialMap (K: Type): Type := id -> option K.

Definition emptyMap {K: Type}: idPartialMap K := fun _ => None.
Definition extend {K: Type} (G: idPartialMap K) (i0: id) (T0: K):
  idPartialMap K :=
  fun i1 => if eq_id_dec i0 i1 then Some T0 else G i1.

Hint Unfold emptyMap.
Hint Unfold extend.

Lemma extend_eq: forall K (G: idPartialMap K) i T,
    (extend G i T) i = Some T.
Proof.
  intros.
  unfold extend. rewrite eq_id. reflexivity.
Qed.

Lemma extend_neq: forall K (G: idPartialMap K) i0 i1 T,
    i0 <> i1 ->
    (extend G i0 T) i1 = G i1.
Proof.
  intros.
  unfold extend. rewrite neq_id; auto.
Qed.

Definition tyCtxt: Type := idPartialMap ty.

Reserved Notation "TC '|-' t ':|' T" (at level 40).

Inductive hasTy: tyCtxt -> tm -> ty -> Prop :=
| HasTyError: forall TC T,
    TC |- TmError :| T

| HasTyUnit: forall TC,
    TC |- TmUnit :| TyUnit

| HasTyTrue: forall TC,
    TC |- TmTrue :| TyBool
| HasTyFalse: forall TC,
    TC |- TmFalse :| TyBool
| HasTyNeg: forall TC tneg,
    TC |- tneg :| TyBool ->
    TC |- TmNeg tneg :| TyBool
| HasTyAnd: forall TC tleft tright,
    TC |- tleft :| TyBool ->
    TC |- tright :| TyBool ->
    TC |- TmAnd tleft tright :| TyBool
| HasTyOr: forall TC tleft tright,
    TC |- tleft :| TyBool ->
    TC |- tright :| TyBool ->
    TC |- TmOr tleft tright :| TyBool
| HasTyIf: forall TC tcond ttrue tfalse Tif,
    TC |- tcond :| TyBool ->
    TC |- ttrue :| Tif ->
    TC |- tfalse :| Tif ->
    TC |- TmIf tcond ttrue tfalse :| Tif

| HasTyChar: forall TC c,
    TC |- TmChar c :| TyChar

| HasTyInt: forall TC z,
    TC |- TmInt z :| TyInt

| HasTyPair: forall TC tfst Tfst tsnd Tsnd,
    TC |- tfst :| Tfst ->
    TC |- tsnd :| Tsnd ->
    TC |- TmPair tfst tsnd :| TyPair Tfst Tsnd
| HasTyFst: forall TC tpair Tfst Tsnd,
    TC |- tpair :| TyPair Tfst Tsnd ->
    TC |- TmFst tpair :| Tfst
| HasTySnd: forall TC tpair Tfst Tsnd,
    TC |- tpair :| TyPair Tfst Tsnd ->
    TC |- TmSnd tpair :| Tsnd

| HasTyNil: forall TC Telem,
    TC |- TmNil :| TyList Telem
| HasTyCons: forall TC thead ttail Telem,
    TC |- thead :| Telem ->
    TC |- ttail :| TyList Telem ->
    TC |- TmCons thead ttail :| TyList Telem
| HasTyHead: forall TC tlist Telem,
    TC |- tlist :| TyList Telem ->
    TC |- TmHead tlist :| Telem
| HasTyTail: forall TC tlist Telem,
    TC |- tlist :| TyList Telem ->
    TC |- TmTail tlist :| TyList Telem

| HasTyLam: forall TC ipar Tpar tres Tres,
    (extend TC ipar Tpar) |- tres :| Tres ->
    TC |- TmLam ipar Tpar tres :| TyArrow Tpar Tres
| HasTyApp: forall TC tlam Tres tapp Tapp,
    TC |- tlam :| TyArrow Tapp Tres ->
    TC |- tapp :| Tapp ->
    TC |- TmApp tlam tapp :| Tres

| HasTyEq: forall TC tleft tright Teq,
    TC |- tleft :| Teq ->
    TC |- tright :| Teq ->
    isComparable Teq ->
    TC |- TmEq tleft tright :| TyBool

| HasTyVar: forall TC i Tvar,
    TC i = Some Tvar ->
    TC |- TmVar i :| Tvar

| HasTyLet: forall TC ilet tlet Tlet tin Tin,
    TC |- tlet :| Tlet ->
    (extend TC ilet Tlet) |- tin :| Tin ->
    TC |- TmLet ilet tlet tin :| Tin
| HasTyFix: forall TC tfix Tfix ,
    TC |- tfix :| TyArrow Tfix Tfix ->
    TC |- TmFix tfix :| Tfix

where "TC '|-' t ':|' T" := (hasTy TC t T)
.

Hint Constructors hasTy.

(* Fixpoint complexness (t: tm): nat := *)
(*   match t with *)
(*   | TmError => 0 *)

(*   | TmUnit => 0 *)

(*   | TmTrue => 0 *)
(*   | TmFalse => 0 *)

(*   | TmChar => 0 *)

(*   | TmInt => 0 *)

(*   | TmPair tfst tsnd => *)
(*     max (complexness tfst) (complexness tsnd) + 1 *)
(*   | TmFst (TmPair tfst tsnd) => *)
(*     complexness tfst *)
(*   | TmFst _ => 0 *)
(*   | TmSnd (TmPair tfst tsnd) => *)
(*     complexness tsnd *)
(*   | TmSnd _ => 0 *)

(*   | TmNil => 0 *)
(*   | TmCons thead ttail => *)
(*     complexness thead + complexness ttail *)
(*   | TmHead (TmCons thead ttail) => *)
(*     complexness thead *)
(*   | TmHead _ => 0 *)
(*   | TmTail (TmCons thead ttail) => *)
(*     complexness ttail *)
(*   | TmTail _ => 0 *)

(*   | TmLam ipar Tpar tres => *)
(*     complexness tres + 1 *)
(*   | TmApp tlam tapp => *)
(*     complexness tlam * complexness tapp *)

(*   | TmVar ivar => 0 *)

(*   | TmEq tleft tright => *)
(*     max (complexness tleft) (complexness tright) + 1 *)
(*   | TmIf *)

(*   | TmLet: id -> tm -> tm -> tm *)
(*   | TmFix: tm -> tm *)

Theorem progress : forall t T,
    emptyMap |- t :| T ->
    val t \/ exists t', t ==> t'.
Proof with eauto.
  intros t T typed.
  remember emptyMap as G.
  generalize dependent HeqG.
  induction typed; intros;
    subst; eauto;
      try (right;
           destruct IHtyped; subst; eauto;
           [inversion typed; subst; try solve by inversion; eauto |
            inversion H; eauto])...

  - (* TmAnd *)
    right.
    destruct IHtyped1; subst...
    + inversion typed1; subst; inversion H...
      destruct IHtyped2; subst...
      * inversion typed2; subst; inversion H0...
      * inversion typed2; subst; inversion H0; eauto;
          inversion H0; exists (TmAnd TmTrue x); constructor; eauto;
            intros contra; inversion contra.
    + inversion H...
  - (* TmOr *)
    right.
    destruct IHtyped1; subst...
    + inversion typed1; subst; inversion H...
      * destruct IHtyped2; subst...
        { inversion typed2; subst; inversion H0... }
        { inversion H0... }
    + inversion H...
  - (* TmIf *)
    right.
    destruct IHtyped1; subst...
    + inversion typed1; subst; inversion H...
    + inversion H...

  - (* TmApp *)
    right.
    destruct IHtyped1; subst...
    + inversion typed1; subst; inversion H...
    + inversion H...

  - (* TmEq *)
    right.
    destruct IHtyped1; subst...
    + destruct IHtyped2; subst...
      * inversion typed1; subst; inversion H0; eauto;
          inversion typed2; subst; inversion H1;
            try (exists TmError; constructor; eauto;
                    intros contra; by inversion contra);
            try (exists TmTrue; constructor; by eauto);
            try (exists TmFalse; constructor; by eauto)...
        { destruct (eq_nat_dec c c0).
          - exists TmTrue; constructor; subst...
          - exists TmFalse; constructor;
              intros contra; inversion contra; subst... }
        { destruct (Z.eq_dec z z0).
          - exists TmTrue; constructor; subst...
          - exists TmFalse; constructor;
              intros contra; inversion contra; subst... }
        { inversion H. }
      * remember tleft as tl.
        inversion typed1; subst; inversion H0; eauto;
          inversion H1; exists (TmEq tleft x); subst; constructor; eauto;
            intros contra; by inversion contra.
    + inversion H0...

  - (* TmVar *)
    inversion H.
Qed.

Hint Immediate progress.

Inductive freeVar: id -> tm -> Prop :=
| FreeVarNeg: forall i tneg,
    freeVar i tneg ->
    freeVar i (TmNeg tneg)
| FreeVarAndLeft: forall i tleft tright,
    freeVar i tleft ->
    freeVar i (TmAnd tleft tright)
| FreeVarAndRight: forall i tleft tright,
    freeVar i tright ->
    freeVar i (TmAnd tleft tright)
| FreeVarOrLeft: forall i tleft tright,
    freeVar i tleft ->
    freeVar i (TmOr tleft tright)
| FreeVarOrRight: forall i tleft tright,
    freeVar i tright ->
    freeVar i (TmOr tleft tright)
| FreeVarIfCond: forall i tcond ttrue tfalse,
    freeVar i tcond ->
    freeVar i (TmIf tcond ttrue tfalse)
| FreeVarIfTrue: forall i tcond ttrue tfalse,
    freeVar i ttrue ->
    freeVar i (TmIf tcond ttrue tfalse)
| FreeVarIfFalse: forall i tcond ttrue tfalse,
    freeVar i tfalse ->
    freeVar i (TmIf tcond ttrue tfalse)

| FreeVarPairFst: forall i tfst tsnd,
    freeVar i tfst ->
    freeVar i (TmPair tfst tsnd)
| FreeVarPairSnd: forall i tfst tsnd,
    freeVar i tsnd ->
    freeVar i (TmPair tfst tsnd)
| FreeVarFst: forall i tpair,
    freeVar i tpair ->
    freeVar i (TmFst tpair)
| FreeVarSnd: forall i tpair,
    freeVar i tpair ->
    freeVar i (TmSnd tpair)

| FreeVarConsHead: forall i thead ttail,
    freeVar i thead ->
    freeVar i (TmCons thead ttail)
| FreeVarConsTail: forall i thead ttail,
    freeVar i ttail ->
    freeVar i (TmCons thead ttail)
| FreeVarHead: forall i tlist,
    freeVar i tlist ->
    freeVar i (TmHead tlist)
| FreeVarTail: forall i tlist,
    freeVar i tlist ->
    freeVar i (TmTail tlist)

| FreeVarLam: forall i ipar Tpar tres,
    i <> ipar ->
    freeVar i tres ->
    freeVar i (TmLam ipar Tpar tres)
| FreeVarAppLam: forall i tlam tapp,
    freeVar i tlam ->
    freeVar i (TmApp tlam tapp)
| FreeVarAppApp: forall i tlam tapp,
    freeVar i tapp ->
    freeVar i (TmApp tlam tapp)

| FreeVarEqLeft: forall i tleft tright,
    freeVar i tleft ->
    freeVar i (TmEq tleft tright)
| FreeVarEqRight: forall i tleft tright,
    freeVar i tright ->
    freeVar i (TmEq tleft tright)

| FreeVarVar: forall i,
    freeVar i (TmVar i)

| FreeVarLetLet: forall i ilet tlet tin,
    freeVar i tlet ->
    freeVar i (TmLet ilet tlet tin)
| FreeVarLetIn: forall i ilet tlet tin,
    i <> ilet ->
    freeVar i tin ->
    freeVar i (TmLet ilet tlet tin)

| FreeVarFix: forall i tfix,
    freeVar i tfix ->
    freeVar i (TmFix tfix)
.

Hint Constructors freeVar.

Lemma context_invariance: forall (TC0 TC1: tyCtxt) t T,
    TC0 |- t :| T ->
    (forall i, freeVar i t -> TC0 i = TC1 i) ->
    TC1 |- t :| T.
Proof with eauto.
  intros TC0 TC1 t T typed eqFreeVar.
  generalize dependent TC1.
  induction typed; intros;
    try (constructor; by eauto)...
  - (* TmLam *)
    constructor.
    apply IHtyped. intros.
    unfold extend.
    destruct (eq_id_dec ipar i)...
  - (* TmApp *)
    econstructor...
  - (* TmBool *)
    econstructor...
  - (* TmVar *)
    constructor. rewrite <- eqFreeVar...
  - (* TmLet *)
    econstructor.
    + apply IHtyped1. intros.
      apply eqFreeVar...
    + apply IHtyped2. intros.
      unfold extend.
      destruct (eq_id_dec ilet i)...
Qed.

Hint Immediate context_invariance.

Lemma free_in_context: forall TC i t T0,
    TC |- t :| T0 ->
    freeVar i t ->
    exists T1, TC i = Some T1.
Proof with eauto.
  intros TC i t T0 typed free.
  induction typed; intros; inversion free; subst...
  - (* TmLam *)
    destruct IHtyped... exists x.
    rewrite <- H. unfold extend.
    rewrite neq_id...
  - (* TmLet *)
    destruct IHtyped2... exists x.
    rewrite <- H. unfold extend.
    rewrite neq_id...
Qed.

Hint Immediate free_in_context.

Lemma substitution_preserves_typing: forall TC i s S t T,
    (extend TC i S) |- t :| T ->
    emptyMap |- s :| S ->
    TC |- ([i <- s] t) :| T.
Proof with eauto.
  intros TC i s S t T typed0 typed1.
  generalize dependent T.
  generalize dependent S.
  generalize dependent s.
  generalize dependent i.
  generalize dependent TC.
  induction t; intros; inversion typed0;
    try (constructor; by eauto);
    try (simpl; econstructor; by eauto); subst; simpl...
  - (* TmLam *)
    constructor.
    destruct (eq_id_dec i0 i).
    + eapply context_invariance...
      intros. subst. unfold extend.
      destruct (eq_id_dec i i1)...
    + eapply IHt...
      eapply context_invariance...
      intros. subst. unfold extend.
      destruct (eq_id_dec i i1)...
      subst. rewrite neq_id...
  - (* TmVar *)
    destruct (eq_id_dec i0 i).
    + subst. rewrite extend_eq in H1.
      inversion H1; subst. clear H1.
      eapply context_invariance... intros.
      destruct (free_in_context _ _ _ T typed1 H).
      inversion H0.
    + econstructor.
      rewrite <- H1. unfold extend.
      rewrite neq_id...
  - (* TmLet *)
    destruct (eq_id_dec i0 i).
    + econstructor...
      eapply context_invariance...
      intros. subst. unfold extend.
      destruct (eq_id_dec i i1)...
    + econstructor...
      eapply IHt2...
      eapply context_invariance...
      intros. subst. unfold extend.
      destruct (eq_id_dec i i1); destruct (eq_id_dec i0 i1); subst...
      exfalso...
Qed.

Hint Immediate substitution_preserves_typing.

Theorem preservation: forall t0 t1 T,
    emptyMap |- t0 :| T ->
    t0 ==> t1 ->
    emptyMap |- t1 :| T.
Proof with eauto.
  intros t0 t1 T typed step.
  remember emptyMap as TC. generalize dependent HeqTC.
  generalize dependent t1.
  induction typed; intros; subst;
    try (inversion step; subst;
         inversion typed; by eauto);
    try (inversion step; subst; by eauto)...
  - (* TmApp *)
    inversion step; subst...
    eapply substitution_preserves_typing...
    inversion typed1...
  - (* TmEq *)
    inversion step; subst; try (econstructor; by eauto)...
    + inversion typed1; subst;
        inversion typed2; subst;
          inversion H; subst.
      econstructor; econstructor...
    + inversion typed1; subst;
        inversion typed2; subst;
          inversion H; subst.
      econstructor; econstructor...
  - (* TmFix *)
    inversion step; subst...
    eapply substitution_preserves_typing...
    inversion typed; subst...
Qed.

Hint Immediate preservation.

Definition nmlfm {T: Type} (R: Relation T) (t0: T): Prop :=
  ~ exists t1, R t0 t1.

Hint Unfold nmlfm.

Notation stnmlfm := (nmlfm smst).

Notation mltst := (mlt smst).
Notation "t0 '==>*' t1" := (mltst t0 t1) (at level 40).

Theorem soundness: forall t0 t1 T,
    emptyMap |- t0 :| T ->
    t0 ==>* t1 ->
    ~ stnmlfm t1 \/ val t1.
Proof with eauto.
  intros t0 t1 T typed mltstep.
  induction mltstep...
  - apply progress in typed.
    destruct typed...
Qed.

Hint Immediate soundness.


(* monae: Monadic equational reasoning in Coq                                 *)
(* Copyright (C) 2020 monae authors, license: LGPL-2.1-or-later               *)
From mathcomp Require Import all_ssreflect.
From mathcomp Require boolp.
Require Import monae_lib.
From HB Require Import structures.
Require Import hierarchy monad_lib fail_lib.
From infotheo Require Import ssrZ.
Require Import ZArith.

(******************************************************************************)
(*                Definitions and lemmas about the array monad                *)
(*                                                                            *)
(*           aswap i j == swap the cells at addresses i and j; this is a      *)
(*                        computation of type (M unit)                        *)
(*       writeList i s == write the list s at address i; this is a            *)
(*                        computation of type (M unit)                        *)
(*          writeL i s := writeList i s >> Ret (size s)                       *)
(*    write2L i (s, t) := writeList i (s ++ t) >> Ret (size s, size t)        *)
(* write3L i (s, t, u) := writeList i (s ++ t ++ u) >>                        *)
(*                        Ret (size s, size t, size u)                        *)
(*        readList i n == read the list of values of size n starting at       *)
(*                        address i; it is a computation of type (M (seq E))  *)
(*                        where E is the type of stored elements              *)
(*                                                                            *)
(******************************************************************************)

Local Open Scope monae_scope.
Local Open Scope zarith_ext_scope.

Section marray.
Context {d : unit} {E : porderType d} {M : arrayMonad E Z_eqType}.
Implicit Type i j : Z.

Definition aswap i j : M unit :=
  aget i >>= (fun x => aget j >>= (fun y => aput i y >> aput j x)).

Lemma aswapxx i : aswap i i = skip.
Proof.
rewrite /aswap agetget.
under eq_bind do rewrite aputput.
by rewrite agetputskip.
Qed.

Fixpoint writeList i (s : seq E) : M unit :=
  if s isn't x :: xs then Ret tt else aput i x >> writeList (i + 1) xs.

Lemma writeList1 i (x : E) : writeList i [:: x] = aput i x.
Proof. by rewrite /writeList bindmskip. Qed.

Lemma writeList_cons i (x : E) (xs : seq E) :
  writeList i (x :: xs) = aput i x >> writeList (i + 1) xs.
Proof. by []. Qed.

Lemma aput_writeListC i j (x : E) (xs : seq E) : (i < j)%Z ->
  aput i x >> writeList j xs = writeList j xs >> aput i x.
Proof.
elim: xs i j => [|h tl ih] i j ij.
  by rewrite bindretf bindmskip.
rewrite /= -bindA aputC; last by left; apply/eqP/ltZ_eqF.
rewrite !bindA; bind_ext => -[].
by rewrite ih// ltZadd1; apply/ltZW.
Qed.

Lemma writeListC i j (ys zs : seq E) : (i + (size ys)%:Z <= j)%Z ->
  writeList i ys >> writeList j zs = writeList j zs >> writeList i ys.
Proof.
elim: ys zs i j => [|h t ih] zs i j hyp; first by rewrite bindretf bindmskip.
rewrite /= aput_writeListC; last by rewrite ltZadd1; exact: leZZ.
rewrite bindA aput_writeListC; last exact/ltZ_leZ_trans/hyp/ltZ_addr/leZZ.
rewrite /= natZS -add1Z addZA in hyp.
by rewrite -!bindA ih.
Qed.

Lemma aput_writeListCR i j (x : E) (xs : seq E) : (j + (size xs)%:Z <= i)%Z ->
  aput i x >> writeList j xs = writeList j xs >> aput i x.
Proof. by move=> ?; rewrite -writeList1 -writeListC. Qed.

Lemma writeList_cat i (s1 s2 : seq E) :
  writeList i (s1 ++ s2) = writeList i s1 >> writeList (i + (size s1)%:Z) s2.
Proof.
elim: s1 i => [|h t ih] i /=; first by rewrite bindretf addZ0.
by rewrite ih bindA -addZA add1Z natZS.
Qed.

Lemma writeList_rcons i (x : E) (xs : seq E) :
  writeList i (rcons xs x) = writeList i xs >> aput (i + (size xs)%:Z)%Z x.
Proof. by rewrite -cats1 writeList_cat /= -bindA bindmskip. Qed.

Definition writeL i (s : seq E) := writeList i s >> Ret (size s).

Definition write2L i '(s, t) := writeList i (s ++ t) >> Ret (size s, size t).

Lemma write2LE i a b D (f : nat * nat -> M D) :
  write2L i (a, b) >>= f = writeList i (a ++ b) >> f (size a, size b).
Proof. by rewrite /write2L bindA bindretf. Qed.

Definition write3L i '(s, t, u) :=
  writeList i (s ++ t ++ u) >> Ret (size s, size t, size u).

Lemma write3LE i x D (f : nat * nat * nat -> M D) :
  write3L i x >>= f = let '(s, t, u) := x in
    writeList i (s ++ t ++ u) >> f (size s, size t, size u).
Proof. by move: x => -[[x y] z]; rewrite /write3L bindA bindretf. Qed.

Lemma write_read i x : aput i x >> aget i = aput i x >> Ret x :> M _.
Proof. by rewrite -[RHS]aputget bindmret. Qed.

Lemma write_readC i j x : i != j ->
  aput i x >> aget j = aget j >>= (fun v => aput i x >> Ret v) :> M _.
Proof. by move => ?; rewrite -aputgetC // bindmret. Qed.

(* see postulate introduce-read in IQsort.agda *)
Lemma writeListRet i x (s : seq E) :
  writeList i (x :: s) >> Ret x = writeList i (x :: s) >> aget i.
Proof.
elim/last_ind: s x i => [|h t ih] /= x i.
  by rewrite bindmskip write_read.
rewrite writeList_rcons 2![in RHS]bindA.
rewrite write_readC; last first.
  apply/eqP/gtZ_eqF; rewrite addZC; apply/ltZ_addl; first exact/leZ0n.
  exact/ltZadd1/leZZ.
rewrite -2![RHS]bindA -ih [RHS]bindA.
rewrite !bindA; bind_ext => _.
by under [in RHS]eq_bind do rewrite bindretf.
Qed.

Lemma writeList_aswap i x h (t : seq E) :
  writeList i (rcons (h :: t) x) =
  writeList i (rcons (x :: t) h) >> aswap i (i + (size (rcons t h))%:Z).
Proof.
rewrite /aswap -!bindA writeList_rcons /=.
rewrite aput_writeListC; last by apply/ltZ_addr => //; exact: leZZ.
rewrite bindA.
rewrite aput_writeListC; last by apply/ltZ_addr => //; exact: leZZ.
rewrite writeList_rcons !bindA; bind_ext => -[].
under [RHS] eq_bind do rewrite -bindA.
rewrite aputget -bindA size_rcons -addZA natZS -add1Z.
under [RHS] eq_bind do rewrite -!bindA.
rewrite aputgetC; last first.
  apply/eqP/ltZ_eqF; rewrite addZA addZC; apply/ltZ_addl; first exact/leZ0n.
  by apply/ltZ_addr => //; exact: leZZ.
rewrite -!bindA aputget aputput aputC; last by right.
by rewrite bindA aputput.
Qed.

Lemma aput_writeList_rcons i x h (t : seq E) :
  aput i x >> writeList (i + 1) (rcons t h) =
  aput i h >>
      ((writeList (i + 1) t >> aput (i + 1 + (size t)%:Z)%Z x) >>
        aswap i (i + (size t).+1%:Z)).
Proof.
rewrite /aswap -!bindA writeList_rcons -bindA.
rewrite aput_writeListC; last by rewrite ltZadd1; exact: leZZ.
rewrite aput_writeListC; last by rewrite ltZadd1; exact: leZZ.
rewrite !bindA; bind_ext => -[].
under [RHS] eq_bind do rewrite -bindA.
rewrite aputgetC; last first.
  apply/eqP/gtZ_eqF; rewrite addZC; apply/ltZ_addl; first exact: leZ0n.
  by apply/ltZ_addr => //; exact: leZZ.
rewrite -bindA -addZA natZS -add1Z aputget.
under [RHS] eq_bind do rewrite -!bindA.
rewrite aputget aputC; last by right.
by rewrite -!bindA aputput bindA aputput.
Qed.

Lemma writeList_ret_aget i x (s : seq E) (f : E -> M (nat * nat)%type):
  writeList i (x :: s) >> Ret x >> f x =
  writeList i (x :: s) >> aget i >>= f.
Proof.
rewrite writeListRet 2!bindA /=.
rewrite aput_writeListC; last by apply/ltZ_addr => //; exact: leZZ.
rewrite 2!bindA.
under [LHS] eq_bind do rewrite -bindA aputget.
by under [RHS] eq_bind do rewrite -bindA aputget.
Qed.

Fixpoint readList i (n : nat) : M (seq E) :=
  if n isn't k.+1 then Ret [::] else liftM2 cons (aget i) (readList (i + 1) k).

End marray.

Section refin_writeList_aswap.
Variable (d : unit) (E : orderType d) (M : plusArrayMonad E Z_eqType).

(* eqn 13 in mu2020flops, postulate introduce-swap in IQSort.agda *)
Lemma refin_writeList_cons_aswap (i : Z) x (s : seq E) :
  writeList i (x :: s) >> aswap (M := M) i (i + (size s)%:Z)
  `<=`
  qperm s >>= (fun s' => writeList i (rcons s' x)).
Proof.
elim/last_ind: s => [|t h ih] /=.
  rewrite qperm_nil bindmskip bindretf addZ0 aswapxx /= bindmskip.
  exact: refin_refl.
rewrite bindA.
apply: (refin_trans _ (refin_bindr _ (qperm_refin_cons _ _ _))).
by rewrite bindretf -bindA -writeList_aswap; exact: refin_refl.
Qed.

(* eqn 11 in mu2020flops, introduce-swap in IPartl.agda *)
Lemma refin_writeList_rcons_aswap (i : Z) x (s : seq E) :
  writeList i (rcons s x) >> aswap (M := M) i (i + (size s)%:Z)
  `<=`
  qperm s >>= (fun s' => writeList (M := M) i (x :: s')).
Proof.
case: s => [|h t] /=.
  rewrite qperm_nil bindmskip bindretf addZ0 aswapxx bindmskip.
  exact: refin_refl.
rewrite bindA writeList_rcons -aput_writeList_rcons.
apply: (refin_trans _ (refin_bindr _ (qperm_refin_rcons _ _ _))).
by rewrite bindretf; exact: refin_refl.
Qed.

(* bottom of the page 11, used in the proof of lemma 10 *)
Lemma refin_writeList_rcons_cat_aswap (i : Z) x (ys zs : seq E) :
  writeList i (rcons (ys ++ zs) x) >>
    aswap (M := M) (i + (size ys)%:Z) (i + (size (ys ++ zs))%:Z)
  `<=`
  qperm zs >>= (fun zs' => writeList i (ys ++ x :: zs')).
Proof.
under [in X in _ `<=` X]eq_bind do rewrite writeList_cat.
have -> : commute (qperm zs) (writeList i ys) _.
  by move=> *; exact/commute_plus/nondetPlus_sub_qperm.
rewrite rcons_cat writeList_cat bindA; apply: refin_bindl => -[].
by rewrite size_cat intRD addZA; exact: refin_writeList_rcons_aswap.
Qed.

End refin_writeList_aswap.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Parameter ident : Type.

Axiom ident_eq_dec : forall (i1:ident) (i2:ident), (i1 = i2) \/ ~ (i1 = i2).

Parameter mk_ident: Z -> ident.

Axiom mk_ident_inj : forall (i:Z) (j:Z), ((mk_ident i) = (mk_ident j)) ->
  (i = j).

Inductive operator  :=
  | Oplus : operator
  | Ominus : operator
  | Omult : operator .

Inductive expr  :=
  | Econst : Z -> expr
  | Evar : ident -> expr
  | Ebin : expr -> operator -> expr -> expr .

Inductive stmt  :=
  | Sskip : stmt
  | Sassign : ident -> expr -> stmt
  | Sseq : stmt -> stmt -> stmt
  | Sif : expr -> stmt -> stmt -> stmt
  | Swhile : expr -> stmt -> stmt .

Axiom check_skip : forall (s:stmt), (s = Sskip) \/ ~ (s = Sskip).

Parameter map : forall (a:Type) (b:Type), Type.

Parameter get: forall (a:Type) (b:Type), (map a b) -> a -> b.

Implicit Arguments get.

Parameter set: forall (a:Type) (b:Type), (map a b) -> a -> b -> (map a b).

Implicit Arguments set.

Axiom Select_eq : forall (a:Type) (b:Type), forall (m:(map a b)),
  forall (a1:a) (a2:a), forall (b1:b), (a1 = a2) -> ((get (set m a1 b1)
  a2) = b1).

Axiom Select_neq : forall (a:Type) (b:Type), forall (m:(map a b)),
  forall (a1:a) (a2:a), forall (b1:b), (~ (a1 = a2)) -> ((get (set m a1 b1)
  a2) = (get m a2)).

Parameter const: forall (b:Type) (a:Type), b -> (map a b).

Set Contextual Implicit.
Implicit Arguments const.
Unset Contextual Implicit.

Axiom Const : forall (b:Type) (a:Type), forall (b1:b) (a1:a), ((get (const(
  b1):(map a b)) a1) = b1).

Definition state  := (map ident Z).

Definition eval_bin(x:Z) (op:operator) (y:Z): Z :=
  match op with
  | Oplus => (x + y)%Z
  | Ominus => (x - y)%Z
  | Omult => (x * y)%Z
  end.

Set Implicit Arguments.
Fixpoint eval_expr(s:(map ident Z)) (e:expr) {struct e}: Z :=
  match e with
  | (Econst n) => n
  | (Evar x) => (get s x)
  | (Ebin e1 op e2) => (eval_bin (eval_expr s e1) op (eval_expr s e2))
  end.
Unset Implicit Arguments.

Inductive one_step : (map ident Z) -> stmt -> (map ident Z)
  -> stmt -> Prop :=
  | one_step_assign : forall (s:(map ident Z)) (x:ident) (e:expr),
      (one_step s (Sassign x e) (set s x (eval_expr s e)) Sskip)
  | one_step_seq : forall (s:(map ident Z)) (sqt:(map ident Z)) (i1:stmt)
      (i1qt:stmt) (i2:stmt), (one_step s i1 sqt i1qt) -> (one_step s (Sseq i1
      i2) sqt (Sseq i1qt i2))
  | one_step_seq_skip : forall (s:(map ident Z)) (i:stmt), (one_step s
      (Sseq Sskip i) s i)
  | one_step_if_true : forall (s:(map ident Z)) (e:expr) (i1:stmt) (i2:stmt),
      (~ ((eval_expr s e) = 0%Z)) -> (one_step s (Sif e i1 i2) s i1)
  | one_step_if_false : forall (s:(map ident Z)) (e:expr) (i1:stmt)
      (i2:stmt), ((eval_expr s e) = 0%Z) -> (one_step s (Sif e i1 i2) s i2)
  | one_step_while_true : forall (s:(map ident Z)) (e:expr) (i:stmt),
      (~ ((eval_expr s e) = 0%Z)) -> (one_step s (Swhile e i) s (Sseq i
      (Swhile e i)))
  | one_step_while_false : forall (s:(map ident Z)) (e:expr) (i:stmt),
      ((eval_expr s e) = 0%Z) -> (one_step s (Swhile e i) s Sskip).

Axiom progress : forall (s:(map ident Z)) (i:stmt), (~ (i = Sskip)) ->
  exists sqt:(map ident Z), exists iqt:stmt, (one_step s i sqt iqt).

Inductive many_steps : (map ident Z) -> stmt -> (map ident Z) -> stmt
  -> Z -> Prop :=
  | many_steps_refl : forall (s:(map ident Z)) (i:stmt), (many_steps s i s i
      0%Z)
  | many_steps_trans : forall (s1:(map ident Z)) (s2:(map ident Z)) (s3:(map
      ident Z)) (i1:stmt) (i2:stmt) (i3:stmt) (n:Z), (one_step s1 i1 s2
      i2) -> ((many_steps s2 i2 s3 i3 n) -> (many_steps s1 i1 s3 i3
      (n + 1%Z)%Z)).

Axiom steps_non_neg : forall (s1:(map ident Z)) (s2:(map ident Z)) (i1:stmt)
  (i2:stmt) (n:Z), (many_steps s1 i1 s2 i2 n) -> (0%Z <= n)%Z.

Axiom many_steps_seq : forall (s1:(map ident Z)) (s3:(map ident Z)) (i1:stmt)
  (i2:stmt) (n:Z), (many_steps s1 (Sseq i1 i2) s3 Sskip n) -> exists s2:(map
  ident Z), exists n1:Z, exists n2:Z, (many_steps s1 i1 s2 Sskip n1) /\
  ((many_steps s2 i2 s3 Sskip n2) /\ (n = ((1%Z + n1)%Z + n2)%Z)).

Inductive fmla  :=
  | Fterm : expr -> fmla
  | Fand : fmla -> fmla -> fmla
  | Fnot : fmla -> fmla
  | Fimplies : fmla -> fmla -> fmla .

Set Implicit Arguments.
Fixpoint eval_fmla(s:(map ident Z)) (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm e) => ~ ((eval_expr s e) = 0%Z)
  | (Fand f1 f2) => (eval_fmla s f1) /\ (eval_fmla s f2)
  | (Fnot f1) => ~ (eval_fmla s f1)
  | (Fimplies f1 f2) => (eval_fmla s f1) -> (eval_fmla s f2)
  end.
Unset Implicit Arguments.

Parameter subst_expr: expr -> ident -> expr -> expr.

Axiom subst_expr_def : forall (e:expr) (x:ident) (t:expr),
  match e with
  | (Econst _) => ((subst_expr e x t) = e)
  | (Evar y) => ((x = y) -> ((subst_expr e x t) = t)) /\ ((~ (x = y)) ->
      ((subst_expr e x t) = e))
  | (Ebin e1 op e2) => ((subst_expr e x t) = (Ebin (subst_expr e1 x t) op
      (subst_expr e2 x t)))
  end.

Axiom eval_subst_expr : forall (s:(map ident Z)) (e:expr) (x:ident) (t:expr),
  ((eval_expr s (subst_expr e x t)) = (eval_expr (set s x (eval_expr s t))
  e)).

Set Implicit Arguments.
Fixpoint subst(f:fmla) (x:ident) (t:expr) {struct f}: fmla :=
  match f with
  | (Fterm e) => (Fterm (subst_expr e x t))
  | (Fand f1 f2) => (Fand (subst f1 x t) (subst f2 x t))
  | (Fnot f1) => (Fnot (subst f1 x t))
  | (Fimplies f1 f2) => (Fimplies (subst f1 x t) (subst f2 x t))
  end.
Unset Implicit Arguments.

Axiom eval_subst : forall (s:(map ident Z)) (f:fmla) (x:ident) (t:expr),
  (eval_fmla s (subst f x t)) <-> (eval_fmla (set s x (eval_expr s t)) f).

Definition valid_fmla(p:fmla): Prop := forall (s:(map ident Z)), (eval_fmla s
  p).

Definition valid_triple(p:fmla) (i:stmt) (q:fmla): Prop := forall (s:(map
  ident Z)), (eval_fmla s p) -> forall (sqt:(map ident Z)) (n:Z),
  (many_steps s i sqt Sskip n) -> (eval_fmla sqt q).

Axiom skip_rule : forall (q:fmla), (valid_triple q Sskip q).

(* YOU MAY EDIT THE CONTEXT BELOW *)

(* DO NOT EDIT BELOW *)

Theorem assign_rule : forall (q:fmla) (x:ident) (e:expr),
  (valid_triple (subst q x e) (Sassign x e) q).
(* YOU MAY EDIT THE PROOF BELOW *)
intros q x e.
unfold valid_triple.
intros s Pre s' n Hred.
inversion Hred; subst.
inversion H; subst.
inversion H0; subst.
(* normal case *)
clear H Hred H0.
rewrite <- eval_subst; auto.

(* absurd case *)
inversion H1.
Qed.
(* DO NOT EDIT BELOW *)


(****************************************************************)
(*  On monadic parametricity of second-order functionals        *)
(*  by Bauer A., Hofmann M., Karbyshev A.                       *)
(*                                                              *)
(*  Aleksandr Karbyshev                                         *)
(*  May 2012                                                    *)
(*  Build with Coq 8.4 + Ssreflect 1.4                          *)
(****************************************************************)

(* typedparam.v
   Parametricity theorem
*)

Set Automatic Coercions Import.
Require Import seq.
Require Import typeddensem.
Require Import relations.
Require Import Program.Equality.

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

Section TypesRSem.

Variables T T' : monadType.
Variable TRacc : TRelAccType T T'.

Parameter RSem_Base :
  forall (o : baseType), Rel (semBase o T) (semBase o T').
Parameter admissible_RSem_Base :
  forall (o : baseType), admissibleR (@RSem_Base o).

Fixpoint TRSemTy (ty : Ty) : Rel (SemTy T ty) (SemTy T' ty) :=
  match ty with
    | Base o => @RSem_Base o
    | ty1 --> ty2 =>
        (@TRSemTy ty1) =R=>
        (TRel TRacc (X:=SemTy T ty2) (X':=SemTy T' ty2) (@TRSemTy ty2))
    | ty1 ** ty2 => (@TRSemTy ty1) *R* (@TRSemTy ty2)
  end.

Lemma admissibleTRSemTy : forall ty, admissibleR (@TRSemTy ty).
elim => [o | ty1 Hty1 ty2 Hty2 | ty1 Hty1 ty2 Hty2].
- by apply: admissible_RSem_Base.
- rewrite /=. apply: admissibleArrR. by apply: (@Adm _ _ TRacc).
- rewrite /=. by apply: admissibleProdR.
Qed.

End TypesRSem.

Implicit Arguments TRSemTy [T T'].

Lemma parametricity
        T T' (TRacc : TRelAccType T T')
        env (eta : SemEnv T env) (eta' : SemEnv T' env) :
    (forall ty (c : Const ty),
      TRSemTy TRacc _ (SemConst T c) (SemConst T' c)) ->
    (forall ty (v : Var env ty),
      TRSemTy TRacc _ (SemVar T v eta) (SemVar T' v eta')) ->
    forall ty (e : Exp env ty),
      TRel TRacc (X:=SemTy T ty) (X':=SemTy T' ty)
        (TRSemTy TRacc _)
        (SemExp T e eta)
        (SemExp T' e eta').
Proof.
move => Hconst Hvar.
dependent induction e.

(* TCONST *)
- rewrite /=. by apply: (proj1 (Acc TRacc)).

(* TVAR *)
- rewrite /=. by apply: (proj1 (Acc TRacc)).

(* TPROD *)
- move => /=.
  apply: (proj2 (Acc TRacc)); first by auto.
  move => x x' Hxx' /=.
  apply: (proj2 (Acc TRacc)); first by auto.
  move => y y' Hyy' /=.
  by apply: (proj1 (Acc TRacc)).

(* TFST *)
- move => /=.
  apply: (proj2 (Acc TRacc)); first by auto.
  intros x x' Hxx' => /=.
  apply: (proj1 (Acc TRacc)).
  by apply: (proj1 (ProdR_elim Hxx')).

(* TSND *)
- move => /=.
  apply: (proj2 (Acc TRacc)); first by auto.
  intros x x' Hxx' => /=.
  apply: (proj1 (Acc TRacc)).
  by apply: (proj2 (ProdR_elim Hxx')).

(* TABS *)
- move => /=.
  apply: (proj1 (Acc TRacc)).
  intros x x' Hxx' => /=.
  apply: IHe => // ty v.
  by dependent destruction v => //=.

(* TAPP *)
- move => /=.
  apply: (proj2 (Acc TRacc)); first by auto.
  move => f f' Hff' => /=.
  by apply: (proj2 (Acc TRacc)); auto.

(* TLET *)
- move => /=.
  apply: (proj2 (Acc TRacc)); first by auto.
  move => f f' Hff' => /=.
  apply: IHe2 => //.
  move => ty v.
  by  dependent destruction v => //=.

(* TFIX *)
- move => /=.
  apply: (proj1 (Acc TRacc)).
  have Hadm : admissibleR (TRSemTy TRacc ty1 =R=> TRel TRacc (TRSemTy TRacc ty2)).
    apply: admissibleArrR. apply: (@Adm _ _ TRacc). by apply: admissibleTRSemTy.
  apply: (fixpR_ind Hadm).
  + move => x x' Hxx' /=. by apply: (Str TRacc).
  + move => f f' Hff' x x' Hxx' /=.
    apply: IHe => //.
    move => ty v.
    dependent destruction v => //=.
    by dependent destruction v => //=.
Qed.

Corollary ParametricityTheorem
            T T' (TRacc : TRelAccType T T')
            (eta : SemEnv T [::]) (eta' : SemEnv T' [::]) :
    (forall ty (c : Const ty),
      TRSemTy TRacc _ (SemConst T c) (SemConst T' c)) ->
    forall ty (e : CExp ty),
      TRel TRacc (X:=SemTy T ty) (X':=SemTy T' ty)
           (TRSemTy TRacc _)
           (SemExp T e eta)
           (SemExp T' e eta').
Proof.
move => Hconst ty e.
apply: parametricity => //.
move => {ty e Hconst} ty v.
by dependent destruction v.
Qed.


(* Checks syntax of Hints commands *)
(* Checks that qualified names are accepted *)

(* New-style syntax *)
Hint Resolve refl_equal: core arith.
Hint Immediate trans_equal.
Hint Unfold sym_equal: core.
Hint Constructors eq: foo bar.
Hint Extern 3 (_ = _) => apply refl_equal: foo bar.

(* Old-style syntax *)
Hint Resolve refl_equal sym_equal.
Hint Resolve refl_equal sym_equal: foo.
Hint Immediate refl_equal sym_equal.
Hint Immediate refl_equal sym_equal: foo.
Hint Unfold fst sym_equal.
Hint Unfold fst sym_equal: foo.

(* What's this stranged syntax ? *)
Hint Destruct h6 := 4 Conclusion (_ <= _) => fun H => apply H.
Hint Destruct h7 := 4 Discardable Hypothesis (_ <= _) => fun H => apply H.
Hint Destruct h8 := 4 Hypothesis (_ <= _) => fun H => apply H.

(* Checks that local names are accepted *)
Section A.
  Remark Refl : forall (A : Set) (x : A), x = x.
  Proof. exact refl_equal. Defined.
  Definition Sym := sym_equal.
  Let Trans := trans_equal.

  Hint Resolve Refl: foo.
  Hint Resolve Sym: bar.
  Hint Resolve Trans: foo2.

  Hint Immediate Refl.
  Hint Immediate Sym.
  Hint Immediate Trans.

  Hint Unfold Refl.
  Hint Unfold Sym.
  Hint Unfold Trans.

  Hint Resolve Sym Trans Refl.
  Hint Immediate Sym Trans Refl.
  Hint Unfold Sym Trans Refl.

End A.

Axiom a : forall n, n=0 <-> n<=0.

Hint Resolve -> a.
Goal forall n, n=0 -> n<=0.
auto.
Qed.

(* This example comes from Chlipala's ltamer *)
(* It used to fail from r12902 to r13112 since type_of started to call *)
(* e_cumul (instead of conv_leq) which was not able to unify "?id" and *)
(* "(fun x => x) ?id" *)

Notation "e :? pf" := (eq_rect _ (fun X : Set => X) e _ pf)
  (no associativity, at level 90).

Axiom cast_coalesce :
  forall (T1 T2 T3 : Set) (e : T1) (pf1 : T1 = T2) (pf2 : T2 = T3),
  ((e :? pf1) :? pf2) = (e :? trans_eq pf1 pf2).

Hint Rewrite cast_coalesce : ltamer.


Require Import BoolEquality.
Require Import BaseDef.
Require Import MSets.
Require Import Reals.
Require Import Fourier.
Require Import CCMisc.
Require Import le_lift.

Set Implicit Arguments.
Unset Strict Implicit.

Open Scope R_scope.

(* *********************************************************************** *)
(*                           1.Some auxiliary lemmas                       *)
(* *********************************************************************** *)

Lemma R_dist_le : forall x y l,
 0 <= x <= l ->
 0 <= y <= l ->
 R_dist x y <= l.
Proof.
 intros x y l (H1x, H2x) (H1y, H2y).
 unfold R_dist, Rabs.
 destruct (Rcase_abs (x - y)); fourier.
Qed.

Lemma prod_dec:  forall (A B : Type),
  (forall (a1 a2:A), {a1 = a2} + {~ a1 = a2}) ->
  (forall (b1 b2:B), {b1 = b2} + {~ b1 = b2}) ->
  forall (ab1 ab2: A*B), { ab1 = ab2} + {~ ab1 = ab2}.
Proof.
 intros A B HA HB (a1,b1) (a2,b2).
 destruct (HA a1 a2).
   destruct (HB b1 b2).
     subst; left; trivial.
     right; intros H; inversion H; tauto.
   right; intros H; inversion H; tauto.
Qed.

Lemma NoDupA_NoDup: forall (A:Type) (l:list A),
  NoDupA eq l -> NoDup l.
Proof.
 intros; induction l.
   trivial.
   inversion H; subst.
   constructor.
   intro H'; apply (H2 (In_InA eq_equivalence H')).
   auto.
Qed.

Lemma InA_In: forall (A:Type) (a:A) (l:list A),
  InA eq a l <-> List.In a l.
Proof.
 split; intros.
   induction l.
     rewrite InA_nil in H; elim H.
     inversion H; subst; [ apply in_eq |
       apply (in_cons _ _ _ (IHl H1)) ].
   apply (In_InA eq_equivalence H).
Qed.

Lemma Permutation_PermutP: forall (A:Type) (l1 l2:list A),
  Permutation l1 l2 -> PermutP eq l1 l2.
Proof.
 intros.
 induction H.
   constructor.
   apply PermutP_cons; trivial.
   apply permP_swap with (x:=y) (l:=x::l) (l1':=x::List.nil)
       (x':=y) (l2':=l); [ trivial | ].
   apply (PermutP_cons _ _ (eq_refl _)), PermutP_refl; intros; trivial.
   apply PermutP_trans with l'; trivial.
Qed.

Lemma fold_right_Perm: forall (A:Type) (a:A) (f: A -> A -> A),
  (forall x y z, f x (f y z) = f y (f x z)) ->
  forall (l1 l2: list A),
    PermutP (@eq _) l1 l2 ->
    fold_right f a l1 = fold_right f a l2.
Proof.
 intros A a f Hf.
 induction 1.
   trivial.
   subst; simpl; clear H0.
   rewrite IHPermutP.
   clear IHPermutP; induction l1'.
     trivial.
     change (f x' (f a0 (fold_right f a (l1' ++ l2'))) =
       f a0 (fold_right f a (l1' ++ x' :: l2'))).
     rewrite <-IHl1'; trivial.
Qed.

(* *********************************************************************** *)
(*                   2.[Discretize] for a finite domain.                   *)
(* *********************************************************************** *)

Section Finite_Discretize.

 Variable A B:Type.

 Variable s: A -> B -> R.

 Variable Out : list B.
 Hypothesis Out_spec:
  {b:B | List.In b Out /\ forall a, s a b > 0} + {Out = @List.nil B}.

 Hypothesis s_pos: forall a b, 0 <= s a b .

 Variable dummy:B.

 (* For each [a in A], pick an element [b in Out] with
    probability proportional to [s a b] *)
 Definition finite_discr: A -> Distr (B).
  intro a.
  destruct Out_spec as [ (b,(H1b,H2b)) | HOut ].
    refine (@finite_distr _ Out (fun b => s a b) (s_pos a) b H1b (H2b a)).
    exact (Munit dummy).
 Defined.

 Lemma finite_discr_is_Discrete: forall a,
   is_Discrete (finite_discr a).
 Proof.
  intros a; unfold finite_discr.
  destruct Out_spec as [ (b,(H1b,H2b)) | HOut ].
    apply finite_distr_discrete.
    apply is_Discrete_Munit.
 Qed.

 Lemma finite_discr_lossless: forall a,
   mu (finite_discr a) (fun _ => 1)%U == 1%U.
 Proof.
  intros; unfold finite_discr.
  destruct Out_spec as [ (b,(H1b,H2b)) | HOut ].
    apply finite_distr_lossless.
    trivial.
 Qed.

 Variable eqU: B -> B -O-> U.
 Hypothesis eqU_spec: forall b:B, cover (eq b) (eqU b).

 Hypothesis Hdec: forall (b:B), {List.In b Out} + {~ List.In b Out}.
 Hypothesis Out_NoDup: NoDup Out.

 Section Assym_Distance.

  Variables a a':A.
  Variables M M':R.
  Hypothesis HM:  forall b, List.In b Out -> s a b  <= M  * s a' b.
  Hypothesis HM': forall b, List.In b Out -> s a' b <= M' * s a  b.
  Hypothesis HM_pos:  0 <= M.
  Hypothesis HM'_pos: 0 <= M'.

  Lemma finite_discr_assym_dist:
   let d1 := finite_discr a in
   let d2 := finite_discr a' in
   let lam := M * M' in
   1 <= lam ->
   forall (b:B), (mu d1 (eqU b) <= lam ** mu d2 (eqU b))%tord.
  Proof.
   intros d1 d2 lam Hlam b.
   unfold d1, d2, finite_discr.
   destruct Out_spec as [ (b',(H1b',H2b')) | HOut ].
   (* case [Out] not empty *)
   destruct (Hdec b) as [Hb | Hb].
     (* case [ b in Out ] *)
     rewrite 2 finite_distr_in; trivial.
     unfold multRU; repeat case_Rle; trivial; [ | elim n;
       apply Rmult_le_pos; [ apply Rmult_le_pos; trivial | apply iR_ge_0 ] ].
     assert (Haux: forall x, 0 < y Out (fun b0 : B => s x b0)) by
       (intro x; refine (y_gt_0 _ _ (s_pos x) _ H1b' (H2b' x))).
     unfold c; rewrite retract_R.
     Focus 2.
     split; [ apply Rdiv_pos; trivial | ].
     apply Rdiv_le_1; trivial.
     unfold y; generalize Out b Hb; clear -s_pos.
     induction Out; intros.
       elim (in_nil Hb).
       simpl; destruct (in_inv Hb).
         subst; apply Rle_plus_l.
         clear -s_pos; induction l; simpl;
           [ trivial | rewrite <-s_pos, <-IHl; fourier ].
         rewrite (IHl _ H); apply (Rle_plus_r _ (s_pos _ _)).
     apply iU_le_morphism; unfold lam.
     generalize (Haux a) (Haux a');
     set (y1:= y Out (fun b0 : B => s a b0));
     set (y2:= y Out (fun b0 : B => s a' b0));
     clear -s_pos HM HM' HM_pos HM'_pos Hb; intros Hy1 Hy2.
     transitivity (M * (s a' b / y1)).
     replace (M * (s a' b / y1)) with ((M * s a' b) / y1) by
       (field; intro; fourier); apply Rdiv_le_compat; auto.
     rewrite Rmult_assoc; apply Rmult_le_compat_l; trivial.
     replace (M' * (s a' b / y2)) with (s a' b * (M' / y2)) by
       (field; intro; fourier); apply Rmult_le_compat_l; trivial.
     apply Rmult_le_reg_r with y2; [trivial | rewrite (Rdiv_mult _ Hy2) ].
     apply Rmult_le_reg_r with y1; [trivial | ];
     replace (/ y1 * y2 * y1) with y2  by (field; intro; fourier).
     unfold y2, y1, y.
     rewrite <-fold_right_Rplus_mult.
     apply fold_right_Rplus_monotonic; auto.
     (* case [b not_in Out] *)
     rewrite 2 finite_distr_notin; trivial.
   (* case [Out] empty *)
   simpl; rewrite <-(multRU_1_l (eqU b dummy)) at 1;
     apply multRU_le_compat; trivial; fourier.
  Qed.

 End Assym_Distance.

 Section Symm_Distance.

  Variables a a':A.
  Variables M:R.
  Hypothesis HM1: forall b, List.In b Out -> s a  b <= M * s a' b.
  Hypothesis HM2: forall b, List.In b Out -> s a' b <= M * s a  b.
  Hypothesis HM_pos:  0 <= M.

  Lemma finite_discr_symm_dist:
   let d1 := finite_discr a in
   let d2 := finite_discr a' in
   let lam := M * M in
   (1 <= M) ->
   le_dist d1 d2 lam D0.
  Proof.
   intros.
   assert (d1_discr: is_Discrete d1) by apply finite_discr_is_Discrete.
   assert (d2_discr: is_Discrete d2) by apply finite_discr_is_Discrete.
   set (p:=parity_split (D_points d1_discr) (D_points d2_discr)).
   refine (le_dist_discr_serie_intro _ eqU_spec _
     (disc_eqpoint_l d1_discr d2_discr) (disc_eqpoint_r d1_discr d2_discr) _ _ _).
     rewrite <-(Rmult_1_r 1); apply Rmult_le_compat; trivial; fourier.
   apply serie_zero; intro k.
   split; trivial; apply Uminus_le_zero.
   apply (cover_elim (cover_not_first_repr _ _  eqU_spec p) k);
     [auto | | ]; intros [H4 H5].
     rewrite (coeff_first_repr _ eqU_spec (disc_eqpoint_l d1_discr d2_discr) _ H5),
       (coeff_first_repr _ eqU_spec (disc_eqpoint_r d1_discr d2_discr) _ H5); fold p.
     apply finite_discr_assym_dist; trivial.
     rewrite <-(Rmult_1_r 1); apply Rmult_le_compat; trivial; fourier.
     fold p; rewrite (coeff_not_first_repr _ _ _ _ H5); trivial.
   apply serie_zero; intro k.
   split; trivial; apply Uminus_le_zero.
   apply (cover_elim (cover_not_first_repr _ _  eqU_spec p) k);
     [auto | | ]; intros [H4 H5].
     rewrite (coeff_first_repr _ eqU_spec (disc_eqpoint_l d1_discr d2_discr) _ H5),
       (coeff_first_repr _ eqU_spec (disc_eqpoint_r d1_discr d2_discr) _ H5); fold p.
     apply finite_discr_assym_dist; trivial.
     rewrite <-(Rmult_1_r 1); apply Rmult_le_compat; trivial; fourier.
     fold p; rewrite (coeff_not_first_repr _ _ _ _ H5); trivial.
  Qed.

 End Symm_Distance.

End Finite_Discretize.

(* Exponential distribution over a finite carrier set,
   antimonotonic wrt the scoring function -ie the higher
   the score function, the less likely- *)
Section Finite_Exp_Antimonot.

 Variable A B:Type.

 Variable eps : R.
 Hypothesis eps_pos : 0 <= eps.

 Variable f: A -> B -> R.

 Let s := fun a b => exp (- eps * f a b).

 Variable Out : list B.
 Hypothesis Out_spec:
  {b:B | List.In b Out} + {Out = @List.nil B}.

 Let s_pos: forall a b, 0 <= s a b.
 Proof.
  intros; unfold s; left; apply exp_pos.
 Qed.

 Variable dummy:B.

 Definition exp_antimon: A -> Distr (B).
  intro a.
  refine (@finite_discr _ _ s Out _ s_pos dummy a).
  destruct Out_spec as [ (b,Hb) | HOut ].
    left; exists b; split; [ trivial | intros; apply exp_pos ].
    right; subst; trivial.
 Defined.

 Lemma exp_antimon_is_Discr: forall a,
   is_Discrete (exp_antimon a).
 Proof.
  intro a; apply (finite_discr_is_Discrete _ _ dummy).
 Qed.

 Lemma exp_antimon_lossless:  forall a,
   mu (exp_antimon a) (fun _ => 1%U) == 1%U.
 Proof.
  intros; apply finite_discr_lossless.
 Qed.

 Variable eqU: B -> B -O-> U.
 Hypothesis eqU_spec: forall b:B, cover (eq b) (eqU b).

 Hypothesis Hdec: forall (b:B), {List.In b Out} + {~ List.In b Out}.
 Hypothesis Out_NoDup: NoDup Out.

 Variables a a':A.
 Variables M:R.
 Hypothesis HM: forall b, List.In b Out -> R_dist (f a b) (f a' b) <= M.
 Hypothesis M_pos: 0 <= M.

 Lemma exp_antimon_dist:
  let d1 := exp_antimon a in
  let d2 := exp_antimon a' in
  let lam := exp (2 * eps * M) in
  le_dist d1 d2 lam D0.
 Proof.
  intros.
  apply le_dist_weaken_lam with (exp (eps * M) * exp (eps * M)).
    split; [ left; apply Rmult_lt_0_compat; apply exp_pos |
      unfold lam; rewrite Rmult_assoc, double, exp_plus; trivial ].
  refine (@finite_discr_symm_dist _ _ s Out _ s_pos dummy _ eqU_spec
    Hdec Out_NoDup _ _ _ _ _ _ _).
    intros b Hb; unfold s.
    rewrite <-exp_plus; apply exp_monotonic.
    replace (eps * M + - eps * f a' b) with (eps * (M - f a' b)) by ring.
    replace (- eps * f a b) with (eps * (- f a b)) by ring.
    refine (Rmult_le_compat_l _ _ _ eps_pos _); apply Rplus_le_perm_right.
    rewrite Rplus_comm, <-(HM Hb), R_dist_sym; apply Rle_abs.
    intros b Hb; unfold s.
    rewrite <-exp_plus; apply exp_monotonic.
    replace (eps * M + - eps * f a b) with (eps * (M - f a b)) by ring.
    replace (- eps * f a' b) with (eps * (- f a' b)) by ring.
    refine (Rmult_le_compat_l _ _ _ eps_pos _); apply Rplus_le_perm_right.
    rewrite Rplus_comm, <-(HM Hb); apply Rle_abs.
    left; apply exp_pos.
    rewrite <-exp_0 at 1; apply exp_monotonic; apply Rmult_le_pos; trivial.
 Qed.

End Finite_Exp_Antimonot.

(* *********************************************************************** *)
(*         3.Two exponential distributions over a quasimetric space        *)
(* *********************************************************************** *)

(* Finite set equipped with a quasi-metric
   --ie we do not require symmetry-- *)
Module Type FiniteQuasiMetricSpace.

 Declare Module E : UsualDecidableType.
 Declare Module Set_of_E : WSetsOn E.

 (* QuasiMetric specification *)
 Parameter Delta : E.t -> E.t -> R.
 Hypothesis Delta_pos: forall (x1 x2:E.t), 0 <= Delta x1 x2.
 Hypothesis Delta_triang: forall (x1 x2 x3:E.t),
   Delta x1 x3  <= Delta x1 x2 + Delta x2 x3.
 Hypothesis Delta_eq: forall (x:E.t), Delta x x = 0.

 (* Diameter of the QuasiMetric *)
 Parameter Diameter : R.
 Hypothesis Diam_spec: forall (x1 x2:E.t),
   Delta x1 x2 <= Diameter.

 (* Distance between a point [x] and a set of points [F] *)
 Definition DeltaSet (x:E.t) (F:Set_of_E.t) :=
   Set_of_E.fold (fun p r => Rmin r (Delta p x)) F Diameter.

 Lemma DeltaSet_Bound: forall d F,
   0 <= DeltaSet d F <= Diameter.
 Proof.
  intros.
  unfold DeltaSet; rewrite Set_of_E.fold_spec; unfold Basics.flip.
  rewrite <-fold_left_rev_right.
  induction (rev (Set_of_E.elements F)).
    simpl; split.
    rewrite <-(Delta_eq d); apply Diam_spec.
    trivial.
    destruct IHl; simpl; split.
      apply Rmin_glb; [trivial | apply Delta_pos].
      rewrite Rmin_r; apply Diam_spec.
 Qed.

 Parameter compl: Set_of_E.t -> Set_of_E.t.
 Hypothesis compl_spec : forall (p:E.t) (X:Set_of_E.t),
   Set_of_E.In p (compl X) <-> ~  Set_of_E.In p X.

 Parameter Set_of_E_eqb:  Set_of_E.t -> Set_of_E.t -> bool.
 Hypothesis Set_of_E_eqb_spec: forall X1 X2,
   if  Set_of_E_eqb X1 X2 then X1 = X2 else X1 <> X2.

End FiniteQuasiMetricSpace.

(* Extension of a quasimetric with a notion of
   distance from a set wrt another, and definition
   of two distributions on top of this notion *)
Module QMetricExtension (M: FiniteQuasiMetricSpace).

 Export M.

 (* Distance of [D] wrt [F] *)
 Definition cost (F D: Set_of_E.t) :=
   fold_right Rplus 0 (map (fun p => DeltaSet p F) (Set_of_E.elements D)).

 (* Sets adjacency *)
 Definition adj_sets (X Y:Set_of_E.t) :=
   exists Z, exists x, exists y,
   X = (Set_of_E.add x Z) /\ Y = (Set_of_E.add y Z)
   /\ ~ Set_of_E.mem x Z /\  ~ Set_of_E.mem y Z.

 (* Sensitivity of the [cost] function *)
 Lemma cost_sensitivity: forall (F D1 D2: Set_of_E.t),
   adj_sets D1 D2 ->
   R_dist (cost F D1) (cost F D2) <= Diameter.
 Proof.
   intros F D1 D2 (D,(d1,(d2,(?,(?,(H1,H2)))))); subst; unfold cost.
   match goal with
   |- R_dist (fold_right Rplus 0 ?l1') (fold_right Rplus 0 ?l2') <= _ =>
     rewrite fold_right_Perm with (l1:=l1')
       (l2:=map (fun p : E.t => DeltaSet p F) (d1 :: Set_of_E.elements D)); [
     rewrite fold_right_Perm with (l1:=l2')
       (l2:=map (fun p : E.t => DeltaSet p F) (d2 :: Set_of_E.elements D)) | | ]
   end.
   simpl; rewrite R_dist_plus, R_dist_eq, Rplus_0_r.
   apply R_dist_le; apply DeltaSet_Bound.
   intros; ring.
   apply PermutP_map, PermutP_sym, PermutP_map.
   apply PermutP_weaken with eq; [ intros; subst; trivial | ].
   apply Permutation_PermutP, NoDup_Permutation.
     apply NoDup_cons.
       unfold is_true in H2; rewrite Set_of_E.mem_spec, <-Set_of_E.elements_spec1 in H2;
       intro H; apply H2; apply (In_InA E.eq_equiv H).
       apply (NoDupA_NoDup (Set_of_E.elements_spec2w _)).
     apply (NoDupA_NoDup (Set_of_E.elements_spec2w _)).
     intros; rewrite <- 2 InA_In.
     rewrite InA_cons, (Set_of_E.elements_spec1 D x),
       <-Set_of_E.add_spec, Set_of_E.elements_spec1; apply iff_refl.
   intros; ring.
   apply PermutP_map, PermutP_sym, PermutP_map.
   apply PermutP_weaken with eq; [ intros; subst; trivial | ].
   apply Permutation_PermutP, NoDup_Permutation.
     apply NoDup_cons.
       unfold is_true in H1; rewrite Set_of_E.mem_spec, <-Set_of_E.elements_spec1 in H1;
       intro H; apply H1; apply (In_InA E.eq_equiv H).
       apply (NoDupA_NoDup (Set_of_E.elements_spec2w _)).
     apply (NoDupA_NoDup (Set_of_E.elements_spec2w _)).
     intros; rewrite <- 2 InA_In.
     rewrite InA_cons, (Set_of_E.elements_spec1 D x),
       <-Set_of_E.add_spec, Set_of_E.elements_spec1; apply iff_refl.
 Qed.

 (* Specification of WSetOn seems incomplete *)
 Hypothesis Empty_elements: forall X,
   Set_of_E.Empty X -> Set_of_E.elements X = List.nil.

 Hypothesis is_empty_dec: forall (X:Set_of_E.t),
   {x:E.t | Set_of_E.In x X} + {Set_of_E.Empty X}.

 Parameter dummy: E.t.

 (* Pick an element [(x1,x2) in X1 x X2] with probability
    proportional to [exp (-eps * cost (F - {x1} + {x2}, D))] *)
 Definition pick_points (F D X1 X2: Set_of_E.t) (eps:R): Distr (E.t * E.t).
  intros.
  set (f := fun D' x => cost (Set_of_E.add (snd x) (Set_of_E.remove (fst x) F)) D').
  set (Out := list_prod (Set_of_E.elements X1) (Set_of_E.elements X2)).
  refine (@exp_antimon Set_of_E.t (E.t * E.t) eps f Out _ (dummy,dummy) D).
  unfold Out.
  destruct (is_empty_dec X1) as [ (x1,HX1) | HX1 ];
    [ | right; rewrite (Empty_elements HX1); simpl; trivial ].
  destruct (is_empty_dec X2) as [ (x2,HX2) | HX2 ];
    [ | right; rewrite (Empty_elements HX2) ;
      induction (Set_of_E.elements X1); simpl; trivial ].
  left; exists (x1,x2); rewrite in_prod_iff;
    rewrite <-Set_of_E.elements_spec1, InA_In in *; split; trivial.
 Defined.

 Parameter eqU: E.t -> E.t -O-> U.
 Hypothesis eqU_spec: forall a:E.t, cover (eq a) (eqU a).

 Lemma pick_points_distance: forall (F D1 D2 X1 X2: Set_of_E.t) (eps:R),
   0 <= eps ->
   adj_sets D1 D2 ->
   let d1 := pick_points F D1 X1 X2 eps in
   let d2 := pick_points F D2 X1 X2 eps in
   let lam := exp (2 * eps * Diameter) in
   le_dist d1 d2 lam D0.
 Proof.
  intros.
  refine (@exp_antimon_dist _ _ _  H _ _ _ (dummy,dummy) _
    (cover_eq_prod _ _ eqU_spec eqU_spec) _ _ _ _ _ _ _).
    intro; apply (in_dec (prod_dec E.eq_dec E.eq_dec)).
    apply NoDup_list_prod; apply NoDupA_NoDup;
      apply Set_of_E.elements_spec2w.
    intros; apply (cost_sensitivity _ H0).
    rewrite <-(Diam_spec dummy dummy), <-Delta_pos; trivial.
 Qed.

 (* Pick an index [i in [0...N-1]] with probability
    proportional to [exp (-exp * cost (F i, D))] *)
 Definition pick_index (D:Set_of_E.t) (F:nat -> Set_of_E.t) (N:nat) (eps:R): Distr (nat).
  intros.
  set (f:= fun D' i => cost (F i) D').
  set (Out := seq 0 N).
  refine (@exp_antimon (@Set_of_E.t) nat eps f Out _ 0%nat D).
  unfold Out; destruct (zerop N); [ right; subst; trivial |
    left; exists 0%nat; apply le_In_seq; split; omega ].
 Defined.

 Lemma pick_index_distance: forall (D1 D2:Set_of_E.t) (F:nat -> Set_of_E.t)
   (N:nat) (eps:R),
   0 <= eps ->
   adj_sets D1 D2 ->
   let d1 := pick_index D1 F N eps in
   let d2 := pick_index D2 F N eps in
   let lam := exp (2 * eps * Diameter) in
   le_dist d1 d2 lam D0.
 Proof.
  intros.
  refine (@exp_antimon_dist _ _ _  H _ _ _ (0%nat) _
    (fun b =>  cover_dec (eq_nat_dec b)) _ _ _ _ _ _ _).
    intro b; case_eq (leb N b); intro Heq.
      apply leb_complete in Heq; right; intro H'; apply In_seq_le in H'; omega.
      apply leb_complete_conv in Heq; left; apply le_In_seq; split; omega.
    apply NoDup_seq.
    intros; apply (cost_sensitivity _ H0).
    rewrite <-(Diam_spec dummy dummy), <-Delta_pos; trivial.
 Qed.

End QMetricExtension.


Module Day.
  Inductive day : Type :=
    | monday : day
    | tuesday : day
    | wednesday : day
    | thursday : day
    | friday : day
    | saturday : day
    | sunday : day.

  Definition next_day (d : day) : day :=
    match d with
    | monday => tuesday
    | tuesday => wednesday
    | wednesday => thursday
    | thursday => friday
    | friday => saturday
    | saturday => sunday
    | sunday => monday
    end.

  Example test_next_day : (next_day (next_day saturday)) = monday.
  Proof. simpl. trivial. Qed.
End Day.

Require Extraction.
Extraction "day.ml" Day.