From Mon Require Import FiniteProbabilities SPropMonadicStructures
  SpecificationMonads MonadExamples SPropBase.

From Relational Require Import OrderEnrichedCategory
  OrderEnrichedRelativeMonadExamples Commutativity GenericRulesSimple.

Set Warnings "-notation-overridden,-ambiguous-paths".
From mathcomp Require Import all_ssreflect all_algebra reals distr realsum.
Set Warnings "notation-overridden,ambiguous-paths".

From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings Theta_dens
  Theta_exCP LaxComp FreeProbProg UniformDistrLemmas
  Prelude chUniverse StateTransformingLaxMorph RulesStateProb.

Import SPropNotations.
Import Num.Theory.

Local Open Scope ring_scope.

(* general Rules + Rules for uniform distributions over a finite
    family of non-empty finite types *)

Definition Index : Type := positive.

Definition fin_family (i : Index) : finType := [finType of chFin i].

Lemma F_w0 :
  forall (i : Index), fin_family i.
Proof.
  intros i. unfold fin_family. cbn.
  exists 0%N. eapply i.(cond_pos).
Qed.

(* extend the initial parameters for the rules  *)

Definition Uni_W : forall i, SDistr (fin_family i).
  move=> i. apply (@uniform_F (fin_family i)).
  apply F_w0.
Defined.

Definition Uni_W' : forall i, SDistr( chFin i) := Uni_W.

Definition Fail_Unit : SDistr chUnit.
  exact dnull.
Defined.

#[local] Definition FrStP := @FrStP.
(* #[local] Definition θ0 {S} {A} (c : @FrStP S A) := @θ0 S A c. *)
(* #[local] Definition θ_dens {S} {X} := @θ_dens S X. *)

(* Definition inhab (i : positive) : [finType of chFin i]. *)
(* destruct i as [i ipos]. destruct i. *)
(* - cbv in ipos. discriminate. *)
(* - cbn. unshelve econstructor. *)
(*   exact i. auto. *)
(* Defined. *)

(* Uniform distribution over F *)
Definition Uniform_F {i : Index} {S : choiceType} : @FrStP S (fin_family i).
Proof.
  rewrite /=.
  rewrite /ops_StP /ar_StP /fin_family.
  (* pose usd :=  @uniform_F [finType of chFin i] (inhab i). *)
  unshelve eapply ropr.
  - apply op_iota. unshelve econstructor.
    + exact (chFin i).
    + apply Uni_W'.
  - rewrite /=. move=> j. eapply retrFree. assumption.
Defined.

Definition Uniform ( i : Index ) { S : choiceType } { s : S } :=
  θ_dens (θ0 (@Uniform_F i S) s).

Lemma Uniform_eval (i : Index ) {S : choiceType} {s : S} :
  forall (st : S) (w : fin_family i),
    @Uniform i S s (w, st) =
    if st == s then @r (fin_family i) (F_w0 i) else 0.
Proof.
  (* move=> st w. rewrite /Uniform /=. *)
  (* case bb : (st == s). *)
  (* - rewrite  *)
  cbn.
  rewrite /SDistr_bind /SDistr_unit => st w /=.
  rewrite dletE.
  match goal with
  | |- psum ?k = _ =>
    eassert (k = _) as H
  end.
  { extensionality x.
    rewrite dunit1E.
    eassert (((x, s) == (w, st))%:R = (x == w)%:R * (s == st)%:R).
    { destruct (x == w) eqn:e1, (s == st) eqn:e2.
      all: cbn.
      all: cbn in e1.
      all: rewrite ?e1 ?e2.
      all: cbn.
      all: rewrite ?GRing.mulr1 ?GRing.mul0r ?GRing.mulr0.
      all: reflexivity.
    }
    rewrite H.
    rewrite GRing.mulrA.
    rewrite -dunit1E.
    reflexivity.
  }
  rewrite H. clear H.
  rewrite psumZr.
  2:{
    destruct (s == st). all: cbn.
    - apply (@ler01 R).
    - apply Order.POrderTheory.lexx.
  }
  rewrite -dletE.
  rewrite dlet_dunit_id.
  destruct (s == st) eqn:Heq.
  - have Heq' : st == s. apply /eqP. by move /eqP: Heq.
    rewrite Heq'. rewrite GRing.mulr1. reflexivity.
  - have Heq' : st == s = false. apply /eqP. move /eqP: Heq. congruence.
    rewrite Heq'. rewrite GRing.mulr0. reflexivity.
  Unshelve. exact (Real.ringType R).
Qed.

Definition f_dprod { F1 F2: finType } { S1 S2 : choiceType } { w0 : F1 } { w0' : F2 } {s1 : S1 } {s2 : S2}
            (f : F1 -> F2) : (F1 * S1) * (F2 * S2) -> R :=
fun '((w1,st1),(w2, st2)) => if  ((st1 == s1) && (st2 == s2) && ((f w1) == w2)) then (@r F1 w0) else 0.

Lemma item_addr0_mulr :
  forall n x,
    (* @iter R n (+%R x) 0 = x * n%:~R. *)
    @iter R n (+%R x) 0 = x *~ n.
Proof.
  intros n x.
  induction n as [| n ih].
  - cbn. reflexivity.
  - simpl. rewrite ih.
    unfold intmul. rewrite GRing.mulrS. reflexivity.
Qed.

Lemma bijective_isdistr
  {F1 F2 : finType} {w0 : F1} {w0' : F2}
  {S1 S2 : choiceType} {s1 : S1} {s2 : S2}
  {f : F1 -> F2} (f_bij : bijective f) :
  isdistr (@f_dprod F1 F2 S1 S2 w0 w0' s1 s2 f).
Proof.
  rewrite /f_dprod.
  split.
  - move => [[w1 st1] [w2 st2]].
    destruct ((st1 == s1) && (st2 == s2) && (f w1 == w2)) eqn:Heq; auto.
    exact r_nonneg.
  - rewrite /= => J uniq_J.
    rewrite [X in X<=_](bigID [pred j : _ | (j.1.2 == s1) && (j.2.2 == s2) && (f j.1.1 == j.2.1)]) /=.
    lazymatch goal with
    | |- context [ _ + ?x ] =>
      assert (e : x == 0)
    end.
    { rewrite psumr_eq0.
      - apply/allP. intros [[w1 st1] [w2 st2]] h. cbn.
        match goal with
        | |- context [ if ?b then _ else _ ] =>
          destruct b
        end.
        + cbn. reflexivity.
        + cbn. apply/eqP. reflexivity.
      - intros [[w1 st1] [w2 st2]]. cbn. intros h.
        match goal with
        | |- context [ if ?b then _ else _ ] =>
          destruct b
        end.
        1: discriminate.
        auto.
    }
    move: e => /eqP e. rewrite e. clear e.
    rewrite GRing.Theory.addr0.
    erewrite sum_oneq_eq with (G := fun i => r).
    2:{
      intros [[w1 st1] [w2 st2]]. cbn. intros h.
      rewrite h. reflexivity.
    }
    rewrite big_const_seq. cbn.
    match goal with
    | |- context [ count ?p _ ] =>
      set (P := p)
    end.
    pose (J' := [seq p <- J | P p ]).
    assert (e1 : count P J = size J').
    { rewrite size_filter. reflexivity. }
    pose (g := fun i => ((i, s1), (f i, s2))).
    pose (proj := fun (j : F1 * S1 * (F2 * S2)) => let '((i,_),_) := j in i).
    pose (g' := g \o proj).
    pose (J'' := [seq g' j | j <- J' ]).
    assert (e2 : J' = J'').
    { clear - uniq_J.
      subst J' J''. induction J as [| [[w1 st1] [w2 st2]] J ih].
      - cbn. reflexivity.
      - simpl. destruct (P _) eqn:e.
        + simpl. f_equal.
          * unfold P in e. simpl in e.
            move: e => /andP [e /eqP ?]. move: e => /andP [/eqP ? /eqP ?].
            subst. reflexivity.
          * eapply ih. cbn in uniq_J. move: uniq_J => /andP []. auto.
        + eapply ih. cbn in uniq_J. move: uniq_J => /andP []. auto.
    }
    subst g'.
    unfold J'' in e2. rewrite -> map_comp in e2.
    assert (uniq_J' : uniq J').
    { subst J'. apply filter_uniq. auto. }
    pose (I := [seq g i | i <- enum F1]).
    assert (e3 : (size J' <= size I)%N).
    { subst I. rewrite size_map.
      rewrite e2. rewrite size_map.
      eapply uniq_leq_size.
      1:{ rewrite e2 in uniq_J'. apply map_uniq in uniq_J'. auto. }
      intros x h. rewrite mem_enum. reflexivity.
    }
    rewrite -e1 in e3.
    subst I. rewrite size_map in e3.
    rewrite -cardE in e3.
    rewrite item_addr0_mulr.
    eapply Order.POrderTheory.le_trans with (y := @r _ w0 *~ #|F1|).
    + rewrite -mulrzr. rewrite -[X in _<=X]mulrzr.
      rewrite ler_pmul2l.
      * rewrite ler_int. auto.
      * unfold r. apply mulr_gt0.
        -- cbn. rewrite posnum.one_pos_gt0. reflexivity.
        -- rewrite -(@pmulr_rgt0 _ #|F1|%:~R).
            ++ rewrite -(GRing.mul1r (#|F1|%:~R / #|F1|%:~R)).
              rewrite GRing.mulrA.
              rewrite GRing.Theory.mulfK.
              ** rewrite posnum.one_pos_gt0. reflexivity.
              ** unshelve eapply card_non_zero. auto.
            ++ eapply fintype0 in w0 as h.
              destruct #|F1| eqn:e. 1: contradiction.
              rewrite ltr0n. reflexivity.
    + unfold r. rewrite -[X in X <= _]mulrzr. rewrite GRing.div1r.
      erewrite <- GRing.mulr1. rewrite -GRing.mulrA.
      rewrite GRing.Theory.mulKf.
      * auto.
      * unshelve eapply card_non_zero. auto.
Qed.

Definition UniformFsq_f { F1 F2 : finType} { w0 : F1 } { w0' : F2 }
                        { S1 S2 : choiceType } { s1 : S1 } { s2 : S2 }
                        {f : F1 -> F2} (f_bij : bijective f):
  SDistr (ChoiceAsOrd.F_choice_prod ⟨ ChoiceAsOrd.F_choice_prod ⟨ Finite.choiceType F1 , S1 ⟩ ,
                                    ChoiceAsOrd.F_choice_prod ⟨ Finite.choiceType F2 , S2 ⟩ ⟩ ).
Proof.
  unshelve eapply mkdistr.
  1:{
    exact: (@f_dprod F1 F2 S1 S2 w0 w0' s1 s2 f).
  }
  by apply: bijective_isdistr.
Defined.

Definition UniformSQ { i j : Index } { S1 S2 : choiceType } (s1 : S1) (s2 : S2)
                      { f : fin_family i -> fin_family j } (f_bij : bijective f) :=
  @UniformFsq_f (fin_family i) (fin_family j) (F_w0 i) (F_w0 j) S1 S2 s1 s2 f f_bij.

Lemma bij_same_r { F1 F2 : finType } { w0 : F1 } { w0' : F2 } { f : F1 -> F2 }
      ( bij_f : bijective f ) : @r F1 w0 = @r F2 w0'.
Proof.
  unfold r. f_equal. f_equal. f_equal.
  erewrite <- on_card_preimset with (f := f).
  2:{
    destruct bij_f as [g hfg hgf].
    exists g.
    - intros x hx. apply hfg.
    - intros x hx. apply hgf.
  }
  rewrite cardsT. reflexivity.
Qed.

Lemma UniformSQ_f_coupling { i j : Index}
                            { S1 S2 : choiceType } { s1 : S1 } { s2 : S2 }
                            { f : fin_family i -> fin_family j } (f_bij : bijective f):
  coupling (UniformSQ s1 s2 f_bij) (@Uniform i S1 s1) (@Uniform j S2 s2).
Proof.
  destruct f_bij as [f_inv Kf1 Kf2].
  rewrite /UniformFsq_f /f_dprod.
  split; apply: distr_ext; rewrite /=.
  - move => [w1 st1].
    rewrite /lmg dfstE /mkdistr psum_sum /=.
    rewrite (sum_seq1 ((f w1), s2)).
    by rewrite !refl_true !Bool.andb_true_r Uniform_eval.
    move => [w2 st2] /= H.
    have Hs : (st2 = s2).
    { destruct (st2 == s2) eqn:Heq;  apply /eqP; rewrite Heq; auto.
      exfalso. rewrite Bool.andb_false_r Bool.andb_false_l in H. by move /eqP : H.  }
    have Hf : (f w1 = w2).
    { destruct (f w1 == w2) eqn:Heq; apply /eqP; rewrite Heq; auto.
      rewrite Bool.andb_false_r in H. by move /eqP: H. }
      by rewrite Hs Hf.
    move => [w2 st2] /=.
    destruct ((st1 == s1) && (st2 == s2) && (f w1 == w2)); auto.
    exact: r_nonneg.
  - move => [w2 st2].
    rewrite /rmg dsndE /mkdistr psum_sum /=.
    rewrite (sum_seq1 ((f_inv w2), s1)).
    have Hf: (f (f_inv w2) = w2) by apply: (Kf2 w2).
    have Hs: s1 == s1 by apply /eqP.
    rewrite Hf Hs /= refl_true Bool.andb_true_r Uniform_eval.
    rewrite (@bij_same_r (fin_family i) (fin_family j) (F_w0 i) w2 f).
    reflexivity.
    by exists f_inv.
    move => [w1 st1] /= Hneq.
    have [Hfoo1 Hfoo2] : s1 = st1 /\ f w1 = w2.
    { destruct ((st1 == s1) && (f w1 == w2)) eqn: Heq.
      move /andP : Heq. move => [H1 H2].
      split; by [move /eqP : H1 | move /eqP : H2].
      exfalso. move /eqP: Hneq. rewrite Bool.andb_comm in Heq.
      by rewrite Bool.andb_comm Bool.andb_assoc Heq Bool.andb_false_l. }
    subst.
    by rewrite Kf1 refl_true.
    move => [w1 st1] /=. destruct ((st1 == s1) && (st2 == s2) && (f w1 == w2)); auto.
    exact: r_nonneg.
Qed.

Import RSemanticNotation.
#[local] Open Scope rsemantic_scope.

Theorem Uniform_bij_rule { i j : Index } { S1 S2 : choiceType }
                          { f : fin_family i -> fin_family j } (f_bij : bijective f)
                          (P : S1 * S2 -> Prop) :
  ⊨ ⦃ P ⦄ (@Uniform_F i S1) ≈ (@Uniform_F j S2) ⦃ fun '(w1, s1) '(w2, s2) => P (s1, s2) /\ (f w1 == w2) ⦄.
Proof.
  move => [s1 s2] /=.
  move => π /= [H11 H2].
  exists (UniformSQ s1 s2 f_bij).
  split.
  - by apply: UniformSQ_f_coupling.
  - rewrite /UniformSQ.
    move => [w1 st1] [w2 st2] H. apply: H2.
    rewrite /UniformFsq_f /= in H.
    have hfoo1 : (st1 == s1).
    { destruct (st1 == s1) eqn:Heq; auto.
      by rewrite Bool.andb_false_l  Order.POrderTheory.ltxx in H. }
    have hfoo2 : (st2 == s2).
    { destruct (st2 == s2) eqn:Heq; auto.
      by rewrite Bool.andb_false_r Order.POrderTheory.ltxx in H. }
    have hfoo3 : (f w1 == w2).
    { destruct (f w1 == w2) eqn:Heq; auto.
      by rewrite Bool.andb_false_r  Order.POrderTheory.ltxx in H. }
    move /eqP : hfoo1. move /eqP : hfoo2. move /eqP : hfoo3.
    move => hfoo3 hfoo2 hfoo1. subst.
    split; [assumption |  by rewrite refl_true ].
Qed.

Export RSPNotation.

(*CA: probably not necessary *)
(* Theorem Uniform_bij_rule_sq { i1 i2 j1 j2 : Index } { S1 S2 : choiceType } *)
(*         { f1 : fin_family i1 -> fin_family j1 } (f1_bij : bijective f1) *)
(*         { f2 : fin_family i2 -> fin_family j2 } (f2_bij : bijective f2) *)
(*         (P : S1 * S2 -> Prop) : *)
(*   ⊨ ⦃ P ⦄ ( ( A <- (A <- (@Uniform_F i1 S1) ;; @retrFree _ _ _ A) ;; *)
(*              (B <- (B <- (@Uniform_F i2 S1) ;; @retrFree _ _ _ B) ;; *)
(*              @retrFree _ _ _ (A, B) ))) *)

(*                 ≈ *)
(*           (( A <- (A <- (@Uniform_F j1 S2) ;; @retrFree _ _ _ A) ;; *)
(*            (B <- (B <- (@Uniform_F j2 S2) ;; @retrFree _ _ _ B) ;; *)
(*            @retrFree _ _ _ (A, B) ))) *)
(*        ⦃ fun '((A1, B1), s1) '((A2, B2), s2) => P (s1, s2) /\ (f1 A1 == A2) /\ (f2 B1 == B2) ⦄. *)
(* Proof. *)
(*   unshelve apply: seq_rule. *)
(*   { move => [A1 s1] [A2 s2]. exact: (P (s1, s2) /\ (f1 A1 == A2)). } *)
(*   apply: Uniform_bij_rule. assumption. *)
(*   move => A1 A2. *)
(*   unshelve apply: seq_rule.   *)
(*   { move => [B1 s1] [B2 s2]. exact: ((P (s1, s2) /\ (f1 A1 == A2) ) /\ (f2 B1 == B2)). } *)
(*   simpl.     *)
(*   apply: Uniform_bij_rule f2_bij (fun '(s1,s2) => P (s1, s2) /\ (f1 A1 == A2)). *)
(*   move => B1 B2. *)
(*   simpl.  *)
(*   apply: pre_hypothesis_rule => s1 s2 [[HP H1] H2]. simpl in HP.  *)
(*   move /eqP: H1. move /eqP: H2. move => H2 H1. subst.  *)
(*   unshelve apply: post_weaken_rule. *)
(*   { move => [[A B] st1] [[A' B'] st2]. *)
(*     exact: ((st1 , st2) = (s1, s2) /\ (f1 A, f2 B) = (A', B') ). } *)
(*   simpl. rewrite /fromPrePost.  Check ret_rule (A1,B1) (f1 A1, f2 B1).  *)
(*   admit.  *)
(*   simpl.   *)
(*   move => [[a1 b1] st1] [[a2 b2] st2] [H1 [H2 H3]]. subst. *)
(*   rewrite H1.  *)
(*   split; auto.  *)
(*   Admitted.  *)

Definition Fail { S : choiceType } : FrStP S chUnit.
Proof.
  unshelve eapply ropr.
    apply op_iota. econstructor. exact Fail_Unit.
  move=> _ /=. eapply retrFree. easy.
Defined.

Definition Assert {S : choiceType} (b : bool) : FrStP S chUnit.
Proof.
  destruct b.
  - apply retrFree.
    exact Datatypes.tt.
  - exact Fail.
Defined.

Lemma destruct_pair_eq {R : ringType} {A B : eqType} {a b : A} {c d : B}
  : ((a, c) == (b, d))%:R = (a == b)%:R * (c == d)%:R :> R.
Proof.
  destruct (a == b) eqn:ab, (c == d) eqn:cd.
  all: cbn; rewrite ab cd /=; try rewrite GRing.mulr1; try rewrite GRing.mulr0; reflexivity.
Qed.

Theorem assert_rule { S1 S2 : choiceType }  (b b' : bool) :
  ⊨ ⦃ fun (_ : S1 * S2) => b = b' ⦄ (Assert b) ≈ (Assert b') ⦃ fun _ _ => b = true /\ b' = true ⦄.
Proof.
  intros [s1 s2].
  hnf. intros post. hnf in *.
  cbv in post. intros H.
  cbv in H. destruct H as [Hpre K].
  simpl.
  destruct b, b'.
  all: simpl in *.
  - exists (SDistr_unit _ ((Datatypes.tt, s1), (Datatypes.tt, s2))).
    split.
    + unfold coupling.
      split.
      * unfold lmg. apply distr_ext.
        move => x0. unfold SDistr_unit, dfst.
        rewrite dlet_unit. reflexivity.
      * unfold rmg. apply distr_ext.
        move => x0. unfold SDistr_unit, dsnd.
        rewrite dlet_unit. reflexivity.
    + auto.
  - discriminate.
  - discriminate.
  - exists dnull.
    split.
    + unfold coupling.
      split.
      * unfold SDistr_bind.
        unfold lmg. apply distr_ext.
        move => x0. rewrite !dlet_null.
        reflexivity.
      * unfold SDistr_bind.
        unfold rmg. apply distr_ext.
        move => x0. rewrite !dlet_null.
        reflexivity.
    + intros [a1 s1'] [a2 s2'].
      rewrite dnullE.
      rewrite Order.POrderTheory.ltxx.
      auto.
Qed.

Theorem assert_rule_left { S1 S2 : choiceType }  (b : bool) :
  ⊨ ⦃ fun (_ : S1 * S2) => b = true ⦄ (Assert b) ≈ (retF Datatypes.tt) ⦃ fun _ _ => b = true ⦄.
Proof.
  intros [s1 s2].
  hnf. intros post. hnf in *.
  cbv in post. intros H.
  cbv in H. destruct H as [Hpre K].
  simpl.
  destruct b.
  all: simpl in *.
  - exists (SDistr_unit _ ((Datatypes.tt, s1), (Datatypes.tt, s2))).
    split.
    + unfold coupling.
      split.
      * unfold lmg. apply distr_ext.
        move => x0. unfold SDistr_unit, dfst.
        rewrite dlet_unit. reflexivity.
      * unfold rmg. apply distr_ext.
        move => x0. unfold SDistr_unit, dsnd.
        rewrite dlet_unit. reflexivity.
    + auto.
  - discriminate.
Qed.

Theorem assert_rule_right { S1 S2 : choiceType }  (b : bool) :
  ⊨ ⦃ fun (_ : S1 * S2) => b = true ⦄ (retF Datatypes.tt) ≈ (Assert b) ⦃ fun _ _ => b = true ⦄.
Proof.
  intros [s1 s2].
  hnf. intros post. hnf in *.
  cbv in post. intros H.
  cbv in H. destruct H as [Hpre K].
  simpl.
  destruct b.
  all: simpl in *.
  - exists (SDistr_unit _ ((Datatypes.tt, s1), (Datatypes.tt, s2))).
    split.
    + unfold coupling.
      split.
      * unfold lmg. apply distr_ext.
        move => x0. unfold SDistr_unit, dfst.
        rewrite dlet_unit. reflexivity.
      * unfold rmg. apply distr_ext.
        move => x0. unfold SDistr_unit, dsnd.
        rewrite dlet_unit. reflexivity.
    + auto.
  - discriminate.
Qed.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Proset.
Require Import Blech.Proset.Complete.
Require Import Blech.Proset.Op.
Require Import Blech.Category.
Require Import Blech.Category.PreOrd.
Require Import Blech.Proset.Prp.
Require Blech.Reflect.

Import BishopNotations.
Import CategoryNotations.
Import ProsetNotations.
Import OpNotations.

Open Scope morphism_scope.
Open Scope bishop_scope.

#[local]
Obligation Tactic := Reflect.category_simpl.

Class Continuous [C D: Complete] (F: PreOrd C D) := {
  map_sup [E: Proset] (p: PreOrd (E ᵒᵖ) C):
    proj1_sig F (sup p) == sup (F ∘ p) ;
  map_inf [E: Proset] (p: PreOrd (E ᵒᵖ) C):
    proj1_sig F (inf p) == inf (F ∘ p) ;
}.

(* Not really CABA but a constructive variation.
   supposedly CABA^op ~ Set
 *)
#[program]
Definition CABA: Category := {|
  Obj := Complete ;
  Mor A B := { F: PreOrd A B | Continuous F } /~ {| equiv f g := ∀ x, f x == g x |} ;

  id _ := exist _ (id _) _ ;
  compose _ _ _ f g := exist _ (proj1_sig f ∘ proj1_sig g) _ ;
|}.

Next Obligation.
Proof.
  exists.
  all: admit.
Admitted.

Next Obligation.
Proof.
  admit.
Admitted.

Next Obligation.
Proof.
  admit.
Admitted.

Next Obligation.
Proof.
  admit.
Admitted.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A C D P Q X Y X0 Y0 : Universe, ((wd_ A C /\ (wd_ P Q /\ (wd_ C D /\ (wd_ X Y /\ (wd_ Q C /\ (wd_ P C /\ (wd_ P Y /\ (wd_ X C /\ (wd_ Y C /\ (wd_ Y0 C /\ (wd_ X0 C /\ (col_ P X Y /\ (col_ P Y Q /\ (col_ C X Y /\ (col_ C Y Y0 /\ col_ C X X0))))))))))))))) -> col_ P Q X)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C T P0 Tprime X Y : Universe, ((wd_ A B /\ (wd_ C B /\ (wd_ T B /\ (wd_ A C /\ (wd_ P0 B /\ (wd_ P0 A /\ (wd_ T Tprime /\ (wd_ Tprime B /\ (wd_ Y B /\ (wd_ X B /\ (col_ B P0 T /\ (col_ Tprime T X /\ (col_ Tprime T Y /\ (col_ B C Y /\ col_ B A X)))))))))))))) -> col_ X T Y)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import ProofIrrelevance.
Require Import Coq.Logic.Eqdep.

Ltac inline_all := repeat match goal with x := _ |- _ => subst x end.

Ltac is_identifier H :=
  let foo := fresh in
    assert True as foo by (clear; assert True as H by trivial; trivial); clear foo.

Ltac proof_irrelevance := repeat
  match goal with
  | h:?T, h':?T |- _ =>
    match type of T with
    | Prop => try (rewrite <- (proof_irrelevance _ h h') in *); clear h'
    end
  end.

Ltac generalize_proofs := (repeat
  match goal with
  | |- context[?H] =>
    match type of H with
    | ?T =>
      match type of T with
      | Prop => first [is_identifier H; fail 1 | generalize H; intro]
      end
    end
  end); proof_irrelevance.


(************************************************************
* Lambda-calculus with exceptions and sums,                 *
* Encoding of exceptions into sums                          *
* Correctness using combined pretty-big-step semantics      *
*************************************************************)

Set Implicit Arguments.
Require Export LambdaExnSum_EncodeExn LambdaExnSum_Combi.

Implicit Types v : val.
Implicit Types t : trm.
Implicit Types o : out.
Implicit Types e : ext.

(*==========================================================*)
(* * Definitions *)

(************************************************************)
(* ** Translation *)

Definition tr_res (r:res) :=
  match r with
    | res_ret v => res_ret (val_inj true (tr_val v))
    | res_exn v => res_ret (val_inj false (tr_val v))
  end.

Definition tr_out (o:out) :=
  match o with
  | out_ter n r => out_ter n (tr_res r)
  | out_div => out_div
  end.

(************************************************************)
(* ** Theorem statement *)

Notation "'nine' n" := ((n+n+n+n+n+n+n+n+n)%nat) (at level 20).
Definition cin n := (nine n + 8)%nat.

Definition correctness :=
  forall t o, cred t o ->
  fresh (trm_vars not_used t) 3 L ->
  cred (tr_trm t) (map cin (tr_out o)).

(************************************************************)
(* ** Freshness *)

Definition res_vars (f:vars_opt) (r:res) :=
  match r with
  | res_ret v => trm_vars f v
  | res_exn v => trm_vars f v
  end.

Definition out_vars (f:vars_opt) (o:out) :=
  match o with
  | out_ter n r => res_vars f r
  | out_div => \{}
  end.

Definition ext_vars (f:vars_opt) (e:ext) :=
  let trm_vars := trm_vars f in
  let out_vars := out_vars f in
  match e with
  | ext_trm t1 => trm_vars t1
  | ext_app_1 o1 t1 => out_vars o1 \u trm_vars t1
  | ext_app_2 v1 o2 => trm_vars v1 \u out_vars o2
  | ext_inj_1 b o1 => out_vars o1
  | ext_case_1 o1 t2 t3 => out_vars o1 \u trm_vars t2 \u trm_vars t3
  | ext_try_1 o1 t2 => out_vars o1 \u trm_vars t2
  | ext_raise_1 o1 => out_vars o1
  end.

(*==========================================================*)
(* * Proofs *)

(************************************************************)
(* ** Derived reduction rules *)

Lemma cred_inj_val : forall b v1,
  cred (trm_inj b v1) (out_ter 1 (val_inj b v1)).
Proof.
  intros. applys* cred_inj.
Defined.

Lemma cred_abs_beta : forall o1 o x t3 v2,
  cred (subst x v2 t3) o1 ->
  before (add 2 o1) o ->
  cred (trm_app (trm_abs x t3) v2) o.
Proof.
  introv R B. applys cred_app. auto.
  applys cred_app_1. auto.
  applys cred_app_2 R. apply before_succ'.
  apply faster_before_zero_succ.
  apply faster_before_zero.
  clear R. (* required for guard condition *)
  destruct o1; inverts B; simple~.
Defined.

Lemma cred_abs_beta' : forall o1 o x t3 v2,
  cred (subst x v2 t3) o1 ->
  before (add 2 o1) o ->
  cred (trm_app (val_abs x t3) v2) o.
Proof.
  introv R B. applys cred_app. auto.
  applys cred_app_1. auto.
  applys cred_app_2 R. apply before_succ'.
  apply faster_before_zero_succ.
  apply faster_before_zero.
  clear R. (* required for guard condition *)
  destruct o1; inverts B; simple~.
Defined.

(************************************************************)
(* ** Freshness results *)

(** Reduction of terms does not introduce new variables *)

Hint Extern 1 (_ \notin ext_vars _ _) => unfold ext_vars.

Lemma notin_cred : forall n x e r,
  cred e (out_ter n r) ->
  x \notin ext_vars not_used e ->
  x \notin res_vars not_used r.
Proof.
  induction n using peano_induction. introv R F.
  asserts IH: (forall e m r, cred e (out_ter m r) ->
    m < n -> x \notin ext_vars not_used e ->
    x \notin res_vars not_used r).
    intros. applys* H. clear H.
  inverts R as; simpls.
  auto.
  auto.
  introv R1 R2 [L2 L1]. inverts L1. inverts L2.
   forwards~: IH R1. forwards~: IH R2.
  introv A B. inverts B. simpls~.
  introv R1 R2 [L2 L1]. inverts L1. inverts L2.
   forwards~: IH R1. forwards~: IH R2. simpls~.
  introv A B. inverts B. simpls~.
  introv R1 B. inverts B. forwards~: IH R1. simpls.
   applys~ subst_notin.
  introv R1 R2 [L2 L1]. inverts L1. inverts L2.
   forwards~: IH R1. forwards~: IH R2.
  introv A B. inverts B. simpls~.
  auto.
  introv R1 R2 [L2 L1]. inverts L1. inverts L2.
   forwards~: IH R1. forwards~: IH R2.
  introv A B. inverts B. simpls~.
  introv R1 B. inverts B. forwards~: IH R1. simpls~.
  introv R1 B. inverts B. forwards~: IH R1. simpls~.
  introv R1 R2 [L2 L1]. inverts L1. inverts L2.
   forwards~: IH R1. forwards~: IH R2.
  auto.
  introv R1 B. inverts B. forwards~: IH R1. simpls~.
  introv R1 R2 [L2 L1]. inverts L1. inverts L2.
   forwards~: IH R1. forwards~: IH R2.
  introv A B. inverts B. simpls~.
  auto.
Qed.

Lemma fresh_cred : forall n m xs e r,
  cred e (out_ter n r) ->
  fresh (ext_vars not_used e) m xs ->
  fresh (res_vars not_used r) m xs.
Proof.
  introv R Fr. applys* notin_to_fresh.
  intros. applys* notin_cred.
Qed.

(************************************************************)
(* ** Auxiliary lemmas and tactics *)

Lemma faster_tr_out : forall o1 o2,
  faster o1 o2 -> faster (tr_out o1) (tr_out o2).
Proof. introv F. inverts F; simple~. Qed.

Ltac simpl_substs := simpl; case_if; tryfalse.

Lemma monotone_cin : monotone cin.
Proof. introv L. unfold cin. math. Qed.

Hint Resolve monotone_cin.

Lemma faster_cin_tr_out : forall o1 o2,
  faster o1 o2 ->
  faster (map cin (tr_out o1)) (map cin (tr_out o2)).
Proof. intros. applys~ faster_map; applys~ faster_tr_out. Qed.
Hint Immediate faster_cin_tr_out.

Ltac done := simpl; unfolds cin; auto.

(************************************************************)
(* ** Correctness of auxiliary functions *)

(** Verification of [tr_bind] *)

Lemma cred_tr_bind_abort : forall o3 o2 o o1 t1 x k,
  correctness ->
  cred t1 o1 ->
  abort o1 ->
  before o1 o2 ->
  before o2 o ->
  faster o1 o ->
  before (map cin (tr_out o1)) o3 ->
  fresh (trm_vars not_used t1) 3 L ->
  cred (tr_bind (tr_trm t1) x k) o3.
Proof.
  introv C R A B1 B2 F1 B3 Fr. inverts A.
  inverts B1. inverts B2. inverts B3. inverts F1.
   applys cred_case. applys* C.
   simpl. applys cred_case_1_false.
   applys cred_abs_beta. unfold tr_exn. simpl_substs.
   applys cred_inj_val. auto. auto. done.
  inverts F1. inverts B3. inverts B1. applys cred_case.
   applys* C. applys* cred_case_1_abort. auto.
Defined.

Lemma cred_tr_bind_ret : forall o3 t1 n v1 k x1 o4,
  correctness ->
  cred t1 (out_ter n v1) ->
  faster (map cin (tr_out (out_ter n v1))) o4 ->
  cred (subst x1 (tr_val v1) k) o3 ->
  before (add 4 o3) o4 ->
  fresh (trm_vars not_used t1) 3 L ->
  cred (tr_bind (tr_trm t1) x1 k) o4.
Proof.
  introv C R F1 R3 B3 Fr.
  applys cred_case; [ applys* C | | eauto ].
  simpl. applys cred_case_1_true (add 3 o3).
  applys cred_abs_beta. eauto.
  applys~ before_add. applys~ before_add.
Defined.

(** Verification of [tr_cont] *)

Lemma cred_tr_cont : forall o2 o t v,
  correctness ->
  cred (trm_app t v) o2 ->
  before (add 4 (map cin (tr_out o2))) o ->
  fresh (trm_vars not_used t) 3 L ->
  fresh (val_vars not_used v) 3 L ->
  cred (trm_app (tr_cont (tr_trm t)) (tr_val v)) o.
Proof.
  introv C R B3 Frt Frv. inverts R as R1 R2 [L2 L1].
  applys cred_abs_beta (add 2 (map cin (tr_out o2))).
  rewrite~ subst_tr_bind. simpl.
  simpl_subst. forwards M: tr_trm_vars Frt. auto.
  rewrite~ (@subst_id not_free). clear M.
  inverts R2 as.
    introv A B. applys cred_tr_bind_abort o0; eauto.
     inverts B; inverts L2; done.
    introv R3 R4 [L4 L3]. applys* cred_tr_bind_ret (map cin (tr_out o4)).
      inverts L1; done.
      inverts R3. inverts R4 as.
        introv A B. inverts A.
        introv R5 L5. simpl. case_if; tryfalse.
         applys cred_abs_beta'.
         forwards M: fresh_cred R1 Frt. simpl in M.
         rewrite~ <- tr_val_subst.
         applys* C. applys~ fresh_subst.
         inverts L5; done.
       inverts L4; inverts L2; done.
  destruct o2; inverts B3; done.
Defined.

(************************************************************)
(* ** Correctness of translation *)

(** Verification of the transformation [tr_trm].
    Recall that [correctness] is define as:
    [forall t o, cred t o -> cred (tr_trm t) (map cin (tr_out o))] *)

Lemma tr_trm_correct : correctness.
Proof.
  cofixs IH. introv R Fr. inverts R as; simpls.
  (* case val *)
  unfolds cin. applys* cred_inj.
  (* case abs *)
  unfolds cin. applys* cred_inj.
  (* case app *)
  introv R1 R2 [L2 L1]. inverts R2 as.
    introv A B. applys cred_tr_bind_abort o2; eauto.
     inverts B; inverts L2; done.
    introv R3 R4 [L4 L3].
     applys* cred_tr_bind_ret (add 4 (map cin (tr_out o2)));
       [ |inverts L4; inverts L2; done ].
     rewrite~ subst_tr_bind.
     rewrite (@subst_id not_free); [ | applys~ tr_trm_vars ].
     simpl. simpl_subst. inverts R4 as.
      introv A B. applys* cred_tr_bind_abort o3 o2.
         inverts B; inverts L4; done.
       introv R5 L5.
         applys* cred_tr_bind_ret (add 4 (map cin (tr_out o3))).
           inverts L3; done.
           simpl. case_if; tryfalse.
           asserts~ Fr1: (fresh (trm_vars not_used t1) 3 L).
            forwards M1: fresh_cred R1 Fr1. simpl in M1.
           asserts~ Fr2: (fresh (trm_vars not_used t2) 3 L).
            forwards M2: fresh_cred R3 Fr2. simpl in M2.
            applys cred_abs_beta'.
              rewrite <- tr_val_subst.
                applys* IH.
                applys~ fresh_subst.
                auto.
             inverts L5; inverts L4; done.
           inverts L5; inverts L4; done.
  (* case inj *)
  introv R1 R2 [L2 L1]. inverts R2 as.
    introv A B. applys* cred_tr_bind_abort.
      clear_coind. destruct o1; done. inverts B; inverts L2; done.
    applys* cred_tr_bind_ret.
      simpl_substs. applys cred_inj. applys cred_inj_val.
      applys cred_inj_1. applys faster_before_max.
      inverts L2. done.
  (* case case *)
  introv R1 R2 [L2 L1].
   asserts~ Fr1: (fresh (trm_vars not_used t1) 3 L).
   asserts~ Fr2: (fresh (trm_vars not_used t2) 3 L). inverts R2 as.
    introv A B. applys cred_tr_bind_abort o2; eauto.
     inverts B; inverts L2; done.
    introv R3 L3. applys cred_tr_bind_ret
      (map (fun n => (n-5)%nat) (map cin (tr_out o))); eauto;
      [| clear_coind; destruct o; done ].
     sets_eq T: tr_cont. simpl. subst. case_if;tryfalse.
     do 2 rewrite~ subst_tr_cont.
     do 2 (rewrite (@subst_id not_free); [ | applys~ tr_trm_vars ]).
     applys cred_case. applys cred_val O.
     applys cred_case_1_true.
     forwards M: fresh_cred R1 Fr1. simpl in M.
     applys* cred_tr_cont. auto.
     inverts L2. inverts L3. inverts L1. done. inverts L3. done.
    introv R3 L3. applys cred_tr_bind_ret
      (map (fun n => (n-5)%nat) (map cin (tr_out o))); eauto;
      [| clear_coind; destruct o; done ].
     sets_eq T: tr_cont. simpl. subst. simpl_subst.
     do 2 rewrite~ subst_tr_cont.
     do 2 (rewrite (@subst_id not_free); [ | applys~ tr_trm_vars ]).
     applys cred_case. applys cred_val O.
     applys cred_case_1_false.
     forwards M: fresh_cred R1 Fr1. simpl in M.
     applys* cred_tr_cont. auto.
     inverts L2. inverts L3. inverts L1. done. inverts L3. done.
  (* case try *)
  introv R1 R2 [L2 L1]. inverts R2 as.
  inverts L2. inverts L1. applys* cred_case. simpl.
   applys cred_case_1_true. applys cred_abs_beta.
   simpl. case_if; tryfalse. applys cred_inj_val.
   auto. auto. done.
  introv R3 L3. applys* cred_case. simpl.
   applys cred_case_1_false.
   asserts~ Fr1: (fresh (trm_vars not_used t1) 3 L).
   forwards M: fresh_cred R1 Fr1. simpl in M.
   applys* cred_tr_cont.
   auto. inverts L3; inverts L2; inverts L1; done.
  inverts L2. applys* cred_case.
  (* case raise *)
  introv R1 R2 [L2 L1]. inverts R2 as.
    introv A B. applys* cred_tr_bind_abort.
      clear_coind; destruct o1; done. inverts B; inverts L2; done.
    applys* cred_tr_bind_ret.
      simpl_substs. applys cred_inj_val.
      inverts L2. done.
Admitted. (* TEMPORARY: for faster compilation *)
(* Qed.*)
(* Warning: the check of the guard condition takes about 30 sec *)


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Definition synth (lf1 : lst) (y : lst) : lst := lf1.


Require Import coqutil.Decidable coqutil.Map.Interface.
Require coqutil.Decidable coqutil.Map.Properties.
Import Interface.map.

Module map.
  Section MapKeys. Local Set Default Proof Using "All".
    Context {key value} {map : map key value} {ok : map.ok map}.
    Context {key_eqb: key -> key -> bool} {key_eq_dec: EqDecider key_eqb}.
    Context {key'} {map' : Interface.map.map key' value} {ok' : map.ok map'}.
    Context {key'_eqb: key' -> key' -> bool} {key'_eq_dec: EqDecider key'_eqb}.

    Definition map_keys f (m:map) : map' := fold (fun m k v => put m (f k) v) empty m.
    Lemma get_map_keys_invertible (f : key -> key') m k
      (H:forall k' v', get m k' = Some v' -> f k = f k' -> get m k = get m k')
      : get (map_keys f m) (f k) = get m k.
    Proof.
      revert dependent k.
      cbv [map_keys].
      refine (fold_spec (fun m r => forall k,
        (forall k' v', get m k' = Some v' -> f k = f k' -> get m k = get m k') ->
        get r (f k) = get m k) _ empty _ _ m).
      { intros; rewrite ?get_empty; trivial. }
      clear m.
      intros knew vnew m r Hknew HI k Hk.
      destruct (key_eq_dec k knew) as [HR|HR]; [rewrite <-!HR in *; clear HR|].
      { rewrite 2get_put_same; trivial. }
      rewrite (get_put_diff m k _ _) by congruence.
      destruct (key'_eq_dec (f k) (f knew)) as [HW|HW]; rewrite <-?HW in *.
      { unshelve epose proof Hk knew vnew _ HW.
        { rewrite get_put_same; trivial. }
        rewrite get_put_same, get_put_diff in H; trivial; rewrite H.
        eauto using get_put_same. }
      rewrite get_put_diff by trivial.
      eapply HI.
      intros ? ? Hm Hf.
      specialize (Hk k' v').
      destruct (key_eq_dec k' knew); subst.
      { rewrite Hknew in Hm; inversion Hm. }
      rewrite 2get_put_diff in Hk by assumption; eauto.
    Qed.

    Lemma get_map_keys_always_invertible (f : key -> key')
      (H : forall k k', f k = f k' -> k = k')
      : forall m k, get (map_keys f m) (f k) = get m k.
    Proof.
      intros. eapply get_map_keys_invertible. intros ? ? HA HB.
      rewrite (H _ _ HB); trivial.
    Qed.
  End MapKeys.
End map.


(**
    Definitions of Algorithmic Lightweight Linear F
    Authors: Aileen Zhang, Jianzhou Zhao, and Steve Zdancewic.
*)

Require Export LinF_Definitions.
Require Export LinF_Infrastructure.
Require Export ALinearF_Dmap.

(* ********************************************************************** *)
(** * ## Algo Environments *)

(** In our presentation of System F with subtyping, we use a single
    environment for both typing and subtyping assumptions.  We
    formalize environments by representing them as association lists
    (lists of pairs of keys and values) whose keys are atoms.

    The [Metatheory] and [Environment] libraries provide functions,
    predicates, tactics, notations and lemmas that simplify working
    with environments.  The [Environment] library treats environments
    as lists of type [list (atom * A)].

    Since environments map [atom]s, the type [A] should encode whether
    a particular binding is a typing or subtyping assumption.  Thus,
    we instantiate [A] with the type [binding], defined below. *)

Inductive gbinding : Set :=
  | gbind_kn :  kn -> gbinding
  | gbind_typ : typ -> gbinding.

Notation genv := (list (atom * gbinding)).
Notation gempty := (@nil (atom * gbinding)).

Notation denv := (list (atom * typ)).
Notation dempty := (@nil (atom * typ)).

Fixpoint denv_to_emap (D : denv) {struct D} : dmap :=
  match D with
  | nil => EMap.empty typ
  | (x, t)::D' => EMap.add x t (denv_to_emap D')
  end.
Definition dmap_to_denv (M : dmap) : denv := EMap.elements M.
Notation "<# D #>" := (denv_to_emap D).
Notation "<@ M @>" := (dmap_to_denv M).
Definition denv_Equal (D1 D2: denv) := <#D1#> ~~ <#D2#>.
Notation "D ~~~ D'" := (denv_Equal D D') (at level 70, right associativity).

(* ********************************************************************** *)
(** * ## Well-formedness *)

(** A type [T] is well-formed with respect to an environment [E],
    denoted [(wf_typ E T)], when [T] is locally-closed and its free
    variables are bound in [E].  We need this relation in order to
    restrict the subtyping and typing relations, defined below, to
    contain only well-formed types.  (This relation is missing in the
    original statement of the POPLmark Challenge.)

    Note: It is tempting to define the premise of [wf_typ_var] as [(X
    `in` dom E)], since that makes the rule easier to apply (no need
    to guess an instantiation for [U]).  Unfortunately, this is
    incorrect.  We need to check that [X] is bound as a type-variable,
    not an expression-variable; [(dom E)] does not distinguish between
    the two kinds of bindings. *)

Inductive kn_order : kn -> kn -> Prop :=
  | kn_order_base :
     kn_order kn_nonlin kn_lin
  | kn_order_refl : forall K,
     kn_order K K
.

Inductive wf_atyp : genv -> typ -> kn -> Prop :=
  | wf_atyp_var : forall K K' G (X : atom),
      uniq G ->
      binds X (gbind_kn K') G ->
      kn_order K' K ->
      wf_atyp G (typ_fvar X) K
  | wf_atyp_arrow : forall G K1 K2 K K' T1 T2,
      wf_atyp G T1 K1 ->
      wf_atyp G T2 K2 ->
      kn_order K' K ->
      wf_atyp G (typ_arrow K' T1 T2) K
  | wf_atyp_all : forall L G K1 K2 T2,
      (forall X : atom, X `notin` L ->
        wf_atyp ([(X, gbind_kn K1)] ++ G) (open_tt T2 X) K2) ->
      wf_atyp G (typ_all K1 T2) K2
  .

(** An environment E is well-formed, denoted [(wf_env E)], if each
    atom is bound at most at once and if each binding is to a
    well-formed type.  This is a stronger relation than the [ok]
    relation defined in the [Environment] library.  We need this
    relation in order to restrict the subtyping and typing relations,
    defined below, to contain only well-formed environments.  (This
    relation is missing in the original statement of the POPLmark
    Challenge.)  *)

Inductive wf_genv : genv -> Prop :=
  | wf_genv_empty :
      wf_genv gempty
  | wf_genv_kn : forall (G : genv) (X : atom) (K : kn),
      wf_genv G ->
      X `notin` dom G ->
      wf_genv ([(X, gbind_kn K)] ++ G)
  | wf_genv_typ : forall (G : genv) (x : atom) (T : typ) ,
      wf_genv G ->
      wf_atyp G T kn_nonlin ->
      x `notin` dom G ->
      wf_genv ([(x, gbind_typ T)] ++ G)
.

Inductive wf_denv : genv -> denv -> Prop :=
  | wf_denv_empty : forall G,
     wf_genv G ->
     wf_denv G dempty
  | wf_denv_typ : forall G D T x D' K,
    wf_denv G D ->
    wf_atyp G T K ->
    x `notin` dom G ->
    x `notin` dom D ->
    (* <#_#> does not check if the input is uniq, so ...*)
    uniq D' ->
    (<# [(x, T)] ++ D #>) ~~ <# D' #> ->
    wf_denv G D'
.

(* ********************************************************************** *)
(** * ## Algo Typing *)

Inductive atyping : genv -> denv -> exp -> typ -> denv -> Prop :=
  | atyping_uvar : forall G D x T,
      binds x (gbind_typ T) G ->
      wf_denv G D ->
      atyping G D x T D
  | atyping_lvar : forall G D D' (x:atom) T,
      binds x T D ->
      wf_denv G D ->
      (* <#_#> does not check if the input is uniq, so ...*)
      uniq D' ->
      (<#D#> [-] x) ~~ <#D'#> ->
      atyping G D x T D'
   | atyping_uabs : forall L K G D V e1 T1 D',
      wf_atyp G V kn_nonlin ->
      (forall x : atom, x `notin` L ->
        atyping ([(x, gbind_typ V)] ++ G) D  (open_ee e1 x) T1 D') ->
      (K = kn_nonlin -> D ~~~ D') ->
      atyping G D (exp_abs K V e1) (typ_arrow K V T1) D'
   | atyping_labs : forall L K Q G D V e1 T1 D',
      wf_atyp G V Q ->
      (forall x : atom, x `notin` L ->
        atyping G ([(x, V)] ++ D)  (open_ee e1 x) T1 D') ->
      (K = kn_nonlin -> D ~~~ D') ->
      atyping G D (exp_abs K V e1) (typ_arrow K V T1) D'
  | atyping_app : forall G T1 K D1 D2 D3 e1 e2 T2,
      atyping G D1 e1 (typ_arrow K T1 T2) D2->
      atyping G D2 e2 T1 D3 ->
      atyping G D1 (exp_app e1 e2) T2 D3
  | atyping_tabs : forall L G K e1 T1 D D' ,
      (forall X : atom, X `notin` L -> value (open_te e1 X)) ->
      (forall X : atom, X `notin` L ->
        atyping ([(X,gbind_kn K)] ++ G) D (open_te e1 X) (open_tt T1 X) D')->
      atyping G D (exp_tabs K e1) (typ_all K T1) D'
  | atyping_tapp : forall K K' G e1 T T2 D D',
      atyping G D e1 (typ_all K T2) D' ->
      wf_atyp G T K' ->
      kn_order K' K ->
      atyping G D (exp_tapp e1 T) (open_tt T2 T) D'
.

(* ********************************************************************** *)
(** * ## Automation *)

(** We declare most constructors as [Hint]s to be used by the [auto]
    and [eauto] tactics.  We exclude constructors from the subtyping
    and typing relations that use cofinite quantification.  It is
    unlikely that [eauto] will find an instantiation for the finite
    set [L], and in those cases, [eauto] can take some time to fail.
    (A priori, this is not obvious.  In practice, one adds as hints
    all constructors and then later removes some constructors when
    they cause proof search to take too long.) *)

Hint Constructors wf_atyp wf_genv wf_denv uniq kn_order.
Hint Resolve atyping_uvar atyping_lvar atyping_app atyping_tapp.

(* ********************************************************************** *)
(** * ## Cases Tactic *)

Tactic Notation "wf_atyp_cases" tactic(first) tactic(c) :=
  first;
  [ c "wf_atyp_var" | c "wf_atyp_arrow" | c "wf_atyp_all" ].

Tactic Notation "wf_genv_cases" tactic(first) tactic(c) :=
  first;
  [ c "wf_genv_empty" | c "wf_genv_kn" | c "wf_genv_typ" ].

Tactic Notation "wf_denv_cases" tactic(first) tactic(c) :=
  first;
  [ c "wf_denv_empty" | c "wf_denv_typ" ].

Tactic Notation "atyping_cases" tactic(first) tactic(c) :=
  first;
  [ c "atyping_uvar" | c "atyping_lvar" |
    c "atyping_uabs" | c "atyping_labs" | c "atyping_app" |
    c "atyping_tabs" | c "atyping_tapp" ].

(*
*** Local Variables: ***
*** coq-prog-name: "coqtop" ***
*** coq-prog-args: ("-emacs-U" "-I" "../../../metatheory" "-I" "../linf") ***
*** End: ***
 *)


(*
Copyright © 2009 Valentin Blot

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Import CPoly_Degree CPoly_Euclid RingClass CRingClass.
Import CRing_Homomorphisms.coercions.

Section RX_div.

Variable R : CRing.
Let RX := cpoly_cring R.
Add Ring r_r : (r_rt (Ring:=CRing_is_Ring R)).
Add Ring rx_r : (r_rt (Ring:=CRing_is_Ring (cpoly_cring R))).

Lemma _X_monic : forall a : R, monic 1 (_X_ [-] _C_ a).
Proof.
 split.
  reflexivity.
 intro m; destruct m.
  intro H; inversion H.
 destruct m.
  intro H; destruct (lt_irrefl _ H).
 reflexivity.
Qed.

Definition RX_div (p : RX) (a : R) : RX.
Proof.
 destruct (cpoly_div p (_X_monic a)) as [qr Hunq Heq]; exact (fst qr).
Defined.

Lemma RX_div_spec : forall (p : RX) (a : R), p [=] (RX_div p a) [*] (_X_ [-] _C_ a) [+] _C_ (p ! a).
Proof.
 intros p a.
 unfold RX_div.
 destruct (cpoly_div p (_X_monic a)) as [[q r] s [s0 d]].
 unfold fst, snd in *.
 rewrite -> s0.
 apply cs_bin_op_wd; [reflexivity|].
 destruct d.
 destruct (_X_monic a).
 destruct (degree_le_zero _ _ (d _ H0)).
 rewrite -> s2.
 apply csf_wd.
 rewrite -> plus_apply, mult_apply, minus_apply.
 rewrite -> x_apply, c_apply, c_apply; unfold cg_minus; ring.
Qed.

End RX_div.


(* begin hide *)
From Coq Require Import
     Classes.Morphisms
     Relations.Relation_Operators
     Logic.JMeq
     Lists.List
     Arith.PeanoNat
     Logic.FunctionalExtensionality.

From ExtLib Require Import
     Structures.Monads
     Data.Monads.OptionMonad.

From Heapster2 Require Import
     Utils
     Permissions
     PermissionsSpred2
     Memory
     SepStep
     Typing.

From ITree Require Import
     ITree
     ITreeFacts
     Basics.MonadState
     Basics.MonadProp
     Events.State
     Events.Exception
     Events.Nondeterminism
     Eq.Eqit
     Eq.UpToTaus
     Eq.EqAxiom.

From Paco Require Import
     paco.

Import MonadNotation.
(* end hide *)

Section permType.
  Context {Si Ss : Type}.

  (** * Permission types *)

  Record PermType (A B : Type) : Type :=
    { ptApp : A -> B -> @Perms2 (Si * Ss) }.
  Definition VPermType A := PermType Value A.
  Notation "xi :: T ▷ xs" := (ptApp _ _ T xi xs) (at level 35).

  Definition withPerms {Ai As} (T : PermType Ai As) (P : @Perms2 (Si * Ss)) : PermType Ai As:=
    {| ptApp:= fun ai abs => (ai :: T ▷ abs) *2 P |}.
  Notation "T ∅ P" := (withPerms T P) (at level 40).

  Definition plusPT {A1 A2 B1 B2}
             (T1 : PermType A1 B1) (T2 : PermType A2 B2) : PermType (A1 + A2) (B1 + B2) :=
    {| ptApp := fun eithA eithB =>
                  match (eithA, eithB) with
                  | (inl a1, inl b1) => a1 :: T1 ▷ b1
                  | (inr a2, inr b2) => a2 :: T2 ▷ b2
                  | _ => top_Perms2
                  end |}.
  Notation "T1 ⊕ T2" := (plusPT T1 T2) (at level 50).

  Definition timesPT {A1 A2 B1 B2}
             (T1 : PermType A1 B1) (T2 : PermType A2 B2) : PermType (A1 * A2) (B1 * B2) :=
    {| ptApp := fun a12 b12 => fst a12 :: T1 ▷ fst b12 *2 snd a12 :: T2 ▷ snd b12 |}.
  Notation "T1 ⊗ T2" := (timesPT T1 T2) (at level 40).

  Definition starPT {Ai As Bs} (T1 : PermType Ai As) (T2 : PermType Ai Bs)
    : PermType Ai (As * Bs) :=
    {| ptApp := fun ai abs => (ai :: T1 ▷ fst abs) *2 (ai :: T2 ▷ snd abs) |}.
  Notation "T1 ⋆ T2" := (starPT T1 T2) (at level 40).

  Definition existsPT {Ai As} {Bs : As -> Type}
             (F : forall a, PermType Ai (Bs a)) : PermType Ai (sigT Bs) :=
    {| ptApp := fun ai abs => ai :: F (projT1 abs) ▷ (projT2 abs) |}.
  Notation "'ex' ( x 'oftype' A ) T" := (existsPT (As:=A) (fun x => T)) (at level 70).

  Definition or {Ai As Bs} (T1 : PermType Ai As)
             (T2:PermType Ai Bs) : PermType Ai (As + Bs) :=
    {| ptApp := fun ai abs =>
                  sum_rect _ (ptApp _ _ T1 ai) (ptApp _ _ T2 ai) abs |}.

  Definition trueP {A B} : PermType A B :=
    {| ptApp := fun _ _ => bottom_Perms2 |}.
  Definition falseP {A B} : PermType A B :=
    {| ptApp := fun _ _ => top_Perms2 |}.

  Program Definition eqp {A} (a : A): PermType A unit :=
    {| ptApp := fun a' _ => {| in_Perms2 _ _ := a = a' |} |}.

  (** * Operations used in typing rules *)

  Definition vsingle {A} (a:A) : Vector.t A 1 :=
    Vector.cons _ a _ (Vector.nil _).

  Definition ifz {A} n (x y:A) : A :=
    if Nat.eqb n 0 then x else y.

  Definition getNum {S} v : itree (sceE S) nat :=
    match v with VNum n => Ret n | VPtr _ => throw tt end.

  Definition isNull {S} v: itree (sceE S) bool :=
    match v with
    | VNum n => if Nat.eqb n 0 then Ret true else throw tt
    | VPtr _ => Ret false
    end.

  Definition isNat := ex (n oftype nat) (eqp (VNum n)).

  (** * Recursive and reachability permissions *)

  (** The ordering on permission types is just the lifting of that on Perms *)
  Definition lte_PermType {A B} (T1 T2 : PermType A B): Prop :=
    forall a b, lte_Perms2 (ptApp _ _ T1 a b) (ptApp _ _ T2 a b).

  (** Equals on PermType is just the symmetric closure of the ordering *)
  Definition eq_PermType {A B} (T1 T2 : PermType A B): Prop :=
    lte_PermType T1 T2 /\ lte_PermType T2 T1.

  Global Instance PreOrder_lte_PermType A B : PreOrder (@lte_PermType A B).
  Proof.
    constructor; intro; intros; intros a b.
    - reflexivity.
    - etransitivity; [ apply H | apply H0 ].
  Qed.

  Global Instance Equivalence_eq_PermType A B : Equivalence (@eq_PermType A B).
  Proof.
    constructor; intro; intros.
    - split; reflexivity.
    - destruct H; split; assumption.
    - destruct H; destruct H0; split; etransitivity; eassumption.
  Qed.

  Global Instance Proper_eq_PermType_ptApp A B :
    Proper (eq_PermType ==> eq ==> eq ==> eq_Perms2) (ptApp A B).
  Proof.
    intros T1 T2 eT a1 a2 ea b1 b2 eb. rewrite ea; rewrite eb.
    destruct eT. split; [ apply H | apply H0 ].
  Qed.

  (** The meet on permission types is just the lifitng of that on Perms *)
  Definition meet_PermType {A B} (Ts : PermType A B -> Prop) : PermType A B :=
    {| ptApp := fun a b => meet_Perms2 (fun P => exists T, Ts T /\ P = (a :: T ▷ b)) |}.

  (** Meet is a lower bound for PermType *)
  Lemma lte_meet_PermType {A B} (Ts : PermType A B -> Prop) T:
    Ts T -> lte_PermType (meet_PermType Ts) T.
  Proof.
    intros ts_t a b. simpl. apply lte_meet_Perms2. exists T; split; eauto.
  Qed.

  (** Meet is the greatest lower bound for PermType *)
  Lemma meet_PermType_max {A B} (Ts : PermType A B -> Prop) T:
    (forall T', Ts T' -> lte_PermType T T') ->
    lte_PermType T (meet_PermType Ts).
  Proof.
    intros lte_T_Ts a b. apply meet_Perms2_max. intros P [ T' [ Ts_T' P_eq ]].
    rewrite P_eq. apply (lte_T_Ts T' Ts_T' a b).
  Qed.

  (** The least fixed-point permission type is defined via the standard
  Knaster-Tarski construction as the meet of all F-closed permission types *)
  Definition fixPT {A B} (F : PermType A B -> PermType A B)
             {prp : Proper (lte_PermType ==> lte_PermType) F} : PermType A B :=
    meet_PermType (fun T => lte_PermType (F T) T).

  (** First we prove that fixPT is itself F-closed *)
  Lemma fixPT_F_closed {A B} (F : PermType A B -> PermType A B)
        {prp : Proper (lte_PermType ==> lte_PermType) F} :
    lte_PermType (F (fixPT F)) (fixPT F).
  Proof.
    intros a b. apply meet_PermType_max. intros T' lte_FT'.
    transitivity (F T'); [ | assumption ]. apply prp.
    apply lte_meet_PermType. assumption.
  Qed.

  (** Then we prove that fixPT is a fixed-point *)
  Lemma fixPT_fixed_point {A B} (F : PermType A B -> PermType A B)
        {prp : Proper (lte_PermType ==> lte_PermType) F} :
    eq_PermType (fixPT F) (F (fixPT F)).
  Proof.
    split; [ | apply fixPT_F_closed ].
    apply lte_meet_PermType. apply prp. apply fixPT_F_closed.
  Qed.

  Class FixedPoint (G : Type -> Type) X : Type :=
    { foldFP : G X -> X;
      unfoldFP : X -> G X;
      foldUnfold : forall gx, unfoldFP (foldFP gx) = gx;
      unfoldFold : forall x, foldFP (unfoldFP x) = x; }.
  Definition unmaprPT {A B C} (f:B -> C) (T:PermType A C) : PermType A B :=
    {| ptApp := fun a b => a :: T ▷ (f b) |}.

  Program Definition mu {A G X} `{FixedPoint G X}
             (F : PermType A X -> PermType A (G X))
             {prp : Proper (lte_PermType ==> lte_PermType) F}
    : PermType A X :=
    @fixPT A X (fun T => unmaprPT unfoldFP (F T)) _.
  Next Obligation.
    intros T1 T2 leqT a x. simpl. apply prp. assumption.
  Defined.

  Lemma mu_fixed_point {A G X} `{FixedPoint G X}
        (F : PermType A X -> PermType A (G X))
        {prp : Proper (lte_PermType ==> lte_PermType) F} :
    eq_PermType (mu F) (unmaprPT unfoldFP (F (mu F))).
  Proof.
    apply (fixPT_fixed_point (fun T : PermType A X => unmaprPT unfoldFP (F T))).
  Qed.

  Lemma mu_fixed_point' {A G X} `{FixedPoint G X}
        (F : PermType A X -> PermType A (G X))
        {prp : Proper (lte_PermType ==> lte_PermType) F} :
    lte_PermType (unmaprPT unfoldFP (F (mu F))) (mu F).
  Proof.
    apply (fixPT_fixed_point (fun T : PermType A X => unmaprPT unfoldFP (F T))).
  Qed.

  Definition mu_list A := fun R => sum unit (A * R).
  Global Program Instance fixed_point_list A : FixedPoint (mu_list A) (list A)
    :=
    {
      foldFP := fun s => match s with
                      | inl _ => @nil A
                      | inr (h, t) => (cons h t)
                      end;
      unfoldFP := fun l => match l with
                        | nil => inl tt
                        | cons h t => inr _ (h, t)
                        end;
    }.
  Next Obligation.
    destruct gx.
    - destruct u. auto.
    - destruct p. auto.
  Defined.
  Next Obligation.
    destruct x; auto.
  Defined.

End permType.

Notation "P ⊢ ti ⤳ ts ::: U" := (typing P (@ptApp _ _ _ _ U) ti ts) (at level 60).
Notation "xi :: T ▷ xs" := (@ptApp _ _ _ _ T xi xs) (at level 35).
Notation "T1 ⊕ T2" := (@plusPT _ _ _ _ _ _ T1 T2) (at level 50).
Notation "T1 ⊗ T2" := (@timesPT _ _ _ _ _ _ T1 T2) (at level 40).
Notation "T1 ⋆ T2" := (@starPT _ _ _ _ _ T1 T2) (at level 40).
Notation "'ex' ( x 'oftype' A ) T" := (@existsPT _ _ _ A _ (fun x => T)) (at level 70).
Notation "T ∅ P" := (@withPerms _ _ _ _ T P) (at level 40).


Require Import List Omega Morphisms std calculus.
Import ListNotations.

(** * Higher-Order Unification *)
Section UnificationDefinitions.

  Context {X: Const}.

  Class uni :=
    {
      Gammaᵤ  : ctx;
      sᵤ  : exp X;
      tᵤ  : exp X;
      Aᵤ  : type;
      H1ᵤ : Gammaᵤ ⊢ sᵤ : Aᵤ;
      H2ᵤ : Gammaᵤ ⊢ tᵤ : Aᵤ
    }.

  Definition U (I: uni) :=
    exists (Delta: ctx) (sigma: fin -> exp X), Delta ⊩ sigma : Gammaᵤ /\ sigma • sᵤ ≡ sigma • tᵤ.

End UnificationDefinitions.

Arguments uni _ : clear implicits.
Arguments U _ : clear implicits.
Hint Resolve @H1ᵤ @H2ᵤ.

(** ** Normalisation *)
Section SubstitutionTransformations.

  Variable (X: Const) (n: nat) (s t: exp X) (A: type) (Gamma: ctx).
  Hypothesis (Leq: 1 <= n).
  Hypothesis (T1:  Gamma ⊢(n) s : A) (T2: Gamma ⊢(n) t : A).
  Implicit Types (Delta: ctx) (sigma : fin -> exp X).

  Lemma normalise_subst Delta sigma:
    Delta ⊩ sigma : Gamma ->
              { tau | (forall x, sigma x >* tau x) /\
                    (forall x, x ∈ dom Gamma -> normal (tau x)) /\ Delta ⊩ tau : Gamma}.
  Proof.
    intros T.
    assert (forall x, x ∈ dom Gamma -> { A | nth Gamma x = Some A }) as I.
    { intros x H1. destruct nth eqn: ?; eauto.
      exfalso. domin H1. congruence.  }
    exists (fun x => match x el dom Gamma with
             | left H => eta (sigma x) (T _ _ (proj2_sig (I x H)))
             | right _ => sigma x
             end).
    split; [| split].
    1-2: intros x; destruct dec_in; intuition.
    eapply eta_correct. eapply eta_normal.
    intros x B H. destruct dec_in; intuition.
    destruct I; cbn. generalize (T x x0 e).
    rewrite H in e; injection e as ->.
    eapply eta_typing.
  Qed.

End SubstitutionTransformations.

Definition NU {X: Const} (I: uni X) :=
  exists Delta sigma, Delta ⊩ sigma : Gammaᵤ /\ sigma • sᵤ ≡ sigma • tᵤ /\ forall x, normal (sigma x).

Section Normalisation.

  Variable (X: Const).
  Arguments sᵤ {_} _.
  Arguments tᵤ {_} _.
  Arguments Gammaᵤ {_} _.
  Arguments Aᵤ {_} _.

  Lemma U_NU I: U X I <-> NU I.
  Proof.
    split; intros (Delta & sigma & H1 & H2); [| exists Delta; exists sigma; intuition].
    eapply normalise_subst in H1 as (tau & H5 & H6 & H7).
    pose (theta x := if nth (Gammaᵤ I) x then tau x else var x).
    exists Delta. exists theta. intuition.
    + intros ???; unfold theta; rewrite H; eapply H7; eauto.
    + rewrite subst_pointwise_equiv with (sigma0 := theta) (tau0 := sigma).
      rewrite subst_pointwise_equiv with (sigma0 := theta) (tau0 := sigma); eauto.
      all: intros ? H; eapply typing_variables in H; eauto; domin H.
      all: unfold theta; now rewrite H, H5.
    + unfold theta; destruct nth eqn: ?; [|eauto].
      domin Heqo; eauto.
  Qed.

  Lemma U_reduction (I I': uni X):
    sᵤ I ≡ sᵤ I' -> tᵤ I ≡ tᵤ I' ->
    Gammaᵤ I = Gammaᵤ I' -> Aᵤ I = Aᵤ I' ->
    U X I -> U X I'.
  Proof.
    intros H1 H2 H3 H4; intros (Delta & sigma & T & N); exists Delta; exists sigma; split.
    rewrite <-H3; eauto. now rewrite <-H1, <-H2, N.
  Qed.

  Program Instance uni_normalise (I: uni X) : uni X :=
    { Gammaᵤ := Gammaᵤ I; sᵤ := eta (sᵤ I) H1ᵤ; tᵤ := eta (tᵤ I) H2ᵤ; Aᵤ := Aᵤ I }.
  Next Obligation.
    eapply preservation_under_steps. rewrite <-eta_correct. all: eauto.
  Qed.
  Next Obligation.
    eapply preservation_under_steps. rewrite <-eta_correct. all: eauto.
  Qed.

  Lemma uni_normalise_correct I:
    U X I <-> U X (uni_normalise I).
  Proof.
    split; intros H; [eapply @U_reduction|eapply @U_reduction with (I := uni_normalise I)].
    all: eauto; cbn; eapply equiv_join.
    1, 3, 6, 8: rewrite eta_correct. all: reflexivity.
  Qed.

End Normalisation.