(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

 *)

Require Export unsquashed_continuity.
Require Export Coq.Logic.ConstructiveEpsilon.

(*

  This tries to fix kripke.v, which contains results from Kripke, especially
  the negation of Markov's principle.  The problem in kripke.v is that Kripke's
  theory if about absolutely free choice sequences, while there I used the [baire]
  type, which also contains non-absolutely free choice sequences.

  The problem here is that A in [absolutely_free] is not supposed to contain
  variables for free choice sequences as mentioned for example by Kreisel
  in "A remark on free choice sequences" or by Myhill on "Notes towards an
  axiomatization of intuitionistic analysis".  Because we don't have the right
  definition of [absolutely_free], we can trivially prove that in [no_afcs]
  that there are no absolutely free choice sequences (proved by Mark).

  How can we make sure that A doesn't mention any other choice sequence?

 *)

Definition uniform_continuity :=
  forall (F : cantor -> nat),
    {n : nat | forall (f g : cantor), eq_upto n f g -> F f = F g}.

Definition kuroda :=
  forall (A : nat -> Prop),
    (forall (m : nat), !!(A m)) -> (!!forall (m : nat), A m).

Definition markov :=
  forall (A : nat -> Prop),
    (forall m, A m \/ !A m)
    -> (!!exists (n : nat), A n)
    -> exists (n : nat), A n.

(*Definition lawless :=
  MkLawless
    {
      lawless_type : Type;
      lawless_app  : forall (a : lawless_type) (n : nat), nat;
      lawless_ls1 :
    }*)

(* This is almost the definition of absolutely free choice sequences p.283
   of Myhill's "Notes towards an axiomatization of intuitionistic analysis".
   Is it okay to use the [baire] type?  *)
Definition absolutely_free (a : baire) :=
  forall (A : baire -> Prop),
    A a -> exists (p : nat), forall (b : baire), eq_upto p a b -> A b.

Definition baire_diff_at (a : baire) (k : nat) : baire :=
  fun n =>
    if eq_nat_dec k n then S (a n)
    else a n.

Lemma eq_upto_baire_diff_at :
  forall a p, eq_upto p a (baire_diff_at a p).
Proof.
  introv h.
  unfold baire_diff_at.
  destruct (Nat.eq_dec p m); auto; omega.
Qed.
Hint Resolve eq_upto_baire_diff_at : cont.

Lemma baire_diff_at_diff :
  forall a p, a <> baire_diff_at a p.
Proof.
  introv h.
  assert (a p = baire_diff_at a p p) as q.
  { rewrite <- h; auto. }
  unfold baire_diff_at in q.
  destruct (Nat.eq_dec p p); auto; omega.
Qed.

Lemma no_afcs :
  !exists (a : baire), absolutely_free a.
Proof.
  introv h; exrepnd.
  unfold absolutely_free in h0.
  pose proof (h0 (fun b => a = b)) as q; clear h0; simpl in q.
  autodimp q hyp; exrepnd.
  pose proof (q0 (baire_diff_at a p)) as h; autodimp h hyp; eauto 3 with cont.
  apply baire_diff_at_diff in h; auto.
Qed.

Definition afcs := {a : baire | absolutely_free a}.

(* sequences can either increase by one or not increase at all *)
Definition increasing (a : baire) : Prop :=
  forall (n : nat), a (S n) = a n \/ a (S n) = S (a n).

Definition binary (a : baire) : Prop :=
  forall (n : nat), a n = 0 \/ a n = 1.

Definition init0 (a : baire) : Prop := a 0 = 0.

Definition initF (a : cantor) : Prop := a 0 = false.

(* if a(pred n)=a(n) then b2c(a)(n)=false otherwise b2c(a)(n)=true, meaning it increases *)
Definition baire2cantor (a : baire) : cantor :=
  fun n => if eq_nat_dec (a (pred n)) (a n) then false else true.

(* We have to pick the initial value at 0.  We chose 0, which is why we
   require the [init0] condition below. *)
Fixpoint cantor2baire (a : cantor) (n : nat) : nat :=
  match n with
  | 0 => 0
  | S n =>
    let m := cantor2baire a n in
    if a (S n) then
      S m
    else
      m
  end.

Lemma increasing_cantor2baire :
  forall (a : cantor), increasing (cantor2baire a).
Proof.
  intros a n; simpl.
  destruct (a (S n));[right|left];auto.
Qed.
Hint Resolve increasing_cantor2baire : cont.

Lemma init0_cantor2baire :
  forall (a : cantor), init0 (cantor2baire a).
Proof.
  intros a; simpl.
  unfold init0; simpl; auto.
Qed.
Hint Resolve init0_cantor2baire : cont.

Lemma initF_baire2cantor :
  forall (a : baire), initF (baire2cantor a).
Proof.
  intros a; simpl.
  unfold initF, baire2cantor; simpl.
  destruct (Nat.eq_dec (a 0) (a 0)); auto; omega.
Qed.
Hint Resolve initF_baire2cantor : cont.

Lemma cantor2baire2cantor :
  forall (a : cantor), initF a -> baire2cantor (cantor2baire a) = a.
Proof.
  introv init.
  apply functional_extensionality; introv.

  unfold baire2cantor; simpl.

  destruct x; simpl; auto.
  remember (cantor2baire a x) as m.
  destruct (a (S x)).

  - destruct (Nat.eq_dec m (S m)); auto; try omega.

  - destruct (Nat.eq_dec m m); auto; try omega.
Qed.

Lemma baire2cantor2baire :
  forall (a : baire),
    init0 a
    -> increasing a
    -> cantor2baire (baire2cantor a) = a.
Proof.
  introv init inc.
  apply functional_extensionality; introv.

  induction x; simpl; auto.
  rewrite IHx; clear IHx.
  unfold baire2cantor; simpl.

  destruct (Nat.eq_dec (a x) (a (S x))); try omega.
  pose proof (inc x) as h; destruct h; auto; try omega.
Qed.

(* A non increasing sequence: *)
Definition non_inc_seq : baire :=
  fun n =>
    if eq_nat_dec n 0 then 0
    else if eq_nat_dec n 1 then 1
         else 0.

(* we now prove that we need the [increasing] hypothesis to prove [baire2cantor2baire] *)
Lemma baire2cantor2baire_needs_increassing :
  cantor2baire (baire2cantor non_inc_seq) <> non_inc_seq.
Proof.
  introv h.
  apply equal_f with (x := 2) in h.
  simpl in h.
  unfold non_inc_seq in h; simpl in h; omega.
Qed.

Fixpoint least_greater_aux (b : baire) (n : nat) (x : nat) : option nat :=
  match n with
  | 0 => None
  | S m =>
    match least_greater_aux b m x with
    | Some k => Some k
    | None => if le_lt_dec x (b m) then Some m else None
    end
  end.

Definition least_greater (b : baire) (n : nat) (x : nat) : nat :=
  match least_greater_aux b n x with
  | Some k => k
  | None => n
  end.

Definition least_greater_aux_prop1 :
  forall b n x k,
    least_greater_aux b n x = Some k
    -> x <= b k.
Proof.
  induction n; introv h; simpl in *; try (inversion h; fail).
  remember (least_greater_aux b n x) as l; symmetry in Heql; destruct l.

  - inversion h; subst; clear h.
    apply IHn in Heql; auto.

  - destruct (le_lt_dec x (b n)); inversion h; subst; clear h; auto.
Qed.

Definition increasing_le :
  forall a n m,
    n <= m
    -> increasing a
    -> a n <= a m.
Proof.
  induction m; introv lenm inc.

  - assert (n = 0) by omega; subst; auto.

  - destruct (le_lt_dec n m) as [d|d].

    + repeat (autodimp IHm hyp).
      pose proof (inc m) as q; destruct q; omega.

    + assert (n = S m) by omega; subst; auto.
Qed.

Definition least_greater_aux_prop2 :
  forall b a n x k,
    eq_upto x b a
    -> increasing a
    -> least_greater_aux b n (S (a x)) = Some k
    -> x <= k.
Proof.
  introv equ inca e.
  apply least_greater_aux_prop1 in e.
  destruct (le_lt_dec x k); auto.
  rewrite (equ k l) in e.
  pose proof (increasing_le a k x) as q; repeat (autodimp q hyp); try omega.
Qed.

Lemma implies_eq_upto_baire2cantor :
  forall (a b : baire) n,
    eq_upto n a b
    -> eq_upto n (baire2cantor a) (baire2cantor b).
Proof.
  introv h q.
  unfold baire2cantor.

  destruct m; simpl.

  { destruct (Nat.eq_dec (a 0) (a 0)); try omega.
    destruct (Nat.eq_dec (b 0) (b 0)); try omega.
    auto. }

  destruct (Nat.eq_dec (a m) (a (S m))) as [d1|d1];
    destruct (Nat.eq_dec (b m) (b (S m))) as [d2|d2];
    auto.

  - pose proof (h m) as h1; autodimp h1 hyp; try omega.
    pose proof (h (S m)) as h2; autodimp h2 hyp; try omega.

  - pose proof (h m) as h1; autodimp h1 hyp; try omega.
    pose proof (h (S m)) as h2; autodimp h2 hyp; try omega.
Qed.
Hint Resolve implies_eq_upto_baire2cantor : cont.

Definition baire_eq_from (a : baire) (k : nat) : baire :=
  fun n => if lt_dec n k then a n else a k.

Lemma increasing_baire_eq_from :
  forall (a : baire) n,
    increasing a
    ->  increasing (baire_eq_from a n).
Proof.
  introv inc; introv.
  unfold baire_eq_from.
  destruct (lt_dec (S n0) n); destruct (lt_dec n0 n); auto; try omega.
  assert (n = S n0) as xx by omega; subst; simpl in *; auto.
Qed.
Hint Resolve increasing_baire_eq_from : cont.

Definition baire_diff_from (a : baire) (k : nat) : baire :=
  fun n =>
    if le_lt_dec k n
    then (* k <= n *)
      if eq_nat_dec (a k) (a (pred k))
      then S (a (pred k))
      else a (pred k)
    else (* n < k *) a n.

Lemma eq_upto_baire_diff_from :
  forall n a, eq_upto n a (baire_diff_from a n).
Proof.
  introv h.
  unfold baire_diff_from.
  destruct (le_lt_dec n m); auto; try omega.
Qed.
Hint Resolve eq_upto_baire_diff_from : cont.

Lemma eq_upto0 :
  forall {T} (a b : Seq T), eq_upto 0 a b.
Proof.
  introv h; omega.
Qed.
Hint Resolve eq_upto0 : cont.

Lemma init0_implies_eq_upto1_zeros :
  forall (a : baire), init0 a -> eq_upto 1 a zeros.
Proof.
  introv init h.
  destruct m; try omega; auto.
Qed.
Hint Resolve init0_implies_eq_upto1_zeros : cont.

Lemma init0_zeros : init0 zeros.
Proof.
  compute; auto.
Qed.
Hint Resolve init0_zeros : cont.

Lemma increasing_zeros : increasing zeros.
Proof.
  compute; auto.
Qed.
Hint Resolve increasing_zeros : cont.

Definition change_from1 (a : baire) : cantor :=
  fun n => if eq_nat_dec n 0 then false else
             if eq_nat_dec (a 1) (a 0) then true
             else false.

Lemma init0_baire_diff_from :
  forall a n, 0 < n -> init0 a -> init0 (baire_diff_from a n).
Proof.
  introv lt0 init.
  unfold init0, baire_diff_from.
  destruct (le_lt_dec n 0); try omega; auto.
Qed.
Hint Resolve init0_baire_diff_from : cont.

Lemma increasing_baire_diff_from :
  forall a n, increasing a -> increasing (baire_diff_from a n).
Proof.
  introv cont; introv.
  unfold baire_diff_from.
  destruct (le_lt_dec n (S n0)) as [d1|d1];
    destruct (Nat.eq_dec (a n) (a (Init.Nat.pred n))) as [d2|d2];
    destruct (le_lt_dec n n0) as [d3|d3]; auto; try omega;
      assert (n = S n0) by omega; subst; simpl in *; auto.
Qed.
Hint Resolve increasing_baire_diff_from : cont.

Lemma baire_diff_from_diff :
  forall a n, a n <> baire_diff_from a n n.
Proof.
  introv h.
  unfold baire_diff_from in h.
  destruct (le_lt_dec n n) as [d|d]; try omega.
  clear d.
  destruct (Nat.eq_dec (a n) (a (Init.Nat.pred n))) as [d|d]; auto.
  omega.
Qed.

Lemma eq_upto_baire_eq_from :
  forall a p n,
    p <= n
    -> eq_upto p a (baire_eq_from a n).
Proof.
  introv lepn h.
  unfold baire_eq_from.
  destruct (lt_dec m n); auto; try omega.
Qed.
Hint Resolve eq_upto_baire_eq_from : cont.

Lemma init0_baire_eq_from :
  forall a n, init0 a -> init0 (baire_eq_from a n).
Proof.
  introv inti.
  unfold init0, baire_eq_from; simpl.
  destruct (lt_dec 0 n); auto.
  assert (n = 0) by omega; subst; auto.
Qed.
Hint Resolve init0_baire_eq_from : cont.

Definition baire_inc_from (a : baire) (n : nat) : baire :=
  fun k => if lt_dec k n then a k else (a n) + k - n.

Lemma eq_upto_baire_inc_from :
  forall (a : baire) (p : nat),
    eq_upto p a (baire_inc_from a p).
Proof.
  introv h.
  unfold baire_inc_from.
  destruct (lt_dec m p); auto; omega.
Qed.
Hint Resolve eq_upto_baire_inc_from : cont.

Lemma increasing_baire_inc_from :
  forall (a : baire) (p : nat),
    increasing a
    -> increasing (baire_inc_from a p).
Proof.
  introv inc; introv.
  unfold increasing, baire_inc_from.
  destruct (lt_dec (S n) p) as [d1|d1]; destruct (lt_dec n p) as [d2|d2]; auto; try omega.
  assert (p = S n) by omega; subst.
  rewrite Nat.add_sub; auto.
Qed.
Hint Resolve increasing_baire_inc_from : cont.

(* This is Kripke's lemma (a) in section 2 p.104 *)
Lemma kripke2a :
  forall (a : baire) (m : nat),
    absolutely_free a
    -> increasing a
    -> !!{n : nat | a(n) >= m}.
Proof.
  introv free inc h.

  pose proof (free (fun a => !{n : nat | a n >= m})) as q; simpl in q.
  autodimp q hyp.
  exrepnd.

  assert (a(p) < m) as lem.
  {
    destruct (lt_dec (a p) m); auto.
    destruct h; exists p; omega.
  }

  assert (forall (y : nat), y < p -> a y < m) as ltym.
  {
    introv z.
    pose proof (increasing_le a y p) as w; repeat (autodimp w hyp); try omega.
  }

  pose proof (q0 (baire_inc_from a p))  as z.
  repeat (autodimp z hyp); eauto 2 with cont.
  destruct z.
  exists (p + m - a p).
  unfold baire_inc_from.
  assert (a p + (p + m - a p) - p = m) as xx by omega; rewrite xx; clear xx.
  destruct (lt_dec (p + m - a p) p); auto; omega.
Qed.

(* This is meant to be only true for absolutely free choice sequences *)
Lemma kripke2a_concl_false_if_non_absolutely_free :
  !forall (a : baire) (m : nat),
      increasing a
      -> !!{n : nat | a(n) >= m}.
Proof.
  introv h.
  pose proof (h zeros 1) as z; clear h.
  autodimp z hyp; eauto 2 with cont.
  unfold zeros in z.
  destruct z; intro z; exrepnd; omega.
Qed.

(* This shows that the sequence of zeros used in
   [kripke2a_concl_false_if_non_absolutely_free] above is not absolutely free *)
Lemma zeros_non_absolutely_free :
  !absolutely_free zeros.
Proof.
  introv C.
  pose proof (C (fun a => forall n, a n = 0)) as q; simpl in q.
  autodimp q hyp.
  exrepnd.
  pose proof (q0 (fun n => if lt_dec n p then 0 else 1)) as h; simpl in h; clear q0.
  autodimp h hyp.

  {
    introv ltn.
    unfold zeros.
    destruct (lt_dec m p); omega.
  }

  {
    pose proof (h p) as q; clear h.
    destruct (lt_dec p p); omega.
  }
Qed.

Lemma kripke2a_prop :
  forall (a : baire) (m : nat),
    absolutely_free a
    -> increasing a
    -> !!exists (n : nat), a(n) >= m.
Proof.
  introv free inc h.
  pose proof (kripke2a a m free inc) as q.
  destruct q; intro q; exrepnd.
  destruct h; exists n; auto.
Qed.

(* This is Kripke's lemma (b) in section 2 p.104 *)
Lemma kripke2b :
  uniform_continuity
  ->
  forall (a : baire),
    init0 a
    -> absolutely_free a
    -> increasing a
    -> !forall (m : nat), {n : nat | a(n) >= m}.
Proof.
  introv ucont init free inc.
  introv h.

  pose proof (free (fun a => forall m : nat, Cast {n : nat | a n >= m})) as q.
  simpl in q.
  autodimp q hyp.
  exrepnd.

  assert (forall (b : baire), eq_upto p a b -> forall (m : nat), {n : nat | b n >= m}) as w.
  {
    introv equ; introv.
    pose proof (q0 b equ m) as z.
    apply (constructive_indefinite_ground_description nat (fun n => n) (fun n => n)); auto.
    { introv; apply ge_dec. }
    inversion z; exrepnd; eexists; eauto.
  }

  clear q0.

  assert (forall (b : baire), eq_upto p a b -> {n : nat | b(n) >= S (a p)}) as z.
  {
    introv equ.
    apply w; auto.
  }

  clear w.

  remember (fun (b : cantor) =>
              match eq_upto_dec p a (cantor2baire b) with
              | left q => least_greater
                            (cantor2baire b)
                            (proj1_sig (z (cantor2baire b) q))
                            (S (a p))
              | right _ => 0
              end) as c.

  pose proof (ucont c) as q; exrepnd.
  rename q0 into q.

  assert (p <= n) as lepn.
  {
    (* change a starting at n *)
    destruct (le_lt_dec p n) as [ltnp|ltnp]; auto.
    assert False as xx;[|destruct xx];[].

    destruct (eq_nat_dec n 0) as [ez|ez].

    {
      subst n.

      destruct (eq_nat_dec p 1) as [po|po].

      - subst p.
        pose proof (z zeros) as w.
        repeat (autodimp w hyp); eauto 3 with cont.
        exrepnd.
        compute in w0; omega.

      - pose proof (q (baire2cantor a) (change_from1 a)) as w.
        autodimp w hyp; eauto 2 with cont.
        clear q.
        subst c.
        destruct (eq_upto_dec p a (cantor2baire (baire2cantor a))) as [d1|d1];
          [|destruct d1; rewrite baire2cantor2baire; eauto 2 with cont];[].
        destruct (eq_upto_dec p a (cantor2baire (change_from1 a))) as [d2|d2].

        { pose proof (d2 1) as xx; autodimp xx hyp; try omega.
          unfold change_from1, cantor2baire in xx; simpl in xx.
          destruct (Nat.eq_dec (a 1) (a 0)) as [d|d]; auto;
            rewrite xx in d; rewrite init in d; omega. }

        match type of w with
        | context[proj1_sig ?a] => remember a as xx; exrepnd; simpl in *
        end.
        clear Heqxx.

        rewrite baire2cantor2baire in *; auto;[].
        unfold least_greater in w.
        remember (least_greater_aux a n (S (a p))) as lg; destruct lg; symmetry in Heqlg; subst;
          [|rewrite init in xx0; omega].

        pose proof (least_greater_aux_prop2 a a n p 0) as zz.
        repeat (autodimp zz hyp); omega.
    }

    assert (0 < n) as gz by omega; clear ez.

    pose proof (q (baire2cantor a)
                  (baire2cantor (baire_diff_from a n))) as w.
    autodimp w hyp; eauto with cont; eauto with cont;[].

    clear q; subst c.

    repeat match type of w with
           | context[eq_upto_dec ?a ?b ?c] =>
             let d := fresh "d" in
             destruct (eq_upto_dec a b c) as [d|d]
           end;
      repeat match type of w with
             | context[proj1_sig ?a] =>
               let q := fresh "q" in
               remember a as q; exrepnd; simpl in *;
                 match goal with
                 | [ H : _ = a |- _ ] => clear H
                 end
             end;
      try (complete (destruct d; rewrite baire2cantor2baire in *; eauto 2 with cont));
      repeat (rewrite baire2cantor2baire in *; eauto 3 with cont);[|].

    - pose proof (d0 n) as xx; autodimp xx hyp.
      apply baire_diff_from_diff in xx; auto.

    - unfold least_greater in w.
      remember (least_greater_aux a n0 (S (a p))) as lg; destruct lg; symmetry in Heqlg; subst;
        [|rewrite init in q0; omega].

      pose proof (least_greater_aux_prop2 a a n0 p 0) as zz.
      repeat (autodimp zz hyp); omega.
  }

  pose proof (z (baire_eq_from a p)) as xx.
  repeat (autodimp xx hyp); eauto 3 with cont.
  exrepnd.

  unfold baire_eq_from in xx0.
  destruct (lt_dec n0 p) as [d|d]; try omega.

  pose proof (increasing_le a n0 p) as zz.
  repeat (autodimp zz hyp); try omega.
Qed.

Lemma kripke2b_prop :
  uniform_continuity
  ->
  forall (a : baire),
    init0 a
    -> absolutely_free a
    -> increasing a
    -> !forall (m : nat), exists (n : nat), a(n) >= m.
Proof.
  introv ucont init free inc; intro h.
  pose proof (kripke2b ucont a init free inc) as q.
  destruct q; introv.
  pose proof (h m) as w; clear h.

  apply (constructive_indefinite_ground_description nat (fun n => n) (fun n => n)); auto.
  introv; apply ge_dec.
Qed.

(* It seems that for this we need at least one absolutely free choice sequences.
   Is that what Kripke meant?
 *)
Lemma afcs_contradicts_kuroda :
  (exists (a : baire), init0 a /\ increasing a /\ absolutely_free a)
  -> uniform_continuity
  -> !kuroda.
Proof.
  introv eafcs ucont K.

  assert (forall (a : baire),
             absolutely_free a
             -> increasing a
             -> !!forall (m : nat), exists (n : nat), a n >= m) as h.
  {
    introv free inc.
    apply K; introv.
    pose proof (kripke2a a m free inc) as q.
    intro h; destruct q; intro q; exrepnd.
    destruct h; exists n; auto.
  }

  pose proof (kripke2b ucont) as q.
  exrepnd.
  pose proof (h a) as w; repeat (autodimp w hyp).
  pose proof (q a) as z; repeat (autodimp z hyp).
  destruct w; intro w.
  destruct z; introv.
  pose proof (w m) as z.

  apply (constructive_indefinite_ground_description nat (fun n => n) (fun n => n)); auto.
  introv; apply ge_dec.
Qed.

Lemma afcs_contradicts_markov :
  (exists (a : baire), init0 a /\ increasing a /\ absolutely_free a)
  -> uniform_continuity
  -> !markov.
Proof.
  introv eafcs ucont MP.

  assert (forall (a : baire),
             absolutely_free a
             -> increasing a
             -> forall (m : nat), exists (n : nat), a n >= m) as h.
  {
    introv free inc; introv.
    apply MP; auto.
    { introv; destruct (ge_dec (a m0) m); auto. }
    pose proof (kripke2a a m free inc) as q.
    intro h; destruct q; intro q; exrepnd.
    destruct h; exists n; auto.
  }

  pose proof (kripke2b ucont) as q.
  exrepnd.
  pose proof (h a) as w; repeat (autodimp w hyp).
  pose proof (q a) as z; repeat (autodimp z hyp).
  destruct z; introv.
  pose proof (w m) as z.

  apply (constructive_indefinite_ground_description nat (fun n => n) (fun n => n)); auto.
  introv; apply ge_dec.
Qed.


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 D E F X Dprime : Universe, ((wd_ A B /\ (wd_ A D /\ (wd_ D E /\ (wd_ D Dprime /\ (wd_ A Dprime /\ (wd_ E A /\ (wd_ X A /\ (wd_ X D /\ (wd_ F A /\ (wd_ F D /\ (wd_ E F /\ (wd_ B D /\ (col_ A B A /\ (col_ A B D /\ (col_ B A F /\ col_ D A Dprime))))))))))))))) -> col_ F A D)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import FiatFormal.Language.SubstTypeExp.
Require Import FiatFormal.Language.SubstExpExp.
Require Import FiatFormal.Language.Exp.

Require Export FiatFormal.Data.Context.
Require Export FiatFormal.Data.Chain.

(* TODO: consider implications of below definition...
         esp. that nary function application requires
         value of function but only wnfX of args *)

(*  Evaluation contexts for expressions.
    This describes a place in the exp AST where the sub-expression
    there is able to take an evaluation step *)
Inductive exp_ctx : (exp -> exp) -> Prop :=

 (* Left of an application *)
 | XcApp1
   : forall x2,
     exp_ctx (fun xx => XApp xx x2)

 (* The right of an application can step only when the left is
    already a value. *)
 | XcApp2
   : forall v1,
     value v1
     -> exp_ctx (fun xx => XApp v1 xx)

 | XcCon
   : forall dc C,
     exps_ctx wnfX C
     -> exp_ctx (fun xx => XCon dc (C xx))

 (* We need to reduce the discriminant of a match to a value. *)
 | XcMatch
   : forall alts,
     exp_ctx (fun xx => XMatch xx alts)

 | XcChoice
   : forall t pc C,
     exps_ctx wnfX C
     -> exp_ctx (fun xx => XChoice t pc (C xx))

 | XcTup
   : forall C,
     exps_ctx wnfX C
     -> exp_ctx (fun xx => XTup (C xx))

 | XcProj
   : forall n,
     exp_ctx (fun xx => XProj n xx)

 | XcNApp1
   : forall xs,
     exp_ctx (fun xx => XNApp xx xs)

 | XcNApp2
   : forall v1 C,
     value v1
     -> exps_ctx wnfX C
     -> exp_ctx (fun xx => XNApp v1 (C xx)).
Hint Constructors exp_ctx.


From VLSM.Lib Require Import Itauto.
From stdpp Require Import prelude.
From Coq Require Import FunctionalExtensionality.
From VLSM.Core Require Import VLSM.
From VLSM.Core Require Export VLSMPartialProjection VLSMStutteringEmbedding.
From VLSM.Core Require Export VLSMTotalProjection VLSMEmbedding.
From VLSM.Core Require Export VLSMInclusion VLSMEquality.

(** * VLSM Projection Properties *)

Section sec_same_VLSM_embedding.

(** ** Same VLSM embedding *)

Context
  {message : Type}
  (X1 X2 : VLSM message)
  (Heq : X1 = X2)
  .

Lemma same_VLSM_embedding
  : VLSM_embedding X1 X2 (same_VLSM_label_rew Heq) (same_VLSM_state_rew Heq).
Proof.
  apply basic_VLSM_strong_embedding; intro.
  - by apply same_VLSM_valid_preservation.
  - by apply same_VLSM_transition_preservation.
  - by apply same_VLSM_initial_state_preservation.
  - by apply same_VLSM_initial_message_preservation.
Qed.

End sec_same_VLSM_embedding.

Section sec_transitivity_props.

(** ** Transitivity properties *)

Lemma pre_VLSM_projection_finite_trace_project_trans
  {message : Type}
  (TX TY TZ : VLSMType message)
  (project_labelXY : @label _ TX -> option (@label _ TY))
  (project_stateXY : @state _ TX -> @state _ TY)
  (project_labelYZ : @label _ TY -> option (@label _ TZ))
  (project_stateYZ : @state _ TY -> @state _ TZ)
  : forall trX,
    pre_VLSM_projection_finite_trace_project TX TZ
      (mbind project_labelYZ ∘ project_labelXY)
      (project_stateYZ ∘ project_stateXY)
      trX
      =
    pre_VLSM_projection_finite_trace_project TY TZ project_labelYZ project_stateYZ
      (pre_VLSM_projection_finite_trace_project TX TY project_labelXY project_stateXY
        trX).
Proof.
  induction trX; [done |]; destruct a; cbn;
    unfold pre_VLSM_projection_transition_item_project; cbn;
    unfold mbind, option_bind; cbn.
  destruct (project_labelXY l) as [lY |]; [| done]; cbn;
    unfold pre_VLSM_projection_transition_item_project; cbn.
  destruct (project_labelYZ lY) as [lZ |]; [| done]; cbn.
  by f_equal.
Qed.

Lemma VLSM_projection_trans
  {message}
  (X Y Z : VLSM message)
  (project_labelXY : vlabel X -> option (vlabel Y))
  (project_stateXY : vstate X -> vstate Y)
  (ProjXY : VLSM_projection X Y project_labelXY project_stateXY)
  (project_labelYZ : vlabel Y -> option (vlabel Z))
  (project_stateYZ : vstate Y -> vstate Z)
  (ProjYZ : VLSM_projection Y Z project_labelYZ project_stateYZ)
  : VLSM_projection X Z
    (mbind project_labelYZ ∘ project_labelXY)
    (project_stateYZ ∘ project_stateXY).
Proof.
  constructor; [split |]; intros sX trX HtrX; cbn;
    setoid_rewrite pre_VLSM_projection_finite_trace_project_trans.
  - rewrite <- !final_state_project; [done | apply ProjXY | done | apply ProjYZ |].
    by eapply (VLSM_projection_finite_valid_trace_from ProjXY).
  - by eapply (VLSM_projection_finite_valid_trace ProjYZ),
              (VLSM_projection_finite_valid_trace ProjXY).
Qed.

Lemma VLSM_projection_embedding_trans
  {message}
  (X Y Z : VLSM message)
  (project_labelXY : vlabel X -> option (vlabel Y))
  (project_stateXY : vstate X -> vstate Y)
  (ProjXY : VLSM_projection X Y project_labelXY project_stateXY)
  (project_labelYZ : vlabel Y -> vlabel Z)
  (project_stateYZ : vstate Y -> vstate Z)
  (ProjYZ : VLSM_embedding Y Z project_labelYZ project_stateYZ)
  : VLSM_projection X Z
    (fmap project_labelYZ ∘ project_labelXY)
    (project_stateYZ ∘ project_stateXY).
Proof.
  apply VLSM_embedding_is_projection in ProjYZ.
  replace (fmap project_labelYZ ∘ project_labelXY)
     with (mbind (Some ∘ project_labelYZ) ∘ project_labelXY).
  - by apply VLSM_projection_trans.
  - by extensionality x.
Qed.

Lemma VLSM_embedding_projection_trans
  {message}
  (X Y Z : VLSM message)
  (project_labelXY : vlabel X -> vlabel Y)
  (project_stateXY : vstate X -> vstate Y)
  (ProjXY : VLSM_embedding X Y project_labelXY project_stateXY)
  (project_labelYZ : vlabel Y -> option (vlabel Z))
  (project_stateYZ : vstate Y -> vstate Z)
  (ProjYZ : VLSM_projection Y Z project_labelYZ project_stateYZ)
  : VLSM_projection X Z
    (project_labelYZ ∘ project_labelXY)
    (project_stateYZ ∘ project_stateXY).
Proof.
  apply VLSM_embedding_is_projection in ProjXY.
  replace (project_labelYZ ∘ project_labelXY)
     with (mbind project_labelYZ ∘ (Some ∘ project_labelXY)).
  - by apply VLSM_projection_trans.
  - by extensionality x.
Qed.

Lemma pre_VLSM_embedding_finite_trace_project_trans
  {message}
  (TX TY TZ : VLSMType message)
  (project_labelXY : @label _ TX -> @label _ TY)
  (project_stateXY : @state _ TX -> @state _ TY)
  (project_labelYZ : @label _ TY -> @label _ TZ)
  (project_stateYZ : @state _ TY -> @state _ TZ)
  : forall trX,
    pre_VLSM_embedding_finite_trace_project TX TZ
      (project_labelYZ ∘ project_labelXY)
      (project_stateYZ ∘ project_stateXY)
      trX
      =
    pre_VLSM_embedding_finite_trace_project  TY TZ project_labelYZ project_stateYZ
      (pre_VLSM_embedding_finite_trace_project  TX TY project_labelXY project_stateXY
        trX).
Proof. by induction trX; [| destruct a; cbn; f_equal]. Qed.

Lemma VLSM_embedding_trans
  {message}
  (X Y Z : VLSM message)
  (project_labelXY : vlabel X -> vlabel Y)
  (project_stateXY : vstate X -> vstate Y)
  (ProjXY : VLSM_embedding X Y project_labelXY project_stateXY)
  (project_labelYZ : vlabel Y -> vlabel Z)
  (project_stateYZ : vstate Y -> vstate Z)
  (ProjYZ : VLSM_embedding Y Z project_labelYZ project_stateYZ)
  : VLSM_embedding X Z
    (project_labelYZ ∘ project_labelXY)
    (project_stateYZ ∘ project_stateXY).
Proof.
  constructor; intros sX trX HtrX.
  setoid_rewrite pre_VLSM_embedding_finite_trace_project_trans.
  by eapply (VLSM_embedding_finite_valid_trace ProjYZ),
            (VLSM_embedding_finite_valid_trace ProjXY).
Qed.

Lemma VLSM_projection_incl_trans
  {message}
  (X : VLSM message)
  {T : VLSMType message}
  {MY MZ : VLSMMachine T}
  (Y := mk_vlsm MY)
  (Z := mk_vlsm MZ)
  (project_labelXY : vlabel X -> option (vlabel Y))
  (project_stateXY : vstate X -> vstate Y)
  (ProjXY : VLSM_projection X Y project_labelXY project_stateXY)
  (ProjYZ : VLSM_incl Y Z)
  : VLSM_projection X Z project_labelXY project_stateXY.
Proof.
  replace project_labelXY with (fmap id ∘ project_labelXY)
    by (extensionality lX; cbv; destruct (project_labelXY lX); done).
  change project_stateXY with (id ∘ project_stateXY).
  by apply (VLSM_projection_embedding_trans X Y Z); [| apply VLSM_incl_is_embedding].
Qed.

Lemma VLSM_embedding_incl_trans
  {message}
  (X : VLSM message)
  {T : VLSMType message}
  {MY MZ : VLSMMachine T}
  (Y := mk_vlsm MY)
  (Z := mk_vlsm MZ)
  (project_labelXY : vlabel X -> vlabel Y)
  (project_stateXY : vstate X -> vstate Y)
  (ProjXY : VLSM_embedding X Y project_labelXY project_stateXY)
  (ProjYZ : VLSM_incl Y Z)
  : VLSM_embedding X Z project_labelXY project_stateXY.
Proof.
  change project_labelXY with (id ∘ project_labelXY).
  change project_stateXY with (id ∘ project_stateXY).
  by apply (VLSM_embedding_trans X Y Z); [| apply VLSM_incl_is_embedding].
Qed.

Lemma VLSM_incl_projection_trans
  {message}
  {T : VLSMType message}
  {MX MY : VLSMMachine T}
  (X := mk_vlsm MX)
  (Y := mk_vlsm MY)
  (Z : VLSM message)
  (ProjXY : VLSM_incl X Y)
  (project_labelYZ : vlabel Y -> option (vlabel Z))
  (project_stateYZ : vstate Y -> vstate Z)
  (ProjYZ : VLSM_projection Y Z project_labelYZ project_stateYZ)
  : VLSM_projection X Z project_labelYZ project_stateYZ.
Proof.
  apply (VLSM_embedding_projection_trans X Y Z); [| done].
  by apply VLSM_incl_is_embedding in ProjXY.
Qed.

Lemma VLSM_incl_embedding_trans
  {message}
  {T : VLSMType message}
  {MX MY : VLSMMachine T}
  (X := mk_vlsm MX)
  (Y := mk_vlsm MY)
  (Z : VLSM message)
  (ProjXY : VLSM_incl X Y)
  (project_labelYZ : vlabel Y -> vlabel Z)
  (project_stateYZ : vstate Y -> vstate Z)
  (ProjYZ : VLSM_embedding Y Z project_labelYZ project_stateYZ)
  : VLSM_embedding X Z project_labelYZ project_stateYZ.
Proof.
  apply (VLSM_embedding_trans X Y Z); [| done].
  by apply VLSM_incl_is_embedding in ProjXY.
Qed.

Lemma VLSM_projection_eq_trans
  {message}
  (X : VLSM message)
  {T : VLSMType message}
  {MY MZ : VLSMMachine T}
  (Y := mk_vlsm MY)
  (Z := mk_vlsm MZ)
  (project_labelXY : vlabel X -> option (vlabel Y))
  (project_stateXY : vstate X -> vstate Y)
  (ProjXY : VLSM_projection X Y project_labelXY project_stateXY)
  (ProjYZ : VLSM_eq Y Z)
  : VLSM_projection X Z project_labelXY project_stateXY.
Proof. by apply VLSM_projection_incl_trans; [| apply ProjYZ]. Qed.

Lemma VLSM_embedding_eq_trans
  {message}
  (X : VLSM message)
  {T : VLSMType message}
  {MY MZ : VLSMMachine T}
  (Y := mk_vlsm MY)
  (Z := mk_vlsm MZ)
  (project_labelXY : vlabel X -> vlabel Y)
  (project_stateXY : vstate X -> vstate Y)
  (ProjXY : VLSM_embedding X Y project_labelXY project_stateXY)
  (ProjYZ : VLSM_eq Y Z)
  : VLSM_embedding X Z project_labelXY project_stateXY.
Proof. by apply VLSM_embedding_incl_trans; [| apply ProjYZ]. Qed.

Lemma VLSM_eq_projection_trans
  {message}
  {T : VLSMType message}
  {MX MY : VLSMMachine T}
  (X := mk_vlsm MX)
  (Y := mk_vlsm MY)
  (Z : VLSM message)
  (ProjXY : VLSM_eq X Y)
  (project_labelYZ : vlabel Y -> option (vlabel Z))
  (project_stateYZ : vstate Y -> vstate Z)
  (ProjYZ : VLSM_projection Y Z project_labelYZ project_stateYZ)
  : VLSM_projection X Z project_labelYZ project_stateYZ.
Proof. by apply VLSM_incl_projection_trans; [apply ProjXY |]. Qed.

Lemma VLSM_eq_embedding_trans
  {message}
  {T : VLSMType message}
  {MX MY : VLSMMachine T}
  (X := mk_vlsm MX)
  (Y := mk_vlsm MY)
  (Z : VLSM message)
  (ProjXY : VLSM_eq X Y)
  (project_labelYZ : vlabel Y -> vlabel Z)
  (project_stateYZ : vstate Y -> vstate Z)
  (ProjYZ : VLSM_embedding Y Z project_labelYZ project_stateYZ)
  : VLSM_embedding X Z project_labelYZ project_stateYZ.
Proof. by apply VLSM_incl_embedding_trans; [apply ProjXY |]. Qed.

End sec_transitivity_props.


(*
Lemma star_diff_ptrs : forall specs st p1 p2, interp specs (![p1 =?>1 * p2 =?> 1] st) -> p1 <> p2.
  rewrite sepFormula_eq.
  propxFo.
  subst.
  unfold smem_get_word in *.
  simpl in *.
  case_eq (smem_get p2 x1).
  intros.
  clear H4.
  case_eq (smem_get p2 x4).
  clear H7.
  intros.
  destruct H3.
  subst.
  destruct H1.
  destruct H2.
  subst.
  Require Import Bootstrap.
  eapply disjoint_get_fwd in H1.
  eauto.
  erewrite join_Some by eassumption.
  discriminate.
  erewrite join_Some by eassumption.
  discriminate.
  intros.
  rewrite H0 in H7.
  discriminate.
  intros.
  rewrite H in H4.
  discriminate.
Qed.
*)


(*
lambda-DOT:
Lambda calculus with records, abstract type members, union and intersection types,
but without self references in types, and thus without recursive types nor recursive
functions.

nohas = no "has" judgment, but use type assignment instead
*)

Set Implicit Arguments.

(* CoqIDE users: Run ln/open.sh to start coqide, then open this file. *)
Require Import LibLN.

(* ###################################################################### *)
(* ###################################################################### *)
(** * Definitions *)

(* ###################################################################### *)
(** ** Syntax *)

Parameter typ_label: Set.
Parameter fld_label: Set.
Parameter mtd_label: Set.

Inductive label: Set :=
| label_typ: typ_label -> label
| label_fld: fld_label -> label
| label_mtd: mtd_label -> label.

Module labels.
  Parameter L: typ_label.
  Parameter l: fld_label.
  Parameter m: mtd_label.
  Parameter apply: mtd_label.
End labels.

Inductive avar : Set :=
  | avar_b : nat -> avar  (* bound var (de Bruijn index) *)
  | avar_f : var -> avar. (* free var ("name"), refers to store or ctx *)

Inductive typ : Set :=
  | typ_top  : typ
  | typ_bot  : typ
  | typ_rcd  : dec -> typ (* {D}, no self reference for the moment *)
  | typ_sel  : avar -> typ_label -> typ (* p.L *)
  | typ_and  : typ -> typ -> typ
  | typ_or   : typ -> typ -> typ
with dec : Set :=
  | dec_typ  : typ_label -> typ -> typ -> dec
  | dec_fld  : fld_label -> typ -> dec
  | dec_mtd  : mtd_label -> typ -> typ -> dec.

Inductive trm : Set :=
  | trm_var  : avar -> trm
  | trm_sel  : trm -> fld_label -> trm
  | trm_call : trm -> mtd_label -> trm -> trm
  | trm_new  : defs -> trm (* will later have a nameless self reference, but not yet now *)
with def : Set :=
  | def_typ : typ_label -> typ -> typ -> def (* same as dec_typ *)
  | def_fld : fld_label -> typ -> avar -> def (* cannot have term here, assign it first *)
  | def_mtd : mtd_label -> typ -> typ -> trm -> def (* one nameless argument *)
with defs : Set :=
  | defs_nil : defs
  | defs_cons : defs -> def -> defs.

(** *** Typing environment ("Gamma") *)
Definition ctx := env typ.

(** *** Value environment ("store") *)
Definition sto := env defs.

(** *** Syntactic sugar *)
Definition trm_fun(T U: typ)(body: trm) :=
            trm_new (defs_cons defs_nil (def_mtd labels.apply T U body)).
Definition trm_app(func arg: trm) := trm_call func labels.apply arg.
Definition trm_let(T U: typ)(rhs body: trm) := trm_app (trm_fun T U body) rhs.
Definition typ_arrow(T1 T2: typ) := typ_rcd (dec_mtd labels.apply T1 T2).

(* ###################################################################### *)
(** ** Definition list membership *)

Definition label_of_def(d: def): label := match d with
| def_typ L _ _ => label_typ L
| def_fld l _ _ => label_fld l
| def_mtd m _ _ _ => label_mtd m
end.

Definition label_of_dec(D: dec): label := match D with
| dec_typ L _ _ => label_typ L
| dec_fld l _ => label_fld l
| dec_mtd m _ _ => label_mtd m
end.

Inductive defs_hasnt: defs -> label -> Prop :=
| defs_hasnt_nil: forall l,
    defs_hasnt defs_nil l
| defs_hasnt_cons: forall d ds l,
    defs_hasnt ds l ->
    label_of_def d <> l ->
    defs_hasnt (defs_cons ds d) l.

Inductive defs_has: defs -> def -> Prop :=
| defs_has_hit: forall d ds,
    defs_hasnt ds (label_of_def d) ->
    defs_has (defs_cons ds d) d
| defs_has_skip: forall d1 d2 ds,
    defs_has ds d1 ->
    label_of_def d2 <> label_of_def d1 ->
    defs_has (defs_cons ds d2) d1
(* only def_typ can be merged, def_fld and def_mtd must be unique *)
| defs_has_merge: forall L Lo1 Hi1 Lo2 Hi2 ds,
    defs_has ds (def_typ L Lo1 Hi1) ->
    defs_has (defs_cons ds (def_typ L Lo2 Hi2))
      (def_typ L (typ_or Lo1 Lo2) (typ_and Hi1 Hi2)).

(* ###################################################################### *)
(** ** Opening *)

(** Opening replaces in some syntax a bound variable with dangling index (k)
   by a free variable x. *)

Definition open_rec_avar (k: nat) (u: var) (a: avar) : avar :=
  match a with
  | avar_b i => If k = i then avar_f u else avar_b i
  | avar_f x => avar_f x
  end.

Fixpoint open_rec_typ (k: nat) (u: var) (T: typ) { struct T } : typ :=
  match T with
  | typ_top       => typ_top
  | typ_bot       => typ_bot
  | typ_rcd D     => typ_rcd (open_rec_dec k u D)
  | typ_sel a L   => typ_sel (open_rec_avar k u a) L
  | typ_and T1 T2 => typ_and (open_rec_typ k u T1) (open_rec_typ k u T2)
  | typ_or  T1 T2 => typ_or  (open_rec_typ k u T1) (open_rec_typ k u T2)
  end
with open_rec_dec (k: nat) (u: var) (D: dec) { struct D } : dec :=
  match D with
  | dec_typ L T U => dec_typ L (open_rec_typ k u T) (open_rec_typ k u U)
  | dec_fld l T   => dec_fld l (open_rec_typ k u T)
  | dec_mtd m T U => dec_mtd m (open_rec_typ k u T) (open_rec_typ k u U)
  end.

Fixpoint open_rec_trm (k: nat) (u: var) (t: trm) { struct t } : trm :=
  match t with
  | trm_var a      => trm_var (open_rec_avar k u a)
  | trm_sel e n    => trm_sel (open_rec_trm k u e) n
  | trm_call o m a => trm_call (open_rec_trm k u o) m (open_rec_trm k u a)
  | trm_new ds     => trm_new (open_rec_defs (*S k*) k u ds) (* TODO enable self ref *)
  end
with open_rec_def (k: nat) (u: var) (d: def) { struct d } : def :=
  match d with
  | def_typ L Lo Hi => def_typ L (open_rec_typ k u Lo) (open_rec_typ k u Hi)
  | def_fld f T a => def_fld f (open_rec_typ k u T) (open_rec_avar k u a)
  | def_mtd m T1 T2 e => def_mtd m (open_rec_typ k u T1) (open_rec_typ k u T2)
                       (open_rec_trm (S k) u e)
  end
with open_rec_defs (k: nat) (u: var) (ds: defs) { struct ds } : defs :=
  match ds with
  | defs_nil => defs_nil
  | defs_cons tl d => defs_cons (open_rec_defs k u tl) (open_rec_def k u d)
  end.

Definition open_avar u a := open_rec_avar  0 u a.
Definition open_typ  u t := open_rec_typ   0 u t.
Definition open_dec  u d := open_rec_dec   0 u d.
Definition open_trm  u e := open_rec_trm   0 u e.
Definition open_def  u d := open_rec_def   0 u d.
Definition open_defs u l := open_rec_defs  0 u l.

(* ###################################################################### *)
(** ** Free variables *)

Definition fv_avar (a: avar) : vars :=
  match a with
  | avar_b i => \{}
  | avar_f x => \{x}
  end.

Fixpoint fv_typ (T: typ) { struct T } : vars :=
  match T with
  | typ_top       => \{}
  | typ_bot       => \{}
  | typ_rcd D     => (fv_dec D)
  | typ_sel a L   => (fv_avar a)
  | typ_and T U   => (fv_typ T) \u (fv_typ U)
  | typ_or  T U   => (fv_typ T) \u (fv_typ U)
  end
with fv_dec (D: dec) { struct D } : vars :=
  match D with
  | dec_typ _ T U => (fv_typ T) \u (fv_typ U)
  | dec_fld _ T   => (fv_typ T)
  | dec_mtd _ T U => (fv_typ T) \u (fv_typ U)
  end.

(* Since we define defs ourselves instead of using [list def], we don't have any
   termination proof problems: *)
Fixpoint fv_trm (t: trm) : vars :=
  match t with
  | trm_var x        => (fv_avar x)
  | trm_new ds       => (fv_defs ds)
  | trm_sel t l      => (fv_trm t)
  | trm_call t1 m t2 => (fv_trm t1) \u (fv_trm t2)
  end
with fv_def (d: def) : vars :=
  match d with
  | def_typ _ T U => (fv_typ T) \u (fv_typ U)
  | def_fld _ T x => (fv_typ T) \u (fv_avar x)
  | def_mtd _ T U u => (fv_typ T) \u (fv_typ U) \u (fv_trm u)
  end
with fv_defs(ds: defs) : vars :=
  match ds with
  | defs_nil         => \{}
  | defs_cons tl d   => (fv_defs tl) \u (fv_def d)
  end.

Definition fv_ctx_types(G: ctx): vars := (fv_in_values (fun T => fv_typ T) G).

(* ###################################################################### *)
(** ** Operational Semantics *)

(** Note: Terms given by user are closed, so they only contain avar_b, no avar_f.
    Whenever we introduce a new avar_f (only happens in red_new), we choose one
    which is not in the store, so we never have name clashes. *)
Inductive red : trm -> sto -> trm -> sto -> Prop :=
  (* computation rules *)
  | red_sel : forall s x y l T ds,
      binds x ds s ->
      defs_has ds (def_fld l T y) ->
      red (trm_sel (trm_var (avar_f x)) l) s
          (trm_var y) s
  | red_call : forall s x y m ds T U body,
      binds x ds s ->
      defs_has ds (def_mtd m T U body) ->
      red (trm_call (trm_var (avar_f x)) m (trm_var (avar_f y))) s
          (open_trm y body) s
  | red_new : forall s ds x,
      x # s ->
      red (trm_new ds) s
          (trm_var (avar_f x)) (s & x ~ ds (*open_defs x ds*)) (* TODO enable self ref *)
  (* congruence rules *)
  | red_call1 : forall s o m a s' o',
      red o s o' s' ->
      red (trm_call o  m a) s
          (trm_call o' m a) s'
  | red_call2 : forall s x m a s' a',
      red a s a' s' ->
      red (trm_call (trm_var (avar_f x)) m a ) s
          (trm_call (trm_var (avar_f x)) m a') s'
  | red_sel1 : forall s o l s' o',
      red o s o' s' ->
      red (trm_sel o  l) s
          (trm_sel o' l) s'.

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

Reserved Notation "D1 && D2 == D3" (at level 40).
Reserved Notation "D1 || D2 == D3" (at level 40).

(* Not defined as a function because it's not total: Only defined if same kind of dec
   and same label. *)
Inductive intersect_dec: dec -> dec -> dec -> Prop :=
| intersect_dec_typ: forall L (T1 U1 T2 U2: typ),
    (dec_typ L T1 U1) && (dec_typ L T2 U2) == (dec_typ L (typ_or T1 T2) (typ_and U1 U2))
| intersect_dec_fld: forall l T1 T2,
    (dec_fld l T1) && (dec_fld l T2) == (dec_fld l (typ_and T1 T2))
| intersect_dec_mtd: forall m T1 U1 T2 U2,
    (dec_mtd m T1 U1) && (dec_mtd m T2 U2) == (dec_mtd m (typ_or T1 T2) (typ_and U1 U2))
where "D1 && D2 == D3" := (intersect_dec D1 D2 D3).

Inductive union_dec: dec -> dec -> dec -> Prop :=
| union_dec_typ: forall L T1 U1 T2 U2,
    (dec_typ L T1 U1) || (dec_typ L T2 U2) == (dec_typ L (typ_and T1 T2) (typ_or U1 U2))
| union_dec_fld: forall l T1 T2,
    (dec_fld l T1) || (dec_fld l T2) == (dec_fld l (typ_or T1 T2))
| union_dec_mtd: forall m T1 U1 T2 U2,
    (dec_mtd m T1 U1) || (dec_mtd m T2 U2) == (dec_mtd m (typ_and T1 T2) (typ_or U1 U2))
where "D1 || D2 == D3" := (union_dec D1 D2 D3).

(* Don't try out these:
   - allow transitivity only with a no-path-type in the middle (simp),
     add mode where path type in the middle is allowed (full)
     simp is not strong enough for what we need in invert_ty_var
     simp <=> full should hold, but is very hard to prove because imprecision
     on middle p.L
   - require that p.L in the middle of transitivity rule has good bounds
     doesnt' work because of imprecision (see below)
   *)

(*
Inductive trans_middle_ok: ctx -> typ -> Prop :=
| trans_middle_ok_top: forall G, trans_middle_ok G typ_top
| trans_middle_ok_bot: forall G, trans_middle_ok G typ_bot
| trans_middle_ok_rcd: forall G D, trans_middle_ok G (typ_rcd D)
| trans_middle_ok_sel: forall G p L,
    ty_trm G (pth2trm p) X ->
    subtyp G X (dec_typ L Lo Hi) -> (* imprecise and thus useless !! *)
    trans_middle_ok G (typ_sel p L)
| trans_middle_ok_and: forall G T1 T2, trans_middle_ok G (typ_and T1 T2)
| trans_middle_ok_or:  forall G T1 T2, trans_middle_ok G (typ_or  T1 T2).
*)

Inductive subtyp: ctx -> typ -> typ -> Prop :=
  | subtyp_refl: forall G T,
      subtyp G T T
  | subtyp_top: forall G T,
      subtyp G T typ_top
  | subtyp_bot: forall G T,
      subtyp G typ_bot T
  | subtyp_rcd: forall G D1 D2,
      subdec G D1 D2 ->
      subtyp G (typ_rcd D1) (typ_rcd D2)
  | subtyp_sel_l: forall G a L Lo Hi,
      ty_trm G (trm_var a) (typ_rcd (dec_typ L Lo Hi)) ->
      subtyp G (typ_sel a L) Hi
  | subtyp_sel_r: forall G a L Lo Hi,
      ty_trm G (trm_var a) (typ_rcd (dec_typ L Lo Hi)) ->
      subtyp G Lo (typ_sel a L)
  | subtyp_and: forall G S T1 T2,
      subtyp G S T1 ->
      subtyp G S T2 ->
      subtyp G S (typ_and T1 T2)
  | subtyp_and_l: forall G T1 T2 U,
      subtyp G T1 U ->
      subtyp G (typ_and T1 T2) U
  | subtyp_and_r: forall G T1 T2 U,
      subtyp G T2 U ->
      subtyp G (typ_and T1 T2) U
  | subtyp_or: forall G T1 T2 S,
      subtyp G T1 S ->
      subtyp G T2 S ->
      subtyp G (typ_or T1 T2) S
  | subtyp_or_l: forall G U T1 T2,
      subtyp G U T1 ->
      subtyp G U (typ_or T1 T2)
  | subtyp_or_r: forall G U T1 T2,
      subtyp G U T2 ->
      subtyp G U (typ_or T1 T2)
(* needed?
  ! subtyp_and_rcd: forall G D1 D2 D3,
      D1 && D2 == D3 ->
      subtyp G (typ_and (typ_rcd D1) (typ_rcd D2)) (typ_rcd D3)

  ! subtyp_or_rcd: forall G D1 D2 D3,
      D1 || D2 == D0 ->
      subtyp G (typ_rcd D0) (typ_or (typ_rcd D1) (typ_rcd D2))
  ! subtyp_trans: forall G T1 T2 T3,
      subtyp G T1 T2 ->
      subtyp G T2 T3 ->
      subtyp G T1 T3
*)
with subdec: ctx -> dec -> dec -> Prop :=
  | subdec_typ: forall G L Lo1 Hi1 Lo2 Hi2,
      subtyp G Lo2 Lo1 ->
      subtyp G Hi1 Hi2 ->
      subdec G (dec_typ L Lo1 Hi1) (dec_typ L Lo2 Hi2)
  | subdec_fld: forall G l T1 T2,
      subtyp G T1 T2 ->
      subdec G (dec_fld l T1) (dec_fld l T2)
  | subdec_mtd: forall G m S1 T1 S2 T2,
      subtyp G S2 S1 ->
      subtyp G T1 T2 ->
      subdec G (dec_mtd m S1 T1) (dec_mtd m S2 T2)
  | subdec_refl: forall G D,
      subdec G D D
with ty_trm: ctx -> trm -> typ -> Prop :=
  | ty_var: forall G x T,
      binds x T G ->
      ty_trm G (trm_var (avar_f x)) T
  | ty_sel: forall G t T l U,
      ty_trm G t T ->
      subtyp G T (typ_rcd (dec_fld l U)) ->
      ty_trm G (trm_sel t l) U
  | ty_call: forall G t T m U V u,
      ty_trm G t T ->
      subtyp G T (typ_rcd (dec_mtd m U V)) ->
      ty_trm G u U ->
      ty_trm G (trm_call t m u) V
  | ty_new: forall G ds T, (* TODO enable self reference *)
      ty_defs G ds T ->
      ty_trm G (trm_new ds) T
  | ty_sbsm: forall G t T U,
      ty_trm G t T ->
      subtyp G T U ->
      ty_trm G t U
with ty_def: ctx -> def -> dec -> Prop :=
  | ty_typ: forall G L S T,
      subtyp G S T -> (* <----- only allow realizable bounds *)
      ty_def G (def_typ L S T) (dec_typ L S T)
  | ty_fld: forall G l v T,
      ty_trm G (trm_var v) T ->
      ty_def G (def_fld l T v) (dec_fld l T)
  | ty_mtd: forall L m G S T t,
      (forall x, x \notin L -> ty_trm (G & x ~ S) (open_trm x t) T) ->
      ty_def G (def_mtd m S T t) (dec_mtd m S T)
with ty_defs: ctx -> defs -> typ -> Prop :=
  | ty_defs_nil: forall G,
      ty_defs G defs_nil typ_top
  | ty_defs_cons: forall G ds d T D,
      ty_defs G ds T ->
      ty_def G d D ->
      can_add G ds d ->
      ty_defs G (defs_cons ds d) (typ_and T (typ_rcd D))
with can_add: ctx -> defs -> def -> Prop :=
  | can_add_typ: forall G ds L Lo Hi,
      defs_hasnt ds (label_typ L) ->
      subtyp G Lo Hi ->
      can_add G ds (def_typ L Lo Hi)
  | can_refine_typ: forall G ds L Lo1 Hi1 Lo2 Hi2,
      defs_has ds (def_typ L Lo1 Hi1) ->
      (* added dec must have good bounds: *)
      subtyp G Lo2 Hi2 ->
      (* and if intersected with existing bounds, still good: *)
      subtyp G Lo1 Hi2 ->
      subtyp G Lo2 Hi1 ->
      can_add G ds (def_typ L Lo2 Hi2)
  | can_add_fld: forall G ds l T x,
      defs_hasnt ds (label_fld l) ->
      can_add G ds (def_fld l T x)
  | can_add_mtd: forall G ds m T1 T2 t,
      defs_hasnt ds (label_mtd m) ->
      can_add G ds (def_mtd m T1 T2 t).

(** *** Well-formed store *)
Inductive wf_sto: sto -> ctx -> Prop :=
  | wf_sto_empty : wf_sto empty empty
  | wf_sto_push : forall s G x ds T,
      wf_sto s G ->
      x # s ->
      x # G ->
      (* In lambda-DOT, ds may not use a self reference, so it's "G" and not "G & z ~ T" *)
      ty_defs G ds T ->
      (* No need to check if realizable bounds, because that's already done by ty_def *)
      wf_sto (s & x ~ ds) (G & x ~ T).

(* ###################################################################### *)
(** ** Statements we want to prove *)

Definition progress := forall s G e T,
  wf_sto s G ->
  ty_trm G e T ->
  (
    (* can step *)
    (exists e' s', red e s e' s') \/
    (* or is a value *)
    (exists x o, e = (trm_var (avar_f x)) /\ binds x o s)
  ).

Definition preservation := forall s G e T e' s',
  wf_sto s G -> ty_trm G e T -> red e s e' s' ->
  (exists G', wf_sto s' G' /\ ty_trm G' e' T).

(* ###################################################################### *)
(* ###################################################################### *)
(** * Infrastructure *)

(* ###################################################################### *)
(** ** Induction principles *)

Scheme trm_mut  := Induction for trm  Sort Prop
with   def_mut  := Induction for def  Sort Prop
with   defs_mut := Induction for defs Sort Prop.
Combined Scheme trm_mutind from trm_mut, def_mut, defs_mut.

Scheme typ_mut  := Induction for typ  Sort Prop
with   dec_mut  := Induction for dec  Sort Prop.
Combined Scheme typ_mutind from typ_mut, dec_mut.

Scheme subtyp_mut  := Induction for subtyp  Sort Prop
with   subdec_mut  := Induction for subdec  Sort Prop
with   ty_trm_mut  := Induction for ty_trm  Sort Prop
with   ty_def_mut  := Induction for ty_def  Sort Prop
with   ty_defs_mut := Induction for ty_defs Sort Prop
with   can_add_mut := Induction for can_add Sort Prop.
Combined Scheme ty_mutind from subtyp_mut, subdec_mut,
                               ty_trm_mut, ty_def_mut, ty_defs_mut, can_add_mut.

Scheme subtyp_mut2  := Induction for subtyp  Sort Prop
with   subdec_mut2  := Induction for subdec  Sort Prop.
Combined Scheme subtyp_subdec_mut from subtyp_mut2, subdec_mut2.

(* ###################################################################### *)
(** ** Tactics *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars      => x         ) in
  let B := gather_vars_with (fun x : var       => \{ x }    ) in
  let C := gather_vars_with (fun x : ctx       => (dom x) \u (fv_ctx_types x)) in
  let D := gather_vars_with (fun x : sto       => dom x     ) in
  let E := gather_vars_with (fun x : avar      => fv_avar  x) in
  let F := gather_vars_with (fun x : trm       => fv_trm   x) in
  let G := gather_vars_with (fun x : def       => fv_def   x) in
  let H := gather_vars_with (fun x : defs      => fv_defs  x) in
  let I := gather_vars_with (fun x : typ       => fv_typ   x) in
  let J := gather_vars_with (fun x : dec       => fv_dec   x) in
  constr:(A \u B \u C \u D \u E \u F \u G \u H \u I \u J).

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

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

Hint Constructors subtyp subdec ty_trm ty_def ty_defs can_add.
Hint Constructors defs_has defs_hasnt.

Lemma fresh_push_eq_inv: forall A x a (E: env A),
  x # (E & x ~ a) -> False.
Proof.
  intros. rewrite dom_push in H. false H. rewrite in_union.
  left. rewrite in_singleton. reflexivity.
Qed.

(* ###################################################################### *)
(** ** Definition of var-by-var substitution *)

(** Note that substitution is not part of the definitions, because for the
    definitions, opening is sufficient. For the proofs, however, we also
    need substitution, but only var-by-var substitution, not var-by-term
    substitution. That's why we don't need a judgment asserting that a term
    is locally closed. *)

Definition subst_avar (z: var) (u: var) (a: avar) : avar :=
  match a with
  | avar_b i => avar_b i
  | avar_f x => If x = z then (avar_f u) else (avar_f x)
  end.

Fixpoint subst_typ (z: var) (u: var) (T: typ) { struct T } : typ :=
  match T with
  | typ_top     => typ_top
  | typ_bot     => typ_bot
  | typ_rcd D   => typ_rcd (subst_dec z u D)
  | typ_sel a L => typ_sel (subst_avar z u a) L
  | typ_and T1 T2 => typ_and (subst_typ z u T1) (subst_typ z u T2)
  | typ_or  T1 T2 => typ_or  (subst_typ z u T1) (subst_typ z u T2)
  end
with subst_dec (z: var) (u: var) (D: dec) { struct D } : dec :=
  match D with
  | dec_typ L T U => dec_typ L (subst_typ z u T) (subst_typ z u U)
  | dec_fld l T   => dec_fld l (subst_typ z u T)
  | dec_mtd m T U => dec_mtd m (subst_typ z u T) (subst_typ z u U)
  end.

Fixpoint subst_trm (z: var) (u: var) (t: trm) : trm :=
  match t with
  | trm_var x        => trm_var (subst_avar z u x)
  | trm_new ds       => trm_new (subst_defs z u ds)
  | trm_sel t l      => trm_sel (subst_trm z u t) l
  | trm_call t1 m t2 => trm_call (subst_trm z u t1) m (subst_trm z u t2)
  end
with subst_def (z: var) (u: var) (d: def) : def :=
  match d with
  | def_typ L T1 T2   => def_typ L (subst_typ z u T1) (subst_typ z u T2)
  | def_fld l T x     => def_fld l (subst_typ z u T) (subst_avar z u x)
  | def_mtd m T1 T2 b => def_mtd m (subst_typ z u T1) (subst_typ z u T2) (subst_trm z u b)
  end
with subst_defs (z: var) (u: var) (ds: defs) : defs :=
  match ds with
  | defs_nil => defs_nil
  | defs_cons rest d => defs_cons (subst_defs z u rest) (subst_def z u d)
  end.

Definition subst_ctx (z: var) (u: var) (G: ctx) : ctx := map (subst_typ z u) G.

(* ###################################################################### *)
(** ** Lemmas for var-by-var substitution *)

Lemma subst_fresh_avar: forall x y,
  (forall a: avar, x \notin fv_avar a -> subst_avar x y a = a).
Proof.
  intros. destruct* a. simpl. case_var*. simpls. notin_false.
Qed.

Lemma subst_fresh_typ_dec_decs: forall x y,
  (forall T : typ , x \notin fv_typ  T  -> subst_typ  x y T  = T ) /\
  (forall d : dec , x \notin fv_dec  d  -> subst_dec  x y d  = d ).
Proof.
  intros x y. apply typ_mutind; intros; simpls; f_equal*. apply* subst_fresh_avar.
Qed.

Definition subst_fresh_typ(x y: var) := proj1 (subst_fresh_typ_dec_decs x y).

Lemma subst_fresh_trm_def_defs: forall x y,
  (forall t : trm , x \notin fv_trm  t  -> subst_trm  x y t  = t ) /\
  (forall d : def , x \notin fv_def  d  -> subst_def  x y d  = d ) /\
  (forall ds: defs, x \notin fv_defs ds -> subst_defs x y ds = ds).
Proof.
  intros x y. apply trm_mutind; intros; simpls; f_equal*;
    (apply* subst_fresh_avar || apply* subst_fresh_typ_dec_decs).
Qed.

Lemma invert_fv_ctx_types_push: forall x z T G,
  x \notin fv_ctx_types (G & z ~ T) -> x \notin fv_typ T /\ x \notin (fv_ctx_types G).
Proof.
  introv N.
  unfold fv_ctx_types in *.
  unfold fv_in_values in *.
  rewrite <- cons_to_push in *.
  rewrite values_def in *.
  unfold LibList.map in *.
  do 2 rewrite LibList.fold_right_cons in *.
  simpl in *.
  apply notin_union in N. exact N.
Qed.

Lemma subst_fresh_ctx: forall x y G,
  x \notin fv_ctx_types G -> subst_ctx x y G = G.
Proof.
  intros x y.
  apply (env_ind (fun G => x \notin fv_ctx_types G -> subst_ctx x y G = G)).
  + intro N. unfold subst_ctx. apply map_empty.
  + intros G z T IH N.
    apply invert_fv_ctx_types_push in N. destruct N as [N1 N2].
    unfold subst_ctx in *. rewrite map_push.
    rewrite (IH N2).
    rewrite (subst_fresh_typ _ _ N1).
    reflexivity.
Qed.

Definition subst_fvar(x y z: var): var := If x = z then y else z.

Lemma subst_open_commute_avar: forall x y u,
  (forall a: avar, forall n: Datatypes.nat,
    subst_avar x y (open_rec_avar n u a)
    = open_rec_avar n (subst_fvar x y u) (subst_avar  x y a)).
Proof.
  intros. unfold subst_fvar, subst_avar, open_avar, open_rec_avar. destruct a.
  + repeat case_if; auto.
  + case_var*.
Qed.

(* "open and then substitute" = "substitute and then open" *)
Lemma subst_open_commute_typ_dec_decs: forall x y u,
  (forall t : typ, forall n: Datatypes.nat,
     subst_typ x y (open_rec_typ n u t)
     = open_rec_typ n (subst_fvar x y u) (subst_typ x y t)) /\
  (forall d : dec , forall n: Datatypes.nat,
     subst_dec x y (open_rec_dec n u d)
     = open_rec_dec n (subst_fvar x y u) (subst_dec x y d)).
Proof.
  intros. apply typ_mutind; intros; simpl; f_equal*. apply subst_open_commute_avar.
Qed.

(* "open and then substitute" = "substitute and then open" *)
Lemma subst_open_commute_trm_def_defs: forall x y u,
  (forall t : trm, forall n: Datatypes.nat,
     subst_trm x y (open_rec_trm n u t)
     = open_rec_trm n (subst_fvar x y u) (subst_trm x y t)) /\
  (forall d : def , forall n: Datatypes.nat,
     subst_def x y (open_rec_def n u d)
     = open_rec_def n (subst_fvar x y u) (subst_def x y d)) /\
  (forall ds: defs, forall n: Datatypes.nat,
     subst_defs x y (open_rec_defs n u ds)
     = open_rec_defs n (subst_fvar x y u) (subst_defs x y ds)).
Proof.
  intros. apply trm_mutind; intros; simpl; f_equal*;
    (apply* subst_open_commute_avar || apply* subst_open_commute_typ_dec_decs).
Qed.

Lemma subst_open_commute_trm: forall x y u t,
  subst_trm x y (open_trm u t) = open_trm (subst_fvar x y u) (subst_trm x y t).
Proof.
  intros. apply* subst_open_commute_trm_def_defs.
Qed.

Lemma subst_open_commute_defs: forall x y u ds,
  subst_defs x y (open_defs u ds) = open_defs (subst_fvar x y u) (subst_defs x y ds).
Proof.
  intros. apply* subst_open_commute_trm_def_defs.
Qed.

Lemma subst_open_commute_typ: forall x y u T,
  subst_typ x y (open_typ u T) = open_typ (subst_fvar x y u) (subst_typ x y T).
Proof.
  intros. apply* subst_open_commute_typ_dec_decs.
Qed.

Lemma subst_open_commute_dec: forall x y u D,
  subst_dec x y (open_dec u D) = open_dec (subst_fvar x y u) (subst_dec x y D).
Proof.
  intros. apply* subst_open_commute_typ_dec_decs.
Qed.

(* "Introduce a substitution after open": Opening a term t with a var u is the
   same as opening t with x and then replacing x by u. *)
Lemma subst_intro_trm: forall x u t, x \notin (fv_trm t) ->
  open_trm u t = subst_trm x u (open_trm x t).
Proof.
  introv Fr. unfold open_trm. rewrite* subst_open_commute_trm.
  destruct (@subst_fresh_trm_def_defs x u) as [Q _]. rewrite* (Q t).
  unfold subst_fvar. case_var*.
Qed.

Lemma subst_intro_defs: forall x u ds, x \notin (fv_defs ds) ->
  open_defs u ds = subst_defs x u (open_defs x ds).
Proof.
  introv Fr. unfold open_trm. rewrite* subst_open_commute_defs.
  destruct (@subst_fresh_trm_def_defs x u) as [_ [_ Q]]. rewrite* (Q ds).
  unfold subst_fvar. case_var*.
Qed.

Lemma subst_intro_typ: forall x u T, x \notin (fv_typ T) ->
  open_typ u T = subst_typ x u (open_typ x T).
Proof.
  introv Fr. unfold open_typ. rewrite* subst_open_commute_typ.
  destruct (@subst_fresh_typ_dec_decs x u) as [Q _]. rewrite* (Q T).
  unfold subst_fvar. case_var*.
Qed.

Lemma subst_intro_dec: forall x u D, x \notin (fv_dec D) ->
  open_dec u D = subst_dec x u (open_dec x D).
Proof.
  introv Fr. unfold open_trm. rewrite* subst_open_commute_dec.
  destruct (@subst_fresh_typ_dec_decs x u) as [_ Q]. rewrite* (Q D).
  unfold subst_fvar. case_var*.
Qed.

Lemma subst_undo_avar: forall x y,
  (forall a, y \notin fv_avar a -> (subst_avar y x (subst_avar x y a)) = a).
Proof.
  intros. unfold subst_avar, subst_fvar, open_avar, open_rec_avar; destruct a.
  + reflexivity.
  + unfold fv_avar in H. assert (y <> v) by auto. repeat case_if; reflexivity.
Qed.

Lemma subst_undo_typ_dec_decs: forall x y,
   (forall T , y \notin fv_typ  T  -> (subst_typ  y x (subst_typ  x y T )) = T )
/\ (forall D , y \notin fv_dec  D  -> (subst_dec  y x (subst_dec  x y D )) = D ).
Proof.
  intros.
  apply typ_mutind; intros; simpl; unfold fv_typ, fv_dec in *; f_equal*.
  apply* subst_undo_avar.
Qed.

Lemma subst_undo_trm_def_defs: forall x y,
   (forall t , y \notin fv_trm  t  -> (subst_trm  y x (subst_trm  x y t )) = t )
/\ (forall d , y \notin fv_def  d  -> (subst_def  y x (subst_def  x y d )) = d )
/\ (forall ds, y \notin fv_defs ds -> (subst_defs y x (subst_defs x y ds)) = ds).
Proof.
  intros.
  apply trm_mutind; intros; simpl; unfold fv_trm, fv_def, fv_defs in *; f_equal*;
    (apply* subst_undo_avar || apply* subst_undo_typ_dec_decs).
Qed.

Lemma subst_typ_undo: forall x y T,
  y \notin fv_typ T -> (subst_typ y x (subst_typ x y T)) = T.
Proof.
  apply* subst_undo_typ_dec_decs.
Qed.

Lemma subst_dec_undo: forall x y D,
  y \notin fv_dec D -> (subst_dec y x (subst_dec x y D)) = D.
Proof.
  apply* subst_undo_typ_dec_decs.
Qed.

Lemma subst_trm_undo: forall x y t,
  y \notin fv_trm t -> (subst_trm y x (subst_trm x y t)) = t.
Proof.
  apply* subst_undo_trm_def_defs.
Qed.

(* ###################################################################### *)
(** ** Transitivity *)

Hint Constructors subtyp subdec.

Lemma middle_top_transitivity: forall G T1 T3,
(*subtyp G T1 typ_top (<- needs no hyp) *)
  subtyp G typ_top T3 ->
  subtyp G T1 T3.
Proof.
  introv St23. gen_eq T2: typ_top. gen T1.
  induction St23; introv Eq1; subst; eauto; try discriminate.
Qed.

Lemma middle_bot_transitivity: forall G T1 T3,
  subtyp G T1 typ_bot ->
  (* subtyp G typ_bot T3 (<- needs no hyp) *)
  subtyp G T1 T3.
Proof.
  introv St12. gen_eq T2: typ_bot. gen T3.
  induction St12; introv Eq1; subst; eauto; try discriminate.
Qed.

Lemma ty_var_mix_bounds: forall G a L Lo1 Hi1 Lo2 Hi2,
  ty_trm G (trm_var a) (typ_rcd (dec_typ L Lo1 Hi1)) ->
  ty_trm G (trm_var a) (typ_rcd (dec_typ L Lo2 Hi2)) ->
  ty_trm G (trm_var a) (typ_rcd (dec_typ L Lo1 Hi2)).
Abort.

(* TODO how can we prove this?? *)
Lemma ty_var_good_bounds: forall G a L Lo1 Hi1 Lo2 Hi2,
  ty_trm G (trm_var a) (typ_rcd (dec_typ L Lo1 Hi1)) ->
  ty_trm G (trm_var a) (typ_rcd (dec_typ L Lo2 Hi2)) ->
  subtyp G Lo1 Hi2.
Admitted.

Definition pair_lt(p1 p2: nat*nat): Prop := (fst p1) < (fst p2) /\ (snd p1) < (snd p2).

Definition ms := (@well_founded_induction_type_2 nat nat pair_lt).

Axiom holds: forall P: Prop, P.

Lemma transitivity: forall G T1 T2 T3,
  subtyp G T1 T2 ->
  subtyp G T2 T3 ->
  subtyp G T1 T3.
Proof.
  introv St12 St23. induction St12.
  + (* case subtyp_refl *) eauto.
  + (* case subtyp_top *)
    apply (middle_top_transitivity _ St23).
  + (* case subtyp_bot *) eauto.
  + (* case subtyp_rcd *)
    gen_eq T2: (typ_rcd D2). induction St23; introv Eq; subst.
    - (* case subtyp_refl *) eauto.
    - (* case subtyp_top *) eauto.
    - (* case subtyp_bot *) discriminate.
    - (* case subtyp_rcd *)
      inversions Eq.
      admit. (* TODO subdecs_trans *)
    - (* case subtyp_sel_l *) discriminate.
    - (* case subtyp_sel_r *)
      apply subtyp_sel_r with Hi.
      apply (ty_sbsm H0).
      apply subtyp_rcd.
      refine (subdec_typ _ _ (subtyp_refl _ _)).
      apply (subtyp_rcd H).
    - (* case subtyp_and *) eauto.
    - (* case subtyp_and_l *) discriminate.
    - (* case subtyp_and_r *) discriminate.
    - (* case subtyp_or *) discriminate.
    - (* case subtyp_or_l *) eauto.
    - (* case subtyp_or_r *) eauto.
  + (* case subtyp_sel_l *) eauto.
  + (* case subtyp_sel_r *)
    gen_eq T2: (typ_sel a L). induction St23; introv Eq; subst.
    - (* case subtyp_refl *) eauto.
    - (* case subtyp_top *) eauto.
    - (* case subtyp_bot *) discriminate.
    - (* case subtyp_rcd *) discriminate.
    - (* case subtyp_sel_l *)
      inversions Eq.
      apply (ty_var_good_bounds H H0).
    - (* case subtyp_sel_r *)
      apply subtyp_sel_r with Hi0.
      apply (ty_sbsm H0).
      apply subtyp_rcd.
      refine (subdec_typ _ _ (subtyp_refl _ _)).
      apply (subtyp_sel_r H).
    - (* case subtyp_and *) eauto.
    - (* case subtyp_and_l *) discriminate.
    - (* case subtyp_and_r *) discriminate.
    - (* case subtyp_or *) discriminate.
    - (* case subtyp_or_l *) eauto.
    - (* case subtyp_or_r *) eauto.
  + (* case subtyp_and *)
    rename T1 into T2a, T2 into T2b, S into T1.
    gen_eq T2: (typ_and T2a T2b). induction St23; introv Eq; subst.
    - (* case subtyp_refl *) eauto.
    - (* case subtyp_top *) eauto.
    - (* case subtyp_bot *) discriminate.
    - (* case subtyp_rcd *) discriminate.
    - (* case subtyp_sel_l *) discriminate.
    - (* case subtyp_sel_r *)
      apply subtyp_sel_r with Hi.
      apply (ty_sbsm H).
      apply subtyp_rcd.
      refine (subdec_typ _ _ (subtyp_refl _ _)).
      apply (subtyp_and St12_1 St12_2).
    - (* case subtyp_and *)
      rename T0 into T3a, T2 into T3b. clear IHSt12_1 IHSt12_2 IHSt23_1 IHSt23_2.
      (* use IH, decreasing on rhs, to get: *)
      assert (St13a: subtyp G T1 T3a) by apply holds.
      assert (St13b: subtyp G T1 T3b) by apply holds.
      apply (subtyp_and St13a St13b).
    - (* case subtyp_and_l *)
      inversions Eq. rename U into T3.
      (* T1 <: T2a & T2b <: T3
            |            |
            V            V
         T1 <: T2a   T2a <: T3
         T1 <: T2b
        So we can invoke IH on T1<:T2a<:T3 and decrease on both arguments -> OK *)
      apply holds.
    - (* case subtyp_and_r *)
      (* same as above *)
      apply holds.
    - (* case subtyp_or *) discriminate.
    - (* case subtyp_or_l *)
      rename T0 into T3a, T2 into T3b.
      apply subtyp_or_l.
      apply holds. (* decreases on rhs *)
    - (* case subtyp_or_r *)
      rename T0 into T3a, T2 into T3b.
      apply subtyp_or_r.
      apply holds. (* decreases on rhs *)
  + (* case subtyp_and_l *)
    rename T1 into T1a, T2 into T1b, U into T2.
    apply subtyp_and_l.
    (*     T1a & T1b <: T2 <: T3
                     |     |
                     V     V
                 T1a <: T2 <: T3
        decreases on lhs, stays on rhs -> ok *)
    apply holds.
  + (* case subtyp_and_r *)
    rename T1 into T1a, T2 into T1b, U into T2.
    apply subtyp_and_r.
    (*     T1a & T1b <: T2 <: T3
                     |     |
                     V     V
                 T1b <: T2 <: T3
        decreases on lhs, stays on rhs -> ok *)
    apply holds.
  + (* case subtyp_or *)
    rename T1 into T1a, T2 into T1b, S into T2.
    (* use IH, decreasing on lhs, to get: *)
    assert (St1a3: subtyp G T1a T3) by apply holds.
    assert (St1b3: subtyp G T1b T3) by apply holds.
    apply (subtyp_or St1a3 St1b3).
  + (* case subtyp_or_l *)
    rename T1 into T2a, T2 into T2b, U into T1.
    gen_eq T2: (typ_or T2a T2b). inversions St23; introv Eq; subst.
    - (* case subtyp_refl *) eauto.
    - (* case subtyp_top *) eauto.
    - (* case subtyp_bot *) discriminate.
    - (* case subtyp_rcd *) discriminate.
    - (* case subtyp_sel_l *) discriminate.
    - (* case subtyp_sel_r *)
      apply subtyp_sel_r with Hi.
      apply (ty_sbsm H).
      apply subtyp_rcd.
      refine (subdec_typ _ _ (subtyp_refl _ _)).
      apply (subtyp_or_l _ St12).
    - (* case subtyp_and *)
      rename T0 into T3a, T4 into T3b.
      (* use IH, decreasing on rhs, to get: *)
      assert (St13a: subtyp G T1 T3a) by apply holds.
      assert (St13b: subtyp G T1 T3b) by apply holds.
      apply (subtyp_and St13a St13b).
    - (* case subtyp_and_l *) discriminate.
    - (* case subtyp_and_r *) discriminate.
    - (* case subtyp_or *)
      inversions Eq.
      (* T1 <: (T2a | T2b) <: T3
            |              |
            V              V
         T1 <: T2a     T2a <: T3
                       T2b <: T3
      So we can invoke IH on T1<:T2a<:T3 and decrease on both arguments -> OK *)
      apply holds.
    - (* case subtyp_or_l *)
      rename T0 into T3a, T4 into T3b.
      apply subtyp_or_l.
      (* T1 <: (T2a | T2b) <: (T3a | T3b)
            |              |
            V              V
          keep (T2a | T2b) <: T3a
      decreases on rhs, stays same on lhs  *)
      apply holds.
    - (* case subtyp_or_r *)
      apply holds. (* same as above *)
  + (* case subtyp_or_r *)
    apply holds. (* symmetric to subtyp_or_l *)
Qed.

Print Assumptions transitivity.

(* ###################################################################### *)
(** ** Trivial inversion lemmas *)

Lemma invert_subdec_typ_sync_right: forall G D2 L Lo1 Hi1,
  subdec G (dec_typ L Lo1 Hi1) D2 ->
  (dec_typ L Lo1 Hi1) = D2 \/
  exists Lo2 Hi2, D2 = (dec_typ L Lo2 Hi2) /\
                  subtyp G Lo2 Lo1 /\
                  subtyp G Hi1 Hi2.
Proof.
  introv Sd. inversions Sd.
  - right. exists Lo2 Hi2. auto.
  - left. reflexivity.
Qed.

Lemma invert_subdec_typ_sync_left: forall G D1 L Lo2 Hi2,
   subdec G D1 (dec_typ L Lo2 Hi2) ->
   D1 = (dec_typ L Lo2 Hi2) \/
   exists Lo1 Hi1, D1 = (dec_typ L Lo1 Hi1) /\
                   subtyp G Lo2 Lo1 /\
                   subtyp G Hi1 Hi2.
Proof.
  introv Sd. inversions Sd.
  - right. exists Lo1 Hi1. auto.
  - auto.
Qed.

Lemma invert_subdec_fld_sync_left: forall G D l T2,
   subdec G D (dec_fld l T2) ->
   D = (dec_fld l T2) \/
   exists T1, D = (dec_fld l T1) /\
              subtyp G T1 T2.
Proof.
  introv Sd. inversions Sd.
  - right. exists T1. auto.
  - auto.
Qed.

Lemma invert_subdec_mtd_sync_left: forall G D m T2 U2,
   subdec G D (dec_mtd m T2 U2) ->
   D = (dec_mtd m T2 U2) \/
   exists T1 U1, D = (dec_mtd m T1 U1) /\
                 subtyp G T2 T1 /\
                 subtyp G U1 U2.
Proof.
  introv Sd. inversions Sd.
  - right. exists S1 T1. auto.
  - auto.
Qed.

Lemma invert_ty_defs_cons: forall G ds0 T1 T2,
  ty_defs G ds0 (typ_and T1 T2) ->
  exists d ds D, ds0 = defs_cons ds d /\
                 ty_defs G ds T1 /\
                 T2 = typ_rcd D /\
                 ty_def G d D.
Proof.
  introv H. inversions H. exists d ds D. auto.
Qed.

Lemma wf_sto_to_ok_s: forall s G,
  wf_sto s G -> ok s.
Proof. intros. induction H; jauto. Qed.

Lemma wf_sto_to_ok_G: forall s G,
  wf_sto s G -> ok G.
Proof. intros. induction H; jauto. Qed.

Hint Resolve wf_sto_to_ok_s wf_sto_to_ok_G.

Lemma ctx_binds_to_sto_binds: forall s G x T,
  wf_sto s G ->
  binds x T G ->
  exists o, binds x o s.
Proof.
  introv Wf Bi. gen x T Bi. induction Wf; intros.
  + false* binds_empty_inv.
  + unfolds binds. rewrite get_push in *. case_if.
    - eauto.
    - eauto.
Qed.

Lemma sto_binds_to_ctx_binds: forall s G x ds,
  wf_sto s G ->
  binds x ds s ->
  exists T, binds x T G.
Proof.
  introv Wf Bi. gen x Bi. induction Wf; intros.
  + false* binds_empty_inv.
  + unfolds binds. rewrite get_push in *. case_if.
    - inversions Bi. exists T. reflexivity.
    - auto.
Qed.

Lemma sto_unbound_to_ctx_unbound: forall s G x,
  wf_sto s G ->
  x # s ->
  x # G.
Proof.
  introv Wf Ub_s.
  induction Wf.
  + auto.
  + destruct (classicT (x0 = x)) as [Eq | Ne].
    - subst. false (fresh_push_eq_inv Ub_s).
    - auto.
Qed.

Lemma ctx_unbound_to_sto_unbound: forall s G x,
  wf_sto s G ->
  x # G ->
  x # s.
Proof.
  introv Wf Ub.
  induction Wf.
  + auto.
  + destruct (classicT (x0 = x)) as [Eq | Ne].
    - subst. false (fresh_push_eq_inv Ub).
    - auto.
Qed.

(* TODO needs subtyping transitivity
Lemma invert_ty_var: forall G x T,
  ty_trm G (trm_var (avar_f x)) T ->
  exists T', subtyp G T' T /\ binds x T' G.
Proof.
  introv Ty. gen_eq t: (trm_var (avar_f x)). gen x.
  induction Ty; intros x' Eq; try (solve [ discriminate ]).
  + inversions Eq. exists T.
    apply (conj (subtyp_refl _ _)). assumption.
  + subst. specialize (IHTy _ eq_refl). destruct IHTy as [T' [St Bi]].
    exists T'. split.
    - apply subtyp_trans with T.
      * apply St.
      * apply H.
    - apply Bi.
Qed.
*)

(* ###################################################################### *)
(** ** Weakening *)

Lemma weakening:
   (forall G T1 T2, subtyp G T1 T2 -> forall G1 G2 G3,
      G = G1 & G3 ->
      ok (G1 & G2 & G3) ->
      subtyp (G1 & G2 & G3) T1 T2)
/\ (forall G D1 D2, subdec G D1 D2 -> forall G1 G2 G3,
      G = G1 & G3 ->
      ok (G1 & G2 & G3) ->
      subdec (G1 & G2 & G3) D1 D2)
/\ (forall G t T, ty_trm G t T -> forall G1 G2 G3,
      G = G1 & G3 ->
      ok (G1 & G2 & G3) ->
      ty_trm (G1 & G2 & G3) t T)
/\ (forall G d D, ty_def G d D -> forall G1 G2 G3,
      G = G1 & G3 ->
      ok (G1 & G2 & G3) ->
      ty_def (G1 & G2 & G3) d D)
/\ (forall G ds Ds, ty_defs G ds Ds -> forall G1 G2 G3,
      G = G1 & G3 ->
      ok (G1 & G2 & G3) ->
      ty_defs (G1 & G2 & G3) ds Ds)
/\ (forall G ds d, can_add G ds d -> forall G1 G2 G3,
      G = G1 & G3 ->
      ok (G1 & G2 & G3) ->
      can_add (G1 & G2 & G3) ds d).
Proof.
  apply ty_mutind; intros; subst; auto.
  apply* subtyp_sel_l.
  apply* subtyp_sel_r.
  apply ty_var. apply* binds_weaken.
  apply* ty_sel.
  apply* ty_call.
  apply ty_sbsm with T; auto.
  { apply_fresh ty_mtd as x.
    rewrite <- concat_assoc.
    refine (H x _ G1 G2 (G3 & x ~ S) _ _).
    - auto.
    - symmetry. apply concat_assoc.
    - rewrite concat_assoc. auto.
  }
  apply* can_refine_typ.
Qed.

Lemma weaken_subtyp_middle: forall G1 G2 G3 S U,
  ok (G1 & G2 & G3) ->
  subtyp (G1      & G3) S U ->
  subtyp (G1 & G2 & G3) S U.
Proof.
  destruct weakening as [W _].
  introv Hok123 Hst.
  specialize (W (G1 & G3) S U Hst).
  specialize (W G1 G2 G3 eq_refl Hok123).
  apply W.
Qed.

Lemma env_add_empty: forall (P: ctx -> Prop) (G: ctx), P G -> P (G & empty).
Proof.
  intros.
  assert ((G & empty) = G) by apply concat_empty_r.
  rewrite -> H0. assumption.
Qed.

Lemma env_remove_empty: forall (P: ctx -> Prop) (G: ctx), P (G & empty) -> P G.
Proof.
  intros.
  assert ((G & empty) = G) by apply concat_empty_r.
  rewrite <- H0. assumption.
Qed.

Lemma weaken_subtyp_end: forall G1 G2 S U,
  ok (G1 & G2) ->
  subtyp G1        S U ->
  subtyp (G1 & G2) S U.
Proof.
  introv Hok Hst.
  apply (env_remove_empty (fun G0 => subtyp G0 S U) (G1 & G2)).
  apply weaken_subtyp_middle.
  apply (env_add_empty (fun G0 => ok G0) (G1 & G2) Hok).
  apply (env_add_empty (fun G0 => subtyp G0 S U) G1 Hst).
Qed.

Lemma weaken_subdec_middle: forall G1 G2 G3 S U,
  ok (G1 & G2 & G3) ->
  subdec (G1      & G3) S U ->
  subdec (G1 & G2 & G3) S U.
Proof.
  destruct weakening as [_ [W _]].
  introv Hok123 Hst.
  specialize (W (G1 & G3) S U Hst).
  specialize (W G1 G2 G3 eq_refl Hok123).
  apply W.
Qed.

Lemma weaken_subdec_end: forall G1 G2 D1 D2,
  ok (G1 & G2) ->
  subdec G1        D1 D2 ->
  subdec (G1 & G2) D1 D2.
Proof.
  introv Ok Sd.
  destruct weakening as [_ [W _]].
  rewrite <- (concat_empty_r G1) in Sd.
  specialize (W (G1 & empty) D1 D2 Sd G1 G2 empty).
  repeat progress rewrite concat_empty_r in *.
  apply (W eq_refl Ok).
Qed.

Lemma weaken_ty_trm_end: forall G1 G2 e T,
  ok (G1 & G2) -> ty_trm G1 e T -> ty_trm (G1 & G2) e T.
Proof.
  intros.
  destruct weakening as [_ [_ [W _]]].
  rewrite <- (concat_empty_r (G1 & G2)).
  apply (W (G1 & empty)); rewrite* concat_empty_r.
Qed.

Lemma weaken_ty_defs_end: forall G1 G2 is Ds,
  ok (G1 & G2) -> ty_defs G1 is Ds -> ty_defs (G1 & G2) is Ds.
Proof.
  intros.
  destruct weakening as [_ [_ [_ [_ [W _]]]]].
  rewrite <- (concat_empty_r (G1 & G2)).
  apply (W (G1 & empty)); rewrite* concat_empty_r.
Qed.

Lemma weaken_ty_trm_middle: forall G1 G2 G3 t T,
  ok (G1 & G2 & G3) -> ty_trm (G1 & G3) t T -> ty_trm (G1 & G2 & G3) t T.
Proof.
  intros. apply* weakening.
Qed.

(* ###################################################################### *)
(** ** Misc *)

Lemma vars_dont_type_in_empty_env: forall G t T,
  ty_trm G t T ->
  forall x, t = (trm_var (avar_f x)) ->
  G = empty ->
  False.
Proof.
  introv Ty. induction Ty; try discriminate; intros x' Eq1 Eq2; inversions Eq1.
  + (* case ty_var *)
    apply (binds_empty_inv H).
  + (* case ty_sbsm *)
    inversions H0. apply* IHTy.
Qed.

(* ###################################################################### *)
(** ** More inversion lemmas *)

Lemma invert_wf_sto: forall s G,
  wf_sto s G ->
  forall x T2,
  ty_trm G (trm_var (avar_f x)) T2 ->
  exists ds G1 G2 T1,
    G = G1 & x ~ T1 & G2 /\
    ty_defs G1 ds T1.
Proof.
  intros s G Wf. induction Wf; intros.
  + exfalso. apply (vars_dont_type_in_empty_env H eq_refl eq_refl).
  + rename T into X, H2 into Tyy, x0 into y, T2 into Y2.
    apply invert_ty_var in Tyy. destruct Tyy as [Y1 [St BiG]].
    unfold binds in BiG. rewrite get_push in BiG.
    case_if.
    - inversions BiG.
      exists ds G (@empty typ) Y1. rewrite concat_empty_r.
      apply (conj eq_refl H1).
    - specialize (IHWf y Y1 (ty_var BiG)).
      destruct IHWf as [dsY [G1 [G2 [Y' [EqG TydsY]]]]]. subst.
      lets Eq: (binds_middle_eq_inv BiG (wf_sto_to_ok_G Wf)). subst Y'.
      exists dsY G1 (G2 & x ~ X) Y1.
      rewrite concat_assoc.
      apply (conj eq_refl TydsY).
Qed.

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

Lemma impossible_subtyping_first_try: forall G T1 T2,
  subtyp G T1 T2 ->
  (T1 = typ_top -> T2 = typ_bot \/
                   (exists D2, T2 = typ_rcd D2) -> False) /\
  ((exists D1, T1 = typ_rcd D1) -> T2 = typ_bot -> False).
Proof.
  introv St. induction St; (split;
  [ (intros Eq1 Eqs; destruct Eqs as [Eq2 | [D2' Eq2]])
  | (intros Eq1 Eq2; destruct Eq1 as [D1' Eq1])]);
  subst; try discriminate.
  + (* case subtyp_trans:  top <: T2 <: bot *)
    destruct IHSt1 as [IH1 IH2]. destruct IHSt2 as [IH3 IH4].
    specialize (IH1 eq_refl).
    destruct T2; eauto.
    - (* case top <: p.L <: bot *)
      rename t into L.
      (* exclude because we will require that path types not in middle of subtyp_trans *)
      admit.
    - (* case top <: U & V <: bot *)
      (* IHs not strong enough!! *)
      admit.
    - (* case top <: U | V <: bot *)
      (* IHs not strong enough!! *)
      admit.
  + (* case subtyp_trans: top <: T2 <: (typ_rcd D2) *)
    rename D2' into D2.
    destruct IHSt1 as [IH1 IH2]. destruct IHSt2 as [IH3 IH4].
    specialize (IH1 eq_refl).
    admit. (* basically the same story as above *)
  + (* case subtyp_trans: (typ_rcd D1) <: T2 <: typ_bot *)
    rename D1' into D1.
    destruct IHSt1 as [IH1 IH2]. destruct IHSt2 as [IH3 IH4].
    admit. (* basically the same story as above *)
Qed.

(* So instead of "T = typ_bot", "T = typ_top" and "exists D, T = typ_rcd D",
   we have to use more general propositions: *)

Inductive is_bot: typ -> Prop :=
| is_bot_bot: is_bot typ_bot
| is_bot_and_l: forall T1 T2, is_bot T1 -> is_bot (typ_and T1 T2)
| is_bot_and_r: forall T1 T2, is_bot T2 -> is_bot (typ_and T1 T2)
| is_bot_or: forall T1 T2, is_bot T1 -> is_bot T2 -> is_bot (typ_or T1 T2).

Inductive is_top: typ -> Prop :=
| is_top_top: is_top typ_top
| is_top_and: forall T1 T2, is_top T1 -> is_top T2 -> is_top (typ_and T1 T2)
| is_top_or_l: forall T1 T2, is_top T1 -> is_top (typ_or T1 T2)
| is_top_or_r: forall T1 T2, is_top T2 -> is_top (typ_or T1 T2).

Inductive is_rcd: typ -> Prop :=
| is_rcd_rcd:   forall D, is_rcd (typ_rcd D)
| is_rcd_and:   forall T1 T2, is_rcd T1 -> is_rcd T2 -> is_rcd (typ_and T1 T2)
| is_rcd_and_l: forall T1 T2, is_rcd T1 -> is_top T2 -> is_rcd (typ_and T1 T2)
| is_rcd_and_r: forall T1 T2, is_top T1 -> is_rcd T2 -> is_rcd (typ_and T1 T2)
| is_rcd_or:    forall T1 T2, is_rcd T1 -> is_rcd T2 -> is_rcd (typ_or  T1 T2)
| is_rcd_or_l:  forall T1 T2, is_rcd T1 -> is_bot T2 -> is_rcd (typ_or  T1 T2)
| is_rcd_or_r:  forall T1 T2, is_bot T1 -> is_rcd T2 -> is_rcd (typ_or  T1 T2).

Hint Constructors is_bot is_top is_rcd.

Lemma is_top_is_bot_mutex: forall T, is_top T -> is_bot T -> False.
Proof.
  intro T. induction T; intros It Ib; inversions It; inversions Ib; auto.
Qed.

Lemma is_top_is_rcd_mutex: forall T, is_top T -> is_rcd T -> False.
Proof.
  intro T. induction T; intros It Ir; inversions It; inversions Ir; auto.
  apply* is_top_is_bot_mutex.
  apply* is_top_is_bot_mutex.
Qed.

Lemma is_rcd_is_bot_mutex: forall T, is_rcd T -> is_bot T -> False.
  intro T. induction T; intros Ir Ib; inversions Ir; inversions Ib; auto.
  apply* is_top_is_bot_mutex.
  apply* is_top_is_bot_mutex.
Qed.

(* "no_path_types T" means that T contains no path types (but T's members can) *)
Inductive no_path_types: typ -> Prop :=
| no_path_types_top: no_path_types typ_top
| no_path_types_bot: no_path_types typ_bot
| no_path_types_rcd: forall D, no_path_types (typ_rcd D)
| no_path_types_and: forall T1 T2,
    no_path_types T1 -> no_path_types T2 -> no_path_types (typ_and T1 T2)
| no_path_types_or: forall T1 T2,
    no_path_types T1 -> no_path_types T2 -> no_path_types (typ_or T1 T2).

Lemma no_path_types_cases: forall T, no_path_types T ->
  is_top T \/ is_bot T \/ is_rcd T.
Proof.
  intro T. induction T; intro Np; inversions* Np.
Qed.

Lemma impossible_subtyping: forall G T1 T2,
  subtyp G T1 T2 ->
  (is_top T1 -> is_bot T2 \/ is_rcd T2 -> False) /\
  (is_rcd T1 -> is_bot T2 -> False).
Proof.
  introv St. induction St; (split;
  [ (intros It P; destruct P as [Ib | Ir])
  | (intros Ir Ib)]);
  match goal with
  | H: is_top (typ_and ?A ?B) |- _ => inversions H
  | H: is_top (typ_or  ?A ?B) |- _ => inversions H
  | H: is_bot (typ_and ?A ?B) |- _ => inversions H
  | H: is_bot (typ_or  ?A ?B) |- _ => inversions H
  | H: is_rcd (typ_and ?A ?B) |- _ => inversions H
  | H: is_rcd (typ_or  ?A ?B) |- _ => inversions H
  | _ => idtac
  end;
  match goal with
  | H1: is_top ?A, H2: is_bot ?A |- _ => apply (is_top_is_bot_mutex H1 H2)
  | H1: is_top ?A, H2: is_rcd ?A |- _ => apply (is_top_is_rcd_mutex H1 H2)
  | H1: is_rcd ?A, H2: is_bot ?A |- _ => apply (is_rcd_is_bot_mutex H1 H2)
  | _ => idtac
  end;
  try solve [inversions* Ib];
  try solve [inversions* Ir];
  try solve [inversions* It];
  try (destruct IHSt1 as [IH1 IH2]; destruct IHSt2 as [IH3 IH4]);
  try (inversions H; inversions H2);
  assert (Np: no_path_types T2) by admit; (* <----------- *)
  apply no_path_types_cases in Np;
  destruct Np as [Np | [Np | Np]]; auto.
Qed.


(** * A constructor for simple types *)

Require Import ObAxioms.
Require Import Lambda.

Open Scope Lambda_scope.
Open Scope Ob_scope.

Section pair.
  Let x := VAR 0.
  Let y := VAR 1.
  Let z := VAR 2.
  Definition pair := encode (\x,\y,\z, z * x * y).
End pair.
Notation "<< x , y >>" := (pair * x * y)%Ob : Ob_scope.
Notation "<< x , y >>" := ([pair] * x * y)%Lambda : Lambda_scope.

Definition is_pair (x : Ob) := x = <<x * K, x * F>>.
Lemma pair_is_pair : forall x y, is_pair <<x, y>>.
Proof.
  intros x y. compute. beta_reduce; auto.
Qed.

Definition sub_pair (x : Ob) := x [= <<TOP, TOP>>.
Lemma sub_pair_pair : forall x y, sub_pair <<x, y>>.
Proof.
  intros x y. compute. beta_reduce.
  apply LESS_trans with (C*(C*I*TOP)*y);
  monotonicity; auto.
Qed.

Definition sub_pair_elim_intro : forall x, sub_pair x -> x [= <<x*K, x*F>>.
Proof.
  unfold sub_pair, pair; compute.
  intros x H.
  eta_expand as y. beta_reduce.
  eta_expand in H.
  (* TODO *)
Admitted.

Definition A := Join (<<s, r>> for s : Ob for r : Ob if r o s [= I).
Notation "\\ x , y ; z" := ([A] * \x, \y, z)%Lambda
  (at level 59, right associativity) : Lambda_scope.

Section A_example.
  Let a := VAR 0.
  Let a' := VAR 1.
  Let A_example := (\\a,a'; a --> a').
End A_example.

Section raise.
  Let x := VAR 3.
  Let y := VAR 4.

  Definition raise := encode (\x, \y, x).
  Definition lower := encode (\x, x * [TOP]).

  Definition pull := encode (\x, \y, x || [div] * y).
  Definition push := encode (\x, x * [BOT]).
End raise.

Lemma A_I_I : <<I, I>> [= A.
Proof.
  unfold A.
  assert (I o I [= I) as Heq; eta_expand; beta_reduce; auto.
  (* TODO
  apply Join_ub_eq with (i := restrict2_intro _ I I Heq).
  *)
Admitted.

(*
Lemma A_raise_lower : A_prop <<raise, lower>>.
Proof.
  unfold A_prop; split;
  [ apply pair_is_pair
  | compute; eta_expand; beta_reduce; auto].
Qed.

Lemma A_pull_push : A_prop <<pull, push>>.
Proof.
  unfold A_prop; split.
  apply pair_is_pair.
  unfold pull.
  freeze div in (compute; eta_expand; beta_reduce).
  rewrite div_BOT; auto.
Qed.
*)

Section compose.
  Let s := VAR 0.
  Let a := VAR 1.
  Let a' := VAR 2.
  Let b := VAR 3.
  Let b' := VAR 4.

  Definition compose := encode
    (\s, s*\a,\a', s*\b,\b', <<a o b, b' o a'>>).

  Definition conjugate := encode
    (\s, s*\a,\a', s*\b,\b', <<(a'-->b), (a-->b')>>).
End compose.

(*
Lemma A_compose : forall a, A_prop a -> A_prop (compose * a).
Proof.
  intros a H.
  unfold A_prop in H; destruct H as [Hpair Hless].
  unfold is_pair in Hpair.
  rewrite Hpair.
  unfold A_prop; split.
    compute; beta_reduce; auto.
  compute; eta_expand; beta_reduce.
  apply LESS_trans with (a * F * (a * K * H));
    monotonicity; eta_expand in Hless; apply Hless.
Qed.

Lemma A_conjugate : forall a, A_prop a -> A_prop (conjugate * a).
Proof.
  intros a H.
  unfold A_prop in H; destruct H as [Hpair Hless].
  unfold is_pair in Hpair.
  rewrite Hpair.
  unfold A_prop; split.
    compute; beta_reduce; auto.
  compute; eta_expand; eta_expand; beta_reduce.
  apply LESS_trans with (a * F * (a * K * (H * H0)));
    monotonicity; eta_expand in Hless; apply Hless.
Qed.
*)

Definition A_def :=
  Y * ( K * <<I, I>>
     || K * <<raise, lower>>
     || K * <<pull, push>>
     || compose
     || conjugate).

Lemma A_sound : A_def [= A.
Proof.
  (*
  unfold A.
  apply Join_lub.
  *)
  (* unfold A_prop; split. *)
  unfold A_def.
  apply Y_lfp.
  intros y Hless.
  repeat (rewrite J_beta || rewrite K_beta).
  repeat apply J_lub.
  (* TODO *)
Admitted.

Lemma A_complete : A [= A_def.
Proof.
  unfold A.
  apply Join_lub; unfold is_upper_bound.
  intros sr; induction sr as [[s r] Hless].
  apply LESS_conv.
  intros c Hdef Hconv.
  inversion Hconv.
  (* TODO *)
Admitted.

Theorem A_definable : A = A_def.
Proof.
  apply LESS_antisym ; apply A_sound || apply A_complete.
Qed.


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

Require Export dilatations.
Set Implicit Arguments.
Unset Strict Implicit.

Lemma compo_transl :
 forall A A' A1 I J K L : PO,
 A1 = translation I J A ->
 A' = translation K L A1 -> vec A A' = add_PP (vec I J) (vec K L).
intros A A' A1 I J K L H H0; try assumption.
cut (vec K L = vec A1 A'); intros.
cut (vec I J = vec A A1); intros.
rewrite H1; rewrite H2; Ringvec.
rewrite (translation_vecteur (I:=I) (J:=J) (A:=A) (A':=A1)); auto.
apply translation_vecteur; auto.
Qed.

Lemma composition_translation :
 forall A A' A1 I J K L : PO,
 A1 = translation I J A ->
 A' = translation K L A1 ->
 ex
   (fun M : PO =>
    vec I M = add_PP (vec I J) (vec K L) :>PP /\ A' = translation I M A).
intros A A' A1 I J K L H H0; try assumption.
elim
 existence_representant_som_vecteur with (A := I) (B := J) (C := K) (D := L);
 intros M H1; try clear existence_representant_som_vecteur;
 try exact H1.
exists M.
split; [ try assumption | idtac ].
apply rec_translation_vecteur.
rewrite H1.
symmetry  in |- *; apply compo_transl with A1; auto.
Qed.

Lemma compo_homothetie_I :
 forall (k k' : R) (I A A' A1 : PO),
 A1 = homothetie k I A :>PO ->
 A' = homothetie k' I A1 :>PO -> A' = homothetie (k' * k) I A.
intros k k' I A A' A1 H H0; try assumption.
cut (vec I A' = mult_PP (k' * k) (vec I A)); intros.
apply vecteur_homothetie; auto.
rewrite <- mult_mult_vec.
rewrite <- (homothetie_vecteur (k:=k) (I:=I) (A:=A) (A':=A1)); auto.
apply homothetie_vecteur; auto.
Qed.

Lemma compo_homothetie_IJ :
 forall (k k' : R) (I J A A' A1 : PO),
 A1 = homothetie k I A :>PO ->
 A' = homothetie k' J A1 ->
 cons 1 A' =
 add_PP (add_PP (cons (k' * k) A) (cons (k' * (1 + - k)) I))
   (cons (1 + - k') J) :>PP.
unfold vec, homothetie in |- *; intros.
rewrite H0; rewrite H.
rewrite (distrib_mult_cons k (1 + - k) k' A I).
rewrite add_PP_barycentre; try discrR.
replace (k + (1 + - k)) with 1; try ring; auto.
rewrite def_mult_PP.
replace (k' * 1) with k'; try ring; auto.
rewrite add_PP_barycentre; try discrR.
replace (k' + (1 + - k')) with 1; try ring; auto.
replace (k' + (1 + - k')) with 1; try ring; try discrR.
replace (k + (1 + - k)) with 1; try ring; try discrR.
Qed.

Lemma compo_homothetie_IJ_1 :
 forall (k k' : R) (I J A A' A1 K : PO),
 k' * k = 1 ->
 A1 = homothetie k I A :>PO ->
 A' = homothetie k' J A1 :>PO ->
 vec I K = mult_PP (1 + - k') (vec I J) :>PP -> A' = translation I K A.
intros.
cut (vec A A' = mult_PP (1 + - k') (vec I J)); intros.
apply rec_translation_vecteur; auto.
rewrite H3; rewrite H2; auto.
cut
 (cons 1 A' =
  add_PP (add_PP (cons (k' * k) A) (cons (k' * (1 + - k)) I))
    (cons (1 + - k') J)); intros.
unfold vec in |- *.
rewrite H3; auto.
repeat rewrite add_PP_assoc.
replace (k' * (1 + - k)) with (- (k' * k) + k'); try ring; try ring; auto.
rewrite H; auto.
RingPP.
apply compo_homothetie_IJ with A1; auto.
Qed.

Lemma compo_homothetie_IJ_1_exists :
 forall (k : R) (I J : PO),
 k <> 0 ->
 exists K : PO,
   (forall A A' A1 : PO,
    A1 = homothetie k I A ->
    A' = homothetie (/ k) J A1 :>PO -> A' = translation I K A).
intros.
elim
 existence_representant_mult_vecteur
  with (A := I) (B := I) (C := J) (k := 1 + - / k);
 intros K H3; try clear existence_representant_mult_vecteur.
exists K; intros.
apply compo_homothetie_IJ_1 with (2 := H0) (3 := H1); auto with *.
Qed.

Lemma compo_homothetie_IJ_non1 :
 forall (k k' : R) (I J A A' A1 K : PO),
 k' * k <> 1 ->
 A1 = homothetie k I A :>PO ->
 A' = homothetie k' J A1 :>PO ->
 K = barycentre (cons (k' * (1 + - k)) I) (cons (1 + - k') J) :>PO ->
 A' = homothetie (k' * k) K A.
intros; unfold homothetie in |- *.
cut (A' = barycentre (cons (k' * k) A) (cons (1 + - (k' * k)) K)); intros.
rewrite H3; auto.
elim
 cons_inj
  with
    (a := 1)
    (b := k' * k + (1 + - (k' * k)))
    (A := A')
    (B := barycentre (cons (k' * k) A) (cons (1 + - (k' * k)) K));
 intros; auto with *.
rewrite <- add_PP_barycentre; auto with real.
rewrite H2.
RReplace (1 + - (k' * k)) (k' * (1 + - k) + (1 + - k')).
rewrite <- add_PP_barycentre; auto with real.
rewrite add_PP_assoc.
apply compo_homothetie_IJ with A1; auto.
RReplace (k' * (1 + - k) + (1 + - k')) (1 + - (k' * k)).
auto with real.
RReplace (k' * k + (1 + - (k' * k))) 1.
auto with real.
Qed.

Lemma compo_homothetie_IJ_non1_exists :
 forall (k k' : R) (I J : PO),
 k' * k <> 1 ->
 exists K : PO,
   (forall A A' A1 : PO,
    A1 = homothetie k I A ->
    A' = homothetie k' J A1 :>PO -> A' = homothetie (k' * k) K A :>PO).
intros.
exists (barycentre (cons (k' * (1 + - k)) I) (cons (1 + - k') J)); intros.
apply compo_homothetie_IJ_non1 with (2 := H0) (3 := H1); auto.
Qed.

Lemma composee_homothetie_translation :
 forall (k : R) (A A' B B' B1 I J : PO),
 k <> 1 ->
 k <> 0 ->
 B1 = homothetie k I B :>PO ->
 B' = translation A A' B1 :>PO ->
 J =
 barycentre (cons 1 A')
   (cons (-1 + (1 + - k)) (barycentre (cons (-1) A) (cons (1 + - k) I))) :>PO ->
 B' = homothetie k J B.
unfold translation, homothetie in |- *;
 intros k A A' B B' B1 I J H H0 H1 H2 H30.
elim
 cons_inj
  with
    (a := 1)
    (b := 1)
    (A := B')
    (B := barycentre (cons k B)
            (cons (1 + - k)
               (barycentre (cons 1 A')
                  (cons (-1 + (1 + - k))
                     (barycentre (cons (-1) A) (cons (1 + - k) I))))));
 intros; auto with *.
rewrite H4; rewrite H30; auto.
rewrite H2.
rewrite H1.
pattern 1 at 1 in |- *.
replace 1 with (-1 + 2); [ idtac | try ring ].
rewrite <- add_PP_barycentre; try lra.
replace 2 with (1 + 1) by ring.
rewrite <- add_PP_barycentre; try lra.
replace 1 with (k + (1 + - k)) at 2; try ring.
rewrite <- add_PP_barycentre; try lra.
replace 1 with (k + (1 + - k)) at 3; try ring.
rewrite <- add_PP_barycentre; try lra.
replace (1 + - k) with  (1 + (-1 + (1 + - k))) at 2; try ring.
rewrite <-!add_PP_barycentre; try lra.
RingPP.
Qed.

Lemma composee_homothetie_translation_exists :
 forall (k : R) (I A A' : PO),
 k <> 1 :>R ->
 k <> 0 :>R ->
 exists J : PO,
   (forall B B' B1 : PO,
    B1 = homothetie k I B :>PO ->
    B' = translation A A' B1 :>PO -> B' = homothetie k J B :>PO).
intros.
exists
 (barycentre (cons 1 A')
    (cons (-1 + (1 + - k)) (barycentre (cons (-1) A) (cons (1 + - k) I))));
 intros.
apply composee_homothetie_translation with (4 := H2) (3 := H1); auto.
Qed.

Lemma composee_translation_homothetie :
 forall (k : R) (A A' B B' B1 I J : PO),
 k <> 1 ->
 k <> 0 ->
 B1 = translation A A' B :>PO ->
 B' = homothetie k I B1 :>PO ->
 J =
 barycentre (cons (- k) A)
   (cons (k + (1 + - k)) (barycentre (cons k A') (cons (1 + - k) I))) :>PO ->
 B' = homothetie k J B.
Proof.
unfold translation, homothetie in |- *;
 intros k A A' B B' B1 I J H H0 H1 H2 H30.
elim
 cons_inj
  with
    (a := 1)
    (b := 1)
    (A := B')
    (B := barycentre (cons k B)
            (cons (1 + - k)
               (barycentre (cons (- k) A)
                  (cons (k + (1 + - k))
                     (barycentre (cons k A') (cons (1 + - k) I))))));
 intros; auto with *.
rewrite H4; rewrite H30; auto.
rewrite H2.
rewrite H1.
replace 1 with (k + (1 + - k)) at 1; [ idtac | try ring ].
rewrite <- add_PP_barycentre; try lra.
rewrite <- (homogene_barycentre (a:=(- 1)) (b:=2) (k:=k)); try lra.
replace k with (k * -1 + k * 2) at 1 by ring.
rewrite <- add_PP_barycentre; try lra.
rewrite <- (homogene_barycentre (a:=1) (b:=1) (k:=k)); try lra.
replace (k * 2) with (k * 1 + k * 1) at 1 by ring.
rewrite <- add_PP_barycentre; try lra.
replace 1 with (k + (1 + - k)) at 4; try lra.
rewrite <- add_PP_barycentre; try lra.
replace (1 + - k) with ((- k) + (k + (1 + - k))) at 2; try lra.
rewrite <-!add_PP_barycentre; try lra.
RingPP.
Qed.

Lemma composee_translation_homothetie_exists :
 forall (k : R) (I A A' : PO),
 k <> 1 :>R ->
 k <> 0 :>R ->
 exists J : PO,
   (forall B B' B1 : PO,
    B1 = translation A A' B :>PO ->
    B' = homothetie k I B1 :>PO -> B' = homothetie k J B :>PO).
intros.
exists
 (barycentre (cons (- k) A)
    (cons (k + (1 + - k)) (barycentre (cons k A') (cons (1 + - k) I))));
 intros.
apply composee_translation_homothetie with (4 := H2) (3 := H1); auto.
Qed.