(******************************)
(*                            *)
(*          CONTENTS          *)
(*                            *)
(* is_from          line  20  *)
(* int_or_ptr       line 280  *)
(*                            *)
(******************************)

Require Import compcert.common.Events compcert.common.Memory.
Require Import compcert.common.Values compcert.common.AST.
Require Import compcert.x86_32.Archi compcert.lib.Integers.
Require Import Coq.ZArith.BinInt Coq.Lists.List Coq.micromega.Lia.
Import ListNotations.
Local Open Scope Z_scope. Local Open Scope list_scope.

(* Verification of the function Is_from *)

Definition valid_block (m : mem) (b : block) (o : ptrofs) (n : Z) : Prop :=
  0 < n /\
  Ptrofs.unsigned o + n <= Int.modulus /\
  forall i : Z, 0 <= i < n ->
                common.Memory.Mem.valid_pointer m b (Ptrofs.unsigned o + i) = true.

Definition Is_from_sem : extcall_sem :=
  fun _ args m1 trc ret m2 =>
    m1 = m2 /\ trc = nil /\
    match args with
    | (Vptr b1 o1) :: (Vptr b2 o2) :: (Vptr b3 o3) :: nil =>
      exists n : Z, 0 < n /\
                    Ptrofs.unsigned o1 + n < Int.modulus /\
                    b1 = b2 /\
                    Ptrofs.unsigned o1 + n = Ptrofs.unsigned o2 /\
                    valid_block m1 b1 o1 n /\
                    common.Memory.Mem.valid_pointer m1 b3 (Ptrofs.unsigned o3) = true /\
                    ((b1 = b3 /\
                      Ptrofs.unsigned o1 <= Ptrofs.unsigned o3 < Ptrofs.unsigned o2 /\
                      ret = Vone) \/
                     ((b1 <> b3 \/
                       (b1 = b3 /\
                        (Ptrofs.unsigned o3 < Ptrofs.unsigned o1 \/
                         Ptrofs.unsigned o3 >= Ptrofs.unsigned o2)))
                      /\ ret = Vzero))
    | _ => False
    end.

Definition Is_from_sig : signature :=
  mksignature (AST.Tint :: AST.Tint :: AST.Tint :: nil) (Tret AST.Tint) cc_default.

Ltac split3 := split; [|split ].

Lemma lt_ptr_mod: forall n1 n2,
    n1 <= n2 <= Ptrofs.max_unsigned -> n1 <= n2 < Ptrofs.modulus.
Proof.
  intros.
  replace Ptrofs.max_unsigned with (Z.pred Ptrofs.modulus) in * by
      (unfold Ptrofs.max_unsigned; lia).
  now rewrite <- Z.lt_le_pred in *.
Qed.

Lemma Is_from_extcall: extcall_properties Is_from_sem Is_from_sig.
Proof.
  constructor; intros.
  - destruct H as [_ [_ ?]].
    do 4 (destruct vargs; try destruct v; try contradiction).
    destruct H as [_ [_ [_ [_ [_ [_ [_ ?]]]]]]].
    destruct H as [[_ [_ ?]] | [_ ?]]; subst; apply I.
  - apply H0.
  - destruct H as [? _]. subst m1. trivial.
  - destruct H as [? _]. subst m1. trivial.
  - destruct H as [? _]. subst m1. trivial.
  - exists vres, m1'.
    destruct H as [? [? ?]]; subst m2 t.
    split.
    2: split3; [apply Val.lessdef_refl | trivial | apply Mem.unchanged_on_refl].
    split3; trivial.
    do 4 (destruct vargs; try destruct v; try contradiction).
    inversion H1; inversion H4; inversion H6; inversion H11;
      inversion H13; inversion H18; inversion H20; subst.
    clear H4 H11 H18 H20 H13 H6 H1.
    destruct H3 as [n [? [? [? [? ?]]]]].
    exists n. do 4 (split; trivial).
    clear -H0 H4. destruct H4 as [? [? ?]].
    split3; [|eapply Mem.valid_pointer_extends; eauto | tauto].
    destruct H as [? [? ?]].
    do 2 (split; trivial).
    intros. specialize (H4 i2 H5).
    eapply Mem.valid_pointer_extends; eauto.
  - intros. exists f, vres, m1'. destruct H0 as [? [? ?]]. split.
    2: {
      split. 2: repeat (split; [now subst|]); congruence.
      clear -H4.
      do 4 (destruct vargs; try destruct v; try contradiction).
      destruct H4 as [_ [_ [_ [_ [_ [_ [_ H]]]]]]].
      destruct vres; auto. now destruct H.
    }
    split3; trivial.
    do 4 (destruct vargs; try destruct v; try contradiction).
    inversion H2; inversion H7; inversion H9;
      inversion H17; inversion H19; inversion H27; inversion H29; subst.
    clear H2 H7 H9 H17 H19 H27 H29.
    destruct H4 as [n [? [? [? [? [? [? ?]]]]]]].
    exists n. rewrite H3 in  H12; rewrite H22 in H12; inversion H12.
    subst; clear H12.
    assert (Hf: 0 <= Ptrofs.unsigned i + n < Ptrofs.modulus) by
        (rewrite H4; apply Ptrofs.unsigned_range).
    assert (Ha: Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr delta)) + n < Int.modulus). {
      replace Int.modulus with Ptrofs.modulus by
          (unfold Int.modulus, Ptrofs.modulus; f_equal).
      destruct H1 as [_ _ _ _ rep _].
      destruct (rep b0 b3 delta
                      (Ptrofs.add i (Ptrofs.repr n)) H22) as [Hx Hy].
      { right. apply Mem.perm_cur_max, Mem.valid_pointer_nonempty_perm.
        destruct H5 as [_ [_ H5]].
        assert (Hm: 0 <= n - 1 < n) by lia; rewrite <- (H5 _ Hm).
        f_equal; unfold Ptrofs.add; repeat rewrite Ptrofs.unsigned_repr_eq.
        rewrite Z.add_mod_idemp_r, Z.mod_small by easy. lia.
      }
      clear -Hx Hy Hf H0.
      apply lt_ptr_mod in Hy. unfold Ptrofs.add in *.
      repeat rewrite Ptrofs.unsigned_repr_eq in *.
      rewrite Z.add_mod_idemp_r, Z.mod_small in * by easy.
      rewrite Z.mod_small; [lia|].
      destruct i. unfold Ptrofs.unsigned in *; simpl in *. lia.
    }
    split3; [| |split3; [| |split3]]; trivial.
    + destruct H1 as [_ _ _ _ rep _].
      destruct (rep _ _ delta
                   (Ptrofs.add i (Ptrofs.repr n)) H22) as [Hd' Hd]. {
        right. apply Mem.perm_cur_max, Mem.valid_pointer_nonempty_perm.
        destruct H5 as [_ [_ H5]]. assert (0 <= n - 1 < n) by lia.
        rewrite <- (H5 _ H1). f_equal.
        unfold Ptrofs.add; repeat rewrite Ptrofs.unsigned_repr_eq.
        rewrite Z.add_mod_idemp_r, Z.mod_small by easy. lia.
      }
      unfold Ptrofs.add. rewrite <- H4.
      destruct (Ptrofs.unsigned_range i) as [? _].
      repeat rewrite Ptrofs.unsigned_repr_eq.
      repeat rewrite Z.add_mod_idemp_r by easy.
      replace Int.modulus with Ptrofs.modulus in Ha by
          (unfold Int.modulus, Ptrofs.modulus; f_equal).
      unfold Ptrofs.add in Hd.
      repeat rewrite Ptrofs.unsigned_repr_eq in Hd.
      rewrite Z.add_mod_idemp_r, Z.mod_small in Hd by easy.
      apply lt_ptr_mod in Hd.
      repeat rewrite Z.mod_small; [lia | trivial | lia].
    + split3; [easy | lia|]. intros.
      destruct H5 as [_ [_ H5]].
      rewrite <- (Mem.valid_pointer_inject _ _ _ _ _ _ _ H22 H1 (H5 i2 H3)).
      f_equal. unfold Ptrofs.add; repeat rewrite Ptrofs.unsigned_repr_eq.
      destruct H1 as [_ _ _ _ rep _].
      destruct (rep _ _ delta i H22) as [_ Hd]. {
        left. apply Mem.perm_cur_max, Mem.valid_pointer_nonempty_perm.
        assert (0 <= 0 < n) by lia; rewrite <- (H5 0 H1); f_equal; lia.
      }
      apply lt_ptr_mod in Hd.
      rewrite Z.add_mod_idemp_r, Z.mod_small by easy. lia.
    + rewrite <- (Mem.valid_pointer_inject _ _ _ _ _ _ _ H32 H1 H6).
      f_equal. unfold Ptrofs.add. repeat rewrite Ptrofs.unsigned_repr_eq.
      destruct H1 as [_ _ _ _ rep _].
      destruct (rep _ _ delta1 i1 H32) as [_ Hd]. {
        left; now apply Mem.perm_cur_max,
              Mem.valid_pointer_nonempty_perm.
      }
      apply lt_ptr_mod in Hd.
      rewrite Z.add_mod_idemp_r, Z.mod_small by easy. lia.
    + destruct H7.
      * destruct H3 as [? [? ?]]; subst b1 vres.
        destruct H1 as [_ _ _ _ rep _].
        destruct (rep b0 b3 delta i H22) as [_ Hp]. {
          left; apply Mem.perm_cur_max, Mem.valid_pointer_nonempty_perm.
          destruct H5 as [_ [_ H5]]; assert (0 <= 0 < n) by lia.
          specialize (H5 0 H1).
          now replace (Ptrofs.unsigned i + 0) with (Ptrofs.unsigned i) in H5 by lia.
        }
        destruct (rep b0 b3 delta i1 H22) as [_ Hq]. {
          left; apply Mem.perm_cur_max, Mem.valid_pointer_nonempty_perm;
            destruct H5 as [_ [_ ?]]; assert (0 <= 0 < n) by lia.
          specialize (H1 0 H3); now rewrite H6.
        }
        destruct (rep b0 b3 delta i0 H22) as [_ Hr]. {
          destruct H5 as [_ [_ H5]]. rewrite <- H4.
          assert (Hm: 0 <= n - 1 < n) by lia.
          right. apply Mem.perm_cur_max, Mem.valid_pointer_nonempty_perm.
          rewrite <- (H5 _ Hm); f_equal; lia.
        }
        rewrite H22 in H32; inversion H32.
        left. split3; trivial.
        subst delta1. clear -H7 Hp Hq Hr.
        unfold Ptrofs.add; repeat rewrite Ptrofs.unsigned_repr_eq.
        apply lt_ptr_mod in Hp; apply lt_ptr_mod in Hq; apply lt_ptr_mod in Hr.
        repeat rewrite Z.add_mod_idemp_r, Z.mod_small by easy.
        lia.
      * destruct H3. right. split; trivial.
        rename m2 into m; rename m1' into m'.
        destruct H1 as [_ _ _ lap rep _].
        destruct H3.
        -- destruct (eq_block b3 b7); [|now left].
           subst b3. right. split; trivial.
           unfold Ptrofs.add; repeat rewrite Ptrofs.unsigned_repr_eq.
           repeat rewrite Z.add_mod_idemp_r by easy.
           destruct H5 as [_ [_ H5]].
           assert (0 <= 0 < n) by lia.
           pose proof (H5 _ H3).
           apply Mem.valid_pointer_nonempty_perm, Mem.perm_cur_max in H6.
           apply Mem.valid_pointer_nonempty_perm, Mem.perm_cur_max in H8.
           replace (Ptrofs.unsigned i + 0) with (Ptrofs.unsigned i) in H8 by lia.
           destruct (rep _ _ delta1 i1 H32) as [_ Hp]; [left; easy|].
           destruct (rep _ _ delta i H22) as [_ Hq]; [left; easy|].
           destruct (rep _ _ delta i0 H22) as [_ Hr]. {
             rewrite <- H4.
             assert (Hm: 0 <= n - 1 < n) by lia.
             specialize (H5 _ Hm).
             replace (Ptrofs.unsigned i + (n - 1)) with (Ptrofs.unsigned i + n - 1) in H5 by lia.
             apply Mem.valid_pointer_nonempty_perm, Mem.perm_cur_max in H5. now right.
           }
           replace Ptrofs.max_unsigned with (Z.pred Ptrofs.modulus) in * by
               (unfold Ptrofs.max_unsigned; lia).
           rewrite <- Z.lt_le_pred in *.
           repeat rewrite Z.mod_small by easy.
           destruct (lap _ _ _ _ _ _ _ _ H1 H22 H32 H8 H6); [contradiction|].
           clear rep Hp Hq Hr.
           replace (Ptrofs.unsigned i) with ((Ptrofs.unsigned i - delta) + delta) in H5 by lia.
           assert ((Ptrofs.unsigned i1 + delta1 < Ptrofs.unsigned i + delta) \/
                   (Ptrofs.unsigned i1 + delta1 >= Ptrofs.unsigned i0 + delta) \/
                   ((Ptrofs.unsigned i1 + delta1 >= Ptrofs.unsigned i + delta) /\
                    Ptrofs.unsigned i1 + delta1 < Ptrofs.unsigned i0 + delta)) by lia.
           destruct H10; [auto | destruct H10; [auto|]].
           exfalso.
           destruct H10. rewrite <- H4 in H11.
           assert (0 <= Ptrofs.unsigned i1 + delta1 - Ptrofs.unsigned i - delta < n) by lia.
           specialize (H5 (Ptrofs.unsigned i1 + delta1 - Ptrofs.unsigned i - delta) H12).
           apply Mem.valid_pointer_nonempty_perm, Mem.perm_cur_max in H5.
           destruct (lap b0 b7 delta b1 b7 delta1 _ (Ptrofs.unsigned i1) H1 H22 H32 H5 H6); [auto | apply H13; lia].
        -- destruct H1. subst b0 vres.
           right. rewrite H22 in H32; inversion H32.
           clear H32.
           split; trivial.
           unfold Ptrofs.add; repeat rewrite Ptrofs.unsigned_repr_eq.
           repeat rewrite Z.add_mod_idemp_r by easy.
           subst delta1.
           destruct (rep b1 b3 delta i H22) as [_ Hp]. {
             left; apply Mem.perm_cur_max, Mem.valid_pointer_nonempty_perm.
             destruct H5 as [_ [_ H5]]; assert (H1: 0 <= 0 < n) by lia.
             specialize (H5 0 H1).
             now replace (Ptrofs.unsigned i + 0) with (Ptrofs.unsigned i) in H5 by lia.
           }
           destruct (rep b1 b3 delta i1 H22) as [_ Hq].
           1:  now left; apply Mem.perm_cur_max, Mem.valid_pointer_nonempty_perm.
           destruct (rep b1 b3 delta i0 H22) as [_ Hr]. {
             destruct H5 as [_ [_ H5]]. rewrite <- H4.
             assert (Hm: 0 <= n - 1 < n) by lia.
             right. apply Mem.perm_cur_max, Mem.valid_pointer_nonempty_perm.
             rewrite <- (H5 _ Hm); f_equal; lia.
           }
           clear - H3 Hp Hq Hr.
           apply lt_ptr_mod in Hp; apply lt_ptr_mod in Hq; apply lt_ptr_mod in Hr.
           repeat rewrite Z.mod_small by easy.
           destruct H3; [left | right]; lia.
  - intros. destruct H as [_ [? _]]. subst t. simpl. lia.
  - intros. generalize H. destruct H as [_ [? _]]. subst t1.
    inversion H0. subst t2. clear H0. intro H.
    exists vres1, m1. apply H.
  - intros. destruct H as [? [? ?]]. destruct H0 as [? [? ?]].
    subst m1 m2 t1 t2. split; [constructor|].
    intros _. split; trivial.
    do 4 (destruct vargs; try destruct v; try contradiction).
    destruct H2 as [_ [_ [_ [_ [_ [_ [_ ?]]]]]]].
    destruct H4 as [_ [_ [_ [_ [_ [_ [_ ?]]]]]]].
    intuition; congruence.
Qed.

(* Verification of int_or_ptr *)

Definition valid_b_o_So (m : mem) (b : block) (o : ptrofs) : Prop :=
  Mem.range_perm m b (Ptrofs.unsigned o) (Ptrofs.unsigned o + 2) Cur Nonempty.

Lemma valid_b_o_So_dec: forall m b o, {valid_b_o_So m b o} + {~ valid_b_o_So m b o}.
Proof. intros. unfold valid_b_o_So. apply Mem.range_perm_dec. Qed.

Definition test_iop_sem : extcall_sem :=
  fun _ args m1 trc ret m2 =>
    m1 = m2 /\ trc = nil /\
    match args with
    | [Vint i] =>
      if (Int.eq Int.one (Int.modu i (Int.repr 2)))
      then ret = Vone
      else False
    | [Vptr b ofs] =>
      if (Ptrofs.eq Ptrofs.one (Ptrofs.modu ofs (Ptrofs.repr 2)))
      then False
      else if valid_b_o_So_dec m1 b ofs
           then ret = Vzero
           else False
    | _ => False
    end.

Definition test_iop_sig : signature :=
  mksignature (AST.Tint :: nil) (Tret AST.Tint) cc_default.

Lemma test_iop__extcall: extcall_properties test_iop_sem test_iop_sig.
Proof.
  constructor; intros.
  - destruct H as [_ [_ ?]].
    destruct vargs; try destruct v; try contradiction; destruct vargs; try contradiction.
    1: destruct (Int.eq Int.one (Int.modu i (Int.repr 2))); subst; easy.
    destruct (Ptrofs.eq Ptrofs.one (Ptrofs.modu i (Ptrofs.repr 2))).
    1: contradiction.
    destruct (valid_b_o_So_dec m1 b i); subst; easy.
  - trivial.
  - destruct H as [? _]. subst m1. trivial.
  - destruct H as [? _]. subst m1. trivial.
  - destruct H as [? _]. subst m1. trivial.
  - destruct H as [? [? ?]]; subst m2 t.
    exists vres, m1'. split.
    2: split3; [apply Val.lessdef_refl | trivial | apply Mem.unchanged_on_refl].
    split3; trivial.
    do 2 (try destruct vargs; try destruct v); try contradiction;
      inversion H1; inversion H4; inversion H6; auto.
    clear -H0 H3.
    destruct (Ptrofs.eq Ptrofs.one (Ptrofs.modu i (Ptrofs.repr 2))); auto.
    destruct (valid_b_o_So_dec m1 b i);
      destruct (valid_b_o_So_dec m1' b i); [trivial| | contradiction..].
    clear H3; destruct n.
    destruct H0 as [_ [? _ _] _].
    unfold valid_b_o_So in *.
    unfold Mem.range_perm in *. intros.
    specialize (v ofs H).
    assert (inject_id b = Some (b, 0)) by now unfold inject_id.
    specialize (mi_perm _ _ _ ofs Cur Nonempty H0).
    replace (ofs + 0) with ofs in mi_perm by lia.
    apply (mi_perm v).
  - intros. exists f, vres, m1'.
    destruct H0 as [? [? ?]]. subst.
    split.
    2: {
      split.
      - destruct vres; auto.
        do 2 (destruct vargs; try destruct v; try contradiction).
        + destruct (Int.eq Int.one (Int.modu i0 (Int.repr 2))); [inversion H4 | easy].
        + destruct (Ptrofs.eq Ptrofs.one (Ptrofs.modu i0 (Ptrofs.repr 2))); try contradiction.
          destruct (valid_b_o_So_dec m2 b0 i0); [inversion H4 | easy].
      - split; [trivial|].
        split; [apply Mem.unchanged_on_refl|].
        split; [apply Mem.unchanged_on_refl|].
        split; [apply inject_incr_refl | congruence].
    }
    split3; trivial.
    do 2 (destruct vargs; try destruct v; try contradiction).
    + inversion H2. inversion H5. inversion H7. auto.
    + inversion H2. inversion H5. inversion H7.
      subst. clear H7 H2.
      destruct (Ptrofs.eq Ptrofs.one (Ptrofs.modu i (Ptrofs.repr 2))) eqn:parity1; [contradiction|].
      destruct (valid_b_o_So_dec m2 b i); [|contradiction].
      assert (OF: Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr delta)) = Ptrofs.unsigned i + delta).
        { eapply Mem.address_inject; eauto. apply v. lia. }
        assert (AL: (2 | delta)).
        { change 2 with (align_chunk Mint16unsigned).
          clear - H10 v H1.
          eauto using Mem.mi_align, Mem.mi_inj, Mem.range_perm_max. }
        destruct (Ptrofs.eq Ptrofs.one
                          (Ptrofs.modu (Ptrofs.add i (Ptrofs.repr delta)) (Ptrofs.repr 2))) eqn:parity2.
      * assert (0 <= Ptrofs.unsigned i + delta < Ptrofs.modulus). {
          destruct H1 as [_ _ _ _ rep _].
          specialize (rep _ _ _ i H10) as [_ rep].
          left. unfold valid_b_o_So in v.
          unfold Mem.range_perm in v.
          specialize (v (Ptrofs.unsigned i)).
          apply Mem.perm_cur_max in v. auto.
          lia. apply lt_ptr_mod in rep. assumption.
        }
        clear - parity1 parity2 AL H0.
        rewrite <- Bool.not_false_iff_true in parity2.
        unfold not in *.
        destruct parity2.
        unfold Ptrofs.modu in *.
        rewrite Ptrofs.unsigned_repr_eq in *.
        rewrite (Z.mod_small 2 _) in * by easy.
        unfold Ptrofs.add; repeat rewrite Ptrofs.unsigned_repr_eq.
        rewrite Z.add_mod_idemp_r, (Z.mod_small (Ptrofs.unsigned i + delta) _) by easy.
        rewrite <- parity1. do 2 f_equal.
        rewrite <- Z.add_mod_idemp_r, (Znumtheory.Zdivide_mod delta 2) by easy.
        now replace (Ptrofs.unsigned i + 0) with (Ptrofs.unsigned i) by lia.
      * destruct (valid_b_o_So_dec m1' b2 (Ptrofs.add i (Ptrofs.repr delta))); auto.
        destruct n.
        assert (inj := H1).
        destruct H1 as [[? _ _] _ _ _ rep _].
        unfold valid_b_o_So in *.
        rewrite OF. replace (Ptrofs.unsigned i + delta + 2) with ((Ptrofs.unsigned i + 2) + delta) by lia.
  eapply Mem.range_perm_inject; eauto.
  - destruct H as [_ [? _]]. subst t. simpl; lia.
  - generalize H. destruct H as [_ [? _]].
    subst t1; inversion H0; subst t2.
    intro H; exists vres1, m1; apply H.
  - destruct H as [? [? ?]]. destruct H0 as [? [? ?]].
    subst m1 m2 t1 t2.
    split; [constructor|]. intros _. split; trivial.
    do 2 (try destruct vargs; try destruct v; try contradiction).
    + destruct (Int.eq Int.one (Int.modu i (Int.repr 2))); subst; [trivial | contradiction].
    + destruct (Ptrofs.eq Ptrofs.one (Ptrofs.modu i (Ptrofs.repr 2))); [contradiction|].
      destruct (valid_b_o_So_dec m b i); [|contradiction].
      subst; trivial.
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 C G Gprime Aprime Bprime Cprime Gprimeprime I : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Bprime A /\ (wd_ Bprime C /\ (wd_ Aprime B /\ (wd_ Aprime C /\ (wd_ Cprime A /\ (wd_ Cprime B /\ (wd_ G A /\ (wd_ Cprime Gprimeprime /\ (wd_ Aprime Gprime /\ (wd_ G C /\ (wd_ I Aprime /\ (wd_ I Gprime /\ (wd_ I Cprime /\ (wd_ I Gprimeprime /\ (wd_ Gprimeprime C /\ (wd_ Gprimeprime G /\ (wd_ Gprime A /\ (wd_ Gprime G /\ (col_ G A Aprime /\ (col_ G B Bprime /\ (col_ G Cprime C /\ (col_ I Aprime Gprime /\ (col_ I Cprime Gprimeprime /\ (col_ Gprimeprime C G /\ (col_ Cprime A B /\ (col_ Gprime A G /\ (col_ Bprime A C /\ col_ Aprime B C)))))))))))))))))))))))))))))) -> col_ C G I)).
Proof.
  time tac.
Qed.

End FOFProblem.


(** * Coequalizers defined in terms of colimits *)
(** ** Contents
- Definition of coequalizers
- Coincides with the direct definition
*)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.Combinatorics.StandardFiniteSets.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.graphs.eqdiag.
Require Import UniMath.CategoryTheory.limits.coequalizers.

Local Open Scope cat.

(** * Definition of coequalizers in terms of colimits *)
Section def_coequalizers.

  Variable C : category.

  Local Open Scope stn.
  Definition One : two := ● 0.
  Definition Two : two := ● 1.

  Definition Coequalizer_graph : graph.
  Proof.
    exists two.
    use (@two_rec (two -> UU)).
    - apply two_rec.
      + apply empty.
      + apply (unit ⨿ unit).
    - apply (λ _, empty).
  Defined.

  Definition Coequalizer_diagram {a b : C} (f g : C⟦a, b⟧) : diagram Coequalizer_graph C.
  Proof.
    exists (two_rec a b).
    use two_rec_dep.
    - use two_rec_dep; simpl.
      + apply fromempty.
      + intro x. induction x.
        exact f. exact g.
    - intro. apply fromempty.
  Defined.

  Definition Coequalizer_cocone {a b : C} (f g : C⟦a, b⟧) (d : C) (h : C⟦b, d⟧)
             (H : f · h = g · h) : cocone (Coequalizer_diagram f g) d.
  Proof.
    use make_cocone.
    - use two_rec_dep.
      + exact (f · h).
      + exact h.
    - use two_rec_dep; use two_rec_dep.
      + exact (empty_rect _).
      + intro e. induction e.
        * apply idpath.
        * apply (! H).
      + exact (empty_rect _).
      + exact (empty_rect _).
  Defined.

  Definition isCoequalizer {a b : C} (f g : C⟦a, b⟧) (d : C) (h : C⟦b, d⟧)
             (H : f · h = g · h) : UU := isColimCocone (Coequalizer_diagram f g) d
                                                         (Coequalizer_cocone f g d h H).

  Definition make_isCoequalizer {a b : C} (f g : C⟦a, b⟧) (d : C) (h : C⟦b, d⟧)
             (H : f · h = g · h) :
    (∏ e (h' : C⟦b, e⟧) (H' : f · h' = g · h'),
     iscontr (total2 (fun hk : C⟦d, e⟧ => h · hk = h'))) ->
    isCoequalizer f g d h H.
  Proof.
    intros H' x cx.
    assert (H1 : f · coconeIn cx Two = g · coconeIn cx Two).
    {
      use (pathscomp0 (coconeInCommutes cx One Two (ii1 tt))).
      use (pathscomp0 _ (!(coconeInCommutes cx One Two (ii2 tt)))).
      apply idpath.
    }
    set (H2 := (H' x (coconeIn cx Two) H1)).
    use tpair.
    - use (tpair _ (pr1 (pr1 H2)) _).
      use two_rec_dep.
      + use (pathscomp0 _ (coconeInCommutes cx One Two (ii1 tt))).
        change (coconeIn (Coequalizer_cocone f g d h H) _) with (f · h).
        change (dmor _ _) with f.
        rewrite <- assoc.
        apply cancel_precomposition, (pr2 (pr1 H2)).
      + apply (pr2 (pr1 H2)).
    - abstract (intro t; apply subtypePath;
               [intros y; apply impred; intros t0; apply C
               |induction t as [t p]; apply path_to_ctr, (p Two)]).
  Defined.

  Definition Coequalizer {a b : C} (f g : C⟦a, b⟧) : UU := ColimCocone (Coequalizer_diagram f g).

  Definition make_Coequalizer {a b : C} (f g : C⟦a, b⟧) (d : C) (h : C⟦b, d⟧) (H : f · h = g · h)
             (isCEq : isCoequalizer f g d h H) : Coequalizer f g.
  Proof.
    use tpair.
    - use tpair.
      + exact d.
      + use Coequalizer_cocone.
        * exact h.
        * exact H.
    - exact isCEq.
  Defined.

  Definition Coequalizers : UU := ∏ (a b : C) (f g : C⟦a, b⟧), Coequalizer f g.

  Definition hasCoequalizers : UU := ∏ (a b : C) (f g : C⟦a, b⟧), ishinh (Coequalizer f g).

  Definition CoequalizerObject {a b : C} {f g : C⟦a, b⟧} :
    Coequalizer f g -> C := λ H, colim H.

  Definition CoequalizerArrow {a b : C} {f g : C⟦a, b⟧} (E : Coequalizer f g) :
    C⟦b, colim E⟧ := colimIn E Two.

  Definition CoequalizerArrowEq {a b : C} {f g : C⟦a, b⟧} (E : Coequalizer f g) :
    f · CoequalizerArrow E = g · CoequalizerArrow E.
  Proof.
    use (pathscomp0 (colimInCommutes E One Two (ii1 tt))).
    use (pathscomp0 _ (!(colimInCommutes E One Two (ii2 tt)))).
    apply idpath.
  Qed.

  Definition CoequalizerOut {a b : C} {f g : C⟦a, b⟧} (E : Coequalizer f g) e (h : C⟦b, e⟧)
             (H : f · h = g · h) : C⟦colim E, e⟧.
  Proof.
    now use colimArrow; use Coequalizer_cocone.
  Defined.

  Lemma CoequalizerArrowComm {a b : C} {f g : C⟦a, b⟧} (E : Coequalizer f g) (e : C) (h : C⟦b, e⟧)
        (H : f · h = g · h) : CoequalizerArrow E · CoequalizerOut E e h H = h.
  Proof.
    exact (colimArrowCommutes E e _ Two).
  Qed.

  Lemma CoequalizerOutUnique {a b : C} {f g : C⟦a, b⟧} (E : Coequalizer f g) (e : C) (h : C⟦b, e⟧)
        (H : f · h = g · h) (w : C⟦colim E, e⟧) (H' : CoequalizerArrow E · w = h) :
    w = CoequalizerOut E e h H.
  Proof.
    apply path_to_ctr.
    use two_rec_dep.
    - set (X := colimInCommutes E One Two (ii1 tt)).
      apply (maponpaths (λ h : _, h · w)) in X.
      use (pathscomp0 (!X)); rewrite <- assoc.
      change (dmor _ _) with f.
      change (coconeIn _ _) with (f · h).
      apply cancel_precomposition, H'.
    - apply H'.
  Qed.

  Definition isCoequalizer_Coequalizer {a b : C} {f g : C⟦a, b⟧} (E : Coequalizer f g) :
    isCoequalizer f g (CoequalizerObject E) (CoequalizerArrow E)
                  (CoequalizerArrowEq E).
  Proof.
    apply make_isCoequalizer.
    intros e h H.
    use (unique_exists (CoequalizerOut E e h H)).
    (* Commutativity *)
    - exact (CoequalizerArrowComm E e h H).
    (* Equality on equalities of morphisms *)
    - intros y. apply C.
    (* Uniqueness *)
    - intros y t. cbn in t.
      use CoequalizerOutUnique.
      exact t.
  Qed.

  Definition CoequalizerOfArrows
             {a a' b b' : C} {f g : a --> b}
             {f' g' : a' --> b'}
             (cfg : Coequalizer f g)
             (cfg' : Coequalizer f' g')
             (u : a --> a')
             (v : b --> b')
             (eqf : f · v = u · f')
             (eqg : g · v = u · g')
    :
      CoequalizerObject cfg --> CoequalizerObject cfg'.
  Proof.
    unshelve eapply CoequalizerOut.
    - refine (v · _).
      apply CoequalizerArrow.
    - abstract (rewrite ! assoc, eqf , eqg, ! assoc' ;
                 apply cancel_precomposition, CoequalizerArrowEq).
  Defined.
  Lemma CoequalizerOfArrowsEq
        {a a' b b' : C} {f g : a --> b}
        {f' g' : a' --> b'}
        (cfg : Coequalizer f g)
        (cfg' : Coequalizer f' g')
        (u : a --> a')
        (v : b --> b')
        (eqf : f · v = u · f')
        (eqg : g · v = u · g')
    :
      CoequalizerArrow cfg · CoequalizerOfArrows cfg cfg' u v eqf eqg  =
      v · CoequalizerArrow cfg'.
  Proof.
    apply  CoequalizerArrowComm.
  Qed.

  (** ** Coequalizers to coequalizers *)

  Definition identity_is_Coequalizer_input {a b : C} {f g : C⟦a, b⟧} (E : Coequalizer f g) :
    total2 (fun hk : C⟦colim E, colim E⟧ => CoequalizerArrow E · hk = CoequalizerArrow E).
  Proof.
    use tpair.
    exact (identity _).
    apply id_right.
  Defined.

  Lemma CoequalizerEndo_is_identity  {a b : C} {f g : C⟦a, b⟧} (E : Coequalizer f g)
        (k : C⟦colim E, colim E⟧) (kH :CoequalizerArrow E · k = CoequalizerArrow E) :
    identity (colim E) = k.
  Proof.
    apply colim_endo_is_identity.
    unfold colimIn.
    use two_rec_dep; cbn.
    + set (X := (coconeInCommutes (colimCocone E) One Two (ii1 tt))).
      use (pathscomp0 (! (maponpaths (λ h' : _, h' · k) X))).
      use (pathscomp0 _ X).
      rewrite <- assoc. apply cancel_precomposition.
      apply kH.
    + apply kH.
  Qed.

  Definition from_Coequalizer_to_Coequalizer {a b : C} {f g : C⟦a, b⟧} (E1 E2 : Coequalizer f g) :
    C⟦colim E1, colim E2⟧.
  Proof.
    apply (CoequalizerOut E1 (colim E2) (CoequalizerArrow E2)).
    exact (CoequalizerArrowEq E2).
  Defined.

  Lemma are_inverses_from_Coequalizer_to_Coequalizer {a b : C} {f g : C⟦a, b⟧}
        (E1 E2 : Coequalizer f g) :
    is_inverse_in_precat (from_Coequalizer_to_Coequalizer E2 E1)
                         (from_Coequalizer_to_Coequalizer E1 E2).
  Proof.
    split; apply pathsinv0.
    - apply CoequalizerEndo_is_identity.
      rewrite assoc.
      unfold from_Coequalizer_to_Coequalizer.
      repeat rewrite CoequalizerArrowComm.
      apply idpath.
    - apply CoequalizerEndo_is_identity.
      rewrite assoc.
      unfold from_Coequalizer_to_Coequalizer.
      repeat rewrite CoequalizerArrowComm.
      apply idpath.
  Qed.

  Lemma isiso_from_Coequalizer_to_Coequalizer {a b : C} {f g : C⟦a, b⟧} (E1 E2 : Coequalizer f g) :
    is_iso (from_Coequalizer_to_Coequalizer E1 E2).
  Proof.
    apply (is_iso_qinv _ (from_Coequalizer_to_Coequalizer E2 E1)).
    apply are_inverses_from_Coequalizer_to_Coequalizer.
  Qed.

  Definition iso_from_Coequalizer_to_Coequalizer {a b : C} {f g : C⟦a, b⟧}
             (E1 E2 : Coequalizer f g) : iso (colim E1) (colim E2) :=
    tpair _ _ (isiso_from_Coequalizer_to_Coequalizer E1 E2).

  Lemma inv_from_iso_iso_from_Pullback {a b : C} {f g : C⟦a , b⟧} (E1 E2 : Coequalizer f g):
    inv_from_iso (iso_from_Coequalizer_to_Coequalizer E1 E2) =
    from_Coequalizer_to_Coequalizer E2 E1.
  Proof.
    apply pathsinv0.
    apply inv_iso_unique'.
    apply (pr1 (are_inverses_from_Coequalizer_to_Coequalizer E2 E1)).
  Qed.

  (** ** Connections to other colimits *)

  Lemma Coequalizers_from_Colims : Colims C -> Coequalizers.
  Proof.
    intros H a b f g. apply H.
  Defined.

End def_coequalizers.

(** * Definitions coincide
    In this section we show that the definition of coequalizer as a colimit coincides with the
    direct definition. *)
Section coequalizers_coincide.

  Variable C : category.

  (** ** isCoequalizers *)

  Lemma equiv_isCoequalizer1 {a b : C} {f g : C⟦a, b⟧} (e : C) (h : C⟦b, e⟧) (H : f · h = g · h) :
    limits.coequalizers.isCoequalizer f g h H -> isCoequalizer C f g e h H.
  Proof.
    intros X.
    set (E := limits.coequalizers.make_Coequalizer f g h H X).
    use (make_isCoequalizer C).
    intros e' h' H'.
    use (unique_exists (limits.coequalizers.CoequalizerOut E e' h' H')).
    (* Commutativity *)
    - exact (limits.coequalizers.CoequalizerCommutes E e' h' H').
    (* Equality on equalities of morphisms *)
    - intros y. apply C.
    (* Uniqueness *)
    - intros y T. cbn in T.
      use (limits.coequalizers.CoequalizerOutsEq E).
      use (pathscomp0 T).
      exact (!(limits.coequalizers.CoequalizerCommutes E e' h' H')).
  Qed.

  Lemma equiv_isCoequalizer2 {a b : C} (f g : C⟦a, b⟧) (e : C) (h : C⟦b, e⟧) (H : f · h = g · h) :
    limits.coequalizers.isCoequalizer f g h H <- isCoequalizer C f g e h H.
  Proof.
    intros X.
    set (E := make_Coequalizer C f g e h H X).
    intros e' h' H'.
    use (unique_exists (CoequalizerOut C E e' h' H')).
    (* Commutativity *)
    - exact (CoequalizerArrowComm C E e' h' H').
    (* Equality on equalities of morphisms *)
    - intros y. apply C.
    (* Uniqueness *)
    - intros y T. cbn in T.
      use (CoequalizerOutUnique C E).
      exact T.
  Qed.

  (** ** Coequalizers *)

  Definition equiv_Coequalizer1 {a b : C} (f g : C⟦a, b⟧) :
    limits.coequalizers.Coequalizer f g -> Coequalizer C f g.
  Proof.
    intros E.
    exact (make_Coequalizer
             C f g _ _ _
             (equiv_isCoequalizer1
                (limits.coequalizers.CoequalizerObject E)
                (limits.coequalizers.CoequalizerArrow E)
                (limits.coequalizers.CoequalizerEqAr E)
                (limits.coequalizers.isCoequalizer_Coequalizer E))).
  Defined.

  Definition equiv_Coequalizer2 {a b : C} (f g : C⟦a, b⟧) :
    limits.coequalizers.Coequalizer f g <- Coequalizer C f g.
  Proof.
    intros E.
    exact (@limits.coequalizers.make_Coequalizer
             C a b (CoequalizerObject C E) f g
             (CoequalizerArrow C E)
             (CoequalizerArrowEq C E)
             (@equiv_isCoequalizer2
                a b f g (CoequalizerObject C E)
                (CoequalizerArrow C E)
                (CoequalizerArrowEq C E)
                (isCoequalizer_Coequalizer C E))).
  Defined.

End coequalizers_coincide.

(** Post-composing a coequalizer diagram with a functor yields a
     coequalizer diagram. *)
Lemma mapdiagram_coequalizer_eq_diag {C : category}{D : category}
      (F : functor C D){a b : C}(f g : a --> b)  :
  eq_diag (C := D)
          (mapdiagram F (Coequalizer_diagram _ f g))
          (Coequalizer_diagram _ (# F f) (# F g)).
Proof.
  use tpair.
  -  use StandardFiniteSets.two_rec_dep; cbn; apply idpath.
  -  use StandardFiniteSets.two_rec_dep;  use StandardFiniteSets.two_rec_dep;
       try exact (empty_rect _ ).
     intro e.
     induction e; apply idpath.
Defined.


From iris_examples.logrel.F_mu_ref Require Export logrel_binary.
From iris.algebra Require Import list.
From iris.proofmode Require Import tactics.
From iris.program_logic Require Import lifting.
From iris_examples.logrel.F_mu_ref Require Import rules_binary.

Section bin_log_def.
  Context `{heapG Σ,cfgSG Σ}.
  Notation D := (prodO valO valO -n> iProp Σ).

  Definition bin_log_related (Γ : list type) (e e' : expr) (τ : type) :=
    ∀ Δ vvs (ρ : cfg F_mu_ref_lang), env_Persistent Δ →
    spec_inv ρ ∗ ⟦ Γ ⟧* Δ vvs ⊢
    ⟦ τ ⟧ₑ Δ (e.[env_subst (vvs.*1)], e'.[env_subst (vvs.*2)]).
End bin_log_def.

Notation "Γ ⊨ e '≤log≤' e' : τ" :=
  (bin_log_related Γ e e' τ) (at level 74, e, e', τ at next level).

Section fundamental.
  Context `{heapG Σ,cfgSG Σ}.
  Notation D := (prodO valO valO -n> iPropO Σ).
  Implicit Types e : expr.
  Implicit Types Δ : listO D.
  Local Hint Resolve to_of_val : core.

  Local Tactic Notation "smart_wp_bind" uconstr(ctx) ident(v) ident(w)
        constr(Hv) uconstr(Hp) :=
    iApply (wp_bind (fill [ctx]));
    iApply (wp_wand with "[-]");
      [iApply Hp; iFrame "#"; trivial|];
    iIntros (v); iDestruct 1 as (w) Hv.

  (* Put all quantifiers at the outer level *)
  Lemma bin_log_related_alt {Γ e e' τ} : Γ ⊨ e ≤log≤ e' : τ → ∀ Δ vvs ρ K,
    env_Persistent Δ →
    spec_inv ρ ∗ ⟦ Γ ⟧* Δ vvs ∗ ⤇ fill K (e'.[env_subst (vvs.*2)])
    ⊢ WP e.[env_subst (vvs.*1)] {{ v, ∃ v',
        ⤇ fill K (of_val v') ∗ interp τ Δ (v, v') }}.
  Proof.
    iIntros (Hlog Δ vvs K ρ ?) "[#Hρ [HΓ Hj]]". asimpl.
    iApply (Hlog with "[HΓ]"); iFrame. eauto.
  Qed.

  Notation "'` H" := (bin_log_related_alt H) (at level 8).

  Lemma bin_log_related_var Γ x τ :
    Γ !! x = Some τ → Γ ⊨ Var x ≤log≤ Var x : τ.
  Proof.
    iIntros (? Δ vvs ρ ?) "[#Hρ #HΓ]". iIntros (K) "Hj /=".
    iDestruct (interp_env_Some_l with "HΓ") as ([v v']) "[Heq Hv]"; first done.
    iDestruct "Heq" as %Heq.
    erewrite !env_subst_lookup; rewrite ?list_lookup_fmap ?Heq; eauto.
    iApply wp_value; auto.
  Qed.

  Lemma bin_log_related_unit Γ : Γ ⊨ Unit ≤log≤ Unit : TUnit.
  Proof.
    iIntros (Δ vvs ρ ?) "#[Hρ HΓ]". iIntros (K) "Hj /=".
    iApply wp_value. iExists UnitV; eauto.
  Qed.

  Lemma bin_log_related_pair Γ e1 e2 e1' e2' τ1 τ2
      (IHHtyped1 : Γ ⊨ e1 ≤log≤ e1' : τ1)
      (IHHtyped2 : Γ ⊨ e2 ≤log≤ e2' : τ2) :
    Γ ⊨ Pair e1 e2 ≤log≤ Pair e1' e2' : TProd τ1 τ2.
  Proof.
    iIntros (Δ vvs ρ ?) "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    smart_wp_bind (PairLCtx e2.[env_subst _]) v v' "[Hv #Hiv]"
      ('`IHHtyped1 _ _ _ ((PairLCtx e2'.[env_subst _]) :: K)).
    smart_wp_bind (PairRCtx v) w w' "[Hw #Hiw]"
      ('`IHHtyped2 _ _ _ ((PairRCtx v') :: K)).
    iApply wp_value.
    iExists (PairV v' w'); iFrame "Hw".
    iExists (v, v'), (w, w'); simpl; repeat iSplit; trivial.
  Qed.

  Lemma bin_log_related_fst Γ e e' τ1 τ2
      (IHHtyped : Γ ⊨ e ≤log≤ e' : TProd τ1 τ2) :
    Γ ⊨ Fst e ≤log≤ Fst e' : τ1.
  Proof.
    iIntros (Δ vvs ρ ?) "[#Hρ #HΓ]"; iIntros (K) "Hj /=".
    smart_wp_bind (FstCtx) v v' "[Hv #Hiv]" ('`IHHtyped _ _ _ (FstCtx :: K)); cbn.
    iDestruct "Hiv" as ([w1 w1'] [w2 w2']) "#[% [Hw1 Hw2]]"; simplify_eq.
    iMod (step_fst _ _ K (of_val w1') (of_val w2') with "[-]") as "Hw"; eauto.
    iApply wp_pure_step_later; auto. iApply wp_value; auto.
  Qed.

  Lemma bin_log_related_snd Γ e e' τ1 τ2
      (IHHtyped : Γ ⊨ e ≤log≤ e' : TProd τ1 τ2) :
    Γ ⊨ Snd e ≤log≤ Snd e' : τ2.
  Proof.
    iIntros (Δ vvs ρ ?) "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    smart_wp_bind (SndCtx) v v' "[Hv #Hiv]" ('`IHHtyped _ _ _ (SndCtx :: K)); cbn.
    iDestruct "Hiv" as ([w1 w1'] [w2 w2']) "#[% [Hw1 Hw2]]"; simplify_eq.
    iMod (step_snd _ _ K (of_val w1') (of_val w2') with "[-]") as "Hw"; eauto.
    iApply wp_pure_step_later; auto. iApply wp_value; auto.
  Qed.

  Lemma bin_log_related_injl Γ e e' τ1 τ2
      (IHHtyped : Γ ⊨ e ≤log≤ e' : τ1) :
    Γ ⊨ InjL e ≤log≤ InjL e' : (TSum τ1 τ2).
  Proof.
    iIntros (Δ vvs ρ ?) "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    smart_wp_bind (InjLCtx) v v' "[Hv #Hiv]"
      ('`IHHtyped _ _ _ (InjLCtx :: K)); cbn.
    iApply wp_value. repeat rewrite /= to_of_val. eauto.
    iExists (InjLV v'); iFrame "Hv".
    iLeft; iExists (_,_); eauto 10.
  Qed.

  Lemma bin_log_related_injr Γ e e' τ1 τ2
      (IHHtyped : Γ ⊨ e ≤log≤ e' : τ2) :
    Γ ⊨ InjR e ≤log≤ InjR e' : TSum τ1 τ2.
  Proof.
    iIntros (Δ vvs ρ ?) "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    smart_wp_bind (InjRCtx) v v' "[Hv #Hiv]"
      ('`IHHtyped _ _ _ (InjRCtx :: K)); cbn.
    iApply wp_value. repeat rewrite /= to_of_val. eauto.
    iExists (InjRV v'); iFrame "Hv".
    iRight; iExists (_,_); eauto 10.
  Qed.

  Lemma bin_log_related_case Γ e0 e1 e2 e0' e1' e2' τ1 τ2 τ3
      (Hclosed2 : ∀ f, e1.[upn (S (length Γ)) f] = e1)
      (Hclosed3 : ∀ f, e2.[upn (S (length Γ)) f] = e2)
      (Hclosed2' : ∀ f, e1'.[upn (S (length Γ)) f] = e1')
      (Hclosed3' : ∀ f, e2'.[upn (S (length Γ)) f] = e2')
      (IHHtyped1 : Γ ⊨ e0 ≤log≤ e0' : TSum τ1 τ2)
      (IHHtyped2 : τ1 :: Γ ⊨ e1 ≤log≤ e1' : τ3)
      (IHHtyped3 : τ2 :: Γ ⊨ e2 ≤log≤ e2' : τ3) :
    Γ ⊨ Case e0 e1 e2 ≤log≤ Case e0' e1' e2' : τ3.
  Proof.
    iIntros (Δ vvs ρ ?) "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    iDestruct (interp_env_length with "HΓ") as %?.
    smart_wp_bind (CaseCtx _ _) v v' "[Hv #Hiv]"
      ('`IHHtyped1 _ _ _ ((CaseCtx _ _) :: K)); cbn.
    iDestruct "Hiv" as "[Hiv|Hiv]".
    - iDestruct "Hiv" as ([w w']) "[% Hw]"; simplify_eq.
      iMod (step_case_inl _ _ K (of_val w') with "[-]") as "Hz"; eauto.
      simpl.
      iApply wp_pure_step_later; auto 1 using to_of_val. iNext.
      asimpl. iApply ('`IHHtyped2 _ ((w,w') :: vvs)); repeat iSplit; eauto.
      iApply interp_env_cons; auto.
    - iDestruct "Hiv" as ([w w']) "[% Hw]"; simplify_eq.
      iMod (step_case_inr _ _ K (of_val w') with "[-]") as "Hz"; eauto.
      simpl.
      iApply wp_pure_step_later; auto 1 using to_of_val. iNext.
      asimpl. iApply ('`IHHtyped3 _ ((w,w') :: vvs)); repeat iSplit; eauto.
      iApply interp_env_cons; auto.
  Qed.

  Lemma bin_log_related_lam Γ (e e' : expr) τ1 τ2
      (Hclosed : ∀ f, e.[upn (S (length Γ)) f] = e)
      (Hclosed' : ∀ f, e'.[upn (S (length Γ)) f] = e')
      (IHHtyped : τ1 :: Γ ⊨ e ≤log≤ e' : τ2) :
    Γ ⊨ Lam e ≤log≤ Lam e' : TArrow τ1 τ2.
  Proof.
    iIntros (Δ vvs ρ ?) "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    iApply wp_value. iExists (LamV _). iIntros "{$Hj} !#".
    iIntros ([v v']) "#Hiv". iIntros (K') "Hj".
    iDestruct (interp_env_length with "HΓ") as %?.
    iApply wp_pure_step_later; auto 1 using to_of_val. iNext.
    iMod (step_lam _ _ K' _ (of_val v') with "[-]") as "Hz"; eauto.
    asimpl. iApply ('`IHHtyped _ ((v,v') :: vvs)); repeat iSplit; eauto.
    iApply interp_env_cons; iSplit; auto.
  Qed.

  Lemma bin_log_related_app Γ e1 e2 e1' e2' τ1 τ2
      (IHHtyped1 : Γ ⊨ e1 ≤log≤ e1' : TArrow τ1 τ2)
      (IHHtyped2 : Γ ⊨ e2 ≤log≤ e2' : τ1) :
    Γ ⊨ App e1 e2 ≤log≤ App e1' e2' :  τ2.
  Proof.
    iIntros (Δ vvs ρ ?) "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    smart_wp_bind (AppLCtx (e2.[env_subst (vvs.*1)])) v v' "[Hv #Hiv]"
      ('`IHHtyped1 _ _ _ (((AppLCtx (e2'.[env_subst (vvs.*2)]))) :: K)); cbn.
    smart_wp_bind (AppRCtx v) w w' "[Hw #Hiw]"
                  ('`IHHtyped2 _ _ _ ((AppRCtx v') :: K)); cbn.
    iApply ("Hiv" $! (w, w') with "Hiw"); simpl; eauto.
  Qed.

  Lemma bin_log_related_tlam Γ e e' τ
      (IHHtyped : (subst (ren (+1)) <$> Γ) ⊨ e ≤log≤ e' : τ) :
    Γ ⊨ TLam e ≤log≤ TLam e' : TForall τ.
  Proof.
    iIntros (Δ vvs ρ ?) "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    iApply wp_value. iExists (TLamV _).
    iIntros "{$Hj} /= !#"; iIntros (τi ? K') "Hv /=".
    iApply wp_pure_step_later; auto; iNext.
    iMod (step_tlam _ _ K' (e'.[env_subst (vvs.*2)]) with "[-]") as "Hz"; eauto.
    iApply '`IHHtyped; repeat iSplit; eauto. by iApply interp_env_ren.
  Qed.

  Lemma bin_log_related_tapp Γ e e' τ τ'
      (IHHtyped : Γ ⊨ e ≤log≤ e' : TForall τ) :
    Γ ⊨ TApp e ≤log≤ TApp e' : τ.[τ'/].
  Proof.
    iIntros (Δ vvs ρ ?) "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    smart_wp_bind (TAppCtx) v v' "[Hj #Hv]"
      ('`IHHtyped _ _ _ (TAppCtx :: K)).
    iApply wp_wand_r; iSplitL.
    { iSpecialize ("Hv" $! (interp τ' Δ) with "[#]"); [iPureIntro; apply _|].
      iApply "Hv"; eauto. }
    iIntros (w). iDestruct 1 as (w') "Hw".
    iExists _; rewrite -interp_subst; eauto.
  Qed.

  Lemma bin_log_related_fold Γ e e' τ
      (IHHtyped : Γ ⊨ e ≤log≤ e' : τ.[(TRec τ)/]) :
    Γ ⊨ Fold e ≤log≤ Fold e' : TRec τ.
  Proof.
    iIntros (Δ vvs ρ ?) "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    iApply (wp_bind (fill [FoldCtx])); iApply wp_wand_l; iSplitR;
        [|iApply ('`IHHtyped _ _ _ (FoldCtx :: K));
          rewrite ?fill_app; simpl; repeat iSplitR; trivial].
    iIntros (v); iDestruct 1 as (w) "[Hv #Hiv]".
    iApply wp_value. repeat rewrite /= to_of_val; eauto.
    iExists (FoldV w); iFrame "Hv".
    rewrite fixpoint_interp_rec1_eq /= -interp_subst.
    iAlways; iExists (_, _); eauto.
  Qed.

  Lemma bin_log_related_unfold Γ e e' τ
      (IHHtyped : Γ ⊨ e ≤log≤ e' : TRec τ) :
    Γ ⊨ Unfold e ≤log≤ Unfold e' : τ.[(TRec τ)/].
  Proof.
    iIntros (Δ vvs ρ ?) "#[Hρ HΓ]"; iIntros (K) "Hj /=".
    iApply (wp_bind (fill [UnfoldCtx])); iApply wp_wand_l; iSplitR;
        [|iApply ('`IHHtyped _ _ _ (UnfoldCtx :: K));
          rewrite ?fill_app; simpl; repeat iSplitR; trivial].
    iIntros (v). iDestruct 1 as (v') "[Hw #Hiw]".
    rewrite /= fixpoint_interp_rec1_eq /=.
    change (fixpoint _) with (interp (TRec τ) Δ).
    iDestruct "Hiw" as ([w w']) "#[% Hiz]"; simplify_eq/=.
    iMod (step_Fold _ _ K (of_val w') with "[-]") as "Hz"; eauto.
    iApply wp_pure_step_later; cbn; auto.
    iNext. iApply wp_value; auto. iExists _; iFrame "Hz".
      by rewrite -interp_subst.
  Qed.

  Lemma bin_log_related_alloc Γ e e' τ
      (IHHtyped : Γ ⊨ e ≤log≤ e' : τ) :
    Γ ⊨ Alloc e ≤log≤ Alloc e' : Tref τ.
  Proof.
    iIntros (Δ vvs ρ ?) "#[Hρ HΓ]". iIntros (K) "Hj /=".
    smart_wp_bind (AllocCtx) v v' "[Hv #Hiv]" ('`IHHtyped _ _ _ (AllocCtx :: K)).
    iMod (step_alloc _ _ K (of_val v') v' with "[Hv]") as (l') "[Hj Hl']"; eauto.
    iApply wp_fupd. iApply wp_alloc; auto.
    iIntros "!>"; iIntros (l) "Hl".
    iMod (inv_alloc (logN .@ (l,l')) _ (∃ w : val * val,
      l ↦ w.1 ∗ l' ↦ₛ w.2 ∗ interp τ Δ w)%I with "[Hl Hl']") as "HN"; eauto.
    { iNext; iExists (v, v'); by iFrame. }
    iModIntro; iExists (LocV l'). iFrame "Hj". iExists (l, l'). eauto.
  Qed.

  Lemma bin_log_related_load Γ e e' τ
      (IHHtyped : Γ ⊨ e ≤log≤ e' : (Tref τ)) :
    Γ ⊨ Load e ≤log≤ Load e' : τ.
  Proof.
    iIntros (Δ vvs ρ ?) "#[? HΓ]"; iIntros (K) "Hj /=".
    smart_wp_bind (LoadCtx) v v' "[Hv #Hiv]" ('`IHHtyped _ _ _ (LoadCtx :: K)).
    simpl. iDestruct "Hiv" as ([l l']) "[% Hinv]"; simplify_eq.
    iInv (logN .@ (l,l')) as  ([w w']) "[Hw1 [Hw2 #Hw]]" "Hclose"; simpl.
    iMod "Hw2".
    iMod (step_load _ _ K l' 1 w' with "[Hv Hw2]") as "[Hv Hw2]";
      [solve_ndisj|by iFrame|].
    iApply (wp_load _ _ 1 with "[Hw1]"); eauto.
    iNext. iIntros "Hw1". iMod ("Hclose" with "[Hw1 Hw2]").
    { iNext. iExists (w,w'); by iFrame. }
    iModIntro. iExists w'; by iFrame.
  Qed.

  Lemma bin_log_related_store Γ e1 e2 e1' e2' τ
      (IHHtyped1 : Γ ⊨ e1 ≤log≤ e1' : (Tref τ))
      (IHHtyped2 : Γ ⊨ e2 ≤log≤ e2' : τ) :
    Γ ⊨ Store e1 e2 ≤log≤ Store e1' e2' : TUnit.
  Proof.
    iIntros (Δ vvs ρ ?) "#[? HΓ]"; iIntros (K) "Hj /=".
    smart_wp_bind (StoreLCtx _) v v' "[Hv #Hiv]"
      ('`IHHtyped1 _ _ _ ((StoreLCtx _) :: K)).
    smart_wp_bind (StoreRCtx _) w w' "[Hw #Hiw]"
      ('`IHHtyped2 _ _ _ ((StoreRCtx _) :: K)).
    simpl. iDestruct "Hiv" as ([l l']) "[% Hinv]"; simplify_eq/=.
    iInv (logN .@ (l,l')) as ([v v']) "[>Hv1 [>Hv2 #Hv]]" "Hclose".
    iMod (step_store _ _ K l' v' (of_val w') w' with "[Hw Hv2]")
      as "[Hw Hv2]"; [solve_ndisj|by iFrame|].
    iApply (wp_store with "[Hv1]"); eauto using to_of_val.
    iNext. iIntros "Hv1". iMod ("Hclose" with "[Hv1 Hv2]").
    { iNext; iExists (w, w'); by iFrame. }
    iExists UnitV; iFrame; auto.
  Qed.

  Theorem binary_fundamental Γ e τ :
    Γ ⊢ₜ e : τ → Γ ⊨ e ≤log≤ e : τ.
  Proof.
    induction 1.
    - by apply bin_log_related_var.
    - by apply bin_log_related_unit.
    - apply bin_log_related_pair; eauto.
    - eapply bin_log_related_fst; eauto.
    - eapply bin_log_related_snd; eauto.
    - eapply bin_log_related_injl; eauto.
    - eapply bin_log_related_injr; eauto.
    - eapply bin_log_related_case; eauto;
        match goal with H : _ |- _ => eapply (typed_n_closed _ _ _ H) end.
    - eapply bin_log_related_lam; eauto;
        match goal with H : _ |- _ => eapply (typed_n_closed _ _ _ H) end.
    - eapply bin_log_related_app; eauto.
    - eapply bin_log_related_tlam; eauto with typeclass_instances.
    - eapply bin_log_related_tapp; eauto.
    - eapply bin_log_related_fold; eauto.
    - eapply bin_log_related_unfold; eauto.
    - eapply bin_log_related_alloc; eauto.
    - eapply bin_log_related_load; eauto.
    - eapply bin_log_related_store; eauto.
  Qed.
End fundamental.


Set Implicit Arguments.
Require Import GMuAnnot.Prelude.
Require Import GMuAnnot.Infrastructure.
Require Import GMuAnnot.Regularity.
Require Import GMuAnnot.Regularity2.
Require Import GMuAnnot.SubstMatch.
Require Import GMuAnnot.Equations.
Require Import TLC.LibLN.

#[export] Hint Resolve okt_is_ok.

Lemma typing_weakening_delta_eq:
  forall (u : trm) (Σ : GADTEnv) (D1 D2 : list typctx_elem) (E : env bind) (U : typ) eq TT,
    {Σ, D1 |,| D2, E} ⊢(TT) u ∈ U ->
    {Σ, D1 |,| [tc_eq eq]* |,| D2, E} ⊢(TT) u ∈ U.
Proof.
  introv Typ; gen_eq D': (D1 |,| D2); gen D2.
  induction Typ; introv EQ; subst;
    try solve [
          econstructor; fresh_intros; eauto
        | econstructor; eauto using okt_weakening_delta_eq; eauto using wft_weaken
        ].
  - apply_fresh typing_tabs as Y; auto.
    lets* IH: H1 Y (D2 |,| [tc_var Y]*).
  - econstructor; eauto.
    introv In Alen Adist Afr xfr xAfr.

    lets* IH: H4 In xAfr (D2 |,| tc_vars Alphas |,|
                          equations_from_lists Ts (List.map (open_tt_many_var Alphas) (Crettypes def))).
    repeat rewrite List.app_assoc in *.
    apply~ IH.
  - econstructor; eauto.
    + destruct eq. apply~ equation_weaken_eq.
    + apply~ wft_weaken.
Qed.

Lemma typing_weakening_delta:
  forall (u : trm) (Σ : GADTEnv) (D1 D2 : list typctx_elem) (E : env bind) (U : typ) (Y : var) TT,
    {Σ, D1 |,| D2, E} ⊢(TT) u ∈ U ->
    Y # E ->
    Y \notin domΔ D1 ->
    Y \notin domΔ D2 ->
    Y \notin fv_delta D2 ->
    {Σ, D1 |,| [tc_var Y]* |,| D2, E} ⊢(TT) u ∈ U.
Proof.
  introv Typ FE FD1 FD2 FrD; gen_eq D': (D1 |,| D2); gen D2.
  lets Typ2: Typ.
  induction Typ; introv FD2 FrD EQ; subst;
    try solve [
          econstructor; fresh_intros; eauto
        | econstructor; eauto using okt_weakening_delta; eauto using wft_weaken
        ].
  - econstructor; auto;
    try let envvars := gather_vars in
    instantiate (1:=envvars); auto.
    intros.
    lets* IH: H1 X (D2 |,| [tc_var X]*).
    repeat rewrite <- List.app_assoc in *.
    apply IH; auto.
    rewrite notin_domΔ_eq. split; auto.
    cbn. rewrite notin_union.
    split; auto.
  - econstructor; eauto.
    introv Hin.
    try let envvars := gather_vars in
    introv Hlen Hdist Afresh xfreshL xfreshA;
      instantiate (1:=envvars) in xfreshL.
    lets IH: H4 Hin Hlen (D2 |,| tc_vars Alphas |,| equations_from_lists Ts (List.map (open_tt_many_var Alphas) (Crettypes def))); eauto.
    + introv Ain. lets*: Afresh Ain.
    + eauto.
    + apply~ H3.
      introv Ain. lets*: Afresh Ain.
    + repeat rewrite List.app_assoc in *.
      apply IH; auto.
      rewrite notin_domΔ_eq; split; auto.
      * rewrite notin_domΔ_eq; split; auto.
        -- apply notin_dom_tc_vars.
           intro HF.
           lets HF2: from_list_spec HF.
           lets HF3: LibList_mem HF2.
           lets HF4: Afresh HF3.
           eapply notin_same.
           instantiate (1:=Y).
           eauto.
        -- rewrite equations_have_no_dom; auto.
           apply* equations_from_lists_are_equations.
      * repeat rewrite fv_delta_app.
        repeat rewrite notin_union.
        splits~.
        -- rewrite~ fv_delta_alphas.
        -- lets [? [? WFT]]: typing_regular Typ.
           lets FV: wft_gives_fv WFT.
           cbn in FV.
           apply fv_delta_equations.
           ++ intros T Tin.
              intro HF.
              lets FV2: fold_left_subset fv_typ Tin.
              lets FV3: subset_transitive FV2 FV.
              lets FV4: FV3 HF.
              rewrite domDelta_app in FV4.
              rewrite in_union in FV4.
              destruct FV4; auto.
           ++ intros R Rin.
              assert (OKS: okGadt Σ).
              ** apply~ okt_implies_okgadt.
                 apply* typing_regular.
              ** apply List.in_map_iff in Rin.
                 destruct Rin as [rT [? rTin]]; subst.
                 lets Sub: fv_smaller_many Alphas rT.
                 intro HF.
                 lets HF2: Sub HF.
                 rewrite in_union in HF2.
                 destruct HF2 as [HF2 | HF2].
                 ---
                   destruct OKS as [? OKS].
                   lets [? OKD]: OKS H0.
                   lets Din: fst_from_zip Hin.
                   lets OKC: OKD Din.
                   inversion OKC as [? ? ? ? ? ? ? ? ? FrR]; subst.
                   cbn in rTin.
                   lets FR: FrR rTin.
                   rewrite FR in HF2.
                   false* in_empty_inv.
                 ---
                   lets [A [Ain ?]]: in_from_list HF2; subst.
                   lets: Afresh Ain.
                   assert (A \notin \{ A}); auto.
                   false* notin_same.
  - econstructor.
    + apply~ IHTyp.
    + apply~ equation_weaken_var.
    + apply wft_weaken.
      lets~ [? [? ?]]: typing_regular Typ2.
Qed.

Lemma typing_weakening_delta_many_eq : forall Σ Δ E Deqs u U TT,
    {Σ, Δ, E} ⊢(TT) u ∈ U ->
    (forall eq, List.In eq Deqs -> exists ϵ, eq = tc_eq ϵ) ->
    {Σ, Δ |,| Deqs, E} ⊢(TT) u ∈ U.
  induction Deqs; introv Typ EQs.
  - clean_empty_Δ. auto.
  - destruct a;
      try solve [lets HF: EQs (tc_var A); false~ HF].
    fold_delta.
    rewrite <- List.app_assoc.
    lets W: typing_weakening_delta_eq Σ (Δ |,| Deqs) emptyΔ.
    clean_empty_Δ.
    rewrite <- (List.app_nil_l ((Δ |,| Deqs) |,| [tc_eq eq]*)).
    apply~ W.
    apply~ IHDeqs.
    intros eq1 ?. lets Hin: EQs eq1.
    destruct Hin; eauto.
    cbn. auto.
Qed.

Lemma typing_weakening_delta_many : forall Σ Δ E As u U TT,
    (forall A, List.In A As -> A # E) ->
    (forall A, List.In A As -> A \notin domΔ Δ) ->
    DistinctList As ->
    {Σ, Δ, E} ⊢(TT) u ∈ U ->
    {Σ, Δ |,| tc_vars As, E} ⊢(TT) u ∈ U.
  induction As as [| Ah Ats]; introv AE AD Adist Typ.
  - cbn. clean_empty_Δ. auto.
  - cbn. fold_delta.
    inversions Adist.
    rewrite <- (List.app_nil_l ((Δ |,| tc_vars Ats) |,| [tc_var Ah]*)).
    apply typing_weakening_delta; cbn; auto with listin.
    rewrite notin_domΔ_eq. split.
    + auto with listin.
    + apply notin_dom_tc_vars.
      intro HF.
      apply from_list_spec in HF.
      apply LibList_mem in HF.
      auto.
Qed.

Lemma typing_weakening : forall Σ Δ E F G e T TT,
    {Σ, Δ, E & G} ⊢(TT) e ∈ T ->
    okt Σ Δ (E & F & G) ->
    {Σ, Δ, E & F & G} ⊢(TT) e ∈ T.
Proof.
  introv HTyp. gen_eq K: (E & G). gen G F.
  induction HTyp using typing_ind; introv EQ Ok; subst; eauto.
  - apply* typing_var. apply* binds_weaken.
  - econstructor; eauto.
    let env := gather_vars in
    instantiate (2:=env).
    introv xfresh.
    lets IH: H0 x (G & x ~l V) F; auto.
    rewrite <- concat_assoc.
    apply IH.
    + auto using concat_assoc.
    + rewrite concat_assoc.
      econstructor; eauto.
      assert (xL: x \notin L); auto.
      lets Typ: H xL.
      lets [? [? ?]]: typing_regular Typ.
      eapply okt_is_wft. eauto.
  - apply_fresh* typing_tabs as X.
    lets IH: H1 X G F; auto.
    apply IH.
    + auto using JMeq_from_eq.
    + rewrite <- (List.app_nil_l (Δ |,| [tc_var X]*)).
      apply okt_weakening_delta; clean_empty_Δ; cbn; auto.
  - apply_fresh* typing_fix as x.
    lets IH: H1 x (G & x ~f T) F; auto.
    rewrite <- concat_assoc.
    apply IH; repeat rewrite concat_assoc; auto.
    constructor; auto.
    lets [? [? ?]]: typing_regular T; eauto.
  - apply_fresh* typing_let as x.
    lets IH: H0 x (G & x ~l V) F; auto.
    rewrite <- concat_assoc.
    apply IH; repeat rewrite concat_assoc; auto.
    constructor; auto.
    lets [? [? ?]]: typing_regular V; eauto.
  - eapply typing_case; eauto.
    introv Inzip.
    let envvars := gather_vars in
    (introv AlphasArity ADistinct Afresh xfresh xfreshA;
     instantiate (1:=envvars) in Afresh).
    assert (AfreshL: forall A : var, List.In A Alphas -> A \notin L);
      [ introv Ain; lets*: Afresh Ain | idtac ].
    assert (xfreshL: x \notin L); eauto.
    lets* IH1: H4 Inzip Alphas x AlphasArity ADistinct.
    lets* IH2: IH1 AfreshL xfreshL xfreshA (G & x ~l open_tt_many_var Alphas (Cargtype def)) F.
    repeat rewrite concat_assoc in IH2.
    apply~ IH2.

    constructor; auto.
    + rewrite <- (List.app_nil_l (Δ |,| tc_vars Alphas |,| equations_from_lists Ts (List.map (open_tt_many_var Alphas) (Crettypes def)))).
      apply okt_weakening_delta_many_eq.
      * apply okt_weakening_delta_many; clean_empty_Δ;
          try solve [introv Ain; cbn; lets: Afresh Ain; auto]; auto.
      * apply* equations_from_lists_are_equations.
    + assert (OKS: okGadt Σ).
      * apply~ okt_implies_okgadt.
        apply* typing_regular.
      * destruct OKS as [? OKS].
        lets [? OKD]: OKS H0.
        lets Din: fst_from_zip Inzip.
        lets OKC: OKD Din.
        inversion OKC as [? ? ? ? ? ? Harg ? ? ?]; subst.
        cbn.
        apply wft_weaken_simple.
        apply~ Harg.
    + repeat rewrite notin_domΔ_eq.
      split~.
      * split~.
        apply notin_dom_tc_vars. auto.
      * rewrite equations_have_no_dom; eauto using equations_from_lists_are_equations.
Qed.

Lemma typing_through_subst_ee_lam : forall Σ Δ E F x u U e T TT1 TT2,
    {Σ, Δ, E & (x ~l U) & F} ⊢(TT1) e ∈ T ->
    {Σ, Δ, E} ⊢(TT2) u ∈ U ->
    value u ->
    {Σ, Δ, E & F} ⊢(Tgen) subst_ee x lam_var u e ∈ T.
  Ltac apply_ih :=
    match goal with
    | H: forall X, X \notin ?L -> forall E0 F0 x0 vk0 U0, ?P1 -> ?P2 |- _ =>
      apply_ih_bind* H end.
  introv TypT TypU ValU.
  inductions TypT; introv; cbn;
    try solve [eapply Tgen_from_any; eauto using okt_strengthen];
    lets [okU [termU wftU]]: typing_regular TypU.
  - match goal with
    | [ H: okt ?A ?B ?C |- _ ] =>
      lets: okt_strengthen H
    end.
    case_if~.
    + eapply Tgen_from_any.
      inversions C.
      binds_get H; eauto.
      assert (E & F & empty = E & F) as HEF by apply concat_empty_r.
      rewrite <- HEF.
      apply typing_weakening; rewrite concat_empty_r; eauto.
    + eapply Tgen_from_any. binds_cases H; apply* typing_var.
      match goal with
      | [H: bind_var ?vk ?T = bind_var ?vk2 ?U |- _] =>
        inversion* H
      end.
  - eapply Tgen_from_any.
    apply_fresh* typing_abs as y.
    rewrite* subst_ee_open_ee_var.
    apply_ih.
  - eapply Tgen_from_any.
    apply_fresh* typing_tabs as Y; rewrite* subst_ee_open_te_var.
    match goal with
    | [ H: forall X, X \notin ?L -> forall E0 F0 x0 vk0 U0, ?P1 -> ?P2 |- _ ] =>
      apply* H
    end.
    rewrite <- (List.app_nil_l (Δ |,| [tc_var Y]*)).
    apply typing_weakening_delta; clean_empty_Δ; cbn; auto.
  - eapply Tgen_from_any.
    apply_fresh* typing_fix as y; rewrite* subst_ee_open_ee_var.
    apply_ih.
  - eapply Tgen_from_any.
    apply_fresh* typing_let as y.
    rewrite* subst_ee_open_ee_var.
    apply_ih.
  - eapply Tgen_from_any.
    econstructor; eauto.
    + unfold map_clause_trm_trm.
      rewrite* List.map_length.
    + introv inzip.
      lets* [i [Hdefs Hmapped]]: Inzip_to_nth_error inzip.
      lets* [[clA' clT'] [Hclin Hclsubst]]: nth_error_map Hmapped.
      destruct clause as [clA clT]. cbn.
      inversions Hclsubst.
      lets* Hzip: Inzip_from_nth_error Hdefs Hclin.
      lets*: H2 Hzip.
    + introv inzip.
      let env := gather_vars in
      intros Alphas xClause Alen Adist Afresh xfresh xfreshA;
        instantiate (1:=env) in xfresh.
      lets* [i [Hdefs Hmapped]]: Inzip_to_nth_error inzip.
      lets* [[clA' clT'] [Hclin Hclsubst]]: nth_error_map Hmapped.
      destruct clause as [clA clT]. cbn.
      inversions Hclsubst.
      lets* Hzip: Inzip_from_nth_error Hdefs Hclin.
      lets* IH: H4 Hzip.

      assert (Htypfin: {Σ, Δ |,| tc_vars Alphas |,| equations_from_lists Ts (List.map (open_tt_many_var Alphas) (Crettypes def)),
                        E & F & xClause ~l (open_tt_many_var Alphas (Cargtype def))}
                ⊢(Tgen) subst_ee x lam_var u (open_te_many_var Alphas clT' open_ee_varlam xClause) ∈ Tc).
      * assert (AfreshL: forall A : var, List.In A Alphas -> A \notin L);
          [ introv Ain; lets*: Afresh Ain | idtac ].
        assert (xfreshL: xClause \notin L); eauto.
        lets Htmp: IH Alphas xClause Alen Adist AfreshL.
        lets Htmp2: Htmp xfreshL xfreshA.
        lets Htmp3: Htmp2 E (F & xClause ~l (open_tt_many_var Alphas (Cargtype def))) x U.
        cbn in Htmp3.
        rewrite <- concat_assoc.
        apply* Htmp3.
        apply JMeq_from_eq.
        eauto using concat_assoc.
        apply typing_weakening_delta_many_eq;
          eauto using equations_from_lists_are_equations.
        apply typing_weakening_delta_many; auto;
          try introv Ain; lets: Afresh Ain; auto.
      * assert (Horder:
                  subst_ee x lam_var u (open_te_many_var Alphas clT' open_ee_varlam xClause)
                  =
                  open_te_many_var Alphas (subst_ee x lam_var u clT') open_ee_varlam xClause).
        -- rewrite* <- subst_ee_open_ee_var.
           f_equal.
           apply* subst_commutes_with_unrelated_opens_te_ee.
        -- rewrite* <- Horder.
               Qed.

Lemma typing_through_subst_ee_fix : forall Σ Δ E F x u U e T TT1 TT2,
    {Σ, Δ, E & (x ~f U) & F} ⊢(TT1) e ∈ T ->
    {Σ, Δ, E} ⊢(TT2) u ∈ U ->
    {Σ, Δ, E & F} ⊢(Tgen) subst_ee x fix_var u e ∈ T.
  introv TypT TypU.
  inductions TypT; introv; cbn;
    try solve [eapply Tgen_from_any; eauto using okt_strengthen];
    lets [okU [termU wftU]]: typing_regular TypU.
  - match goal with
    | [ H: okt ?A ?B ?C |- _ ] =>
      lets: okt_strengthen H
    end.
    case_if~.
    + inversions C.
      eapply Tgen_from_any. binds_get H; eauto.
      assert (E & F & empty = E & F) as HEF by apply concat_empty_r.
      rewrite <- HEF.
      apply typing_weakening; rewrite concat_empty_r; eauto.
    + eapply Tgen_from_any. binds_cases H; apply* typing_var.
      match goal with
      | [H: bind_var ?vk ?T = bind_var ?vk2 ?U |- _] =>
        inversion* H
      end.
  - eapply Tgen_from_any.
    apply_fresh* typing_abs as y.
    rewrite* subst_ee_open_ee_var.
    apply_ih.
  - eapply Tgen_from_any.
    apply_fresh* typing_tabs as Y; rewrite* subst_ee_open_te_var.
    + apply* subst_ee_fix_value.
    + match goal with
      | [ H: forall X, X \notin ?L -> forall E0 F0 x0 vk0 U0, ?P1 -> ?P2 |- _ ] =>
        apply* H
      end.
      rewrite <- (List.app_nil_l (Δ |,| [tc_var Y]* )).
      apply typing_weakening_delta; clean_empty_Δ; cbn; auto.
  - eapply Tgen_from_any.
    apply_fresh* typing_fix as y; rewrite* subst_ee_open_ee_var.
    + apply* subst_ee_fix_value.
    + apply_ih.
  - eapply Tgen_from_any.
    apply_fresh* typing_let as y.
    rewrite* subst_ee_open_ee_var.
    apply_ih.
  - eapply Tgen_from_any.
    econstructor; eauto.
    + unfold map_clause_trm_trm.
      rewrite* List.map_length.
    + introv inzip.
      lets* [i [Hdefs Hmapped]]: Inzip_to_nth_error inzip.
      lets* [[clA' clT'] [Hclin Hclsubst]]: nth_error_map Hmapped.
      destruct clause as [clA clT]. cbn.
      inversions Hclsubst.
      lets* Hzip: Inzip_from_nth_error Hdefs Hclin.
      lets*: H2 Hzip.
    + introv inzip.
      let env := gather_vars in
      intros Alphas xClause Alen Adist Afresh xfresh xfreshA;
        instantiate (1:=env) in xfresh.
      lets* [i [Hdefs Hmapped]]: Inzip_to_nth_error inzip.
      lets* [[clA' clT'] [Hclin Hclsubst]]: nth_error_map Hmapped.
      destruct clause as [clA clT]. cbn.
      inversions Hclsubst.
      lets* Hzip: Inzip_from_nth_error Hdefs Hclin.
      lets* IH: H4 Hzip.

      assert (Htypfin: {Σ, Δ |,| tc_vars Alphas |,| equations_from_lists Ts (List.map (open_tt_many_var Alphas) (Crettypes def)),
                        E & F & xClause ~l (open_tt_many_var Alphas (Cargtype def))}
                ⊢(Tgen) subst_ee x fix_var u (open_te_many_var Alphas clT' open_ee_varlam xClause) ∈ Tc).
      * assert (AfreshL: forall A : var, List.In A Alphas -> A \notin L);
          [ introv Ain; lets*: Afresh Ain | idtac ].
        assert (xfreshL: xClause \notin L); eauto.
        lets Htmp: IH Alphas xClause Alen Adist AfreshL.
        lets Htmp2: Htmp xfreshL xfreshA.
        lets Htmp3: Htmp2 E (F & xClause ~l (open_tt_many_var Alphas (Cargtype def))) x U.
        cbn in Htmp3.
        rewrite <- concat_assoc.
        apply* Htmp3.
        apply JMeq_from_eq.
        eauto using concat_assoc.
        apply typing_weakening_delta_many_eq;
          eauto using equations_from_lists_are_equations.
        apply typing_weakening_delta_many; auto;
          try introv Ain; lets: Afresh Ain; auto.
      * assert (Horder:
                  subst_ee x fix_var u (open_te_many_var Alphas clT' open_ee_varlam xClause)
                  =
                  open_te_many_var Alphas (subst_ee x fix_var u clT') open_ee_varlam xClause).
        -- rewrite* <- subst_ee_open_ee_var.
           f_equal.
           apply* subst_commutes_with_unrelated_opens_te_ee.
        -- rewrite* <- Horder.
Qed.

Lemma typing_through_subst_te_gen : forall Σ Δ1 Δ2 E Z e P T TT,
    {Σ, Δ1 |,| [tc_var Z]* |,| Δ2, E} ⊢(TT) e ∈ T ->
    wft Σ Δ1 P ->
    Z \notin fv_typ P ->
    Z \notin domΔ (Δ1 |,| Δ2) ->
    Z # E ->
    {Σ, Δ1 |,| List.map (subst_td Z P) Δ2, map (subst_tb Z P) E} ⊢(Tgen) subst_te Z P e ∈ subst_tt Z P T.
  introv Typ.
  gen_eq G: (Δ1 |,| [tc_var Z]* |,| Δ2). gen Δ2.
  induction Typ; introv EQ WFT FVZP FVZD FVZE; subst; eapply Tgen_from_any;
    cbn; eauto.
  - constructor. apply~ okt_through_subst_tdtb.
  - cbn. econstructor.
    + fold (subst_tb Z P (bind_var vk T)).
      apply~ binds_map.
    + apply~ okt_through_subst_tdtb.
  - assert (OKS: okGadt Σ).
    1: {
      apply~ okt_implies_okgadt.
      apply* typing_regular.
    }
    destruct OKS as [? OKS].
    lets [? OKD]: OKS H.
    lets Din: List.nth_error_In H0.
    lets OKC: OKD Din.
    inversion OKC as [? ? ? ? ? ? Harg Hwft FVarg FVret]; subst.
    econstructor; auto.
    + apply H.
    + rewrite~ List.map_length.
      eauto.
    + rewrite~ subst_commutes_open_tt_many.
      * apply* type_from_wft.
      * rewrite~ FVarg.
    + intros T' Tin.
      apply List.in_map_iff in Tin.
      destruct Tin as [T [? Tin]]; subst.
      apply* wft_subst_tb_3.
    + rewrite~ subst_commutes_open_tt_many.
      * apply* type_from_wft.
      * cbn. fold (fv_typs CretTypes).
        apply~ notin_fold.
        intros TR Tin.
        rewrite~ FVret.
  - apply_fresh typing_abs as x.
    fold (subst_tb Z P (bind_var lam_var V)).
    rewrite <- map_push.
    rewrite subst_te_open_ee_var.
    apply~ H0.
  - lets: type_from_wft WFT.
    apply_fresh typing_tabs as X.
    + forwards~ : H X.
      rewrite~ subst_te_open_te_var.
    + forwards * IH : H1 X (Δ2 |,| [tc_var X]*).
      1: {
        fold_delta.
        repeat rewrite domDelta_app in *.
        repeat rewrite notin_union in *.
        destruct FVZD.
        repeat split~.
        cbn.
        rewrite notin_union; split~.
        apply* notin_inverse.
      }
      fold_delta.
      repeat rewrite List.app_assoc in *.
      rewrite~ subst_te_open_te_var.
      rewrite~ subst_tt_open_tt_var.
      apply* IH.
  - econstructor; auto.
    + apply* IHTyp.
    + apply* wft_subst_tb_3.
    + fold subst_tt.
      rewrite* subst_tt_open_tt.
  - apply_fresh typing_fix as x.
    + forwards~ : H x.
      rewrite subst_te_open_ee_var.
      apply~ subst_te_value.
      apply* type_from_wft.
    + fold (subst_tb Z P (bind_var fix_var T)).
      rewrite <- map_push.
      rewrite subst_te_open_ee_var.
      apply~ H1.
  - apply_fresh typing_let as x.
    + apply* IHTyp.
    + rewrite subst_te_open_ee_var.
      fold (subst_tb Z P (bind_var lam_var V)).
      rewrite <- map_push.
      apply~ H0.
  - econstructor; eauto.
    + cbn. eauto.
    + unfold map_clause_trm_trm.
      rewrite~ List.map_length.
    + introv Inzip.
      lets [clA [clT [In2 ?]]]: inzip_map_clause_trm Inzip; subst.
      lets: H2 In2.
      cbn in *. auto.
    + let FV := gather_vars in
      introv Inzip Len Dist FA Fx FxA;
        instantiate (1 := FV) in FA.
      lets [clA [clT [In2 ?]]]: inzip_map_clause_trm Inzip; subst.
      assert (OKS: okGadt Σ).
      1: {
        apply~ okt_implies_okgadt.
        apply* typing_regular.
      }
      destruct OKS as [? OKS].
      lets [? OKD]: OKS H0; clear OKS.
      lets Din: fst_from_zip In2.
      lets OKC: OKD Din.
      inversion OKC as [? ? ? ? ? ? Harg Hwft FVarg FVret]; subst.
      cbn in *.
      lets~ IH : H4 In2 x Len Dist (Δ2 |,| tc_vars Alphas
                                |,| equations_from_lists Ts
                                (List.map (open_tt_many_var Alphas) retTs)).
      * introv Ain. lets*: FA Ain.
      * cbn in *.
        forwards~ IH2: IH; clear IH.
        -- repeat rewrite~ List.app_assoc.
        -- repeat rewrite domDelta_app in *.
           repeat rewrite notin_union.
           repeat rewrite notin_union in FVZD.
           destruct FVZD.
           repeat split~.
           ++ apply notin_dom_tc_vars.
              apply~ notin_from_list.
              intro HF.
              lets HF2 : FA HF.
              repeat rewrite notin_union in HF2.
              assert (Z \notin \{ Z }).
              ** destruct~ HF2 as [? [[? ?] ?]].
              ** apply* notin_same.
           ++ rewrite~ equations_have_no_dom.
              apply* equations_from_lists_are_equations.
        -- assert (FVZA: forall X : var, List.In X Alphas -> X <> Z).
           1: {
             intros A Ain.
             intro HF.
             subst.
             lets FA2: FA Ain.
             repeat rewrite notin_union in FA2.
             destruct~ FA2 as [? [[?]]].
             apply* notin_same.
           }
           rewrite~ <- subst_commutes_with_unrelated_opens_te.
           ** rewrite subst_te_open_ee_var.
              rewrite List.map_app in IH2.
              rewrite List.map_app in IH2.
              rewrite subst_td_alphas in IH2.
              rewrite subst_td_eqs in IH2.
              --- rewrite map_concat in IH2.
                  rewrite map_single in IH2.
                  cbn in IH2.
                  assert (Hrew: subst_tt Z P (open_tt_many_var Alphas argT) = open_tt_many_var Alphas argT).
                  +++ rewrite~ subst_commutes_with_unrelated_opens.
                      *** f_equal. rewrite~ subst_tt_fresh.
                          rewrite~ FVarg.
                      *** apply* type_from_wft.
                  +++ rewrite Hrew in IH2; clear Hrew.
                      repeat rewrite List.app_assoc in *.
                      apply IH2.
              --- introv Uin.
                  apply List.in_map_iff in Uin.
                  destruct Uin as [V [EQ Vin]]; subst.
                  intro HF.
                  lets Sm: fv_smaller_many Alphas V.
                  apply Sm in HF.
                  rewrite in_union in HF.
                  destruct HF as [HF|HF].
                  +++ rewrite~ FVret in HF.
                      apply* in_empty_inv.
                  +++ apply from_list_spec in HF.
                      apply LibList_mem in HF.
                      lets: FVZA HF. false.
           ** apply* type_from_wft.
  - econstructor; eauto.
    + apply* entails_through_subst.
    + apply* wft_subst_tb_3.
Qed.

Lemma typing_through_subst_te_3 :
  forall Σ Δ E Z e P T TT,
    {Σ, Δ |,| [tc_var Z]*, E} ⊢(TT) e ∈ T ->
    wft Σ Δ P ->
    Z \notin fv_typ P ->
    Z # E ->
    Z \notin fv_env E ->
    Z \notin domΔ Δ ->
    {Σ, Δ, E} ⊢(Tgen) subst_te Z P e ∈ subst_tt Z P T.
  introv Typ WFT ZP ZE1 ZE2 ZD.
  rewrite <- (List.app_nil_l (Δ |,| [tc_var Z]*)) in Typ.
  lets HT: typing_through_subst_te_gen Typ WFT ZP ZD ZE1.
  cbn in HT.
  rewrite~ subst_tb_id_on_fresh in HT.
Qed.

Lemma typing_through_subst_te_many : forall As Σ Δ Δ2 E F e T Ps TT,
    {Σ, (Δ |,| tc_vars As |,| Δ2), E & F} ⊢(TT) e ∈ T ->
    length As = length Ps ->
    (forall P, List.In P Ps -> wft Σ Δ P) ->
    (forall A, List.In A As -> A # E) ->
    (forall A, List.In A As -> A # F) ->
    (forall A, List.In A As -> A \notin domΔ Δ) ->
    (forall A, List.In A As -> A \notin domΔ Δ2) ->
    (forall A P, List.In A As -> List.In P Ps -> A \notin fv_typ P) ->
    (forall A, List.In A As -> A \notin fv_env E) ->
    DistinctList As ->
    {Σ, Δ |,| List.map (subst_td_many As Ps) Δ2, E & map (subst_tb_many As Ps) F} ⊢(Tgen) (subst_te_many As Ps e) ∈  subst_tt_many As Ps T.
  induction As as [| Ah Ats]; introv Htyp Hlen Pwft AE AF AD AD2 AP AEE Adist;
    destruct Ps as [| Ph Pts]; try solve [cbn in *; congruence].
  - cbn. cbn in Htyp.
    rewrite List.map_id.
    rewrite map_def.
    rewrite <- LibList_map.
    rewrite <- map_id; eauto using Tgen_from_any.
    intros. destruct x as [? [?]].
    cbv. auto.
  - cbn.
    inversions Adist.
    lets IH0: IHAts Σ Δ (List.map (subst_td Ah Ph) Δ2) (map (subst_tb Ah Ph) E) (map (subst_tb Ah Ph) F).
    lets IH: IH0 (subst_te Ah Ph e) (subst_tt Ah Ph T) Pts; clear IH0.
    rewrite <- (@subst_tb_id_on_fresh E Ah Ph).
    rewrite subst_tb_many_split.
    rewrite List.map_map in IH.
    eapply IH; auto with listin.
    + clear IH IHAts.
      cbn in Htyp. fold_delta.
      lets HT: typing_through_subst_te_gen Ph Htyp.
      rewrite <- map_concat.
      apply HT; auto with listin.
      * assert (WFT: wft Σ Δ Ph); auto with listin.
        apply* wft_weaken_simple.
      * repeat rewrite domDelta_app.
        repeat rewrite notin_union.
        repeat split; auto with listin.
        apply notin_dom_tc_vars.
        intro HF.
        apply from_list_spec in HF.
        apply LibList_mem in HF.
        false~.
    + introv Ain.
      rewrite <- domDelta_subst_td; auto with listin.
    + introv Ain.
      apply~ fv_env_subst; auto with listin.
    + auto with listin.
Qed.

Ltac generalize_typings :=
  match goal with
  | [ H: {?Σ, ?D, ?E} ⊢(?TT) ?e ∈ ?T |- _ ] =>
    match TT with
    | Tgen => fail 1
    | Treg => fail 1
    | _ => apply Tgen_from_any in H;
           try clear TT
    end
  end.

Lemma typing_replace_typ_gen : forall Σ Δ E F x vk T1 TT e U T2,
    {Σ, Δ, E & x ~ bind_var vk T1 & F} ⊢( TT) e ∈ U ->
    wft Σ Δ T2 ->
    entails_semantic Σ Δ (T1 ≡ T2) ->
    {Σ, Δ, E & x ~ bind_var vk T2 & F} ⊢(Tgen) e ∈ U.
  introv Typ.
  gen_eq K: (E & x ~ bind_var vk T1 & F). gen F x T1.
  induction Typ using typing_ind; introv EQ WFT Sem; subst; eauto;
    try solve [apply Tgen_from_any with Treg; eauto].
  - apply Tgen_from_any with Treg;
      econstructor. apply* okt_replace_typ.
  - destruct (classicT (x = x0)); subst.
    + lets: okt_is_ok H0.
      apply binds_middle_eq_inv in H; auto.
      inversions H.
      apply typing_eq with T2 Treg.
      * constructor.
        -- apply binds_concat_left.
           ++ apply binds_push_eq.
           ++ lets* [? ?]: ok_middle_inv H1.
        -- apply* okt_replace_typ.
      * apply~ teq_symmetry.
      * apply* okt_is_wft_2.
    + apply Tgen_from_any with Treg.
      constructor.
      * lets [? | [[? [? ?]] | [? [? ?]]]]: binds_middle_inv H; subst.
        -- apply~ binds_concat_right.
        -- false.
        -- apply~ binds_concat_left.
      * apply* okt_replace_typ.
  - apply Tgen_from_any with Treg.
    econstructor.
    introv xiL.
    lets IH: H0 xiL (F & x0 ~l V) x T0.
    repeat rewrite concat_assoc in IH.
    apply* IH.
  - apply Tgen_from_any with Treg.
    econstructor; eauto.
    introv xiL.
    lets IH: H1 xiL F x T0.
    repeat rewrite concat_assoc in IH.
    apply* IH.
    + apply~ wft_weaken_simple.
    + rewrite <- (List.app_nil_l (Δ |,| [tc_var X]*)).
      apply~ equation_weaken_var.
      cbn. auto.
  - apply Tgen_from_any with Treg.
    econstructor; eauto.
    introv xiL.
    lets IH: H1 xiL (F & x0 ~f T) x T1.
    repeat rewrite concat_assoc in IH.
    apply* IH.
  - apply Tgen_from_any with Treg.
    econstructor; eauto.
    introv xiL.
    lets IH: H0 xiL (F & x0 ~l V) x T1.
    repeat rewrite concat_assoc in IH.
    apply* IH.
  - apply Tgen_from_any with Treg.
    econstructor; eauto.
    introv In Alen Adist Afr xfr xAfr.
    lets Htmp: H4 In Alen Adist Afr xfr.
    lets IH: Htmp xAfr (F & x0 ~l open_tt_many_var Alphas (Cargtype def)) x T1. clear Htmp.
    repeat rewrite concat_assoc in IH.
    apply* IH.
    + repeat apply* wft_weaken_simple.
    + apply~ equations_weaken_match.
      rewrite List.map_length.
      lets [OKT [? WFT2]]: typing_regular Typ.
      inversions WFT2.
      lets OKS: okt_implies_okgadt OKT.
      inversion OKS as [? OKC].
      lets [? OKD]: OKC H0.
      lets indef: fst_from_zip In.
      lets OKE: OKD indef.
      inversions OKE.
      cbn.
      match goal with
      | [ H1: binds ?g ?A Σ, H2: binds ?g ?B Σ |- _ ] =>
        let H := fresh "H" in
        lets H: binds_ext H1 H2;
          inversions H
      end.
      auto.
Qed.

Lemma typing_replace_typ : forall Σ Δ E x vk T1 TT e U T2,
    {Σ, Δ, E & x ~ bind_var vk T1} ⊢( TT) e ∈ U ->
    entails_semantic Σ Δ (T1 ≡ T2) ->
    wft Σ Δ T2 ->
    {Σ, Δ, E & x ~ bind_var vk T2} ⊢( Tgen) e ∈ U.
  intros.
  rewrite <- (concat_empty_r (E & x ~ bind_var vk T2)).
  apply* typing_replace_typ_gen.
  fold_env_empty.
Qed.

Lemma remove_true_equation : forall Σ Δ1 Δ2 E e TT T U1 U2,
    {Σ, Δ1 |,| [tc_eq (U1 ≡ U2)]* |,| Δ2, E} ⊢(TT) e ∈ T ->
    entails_semantic Σ Δ1 (U1 ≡ U2) ->
    {Σ, Δ1 |,| Δ2, E} ⊢(TT) e ∈ T.
  introv Typ.
  gen_eq D3: (Δ1 |,| [tc_eq (U1 ≡ U2)]* |,| Δ2). gen Δ1 Δ2.
  lets: okt_strengthen_delta_eq.
  lets: wft_strengthen_equation.
  induction Typ using typing_ind; introv EQ Sem; subst; eauto.
  - econstructor; eauto.
    introv XFr.
    lets IH: H3 XFr Δ1 (Δ2 |,| [tc_var X]*).
    apply* IH.
  - econstructor; eauto.
    introv clin Hlen Hdist Afresh xfresh xfreshA.
    lets Htmp: H6 clin Hlen Hdist Afresh xfresh.
    lets IH: Htmp xfreshA Δ1
                  (Δ2 |,| tc_vars Alphas |,| equations_from_lists Ts (List.map (open_tt_many_var Alphas) (Crettypes def)));
      clear Htmp.
    repeat rewrite List.app_assoc in *.
    apply* IH.
  - lets: equation_strengthen H1 Sem.
    econstructor; eauto.
Qed.

Lemma remove_true_equations : forall Σ Δ E e TT V Ts Us,
    {Σ, Δ |,| equations_from_lists Ts Us, E} ⊢(TT) e ∈ V ->
    List.Forall2 (fun T U => entails_semantic Σ Δ (T ≡ U)) Ts Us ->
    {Σ, Δ, E} ⊢(TT) e ∈ V.
  induction 2 as [| T U Ts Us].
  - cbn in *. auto.
  - cbn in H.
    fold (equations_from_lists Ts Us) in H.
    apply* IHForall2.
    rewrite <- (List.app_nil_l ((Δ |,| equations_from_lists Ts Us) |, tc_eq (T ≡ U))) in H.
    forwards~ H2: remove_true_equation H.
    forwards* H3: equations_weaken_match (@nil var) Ts Us.
    apply* Forall2_eq_len.
Qed.

Lemma helper_equations_commute : forall Ts As Us Vs,
    List.length As = List.length Us ->
    List.length Ts = List.length Vs ->
    (forall A, List.In A As -> A \notin fv_typs Ts) ->
    equations_from_lists
      Ts
      (List.map (fun T : typ => subst_tt_many As Us (open_tt_many_var As T)) Vs)
    =
    List.map
      (subst_td_many As Us)
      (equations_from_lists Ts (List.map (open_tt_many_var As) Vs)).
  intros.
  rewrite (equations_from_lists_map _ (subst_tt_many As Us) (subst_tt_many As Us)).
  - f_equal.
    + gen Us.
      induction As as [| A As]; introv Len.
      * cbn. rewrite~ List.map_id.
      * destruct Us as [| U Us]; cbn.
        -- rewrite~ List.map_id.
        -- rewrite <- List.map_map.
           rewrite (List.map_ext_in (subst_tt A U) (fun x => x)).
           ++ rewrite List.map_id.
              apply~ IHAs; auto with listin.
           ++ intros T Tin.
              apply subst_tt_fresh.
              apply fv_typs_notin with Ts; auto with listin.
    + rewrite List.map_map. auto.
  - rewrite~ List.map_length.
  - introv In.
    gen H.
    clear.
    rename U into T2. rename T into T1.
    gen Us T1 T2.
    induction As as [| A As]; introv Len; destruct Us as [| U Us]; auto.
    cbn.
    rewrite~ IHAs.
Qed.

Theorem preservation_thm : preservation.
  Ltac find_hopen :=
    let Hopen := fresh "Hopen" in
    match goal with
    | H: forall x, x \notin ?L -> typing _ _ _ _ _ _ |- _ =>
      rename H into Hopen
    end.
  unfold preservation.
  introv Htyp.
  assert (term e) as Hterm; eauto using typing_implies_term.
  generalize e'.
  clear e'.
  induction Htyp; inversions Hterm;
    introv Hred; inversions Hred;
      try solve [eauto using Tgen_from_any];
      repeat generalize_typings.
  - (* app *)
    lets [U [HT EQ]]: inversion_typing_eq Htyp2.
    inversions HT.
    pick_fresh x.
    find_hopen. forwards~ K: (Hopen x).
    rewrite* (@subst_ee_intro lam_var x).
    expand_env_empty E.
    apply* typing_through_subst_ee_lam.
    fold_env_empty.
    apply teq_symmetry in EQ.
    lets [EQarg EQret]: inversion_eq_arrow EQ.
    apply typing_eq with T0 Tgen; auto.
    + apply* typing_replace_typ.
      lets*: typing_regular Htyp1.
    + lets* [? [? WFT]]: typing_regular Htyp2.
      inversion~ WFT.
  - (* tabs *)
    lets [U [HT EQ]]: inversion_typing_eq Htyp.
    inversions HT.

    apply teq_symmetry in EQ.
    lets: inversion_eq_typ_all EQ; subst.

    apply typing_eq with (open_tt T0 T1) Tgen.
    + pick_fresh X.
      rewrite* (@subst_te_intro X).
      rewrite* (@subst_tt_intro X).
      apply* typing_through_subst_te_3.
    + apply~ teq_open.
    + lets* [? [? WFT]]: typing_regular Htyp.
      apply~ wft_open.
  - (* fst *)
    lets [U [HT EQ]]: inversion_typing_eq Htyp.
    inversions HT.
    repeat generalize_typings.
    apply teq_symmetry in EQ.
    lets [EQarg EQret]: inversion_eq_tuple EQ.
    apply* typing_eq.
    lets* [? [? WFT]]: typing_regular Htyp.
    inversion~ WFT.
  - (* snd *)
    lets [U [HT EQ]]: inversion_typing_eq Htyp.
    inversions HT.
    repeat generalize_typings.
    apply teq_symmetry in EQ.
    lets [EQarg EQret]: inversion_eq_tuple EQ.
    apply* typing_eq.
    lets* [? [? WFT]]: typing_regular Htyp.
    inversion~ WFT.
  - (* fix *)
    pick_fresh f.
    rewrite* (@subst_ee_intro fix_var f).
    expand_env_empty E.
    apply* typing_through_subst_ee_fix.
    fold_env_empty.
  - (* let *)
    pick_fresh x.
    rewrite* (@subst_ee_intro lam_var x).
    expand_env_empty E.
    apply* typing_through_subst_ee_lam.
    fold_env_empty.
  - (* matchgadt *)
    (* we reduce to one of the branches which correspond to their definitions in type *)
    lets* [Def [nthDef Inzip]]: nth_error_implies_zip_swap Defs.
    lets HclTyp: H3 Inzip.
    remember (Cargtype Def) as argT.
    (* prepare fresh vars *)
    let fresh := gather_vars in
    lets* [Alphas [Hlen [Adist Afresh]]]: exist_alphas fresh (length Ts0).
    pick_fresh x.

    match goal with
    | [ H: term (trm_constructor ?A ?B ?C) |- _ ] =>
      inversions H
    end.

    (* extract info from well-formedness of GADT env Σ - our constructors are well formed *)
    lets [Hokt ?]: typing_regular Htyp.
    lets okgadt: okt_implies_okgadt Hokt.
    unfold okGadt in okgadt.
    destruct okgadt as [okΣ okCtors].
    lets [defsNe okDefs]: okCtors H0.
    lets indef: fst_from_zip Inzip.
    lets okCtor: okDefs indef.
    inversion okCtor.
    subst.
    (* clear H14 H15 Tarity0 Σ0. *)
    rename Carity into DefArity.

    (* replace open with subst+open_var *)
    rewrite~ (@subst_ee_intro lam_var x);
      [ idtac
      | apply fv_open_te_many;
        [ introv Tin;
          apply* fv_typs_notin
        | auto ]
      ].

    rewrite (@subst_te_intro_many Alphas _ Ts0); auto;
      [ idtac
      | introv Ain; subst; cbn; cbn in Afresh; lets*: Afresh Ain
      | introv Ain Tin; lets: Afresh Ain; apply* fv_typs_notin
      ].

    (* use fact that subst preserves typing *)
    lets [T' [Typ2 EQ]]: inversion_typing_eq Htyp.
    inversions Typ2.
    match goal with
    | [ H1: binds ?g ?A Σ, H2: binds ?g ?B Σ |- _ ] =>
      let H := fresh "H" in
      lets H: binds_ext H1 H2;
        inversions H
    end.

    rename H19 into TypCtorArg.
    match goal with
    | [ H1: List.nth_error Ctors cid = ?A, H2: List.nth_error Ctors cid = ?B |- _ ] =>
      let H := fresh "H" in
      assert (H: A = B); [ rewrite <- H2; auto | idtac ];
        inversions H
    end.
    rewrite (@subst_tt_intro_many Alphas _ Ts0) in TypCtorArg; auto.
    2: {
      intros A Ain; subst; cbn; cbn in Afresh.
      rewrite H14. auto.
    }
    2: {
      intros A U Ain Uin.
      lets WFT: H28 Uin.
      lets: wft_gives_fv WFT.
      intro HF.
      assert (HA: A \in domΔ Δ); auto.
      lets HA2: Afresh Ain.
      apply HA2. repeat rewrite in_union. repeat right~.
    }

    expand_env_empty E.
    match goal with
    | H: value (trm_constructor _ _ e1) |- _ =>
      inversions H
    end.
    eapply typing_through_subst_ee_lam with (subst_tt_many Alphas Ts0 (open_tt_many_var Alphas CargType)) Tgen _; auto; [idtac | eauto].

    (* instantiate the inductive hypothesis *)
    assert (AfreshL: forall A : var, List.In A Alphas -> A \notin L);
      [ introv Ain; lets*: Afresh Ain | idtac].
    assert (xfreshL: x \notin L); auto.
    assert (xfreshA: x \notin from_list Alphas); auto.

    lets* IH: H3 Inzip Alphas x Adist xfreshA.
    cbn in IH.

    rewrite subst_te_many_commutes_open; auto;
      [ idtac
      | introv Ain; lets: Afresh Ain;
        lets: from_list_spec2 Ain;
        intro; subst; auto
      ].

    fold (subst_tb_many Alphas Ts0 (bind_var lam_var (open_tt_many_var Alphas CargType))).
    rewrite <- map_single.
    fold_env_empty.

    rewrite subst_tt_many_free with Alphas Ts0 Tc;
      [ idtac | introv Ain; lets*: Afresh Ain ].

    assert (length CretTypes = length Ts).
    1: {
      lets [OKT [? WFT2]]: typing_regular Htyp.
      inversions WFT2.
      lets OKS: okt_implies_okgadt OKT.
      inversion OKS as [? OKC].
      lets [? OKD]: OKC H0.
      cbn in *.
      lets OKE: OKD indef.
      inversions OKE.
      match goal with
      | [ H1: binds ?g ?A Σ, H2: binds ?g ?B Σ |- _ ] =>
        let H := fresh "H" in
        lets H: binds_ext H1 H2;
          inversions H
      end.
      auto.
    }

    apply remove_true_equations with Ts (List.map (fun T => subst_tt_many Alphas Ts0 (open_tt_many_var Alphas T)) CretTypes).
    + assert (Hrew:
          equations_from_lists Ts (List.map (fun T : typ => subst_tt_many Alphas Ts0 (open_tt_many_var Alphas T)) CretTypes)
          =
          List.map (subst_td_many Alphas Ts0) (equations_from_lists Ts (List.map (open_tt_many_var Alphas) CretTypes))
        ).
      * apply~ helper_equations_commute.
        introv Ain. lets~ : Afresh Ain.
      * rewrite Hrew; clear Hrew.
        apply typing_through_subst_te_many with Tgen; trivial.
        -- intros A Ain.
           lets: Afresh Ain. auto.
        -- autorewrite with rew_env_dom.
           intros A Ain.
           apply notin_inverse.
           intro HF.
           apply xfreshA.
           rewrite in_singleton in HF. subst.
           apply from_list_spec2. auto.
        -- introv Ain.
           lets~ : Afresh Ain.
        -- introv Ain.
           rewrite~ equations_have_no_dom.
           apply* equations_from_lists_are_equations.
        -- introv Ain Tin.
           apply fv_typs_notin with Ts0; auto.
           lets: Afresh Ain.
           auto with listin.
        -- introv Ain; lets*: Afresh Ain.
    + assert (Hrew:
                open_tt_many Ts0 (typ_gadt CretTypes Name)
                =
                typ_gadt (List.map (open_tt_many Ts0) CretTypes) Name).
      * clear.
        rename Ts0 into Ts.
        rename CretTypes into Us.
        gen Us.
        induction Ts; introv.
        -- cbn. rewrite~ List.map_id.
        -- cbn. rewrite IHTs.
           f_equal.
           rewrite List.map_map.
           apply List.map_ext.
           intro T. auto.
      * rewrite Hrew in EQ; clear Hrew.
        assert (Hrew: (List.map (fun T : typ => subst_tt_many Alphas Ts0 (open_tt_many_var Alphas T)) CretTypes) = List.map (open_tt_many Ts0) CretTypes).
        1: {
          apply List.map_ext_in.
          intros T Tin.
          rewrite~ <- subst_tt_intro_many.
          - intros A Ain.
            rewrite~ H15.
          - intros A U Ain Uin.
            lets: Afresh Ain.
            apply fv_typs_notin with Ts0; auto.
        }
        rewrite Hrew; clear Hrew.
        lets EQ2: inversion_eq_typ_gadt EQ.
        rewrite <- (List.map_ext_in (fun T : typ => open_tt_many Ts0 T)).
        2: {
          intros T Tin.
          rewrite~ (@subst_tt_intro_many Alphas T Ts0).
          -- rewrite~ H15.
          -- introv Ain Uin. lets HF2: Afresh Ain.
             apply* fv_typs_notin.
        }
        -- rewrite~ List.map_length.
        -- apply EQ2.
Qed.


Require Import Blech.Defaults.

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

Require Import Blech.Bishop.
Require Import Blech.Bishop.Trv.
Require Import Blech.Category.
Require Blech.Reflect.

Import CategoryNotations.
Import BishopNotations.

Open Scope category_scope.

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

#[program]
Definition Trv: Category := {|
  Obj := True ;
  Mor _ _ := True  ;
  Mor_Setoid _ _ := {| equiv _ _ := True |} ;

  id _ := I ;
  compose _ _ _ _ _ := I ;
|}.

Next Obligation.
Proof.
  exists.
  all: exists.
Qed.

Module TrvNotations.
  Notation "·" := Trv : category_scope.
End TrvNotations.


From Coq Require Import String List ZArith.
From compcert Require Import Coqlib Integers Floats AST Ctypes Cop Clight Clightdefs.
Require Import CSplit.semantics.
Require Import utils.AClightNotations.
Require Import FloydSeq.proofauto.
Require VST.floyd.proofauto.
Require Import FloydSeq.proofauto.
Require Import CSplit.strong.
Require Import FloydSeq.client_lemmas.
Require Import CSplit.strongSoundness.
Require Import CSplit.AClightFunc.

Local Open Scope Z_scope.
Import AClightNotations.

Module Info.
  Definition version := "3.6"%string.
  Definition build_number := ""%string.
  Definition build_tag := ""%string.
  Definition arch := "x86"%string.
  Definition model := "32sse2"%string.
  Definition abi := "macosx"%string.
  Definition bitsize := 32.
  Definition big_endian := false.
  Definition source_file := "testprogs/reverse_noinv.c"%string.
  Definition normalized := true.
End Info.

Require Import cprogs.reverse_prog.
Require Import cprogs.reverse_def.

Definition f_reverse_spec_annotation :=
  ANNOTATION_WITH  sh p l, ((
            PROP  (writable_share sh)
	    LOCAL (temp _p p)
	    SEP   (listrep sh l p)),
  (
          EX q: val,
	    PROP  ()
	    LOCAL (temp ret_temp q)
	    SEP   (listrep sh (rev l) q))).

Definition f_reverse_spec_complex :=
  ltac:(uncurry_funcspec f_reverse_spec_annotation).

Definition f_reverse_funsig: funsig :=
  (((_p, (tptr (Tstruct _list noattr))) :: nil),
   (tptr (Tstruct _list noattr))).

Definition reverse_spec :=
  ltac:(make_funcspec _reverse f_reverse_funsig f_reverse_spec_complex).

Ltac get_para_type_rec_tac A B :=
  match B with
  | ?B1 -> ?B2 => get_para_type_rec_tac (prod A B1) B2
  | prod _ _ => exact A
  end.

Ltac get_para_type_tac spec_annot :=
  match type of spec_annot with
  | ?A -> prod _ _ => exact A
  | ?A -> ?B => get_para_type_rec_tac A B
  end.

Notation "'GET_PARA_TYPE' x" := ltac:(get_para_type_tac x) (at level 99).

Definition f_reverse_hint (para: GET_PARA_TYPE f_reverse_spec_annotation) :=
  match para with
  | (sh, p, l) =>
        (Csequence
(*          (Cset _w (Econst_int (Int.repr 0) tint)) *)
          (Cset _w  (Ecast (Econst_int (Int.repr 0) tint) (tptr tvoid)))
          (Csequence
            (Cset _v (Etempvar _p (tptr (Tstruct _list noattr))))
            (Csequence
              (Cloop
                (Csequence
                  (Cassert (
       (EX w v l1 l2,
          PROP  (writable_share sh; l = rev l1 ++ l2)
	  LOCAL (temp _w w; temp _v v)
	  SEP   (listrep sh l1 w; listrep sh l2 v))%assert))
                  (EXGIVEN w
                    [[((EX v l1 l2,
          PROP  (writable_share sh; l = rev l1 ++ l2)
	  LOCAL (temp _w w; temp _v v)
	  SEP   (listrep sh l1 w; listrep sh l2 v))%assert)]]
                    (EXGIVEN v
                      [[((EX l1 l2,
          PROP  (writable_share sh; l = rev l1 ++ l2)
	  LOCAL (temp _w w; temp _v v)
	  SEP   (listrep sh l1 w; listrep sh l2 v))%assert)]]
                      (EXGIVEN l1
                        [[((EX l2,
          PROP  (writable_share sh; l = rev l1 ++ l2)
	  LOCAL (temp _w w; temp _v v)
	  SEP   (listrep sh l1 w; listrep sh l2 v))%assert)]]
                        (EXGIVEN l2
                          [[((PROP  (writable_share sh; l = rev l1 ++ l2)
	  LOCAL (temp _w w; temp _v v)
	  SEP   (listrep sh l1 w; listrep sh l2 v))%assert)]]
                          (Csequence
                            (Cifthenelse (Etempvar _v (tptr (Tstruct _list noattr)))
                              Cskip
                              (Csequence Cbreak Cskip))
                            (Csequence
                              (Cassert (
         (EX t x l2',
	    PROP  (writable_share sh; l = rev l1 ++ l2; l2 = x :: l2'; writable_share sh)
	    LOCAL (temp _w w; temp _v v)
	    SEP   (data_at sh t_struct_list (x, t) v;
	           listrep sh l1 w; listrep sh l2' t))%assert))
                              (EXGIVEN t
                                [[((EX x l2',
	    PROP  (writable_share sh; l = rev l1 ++ l2; l2 = x :: l2'; writable_share sh)
	    LOCAL (temp _w w; temp _v v)
	    SEP   (data_at sh t_struct_list (x, t) v;
	           listrep sh l1 w; listrep sh l2' t))%assert)]]
                                (EXGIVEN x
                                  [[((EX l2',
	    PROP  (writable_share sh; l = rev l1 ++ l2; l2 = x :: l2'; writable_share sh)
	    LOCAL (temp _w w; temp _v v)
	    SEP   (data_at sh t_struct_list (x, t) v;
	           listrep sh l1 w; listrep sh l2' t))%assert)]]
                                  (EXGIVEN l2'
                                    [[((PROP  (writable_share sh; l = rev l1 ++ l2; l2 = x :: l2'; writable_share sh)
	    LOCAL (temp _w w; temp _v v)
	    SEP   (data_at sh t_struct_list (x, t) v;
	           listrep sh l1 w; listrep sh l2' t))%assert)]]
                                    (Csequence
                                      (Cset _t
                                        (Efield
                                          (Ederef
                                            (Etempvar _v (tptr (Tstruct _list noattr)))
                                            (Tstruct _list noattr)) _tail
                                          (tptr (Tstruct _list noattr))))
                                      (Csequence
                                        (Cassign
                                          (Efield
                                            (Ederef
                                              (Etempvar _v (tptr (Tstruct _list noattr)))
                                              (Tstruct _list noattr)) _tail
                                            (tptr (Tstruct _list noattr)))
                                          (Etempvar _w (tptr (Tstruct _list noattr))))
                                        (Csequence
                                          (Cset _w
                                            (Etempvar _v (tptr (Tstruct _list noattr))))
                                          (Csequence
                                            (Cset _v
                                              (Etempvar _t (tptr (Tstruct _list noattr))))
                                            Cskip))))))))))))))
                Cskip)
              (Csequence
                (Creturn (Some (Etempvar _w (tptr (Tstruct _list noattr)))))
                Cskip))))
  end.

Definition Gprog : funspecs :=
  ltac:(with_library prog [reverse_spec]).

(*
Time Definition f_reverse_hint_split para :=
  match para with
  | (sh, p, l) =>
    ltac:(compute_split (f_reverse_hint (sh, p, l)))
  end.
Goal forall para,
  match para with
  | (sh, p, l) =>
    ltac:(compute_split (f_reverse_hint (sh, p, l))) = C_split (f_reverse_hint (sh, p, l))
  end.
  intros [ [sh p] l].
  unfold C_split, f_reverse_hint.
  Print C_split_exgiven.

*)
Theorem f_reverse_functionally_correct:
  semax_body Vprog Gprog f_reverse reverse_spec.
Proof.
  Time VST_A_start_function f_reverse_hint.
  + Intros.
    forward.
    forward.
    unfold RA_normal, normal_split_assert.
    Exists nullval p (@nil val) l.
    entailer!.
    unfold listrep.
    entailer!.
  + intros w v l1 l2.
    forward_if; [| forward; apply TT_right].
    forward.
    unfold RA_normal, normal_split_assert.
    sep_apply (listrep_isptr sh l2 v).
    Intros a l2b t.
    Exists t a l2b.
    entailer!.
  + Intros w v l1 l2 t a l2b.
    forward.
    forward.
    forward.
    forward.
    unfold RA_normal, normal_split_assert.
    entailer!.
    Exists v t (a :: l1) l2b.
    entailer!.
    - simpl.
      rewrite <- app_assoc.
      reflexivity.
    - unfold listrep at 2; fold listrep.
      Exists w.
      entailer!.
  + Intros w v l1 l2.
    forward_if; [forward; apply TT_right |].
    unfold POSTCONDITION, abbreviate.
    apply semax_return_return_split_assert.
    forward.
    Exists w; entailer!.
    sep_apply (listrep_null sh l2).
    entailer!.
    rewrite app_nil_r, rev_involutive.
    entailer!.
Qed.