(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

(** This module defines grouping by the domain of an association list
    and the derived equivalence relation, grouped_equiv.
    This equivalence allows elements with different keys to
    be freely rearranged.
 *)

Require Import List.
Require Import ListSet.
Require Import Bool.
Require Import Permutation.
Require Import Morphisms.
Require Import Setoid.
Require Import EquivDec.
Require Import Equivalence.
Require Import RelationClasses.
Require Import Lia.
Require Import CoqLibAdd.
Require Import Lift.
Require Import ListAdd.
Require Import Assoc.
Require Import Sublist.
Require Import Bag.

Section groupbydomain.

  (* There may be some relation here to groupby *)
  Fixpoint groupby_domain {A B} {dec: EqDec A eq} (l:list (A*B)): list (A*list B)
    := match l with
       | nil => nil
       | (a,b)::l' =>
         let rest := groupby_domain l' in
         match lookup dec rest a with
         | Some bs => update_first dec rest a (b::bs)
         | None => (a, (b::nil))::rest
         end
       end.

  Definition grouped_equiv {A B} {dec:EqDec A eq} (l1 l2 :list (A*B))
    := Permutation (groupby_domain l1) (groupby_domain l2).

  Definition list_unnest {A B} (l:list (A*list B)) : list (list (A*B))
    := map (fun x => map (fun y => (fst x, y)) (snd x)) l.

  Global Instance grouped_equiv_equiv {A B} {dec:EqDec A eq} : Equivalence (@grouped_equiv A B dec).
  Proof.
    unfold grouped_equiv.
    constructor; red; intros.
    - reflexivity.
    - symmetry; trivial.
    - etransitivity; eauto.
  Qed.

  Lemma groupby_domain_concat_list_unest_perm {A B} {dec: EqDec A eq} (l:list (A*B))
    : Permutation (concat (list_unnest (groupby_domain l))) l.
  Proof.
    induction l; simpl; trivial.
    destruct a.
    case_eq (lookup dec (groupby_domain l) a); simpl; intros.
    - destruct (in_update_break dec H (b::l0))
        as [l1 [l2 [eqq1 eqq2]]].
      rewrite eqq2.
      unfold list_unnest in *.
      rewrite eqq1 in *.
      rewrite map_app, concat_app in *.
      simpl in *.
      rewrite <- IHl.
      repeat rewrite Permutation_middle.
      reflexivity.
    - constructor; trivial.
  Qed.

  Global Instance grouped_equiv_perm {A B} {dec: EqDec A eq} :
    subrelation (@grouped_equiv A B dec) (@Permutation (A*B)).
  Proof.
    unfold grouped_equiv; intros l1 l2 perm.
    rewrite <- (groupby_domain_concat_list_unest_perm l1).
    rewrite <- (groupby_domain_concat_list_unest_perm l2).
    apply Permutation_concat.
    apply Permutation_map.
    trivial.
  Qed.

  Lemma groupby_domain_NoDup {A B} {dec: EqDec A eq} (l:list (A*B)) :
    NoDup (domain (groupby_domain l)).
  Proof.
    induction l; simpl.
    - constructor.
    - destruct a.
      match_option.
      + rewrite domain_update_first; trivial.
      + simpl; constructor; trivial.
        apply lookup_none_nin in eqq; trivial.
  Qed.

  Lemma groupby_domain_nnil {A B} {dec: EqDec A eq} (l:list (A*B)) :
    ~ In nil (codomain (groupby_domain l)).
  Proof.
    induction l; simpl.
    - tauto.
    - destruct a.
      match_option; simpl.
      + destruct (in_update_break dec eqq (b::l0))
          as [m1 [m2 [meqq mueqq]]].
        rewrite mueqq; simpl.
        rewrite meqq in IHl.
        rewrite codomain_app, in_app_iff in IHl |- *; simpl in *.
        intuition discriminate.
      + intuition discriminate.
  Qed.

  Lemma groupby_domain_concat_list_unest_equiv {A B} {dec: EqDec A eq} (l:list (A*B))
    : lookup_equiv (concat (list_unnest (groupby_domain l))) l.
  Proof.
    unfold lookup_equiv.
    induction l; simpl; trivial.
    destruct a.
    intros x.
    case_eq (lookup dec (groupby_domain l) a); simpl; intros.
    - generalize (groupby_domain_nnil l); intros nn.
      destruct (in_update_break_first dec H (b::l0))
        as [l1 [l2 [eqq1 [eqq2 nin]]]].
      rewrite eqq2.
      unfold list_unnest in *.
      rewrite eqq1 in *.
      rewrite map_app, concat_app in *.
      simpl in *.
      rewrite <- IHl.
      repeat (rewrite lookup_app; simpl).
      destruct (dec x a); unfold equiv, complement in *; trivial.
      subst.
      match_option.
      apply lookup_in in eqq.
      apply concat_In in eqq.
      destruct eqq as [? [inn1 inn2]].
      apply in_map_iff in inn1.
      destruct inn1 as [? [? inn1]]; subst.
      apply in_map_iff in inn2.
      destruct inn2 as [? [eqq inn2]].
      invcs eqq.
      destruct x0; apply in_dom in inn1.
      contradiction.
    - rewrite IHl; trivial.
  Qed.

  Lemma grouped_equiv_cons {A B} {dec: EqDec A eq} {l1 l2:list (A*B)} :
    grouped_equiv l1 l2 ->
    forall a, grouped_equiv (a::l1) (a::l2).
  Proof.
    unfold grouped_equiv; simpl; intros eqq1 a.
    destruct a.
    rewrite (lookup_equiv_perm_nodup (groupby_domain_NoDup l1) eqq1 a).
    match_option.
    - apply update_first_NoDup_perm_proper; trivial.
      apply (groupby_domain_NoDup l1).
    - eauto.
  Qed.

  Lemma grouped_equiv_cons_invs {A B} {dec: EqDec A eq} {a b b'} {l1 l2:list (A*B)} :
    grouped_equiv ((a,b)::l1) ((a,b')::l2) ->
    b = b' /\ grouped_equiv l1 l2.
  Proof.
    unfold grouped_equiv; simpl; intros eqq1.
    repeat match_option_in eqq1; try discriminate.
    - destruct (update_first_NoDup_perm_invs
                  (fun x => b::x) (fun y => b'::y)
                  (groupby_domain_NoDup l1) eqq1 eqq eqq0)
        as [perm2 [eqq21 eqq22]].
      + intros ? ? injeq.
        invcs injeq; trivial.
      + invcs eqq22; tauto.
    - destruct (in_update_break dec eqq (b::l))
        as [m1 [m2 [meqq mueqq]]].
      rewrite mueqq in eqq1.
      rewrite <- Permutation_middle in eqq1.
      assert (inn:In (a, b::l) ((a, b::l) :: m1 ++ m2)).
      { simpl; eauto. }
      rewrite eqq1 in inn.
      simpl in inn.
      destruct inn.
      + invcs H.
        elim (groupby_domain_nnil l1); trivial.
        rewrite meqq.
        rewrite codomain_app, in_app_iff; simpl; tauto.
      + apply in_dom in H; apply lookup_none_nin in eqq0.
        contradiction.
    - destruct (in_update_break dec eqq0 (b'::l))
        as [m1 [m2 [meqq mueqq]]].
      rewrite mueqq in eqq1.
      rewrite <- Permutation_middle in eqq1.
      assert (inn:In (a, b'::l) ((a, b'::l) :: m1 ++ m2)).
      { simpl; eauto. }
      rewrite <- eqq1 in inn.
      simpl in inn.
      destruct inn.
      + invcs H.
        elim (groupby_domain_nnil l2); trivial.
        rewrite meqq.
        rewrite codomain_app, in_app_iff; simpl; tauto.
      + apply in_dom in H; apply lookup_none_nin in eqq.
        contradiction.
    - assert (lo1:lookup dec ((a, (b::nil)) :: groupby_domain l1) a = Some (b::nil)).
      { simpl; match_destr; congruence. }
      assert (nd:NoDup (domain ((a, (b::nil)) :: groupby_domain l1))).
      { simpl; constructor.
        - apply lookup_none_nin in eqq; trivial.
        - apply groupby_domain_NoDup.
      }
      rewrite (lookup_equiv_perm_nodup nd eqq1 a) in lo1.
      simpl in lo1.
      match_destr_in lo1; [| congruence].
      invcs lo1.
      apply Permutation_cons_inv in eqq1.
      tauto.
  Qed.

  Lemma concat_list_unnest_lookup_none {A B} {dec:EqDec A eq} {l1:list (A*list B)} {a} :
    lookup dec l1 a = None ->
    lookup dec (concat (list_unnest l1)) a = None.
  Proof.
    intros lo.
    apply lookup_none_nin in lo.
    apply lookup_nin_none.
    unfold list_unnest, domain.
    rewrite concat_map.
    intros inn.
    apply concat_In in inn.
    destruct inn as [? [inn1 inn2]].
    rewrite map_map in inn1.
    apply in_map_iff in inn1.
    destruct inn1 as [? [? inn1]]; subst.
    rewrite map_map in inn2; simpl in inn2.
    apply in_map_iff in inn2.
    destruct inn2 as [? [? inn2]]; subst.
    destruct x0; apply in_dom in inn1.
    contradiction.
  Qed.

  Lemma concat_list_unnest_lookup_some {A B} {dec:EqDec A eq} {l1:list (A*list B)} {a b l'} :
    lookup dec l1 a = Some (b::l') ->
    lookup dec (concat (list_unnest l1)) a = Some b.
  Proof.
    intros lo.
    destruct (lookup_split dec lo) as [m1 [m2 [? nin]]]; subst.
    unfold list_unnest.
    rewrite map_app, concat_app, lookup_app; simpl.
    match_option.
    - apply lookup_in in eqq.
      apply concat_In in eqq.
      destruct eqq as [? [inn1 inn2]].
      apply in_map_iff in inn1.
      destruct inn1 as [? [? inn1]]; subst.
      apply in_map_iff in inn2.
      destruct inn2 as [? [eqq inn2]].
      invcs eqq.
      destruct x0; apply in_dom in inn1.
      contradiction.
    - match_destr.
      congruence.
  Qed.

  Lemma concat_list_unnest_lookup_equiv {A B} {dec:EqDec A eq} (l1 l2:list (A*list B)) :
    ~ In nil (codomain l1) ->
    lookup_equiv l1 l2 ->
    lookup_equiv (concat (list_unnest l1)) (concat (list_unnest l2)).
  Proof.
    intros nnil lo a.
    specialize (lo a).
    case_eq (lookup dec l1 a); [intros ? eqq1 | intros eqq1]
    ; rewrite eqq1 in *.
    - destruct l.
      + apply lookup_in in eqq1.
        apply in_codom in eqq1.
        contradiction.
      + rewrite (concat_list_unnest_lookup_some eqq1).
        rewrite (concat_list_unnest_lookup_some (symmetry lo)).
        trivial.
    - rewrite (concat_list_unnest_lookup_none eqq1).
      rewrite (concat_list_unnest_lookup_none (symmetry lo)).
      trivial.
  Qed.

  Global Instance grouped_equiv_lookup_equiv {A B} {dec:EqDec A eq} :
    subrelation (@grouped_equiv A B dec) lookup_equiv.
  Proof.
    intros l1 l2.
    unfold grouped_equiv.
    intros perm.
    apply lookup_equiv_perm_nodup in perm.
    - rewrite <- (groupby_domain_concat_list_unest_equiv l1).
      rewrite <- (groupby_domain_concat_list_unest_equiv l2).
      apply concat_list_unnest_lookup_equiv; trivial.
      apply groupby_domain_nnil.
    - apply groupby_domain_NoDup.
  Qed.

  Lemma groupby_domain_equivlist {A B} {dec:EqDec A eq} (l:list (A*B)):
    equivlist (domain (groupby_domain l)) (domain l).
  Proof.
    unfold equivlist.
    induction l; simpl; [tauto | ].
    destruct a; simpl.
    intros x.
    match_option.
    - rewrite domain_update_first.
      rewrite IHl.
      apply lookup_in_domain in eqq.
      rewrite IHl in eqq.
      intuition; congruence.
    - simpl; rewrite IHl; tauto.
  Qed.

  Lemma groupby_domain_update_first_some {A B} {dec:EqDec A eq} {l:list (A*B)} {v b l'} :
    lookup dec (groupby_domain l) v = Some (b::l') ->
    forall d,
      groupby_domain (update_first dec l v d) = update_first dec (groupby_domain l) v (d::l').
  Proof.
    revert b l'.
    induction l; intros b l' inn d; simpl; try discriminate.
    destruct a; simpl in inn.
    destruct (dec v a); unfold equiv, complement in *
    ; subst; simpl.
    - match_option
      ; rewrite eqq in inn.
      + apply lookup_update_eq in inn.
        invcs inn.
        rewrite update_first_update_first_eq; trivial.
      + simpl in *.
        match_destr; try congruence.
    - match_option_in inn.
      + generalize (@lookup_update_neq _ _ dec (groupby_domain l) a v (b0::l0)).
        unfold equiv_dec; intros re; rewrite re in inn by congruence; clear re.
        rewrite update_first_update_first_neq_swap by congruence.
        rewrite (IHl _ _ inn).
        generalize (@lookup_update_neq _ _ dec (groupby_domain l) v a (d::l')).
        unfold equiv_dec; intros re; rewrite re by congruence; clear re.
        rewrite eqq; trivial.
      + simpl in inn.
        match_destr_in inn; try congruence.
        rewrite (IHl _ _ inn).
        simpl.
        destruct (dec v a); try congruence.
        generalize (@lookup_update_neq _ _ dec (groupby_domain l) v a (d::l')).
        unfold equiv_dec; intros re; rewrite re by congruence; clear re.
        rewrite eqq; trivial.
  Qed.

  Lemma grouped_equiv_update_first {A B} {dec:EqDec A eq} (l1 l2:list (A*B)) v d :
    grouped_equiv l1 l2 ->
    grouped_equiv (update_first dec l1 v d) (update_first dec l2 v d).
  Proof.
    unfold grouped_equiv; intros.
    case_eq (lookup dec (groupby_domain l1) v); [intros ? inn1|intros eqq1].
    - destruct l.
      + elim (groupby_domain_nnil l1).
        apply lookup_in in inn1.
        apply in_codom in inn1; trivial.
      + generalize H; intros perm.
        apply lookup_equiv_perm_nodup in perm; [ | apply groupby_domain_NoDup].
        rewrite (groupby_domain_update_first_some inn1).
        rewrite perm in inn1.
        rewrite (groupby_domain_update_first_some inn1).
        apply update_first_NoDup_perm_proper; trivial.
        apply groupby_domain_NoDup.
    - repeat rewrite nin_update; trivial.
      + apply lookup_none_nin in eqq1.
        rewrite (dom_perm _ _ H) in eqq1.
        apply (lookup_nin_none dec) in eqq1.
        generalize (concat_list_unnest_lookup_none eqq1); intros inn1.
        rewrite groupby_domain_concat_list_unest_equiv in inn1; trivial.
      + generalize (concat_list_unnest_lookup_none eqq1); intros inn1.
        rewrite groupby_domain_concat_list_unest_equiv in inn1; trivial.
  Qed.

  Lemma grouped_equiv_singleton {A B} {dec:EqDec A eq} a (l:list (A*B)) :
    grouped_equiv (a::nil) l -> l = a::nil.
  Proof.
    destruct a.
    unfold grouped_equiv; simpl; intros ge.
    apply Permutation_length_1_inv in ge.
    generalize (groupby_domain_concat_list_unest_perm l).
    rewrite ge; simpl; intros perm.
    apply Permutation_length_1_inv in perm.
    trivial.
  Qed.

  Lemma groupby_domain_lookup_app_nin {A B} {dec:EqDec A eq} (l1 l2 l3 : list (A*B)) x :
    ~ In x (domain l2) ->
    lookup dec (groupby_domain (l1++l2++l3)) x =
    lookup dec (groupby_domain (l1++l3)) x.
  Proof.
    induction l2; simpl; trivial.
    intros nin.
    apply notand in nin.
    destruct nin.
    destruct a; simpl in *.
    rewrite <- (IHl2 H0).
    clear IHl2 H0.
    generalize (l2++l3); clear l2 l3; intros l2.
    induction l1; simpl in *.
    - match_option.
      + replace dec with (@equiv_dec _ _ _ dec) in * by trivial.
        rewrite lookup_update_neq; tauto.
      + simpl.
        match_destr; try congruence.
    - destruct a0; simpl in *.
      destruct (dec a0 x); unfold equiv, complement in *.
      + subst.
        rewrite IHl1.
        match_option; simpl.
        * replace dec with (@equiv_dec _ _ _ dec) in * by trivial.
          { repeat rewrite lookup_update_eq_in; trivial.
            - apply lookup_in_domain in eqq; trivial.
            - apply lookup_in_domain in eqq.
              rewrite groupby_domain_equivlist in *.
              rewrite domain_app, in_app_iff in *; simpl; tauto.
          }
        * match_destr.
      + match_option; simpl.
        * replace dec with (@equiv_dec _ _ _ dec) in * by trivial.
          rewrite lookup_update_neq by tauto.
          rewrite IHl1.
          { match_option.
            - repeat rewrite lookup_update_neq by tauto.
              trivial.
            - simpl.
              match_destr; congruence.
          }
        * destruct (dec x a0); try congruence.
          rewrite IHl1.
          { match_option.
            - replace dec with (@equiv_dec _ _ _ dec) in * by trivial.
              rewrite lookup_update_neq by tauto.
              trivial.
            -  simpl.
               match_destr; congruence.
          }
  Qed.

End groupbydomain.


Require Export Smten.
Require Export SmtenProp.
Require Export SmtenS1.

Module SmtenS.
Import Smten.Smten.
Import SmtenProp.SmtenProp.
Import SmtenS1.SmtenS1.

Inductive valueS : tm -> Prop :=
  | vS_empty : forall T, valueS (temptyS T)
  | vS_single : forall t, valueS (tsingleS t)
  .

Tactic Notation "valueS_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "vS_empty" | Case_aux c "vS_single" ].

Hint Constructors valueS.

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

Inductive stepS : tm -> tm -> Prop :=
  | STS_STS1 : forall t t',
      t =S1=> t' ->
      t =S=> t'
  | STS_UnionLeft : forall t1 t2,
      tunionS (tsingleS t1) t2 =S=> tsingleS t1
  | STS_UnionRight : forall t1 t2,
      tunionS t1 (tsingleS t2) =S=> tsingleS t2
  | STS_UnionNotRight : forall T t,
      tunionS t (temptyS T) =S=> t
  | STS_UnionNotLeft : forall T t,
      tunionS (temptyS T) t =S=> t
  | STS_Union1 : forall t1 t1' t2,
      t1 =S=> t1' ->
      tunionS t1 t2 =S=> tunionS t1' t2
  | STS_Union2 : forall t1 t2 t2',
      t2 =S=> t2' ->
      tunionS t1 t2 =S=> tunionS t1 t2'

where "t1 '=S=>' t2" := (stepS t1 t2).

Tactic Notation "stepS_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "STS_STS1"
  | Case_aux c "STS_UnionLeft" | Case_aux c "STS_UnionRight"
  | Case_aux c "STS_UnionNotRight" | Case_aux c "STS_UnionNotLeft"
  | Case_aux c "STS_Union1" | Case_aux c "STS_Union2" ].

Hint Constructors stepS.

Notation multistepS := (multi stepS).
Notation "t1 '=S=>*' t2" := (multistepS t1 t2) (at level 40).

Theorem progressS : forall t T,
    empty |- t \in T ->
    (exists T1 : ty, T = TS T1) ->
    valueS t \/ exists t', t =S=> t'.

Proof with eauto.
  intros t T Ht HSt.
  remember (@empty ty) as Gamma.
  has_type_cases (induction Ht) Case; subst Gamma...
  Case "T_Var". inversion H.
  Case "T_Abs". inversion HSt. inversion H.
  Case "T_App".
     (* progress says either tapp is a value or steps *)
     destruct (progress (tapp t1 t2) T12)...
     SCase "tapp is a value". inversion H.
     SCase "tapp steps". right. destruct H as [t3]...
  Case "T_Unit". inversion HSt. inversion H.
  Case "T_Pair". inversion HSt. inversion H.
  Case "T_Fst".
     destruct(progress (tfst t) T1)...
     SCase "tfst is a value". inversion H.
     SCase "tfst steps". right. destruct H as [t2]...
  Case "T_Snd".
     destruct (progress (tsnd t) T2)...
     SCase "tsnd is a value". inversion H.
     SCase "tsnd steps". right. destruct H as [t2]...
  Case "T_Inl". inversion HSt. inversion H.
  Case "T_Inr". inversion HSt. inversion H.
  Case "T_Case".
     destruct (progress (tcase t1 t2 t3) T3)...
     SCase "tcase is a value". inversion H.
     SCase "tcase steps". right. destruct H as [t4]...
  Case "T_ReturnIO". inversion HSt. inversion H.
  Case "T_BindIO". inversion HSt. inversion H.
  Case "T_SearchIO". inversion HSt. inversion H.
  Case "T_UnionS".
     right. destruct IHHt1...
     SCase "t1 is a valueS".
       inversion H.
       SSCase "t1 is emptyS".
          exists t2. apply STS_UnionNotLeft.
       SSCase "t1 is singleS".
          exists (tsingleS t). apply STS_UnionLeft.
     SCase "t1 steps".
       inversion H as [t1'].
       exists (tunionS t1' t2).
       apply STS_Union1...
  Case "T_MapS".
     right. destruct (progressS1 t2 (TS T1))...
     SCase "t2 is a valueS1".
       inversion H.
       SSCase "t2 is emptyS".
         exists (temptyS T2). apply STS_STS1. apply STS1_MapEmpty.
         rewrite <- H0 in Ht2. inversion Ht2...
       SSCase "t2 is singleS".
         exists (tsingleS (tapp t1 t)). apply STS_STS1. apply STS1_MapSingle.
       SSCase "t2 is unionS".
         exists (tunionS (tmapS t1 t0) (tmapS t1 t3)).
         apply STS_STS1. apply STS1_MapUnion.
     SCase "t1 steps".
       inversion H as [t2'].
       exists (tmapS t1 t2').
       apply STS_STS1. apply STS1_Map. assumption.
  Case "T_JoinS".
     right. destruct (progressS1 t (TS (TS T)))...
     SCase "t is a valueS1".
       inversion H.
       SSCase "t is emptyS".
         subst. inversion Ht.
         exists (temptyS T). apply STS_STS1. apply STS1_JoinEmpty.
       SSCase "t is singleS".
         exists (t0). apply STS_STS1. apply STS1_JoinSingle.
       SSCase "t is unionS".
         exists (tunionS (tjoinS t1) (tjoinS t2)).
         apply STS_STS1. apply STS1_JoinUnion.
     SCase "t steps".
       inversion H as [t'].
       exists (tjoinS t').
       apply STS_STS1. apply STS1_Join. assumption.
Qed.

Theorem preservationS : forall t t' T,
     empty |- t \in T ->
     t =S=> t' ->
     empty |- t' \in T.

Proof with eauto.
   intros t t' T HT Hstep.
   generalize dependent T.
   stepS_cases (induction Hstep) Case; intros Tx HT; subst...
   Case "STS_STS1". apply preservationS1 with t...
   Case "STS_UnionLeft". inversion HT...
   Case "STS_UnionRight". inversion HT...
   Case "STS_UnionNotRight". inversion HT...
   Case "STS_UnionNotLeft". inversion HT...
   Case "STS_Union1". inversion HT...
   Case "STS_Union2". inversion HT...
Qed.

Theorem preservationS_multi : forall t t' T,
  empty |- t \in T ->
  t =S=>* t' ->
  empty |- t' \in T
  .
Proof.
  intros t t' T HT Hsteps.
  multi_cases (induction Hsteps) Case.
  Case "multi_refl". assumption.
  Case "multi_step".
     apply IHHsteps.
     apply preservationS with x0. assumption. assumption.
Qed.

Definition stuckS (t:tm) : Prop :=
  (normal_form stepS) t /\ ~ valueS t.

Corollary soundnessS : forall t t' T,
  empty |- t \in T ->
  (exists T1, T = TS T1) ->
  t =S=>* t' ->
  ~(stuckS t').
Proof.
  intros t t' T Hhas_type Hio Hmulti. unfold stuckS.
  intros [Hnf Hnot_val]. unfold normal_form in Hnf.
  induction Hmulti. apply Hnot_val.
   destruct (progressS x0 T).
   apply Hhas_type. apply Hio. apply H.
   contradiction.

   apply IHHmulti.
   apply (preservationS x0 y0). apply Hhas_type. apply H.
   apply Hnf. apply Hnot_val.
Qed.

Inductive unsat : tm -> Prop :=
  | Un_Empty : forall T, unsat (temptyS T)
  | Un_Step : forall t T,
      empty |- t \in TS T ->
      (exists t', t =S=> t') ->
      (forall t', t =S=> t' -> unsat t') ->
      unsat t
  .

Tactic Notation "unsat_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "Un_Empty" | Case_aux c "Un_Step" ].

Hint Constructors unsat.

Theorem unsat_goes_zero : forall t T,
  empty |- t \in TS T ->
  unsat t ->
  t =S=>* temptyS T
  .
Proof.
  intros t T HT Hunsat.
  unsat_cases (induction Hunsat) Case.
  Case "Un_Empty".
    inversion HT.
    apply multi_refl.
  Case "Un_Step".
    destruct (progressS t (TS T)). assumption.
    exists T. reflexivity.
    SCase "t is a valueS".
      valueS_cases (inversion H3) SSCase.
      SSCase "vS_empty".
        rewrite <- H4 in HT.
        inversion HT.
        apply multi_refl.
      SSCase "vS_single".
        inversion H0.
        rewrite <- H4 in H5.
        inversion H5. inversion H6. inversion H9.
    SCase "t steps".
      inversion H3 as [t1].
      apply multi_step with t1. assumption.
      apply H2. assumption. apply preservationS with t.
      assumption. assumption.
Qed.

Theorem unsat_preserves : forall t t' T,
  empty |- t \in TS T ->
  unsat t ->
  t =S=> t' ->
  unsat t'
  .
Proof.
  intros t t' T HT Hunsat Hstep.
  unsat_cases (inversion Hunsat) Case.
  Case "Un_Empty".
    rewrite <- H in Hstep.
    inversion Hstep.
    inversion H0.
    inversion H3.
  Case "Un_Step".
    apply H1.
    assumption.
Qed.

Theorem unsat_preserves_multi : forall t t' T,
  empty |- t \in TS T ->
  unsat t ->
  t =S=>* t' ->
  unsat t'
  .
Proof.
  intros t t' T HT Hunsat Hsteps.
  multi_cases (induction Hsteps) Case.
  Case "multi_refl". assumption.
  Case "multi_step".
     apply IHHsteps.
     apply preservationS with x0. assumption. assumption.
     apply unsat_preserves with x0 T. assumption. assumption.
     assumption.
Qed.

Theorem unsat_goes_only_zero : forall t tv T,
  empty |- t \in TS T ->
  unsat t ->
  t =S=>* tv ->
  valueS tv ->
  tv = temptyS T
  .
Proof.
  intros t tv T HT Hunsat Hsteps Hval.
  assert (unsat tv).
  apply unsat_preserves_multi with t T.
  assumption. assumption. assumption.
  valueS_cases (destruct Hval) Case.
  Case "vS_empty".
    f_equal.
    assert (empty |- temptyS T0 \in TS T).
    apply preservationS_multi with t.
    assumption. assumption.
    inversion H0. reflexivity.
  Case "vS_single".
    inversion H.
    inversion H1. inversion H4. inversion H5. inversion H8.
Qed.

Theorem unsat_union_unsat_zero : forall t T,
  empty |- t \in TS T ->
  unsat t ->
  unsat (tunionS t (temptyS T))
  .
Proof.
  intros t T HT Hunsat.
  unsat_cases (induction Hunsat) Case.
  Case "Un_Empty".
    apply Un_Step with T.
    apply T_UnionS. assumption. apply T_EmptyS.
    exists (temptyS T). apply STS_UnionNotLeft.
    intros tv Hstep.
    inversion Hstep.
    SCase "Pure". inversion H. inversion H2.
    SCase "UnionNotRight". apply Un_Empty.
    SCase "UnionNotLeft". apply Un_Empty.
    SCase "Union1". inversion H2. inversion H3. inversion H6.
    SCase "Union2". inversion H2. inversion H3. inversion H6.
  Case "Un_Step".
    apply Un_Step with T.
    apply T_UnionS. assumption. apply T_EmptyS.
    exists t. apply STS_UnionNotRight.
    intros tv Hstep.
    inversion Hstep.
    SCase "Pure". inversion H3. inversion H6.
    SCase "UnionLeft".
      inversion H0.
      rewrite <- H4 in H6. inversion H6. inversion H7. inversion H10.
    SCase "UnionNotRight".
      rewrite <- H3.
      apply Un_Step with T.
      assumption. assumption. assumption.
    SCase "UnionNotLeft". apply Un_Empty.
    SCase "Union1".
      apply H2. assumption.
      apply preservationS with t. assumption. assumption.
    SCase "Union2". inversion H6. inversion H7. inversion H10.
Qed.

Theorem unsat_union_if : forall t1 t2 T,
  empty |- t1 \in TS T ->
  empty |- t2 \in TS T ->
  unsat t1 ->
  unsat t2 ->
  unsat (tunionS t1 t2)
  .
Proof.
  intros t1 t2 T HT1  HT2 Hunsat1 Hunsat2.
  generalize dependent t2.
  unsat_cases (induction Hunsat1) Case; intros t2 HT2 Hunsat2.
  Case "Un_Empty".
    unsat_cases (induction Hunsat2) SCase.
    SCase "Un_Empty".
      apply unsat_union_unsat_zero.
      inversion HT1.
      inversion HT2.
      apply T_EmptyS.
      apply Un_Empty.
    SCase "Un_Step".
      apply Un_Step with T.
      apply T_UnionS. assumption. assumption.
      exists t. apply STS_UnionNotLeft.
      intros tv Hstep.
      inversion Hstep.
      SSCase "Pure". inversion H3. inversion H6.
      SSCase "UnionLeft".
        inversion H0.
        rewrite <- H5 in H6. inversion H6. inversion H7. inversion H10.
      SSCase "UnionNotRight". apply Un_Empty.
      SSCase "UnionNotLeft".
        rewrite <- H3.
        apply Un_Step with T.
        assumption. assumption. assumption.
      SSCase "Union1". inversion H6. inversion H7. inversion H10.
      SSCase "Union2".
        apply H2. assumption.
        apply preservationS with t. assumption. assumption.
   Case "Un_Step".
     unsat_cases (induction Hunsat2) SCase.
     SCase "Un_Empty".
       apply unsat_union_unsat_zero.
       inversion HT2. assumption.
       apply Un_Step with T. assumption. assumption. assumption.
     SCase "Un_Step".
       apply Un_Step with T.
       apply T_UnionS. assumption. assumption.
       inversion H0 as [t2].
       exists (tunionS t2 t0). apply STS_Union1. assumption.
       intros tv Hstep.
       inversion Hstep.
       SSCase "Pure". inversion H7. inversion H10.
       SSCase "UnionLeft".
         rewrite <- H8 in H0.
         inversion H0.
         inversion H10. inversion H11. inversion H14.
       SSCase "UnionRight".
         rewrite <- H9 in H4.
         inversion H4. inversion H10. inversion H11. inversion H14.
       SSCase "UnionNotRight".
         rewrite <- H7.
         apply Un_Step with T.
         assumption. assumption. assumption.
       SSCase "UnionNotLeft".
         rewrite <- H7.
         apply Un_Step with T; assumption.
       SSCase "Union1".
         apply H2. assumption.
         apply preservationS with t. assumption. assumption. assumption.
         apply Un_Step with T; assumption.
       SSCase "Union2".
         apply H6. assumption.
         apply preservationS with t0; assumption.
Qed.

Theorem unsat_union_only : forall t t1 t2 T,
  empty |- t \in TS T ->
  unsat t ->
  t = tunionS t1 t2 ->
  unsat t1 /\ unsat t2
  .
Proof.
  intros t t1 t2 T HT Hunsat Hdef.
  generalize dependent t2.
  generalize dependent t1.
  unsat_cases (induction Hunsat) Case; intros t1 t2 Hdef.
  Case "Un_Empty". inversion Hdef.
  Case "Un_Step".
    rewrite Hdef in *. clear Hdef.
    split.
    destruct (progressS t1) with (TS T).
    inversion HT. assumption. exists T. reflexivity.
    SCase "valueS t1".
      valueS_cases (destruct H3) SSCase.
      SSCase "vS_empty". apply Un_Empty.
      SSCase "vS_single".
        apply H1.
        apply STS_UnionLeft.
    SCase "t1 steps".
      apply Un_Step with T.
      inversion HT. assumption.
      assumption.
      intros tv Hstep.

      assert (Hpstep : tunionS t1 t2 =S=> tunionS tv t2).
      apply STS_Union1. assumption.

      assert (HpT : empty |- (tunionS tv t2) \in TS T).
      inversion HT.
      apply T_UnionS.
      apply preservationS with t1.
      assumption. assumption. assumption.

      assert (Hpeq : tunionS tv t2 = tunionS tv t2).
      reflexivity.

      specialize (H2 (tunionS tv t2) Hpstep HpT tv t2 Hpeq).
      decompose [and] H2.
      assumption.

    destruct (progressS t2) with (TS T).
    inversion HT. assumption. exists T. reflexivity.
    SCase "valueS t2".
      valueS_cases (destruct H3) SSCase.
      SSCase "vS_empty". apply Un_Empty.
      SSCase "vS_single".
        apply H1.
        apply STS_UnionRight.
    SCase "t2 steps".
      apply Un_Step with T.
      inversion HT. assumption.
      assumption.
      intros tv Hstep.

      assert (Hpstep : tunionS t1 t2 =S=> tunionS t1 tv).
      apply STS_Union2. assumption.

      assert (HpT : empty |- (tunionS t1 tv) \in TS T).
      inversion HT.
      apply T_UnionS.
      assumption.
      apply preservationS with t2.
      assumption. assumption.

      assert (Hpeq : tunionS t1 tv = tunionS t1 tv).
      reflexivity.

      specialize (H2 (tunionS t1 tv) Hpstep HpT t1 tv Hpeq).
      decompose [and] H2.
      assumption.
Qed.

Theorem union1_multi : forall t1 t1' t2 T,
  empty |- t1 \in TS T ->
  empty |- t2 \in TS T ->
  t1 =S=>* t1' ->
  tunionS t1 t2 =S=>* tunionS t1' t2
  .
Proof.
  intros t1 t1' t2 T HT1 HT2 Hsteps.
  multi_cases (induction Hsteps) Case.
  Case "multi_refl". apply multi_refl.
  Case "multi_step".
    apply multi_step with (tunionS y0 t2).
    apply STS_Union1. assumption.
    apply IHHsteps.
    apply preservationS with x0; assumption.
Qed.

Theorem union2_multi : forall t1 t2 t2' T,
  empty |- t1 \in TS T ->
  empty |- t2 \in TS T ->
  t2 =S=>* t2' ->
  tunionS t1 t2 =S=>* tunionS t1 t2'
  .
Proof.
  intros t1 t2 t2' T HT1 HT2 Hsteps.
  multi_cases (induction Hsteps) Case.
  Case "multi_refl". apply multi_refl.
  Case "multi_step".
    apply multi_step with (tunionS t1 y0).
    apply STS_Union2. assumption.
    apply IHHsteps.
    apply preservationS with x0; assumption.
Qed.

Theorem unsat_expands : forall t t' T,
  empty |- t \in TS T ->
  unsat t' ->
  t =S=> t' ->
  unsat t
  .

Ltac sts1_det t t' T :=
   inversion Hstep; apply Un_Step with T;
   [ assumption
   | exists t'; assumption
   | intros tv Hstep1; assert (Heq : tv = t');
     [ inversion Hstep1; apply stepS1_deterministic with t (TS T); assumption
     | rewrite Heq; assumption ]].

Proof.
  intro t.
  t_cases (induction t) Case; intros t' T HT Hunsat Hstep.
  Case "tvar". sts1_det (tvar i) t' T.
  Case "tapp". sts1_det (tapp t1 t2) t' T.
  Case "tabs". sts1_det (tabs i t t0) t' T.
  Case "tunit". sts1_det tunit t' T.
  Case "tpair". sts1_det (tpair t1 t2) t' T.
  Case "tfst". sts1_det (tfst t) t' T.
  Case "tsnd". sts1_det (tsnd t) t' T.
  Case "tinl". sts1_det (tinl t t0) t' T.
  Case "tinr". sts1_det (tinr t t0) t' T.
  Case "tcase". sts1_det (tcase t1 t2 t3) t' T.
  Case "tfix". sts1_det (tfix t) t' T.
  Case "treturnIO". sts1_det (treturnIO t) t' T.
  Case "tbindIO". sts1_det (tbindIO t1 t2) t' T.
  Case "tsearchIO". sts1_det (tsearchIO t) t' T.
  Case "temptyS". sts1_det (temptyS t) t' T.
  Case "tsingleS". sts1_det (tsingleS t) t' T.
  Case "tunionS".
    inversion Hstep.
    SCase "S1". inversion H. inversion H2.
    SCase "UnionLeft". (* but tsingle is not unsat *)
      rewrite <- H2 in Hunsat.
      inversion Hunsat.
      inversion H3. inversion H6. inversion H7. inversion H10.
    SCase "UnionRight". (* but tsingle is not unsat *)
      rewrite <- H2 in Hunsat.
      inversion Hunsat.
      inversion H3. inversion H6. inversion H7. inversion H10.
    SCase "UnionNotRight".
      apply unsat_union_if with T.
      apply preservationS with (tunionS t1 t2) . assumption. assumption.
      rewrite H1. inversion HT. assumption. assumption.
      apply Un_Empty.
    SCase "UnionNotLeft".
      apply unsat_union_if with T.
      rewrite H0.
      inversion HT. assumption.
      apply preservationS with (tunionS t1 t2). assumption. assumption.
      apply Un_Empty. assumption.
    SCase "Union1".
      rewrite <- H0 in Hunsat.
      inversion HT.
      assert (empty |- t1' \in TS T).
      apply preservationS with t1; assumption.

      assert (unsat t1').
      apply proj1 with (unsat t2).
      apply unsat_union_only with (tunionS t1' t2) T.
      apply T_UnionS ; assumption.
      assumption. reflexivity.

      assert (unsat t1).
      apply IHt1 with t1' T; assumption.

      assert (tunionS t1' t2 =S=>* tunionS (temptyS T) t2).
      apply union1_multi with T ;
      [ assumption | assumption | apply unsat_goes_zero ; assumption ].

      assert (unsat (tunionS (temptyS T) t2)).
      apply unsat_preserves_multi with (tunionS t1' t2) T.
      apply T_UnionS; assumption. assumption. assumption.

      assert (unsat t2).
      apply unsat_preserves with (tunionS (temptyS T) t2) T.
      apply T_UnionS . apply T_EmptyS. assumption.
      assumption.
      apply STS_UnionNotLeft.

      apply unsat_union_if with T; assumption.

    SCase "Union2".
      rewrite <- H0 in Hunsat.
      inversion HT.
      assert (empty |- t2' \in TS T).
      apply preservationS with t2; assumption.

      assert (unsat t2').
      apply proj2 with (unsat t1).
      apply unsat_union_only with (tunionS t1 t2') T.
      apply T_UnionS ; assumption.
      assumption. reflexivity.

      assert (unsat t2).
      apply IHt2 with t2' T; assumption.

      assert (tunionS t1 t2' =S=>* tunionS t1 (temptyS T)).
      apply union2_multi with T ;
      [ assumption | assumption | apply unsat_goes_zero ; assumption ].

      assert (unsat (tunionS t1 (temptyS T))).
      apply unsat_preserves_multi with (tunionS t1 t2') T.
      apply T_UnionS; assumption. assumption. assumption.

      assert (unsat t1).
      apply unsat_preserves with (tunionS t1 (temptyS T)) T.
      apply T_UnionS . assumption. apply T_EmptyS.
      assumption.
      apply STS_UnionNotRight.

      apply unsat_union_if with T; assumption.
  Case "tmapS". sts1_det (tmapS t1 t2) t' T.
  Case "tjoinS". sts1_det (tjoinS t) t' T.
Qed.

Theorem unsat_expands_multi : forall t t' T,
  empty |- t \in TS T ->
  unsat t' ->
  t =S=>* t' ->
  unsat t
  .
Proof.
  intros t t' T HT Hunsat Hsteps.
  multi_cases (induction Hsteps) Case.
  Case "multi_refl". assumption.
  Case "multi_step".
     apply unsat_expands with y0 T. assumption.
     apply IHHsteps.
     apply preservationS with x0 ; assumption.
     assumption. assumption.
Qed.

Theorem perseverence : forall t1 t2 T,
   empty |- t1 \in TS T ->
   t1 =S=>* temptyS T ->
   t1 =S=>* t2 ->
   valueS t2 ->
   t2 = temptyS T
  .
Proof.
   intros t1 t2 T HT Htozero Htot2 Hvt2.
   apply unsat_goes_only_zero with t1.
   assumption.
   apply unsat_expands_multi with (temptyS T) T.
   assumption.
   apply Un_Empty. assumption. assumption. assumption.
Qed.

End SmtenS.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


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

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


(** * A place for various tactic used for the development*)

Require Import Lia ZArith List.

(** ** Tactics taken from the Software Foundations' LibTactics.v *)

Set Implicit Arguments.

(* ================================================================= *)
(** Untyped Arguments for Tactics *)

(** Any Coq value can be boxed into the type [Boxer]. This is
    useful to use Coq computations for implementing tactics. *)

Inductive Boxer : Type :=
  | boxer : forall (A:Type), A -> Boxer.

(* ================================================================= *)
(** Numbers as Arguments *)

(** When tactic takes a natural number as argument, it may be
    parsed either as a natural number or as a relative number.
    In order for tactics to convert their arguments into natural numbers,
    we provide a conversion tactic. *)

Import List.ListNotations.

Definition ltac_int_to_nat (x:BinInt.Z) : nat :=
  match x with
  | BinInt.Z0 => 0%nat
  | BinInt.Zpos p => BinPos.nat_of_P p
  | BinInt.Zneg p => 0%nat
  end.

Ltac number_to_nat N :=
  match type of N with
  | nat => constr:(N)
  | BinInt.Z => let N' := constr:(ltac_int_to_nat N) in eval compute in N'
  end.

(* ================================================================= *)
(** Absurd Goals *)

(** [false_goal] replaces any goal by the goal [False].
    Contrary to the tactic [false] (below), it does not try to do
    anything else *)

Tactic Notation "false_goal" :=
  elimtype False.

(** [false_post] is the underlying tactic used to prove goals
    of the form [False]. In the default implementation, it proves
    the goal if the context contains [False] or an hypothesis of the
    form [C x1 .. xN  =  D y1 .. yM], or if the [congruence] tactic
    finds a proof of [x <> x] for some [x]. *)

Ltac false_post :=
  solve [ assumption | discriminate | congruence ].

(** [false] replaces any goal by the goal [False], and calls [false_post] *)

Tactic Notation "false" :=
  false_goal; try false_post.

(** [tryfalse] tries to solve a goal by contradiction, and leaves
    the goal unchanged if it cannot solve it.
    It is equivalent to [try solve \[ false \]]. *)

Tactic Notation "tryfalse" :=
  try solve [ false ].

Ltac some_inv := repeat (match goal with
                         | [H: Some _ = Some _ |- _] => inversion H; clear H
                         end).

(* ================================================================= *)
(** Deconstructing Terms *)

(** [get_head E] is a tactic that returns the head constant of the
    term [E], ie, when applied to a term of the form [P x1 ... xN]
    it returns [P]. If [E] is not an application, it returns [E].
    Warning: the tactic seems to loop in some cases when the goal is
    a product and one uses the result of this function. *)

Ltac get_head E :=
  match E with
  | ?P _ _ _ _ _ _ _ _ _ _ _ _ => constr:(P)
  | ?P _ _ _ _ _ _ _ _ _ _ _ => constr:(P)
  | ?P _ _ _ _ _ _ _ _ _ _ => constr:(P)
  | ?P _ _ _ _ _ _ _ _ _ => constr:(P)
  | ?P _ _ _ _ _ _ _ _ => constr:(P)
  | ?P _ _ _ _ _ _ _ => constr:(P)
  | ?P _ _ _ _ _ _ => constr:(P)
  | ?P _ _ _ _ _ => constr:(P)
  | ?P _ _ _ _ => constr:(P)
  | ?P _ _ _ => constr:(P)
  | ?P _ _ => constr:(P)
  | ?P _ => constr:(P)
  | ?P => constr:(P)
  end.

(* ================================================================= *)
(** Unfolding *)

(** [unfolds] unfolds the head definition in the goal, i.e. if the
    goal has form [P x1 ... xN] then it calls [unfold P].
    If the goal is an equality, it tries to unfold the head constant
    on the left-hand side, and otherwise tries on the right-hand side.
    If the goal is a product, it calls [intros] first.
    -- warning: this tactic is overriden in LibReflect. *)

Ltac apply_to_head_of E cont :=
  let go E :=
    let P := get_head E in cont P in
  match E with
  | forall _,_ => intros; apply_to_head_of E cont
  | ?A = ?B => first [ go A | go B ]
  | ?A => go A
  end.

Ltac unfolds_base :=
  match goal with |- ?G =>
   apply_to_head_of G ltac:(fun P => unfold P) end.

Tactic Notation "unfolds" :=
  unfolds_base.

(** [unfolds in H] unfolds the head definition of hypothesis [H], i.e. if
    [H] has type [P x1 ... xN] then it calls [unfold P in H]. *)

Ltac unfolds_in_base H :=
  match type of H with ?G =>
   apply_to_head_of G ltac:(fun P => unfold P in H) end.

Tactic Notation "unfolds" "in" hyp(H) :=
  unfolds_in_base H.

(** [unfolds in H1,H2,..,HN] allows unfolding the head constant
    in several hypotheses at once. *)

Tactic Notation "unfolds" "in" hyp(H1) hyp(H2) :=
  unfolds in H1; unfolds in H2.
Tactic Notation "unfolds" "in" hyp(H1) hyp(H2) hyp(H3) :=
  unfolds in H1; unfolds in H2 H3.
Tactic Notation "unfolds" "in" hyp(H1) hyp(H2) hyp(H3) hyp(H4) :=
  unfolds in H1; unfolds in H2 H3 H4.
Tactic Notation "unfolds" "in" hyp(H1) hyp(H2) hyp(H3) hyp(H4) hyp(H5) :=
  unfolds in H1; unfolds in H2 H3 H4 H5.

(* ################################################################# *)
(** N-ary Conjunctions and Disjunctions *)

(** N-ary Conjunctions Splitting in Goals *)

(** Underlying implementation of [splits]. *)

Ltac splits_tactic N :=
  match N with
  | O => fail
  | S O => idtac
  | S ?N' => split; [| splits_tactic N']
  end.

Ltac unfold_goal_until_conjunction :=
  match goal with
  | |- _ /\ _ => idtac
  | _ => progress(unfolds); unfold_goal_until_conjunction
  end.

Ltac get_term_conjunction_arity T :=
  match T with
  | _ /\ _ /\ _ /\ _ /\ _ /\ _ /\ _ /\ _ => constr:(8)
  | _ /\ _ /\ _ /\ _ /\ _ /\ _ /\ _ => constr:(7)
  | _ /\ _ /\ _ /\ _ /\ _ /\ _ => constr:(6)
  | _ /\ _ /\ _ /\ _ /\ _ => constr:(5)
  | _ /\ _ /\ _ /\ _ => constr:(4)
  | _ /\ _ /\ _ => constr:(3)
  | _ /\ _ => constr:(2)
  | _ -> ?T' => get_term_conjunction_arity T'
  | _ => let P := get_head T in
         let T' := eval unfold P in T in
         match T' with
         | T => fail 1
         | _ => get_term_conjunction_arity T'
         end
         (* --TODO: warning this can loop... *)
  end.

Ltac get_goal_conjunction_arity :=
  match goal with |- ?T => get_term_conjunction_arity T end.

(** [splits] applies to a goal of the form [(T1 /\ .. /\ TN)] and
    destruct it into [N] subgoals [T1] .. [TN]. If the goal is not a
    conjunction, then it unfolds the head definition. *)

Tactic Notation "splits" :=
  unfold_goal_until_conjunction;
  let N := get_goal_conjunction_arity in
  splits_tactic N.

(** [splits N] is similar to [splits], except that it will unfold as many
    definitions as necessary to obtain an [N]-ary conjunction. *)

Tactic Notation "splits" constr(N) :=
  let N := number_to_nat N in
  splits_tactic N.

(** N-ary Conjunctions Deconstruction *)

(** Underlying implementation of [destructs]. *)

Ltac destructs_conjunction_tactic N T :=
  match N with
  | 2 => destruct T as [? ?]
  | 3 => destruct T as [? [? ?]]
  | 4 => destruct T as [? [? [? ?]]]
  | 5 => destruct T as [? [? [? [? ?]]]]
  | 6 => destruct T as [? [? [? [? [? ?]]]]]
  | 7 => destruct T as [? [? [? [? [? [? ?]]]]]]
  end.

(** [destructs T] allows destructing a term [T] which is a N-ary
    conjunction. It is equivalent to [destruct T as (H1 .. HN)],
    except that it does not require to manually specify N different
    names. *)

Tactic Notation "destructs" constr(T) :=
  let TT := type of T in
  let N := get_term_conjunction_arity TT in
  destructs_conjunction_tactic N T.

(** [destructs N T] is equivalent to [destruct T as (H1 .. HN)],
    except that it does not require to manually specify N different
    names. Remark that it is not restricted to N-ary conjunctions. *)

Tactic Notation "destructs" constr(N) constr(T) :=
  let N := number_to_nat N in
  destructs_conjunction_tactic N T.

Section equatesLemma.
Variables (A0 A1 : Type).
Variables (A2 : forall (x1 : A1), Type).
Variables (A3 : forall (x1 : A1) (x2 : A2 x1), Type).
Variables (A4 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2), Type).

Lemma equates_0 : forall (P Q:Prop),
  P -> P = Q -> Q.
Proof. intros. subst. auto. Qed.

Lemma equates_1 :
  forall (P:A0->Prop) x1 y1,
  P y1 -> x1 = y1 -> P x1.
Proof. intros. subst. auto. Qed.

Lemma equates_2 :
  forall y1 (P:A0->forall(x1:A1),Prop) x1 x2,
  P y1 x2 -> x1 = y1 -> P x1 x2.
Proof. intros. subst. auto. Qed.

Lemma equates_3 :
  forall y1 (P:A0->forall(x1:A1)(x2:A2 x1),Prop) x1 x2 x3,
  P y1 x2 x3 -> x1 = y1 -> P x1 x2 x3.
Proof. intros. subst. auto. Qed.

Lemma equates_4 :
  forall y1 (P:A0->forall(x1:A1)(x2:A2 x1)(x3:A3 x2),Prop) x1 x2 x3 x4,
  P y1 x2 x3 x4 -> x1 = y1 -> P x1 x2 x3 x4.
Proof. intros. subst. auto. Qed.

(* Ltac apply_eq H n := *)
(*   match number_to_nat n with *)
(*   | 0 => eapply equates_0;[eapply H | ] *)
(*   | 1 => eapply equates_1;[eapply H | ] *)
(*   | 2 => eapply equates_2;[eapply H | ] *)
(*   end. *)

End equatesLemma.

(** Lia hints - pretty much as for Lia *)
Hint Extern 10 (_ = _ :>nat) => abstract lia: zarith.
Hint Extern 10 (_ <= _) => abstract lia: zarith.
Hint Extern 10 (_ < _) => abstract lia: zarith.
Hint Extern 10 (_ >= _) => abstract lia: zarith.
Hint Extern 10 (_ > _) => abstract lia: zarith.

Hint Extern 10 (_ <> _ :>nat) => abstract lia: zarith.
Hint Extern 10 (~ _ <= _) => abstract lia: zarith.
Hint Extern 10 (~ _ < _) => abstract lia: zarith.
Hint Extern 10 (~ _ >= _) => abstract lia: zarith.
Hint Extern 10 (~ _ > _) => abstract lia: zarith.

Hint Extern 10 False => abstract lia: zarith.

(** ** Converting between bool and Prop *)

Ltac inv_andb H := apply Bool.andb_true_iff in H;destruct H.
Ltac split_andb := apply Bool.andb_true_iff;split.
Ltac leb_ltb_to_prop :=
  try rewrite PeanoNat.Nat.ltb_lt in *;
  try rewrite PeanoNat.Nat.leb_le in *;
  try rewrite PeanoNat.Nat.leb_gt in *;
  try rewrite PeanoNat.Nat.ltb_ge in *.

Ltac prop_to_leb_ltb :=
  try rewrite <- PeanoNat.Nat.ltb_lt in *;
  try rewrite <-PeanoNat.Nat.leb_le in *;
  try rewrite <- PeanoNat.Nat.leb_gt in *;
  try rewrite <- PeanoNat.Nat.ltb_ge in *.

Ltac Zleb_ltb_to_prop :=
  try rewrite Z.ltb_ge in *;
  try rewrite Z.ltb_lt in *;
  try rewrite Z.leb_le in *;
  try rewrite Z.leb_gt in *.

Ltac Zprop_to_leb_ltb :=
  try rewrite <- Z.ltb_ge in *;
  try rewrite <- Z.ltb_lt in *;
  try rewrite <- Z.leb_le in *;
  try rewrite <- Z.leb_gt in *.


Require Export maps_int.
Require Export maps_def.
Require Export maps_proofs.
Import Maps.

Require Import Coq.Lists.ListSet.
Require Import Coq.Arith.Arith.
Require Import Coq.Init.Specif.
Require Export Coq.Lists.List.

Program Instance Maps_Inst : Maps S T map_:=
{
  unique_ := unique_func;
  dom_ := dom_func;
  img := img_func;
  getTs:= getTs_func;
  isMappable_ := isMappable_func;
  maps := maps_func;
  union_s:= union_s_func;
  union_t:= union_t_func;
  set_add_S := set_add_S_func;
  set_add_T := set_add_T_func;

}. Next Obligation.
{ (*mappingUnique*)
  induction m.
    + intros. intuition.
    + intros.
      left. unfold unique_func. intros.
      rewrite r1, r2. reflexivity.

} Qed.
{ Next Obligation. (*inDom*)
  intros.
    induction m.
      + simpl in H. contradiction.
      + apply isMappable_elim in H. intuition.
        - rewrite H. apply set_add_intro2. reflexivity.
        - simpl. apply set_add_intro1. apply H.
Qed. }
{ Next Obligation. (*eqdecS*)
  apply Seq_dec.
  Qed.
}{ Next Obligation. (*eqdecT*)
  apply Teq_dec.
  Qed.
}
 Admit Obligations.


(* Require Import L AbstractMachines.FunctionalDefinitions LNat LProd Datatypes.Lists LOptions. *)
(* Require Import LTactics. *)
(* Require Import AbstractMachines.Computable.Undecidability.Shared.Libs.PSL. *)
(*
Lemma N_size_nat_add_leq x y : N.size_nat (x+y) <= 1 + max (N.size_nat x) (N.size_nat y).
Proof.
  destruct x,y;cbn. 1-3:Lia.nia.
  rewrite !pos_size_eq_log2.
  destruct (@Pos.leb_spec0 p p0).
  2:rename n into l;apply Pos.lt_nle,Pos.lt_le_incl in l.
  all:setoid_rewrite l at 1.
  replace (p0 + p0)%positive with (2*p0)%positive;[|Lia.lia].
  2:  replace (p + p)%positive with (2*p)%positive;[|Lia.lia].
  all:rewrite Pos2Nat.inj_mul.
  all:change (Pos.to_nat 2) with 2.
  all:rewrite Nat.log2_double;[|now eauto using Pos2Nat.is_pos]. all:Lia.lia.
Qed.

Fixpoint substP_keepTrack'_time (m sizeQ : N) (P : list Tok) (k:nat) (revQ akk : Pro) (curSize : N) {struct P} :=
          match P with
            [] => length akk*13
          | (t::P') =>
            let
              '(d, Q', k0) :=
               match t with
               | varT k' => if k' =? k then (sizeQ, None, Some k) else (N.of_nat (1 + k'), Some t, Some k)
               | appT => (1%N, Some t, Some k)
               | lamT => (1%N, Some t, Some (1 + k))
               | retT => (1%N, Some t, if k =? 0 then None else Some (k - 1))
               end in
            match t with
              varT k' => time_N_of_nat (1 + k') + 17 * Init.Nat.min k' k + 12 * N.size_nat sizeQ
            | _ => 0
            end
            +
            let curSize' := (d + curSize)%N in
            24 * N.size_nat d + 24* N.size_nat curSize + 17 * N.size_nat curSize' +
            if (curSize' <=? m)%N
            then
              let akk0 := match Q' with
                    | Some t0 => t0 :: akk
                    | None => revQ ++ akk
                          end
              in
              match Q' with
                Some t0 => 0
              | _ => length revQ*16
              end
              +
              match k0 with
                None => length akk0 * 13
              | Some k1 => substP_keepTrack'_time m sizeQ P' k1 revQ akk0 curSize'
              end
            else
              0
          end + 180.

Fixpoint largestVar P :=
  match P with
    varT k::P' => max k (largestVar P')
  | _::P' => largestVar P'
  | [] => 0
  end.

#[export]
Instance time_N_of_nat_mono: Proper (le ==> le) time_N_of_nat.
Admitted.
(*
Lemma substP_keepTrack'_time_solved m sizeQ P k revQ akk curSize:
  substP_keepTrack'_time m sizeQ P k revQ akk curSize <= sizeP P * 17 +
  length P * (time_N_of_nat (1 + largestVar P) + 180) + length akk * 13 + 180.
Proof.
  induction P in m,k,akk,curSize |-*;cbn- [plus mult largestVar]. 1:now Lia.lia.
  destruct match a with
    | varT k' => if k' =? k then (sizeQ, None, Some k) else (N.of_nat (1 + k'), Some a, Some k)
    | appT => (1%N, Some a, Some k)
    | lamT => (1%N, Some a, Some (1 + k))
    | retT => (1%N, Some a, if k =? 0 then None else Some (k - 1))
           end as [[d Q'] k0 ] eqn:eq.
  remember (match Q' with
            | Some t0 => t0 :: akk
            | None => revQ ++ akk
            end) as akk0.

  setoid_rewrite ( _ : (match a with
  | varT k' => time_N_of_nat (1 + k') + 17 * Init.Nat.min k' k + 12 * N.size_nat sizeQ
  | _ => 0
                        end <= time_N_of_nat (1 + largestVar (a :: P)) + 17 * sizeT a + 12*N.size_nat sizeQ)) at 1.
  2:{ destruct a. 2-4:lia. cbn [largestVar].
      rewrite <- (Nat.le_max_l n (largestVar P)) at 1. cbn [sizeT]. Lia.nia. (*assert (12 * N.size_nat sizeQ <= cnst "12*N.size_nat sizeQ"
                                                             ) by admit. Lia.nia. *) }
  rewrite N_size_nat_add_leq.
  2:admit.

  repeat (let eq := fresh "eq" in destruct _ eqn:eq);try (exfalso;congruence).
  all:try rewrite !IHP.
  all:inv eq. all:cbn [length]. ring_sim(plify.
  all:try setoid_rewrite <- (Nat.le_max_l n0 (largestVar P)) at 2.
  all:try setoid_rewrite <- (Nat.le_max_r n0 (largestVar P)) at 1.

  y. ring_simplify.
  intros.  (d&Q'&k0).
*)
Require Import Functions.BinNums BinNumsCompare.
Require Import AbstractMachines.Computable.Shared.

#[export]
Instance cubstP_keepTrack' :
  computableTime' substP_keepTrack'
                 (fun m _ =>
                    (5,fun sizeQ _ =>
                         (1,fun P _ =>
                              (1,fun k _ =>
                                   (1,fun revQ _ =>
                                        (1,fun akk _ =>
                                             (1,fun curSize _ =>
                                                (substP_keepTrack'_time m sizeQ P k revQ akk curSize,tt)))))))).
unfold substP_keepTrack'.
unfold sizeT.
(*Set Ltac Profiling.*)
extract.
(*Show Ltac Profile.*)
(* Without time:
─extract -------------------------------   0.0% 100.0%       1   99.141s
└computable using (open_constr) --------   0.0%  98.1%       1   97.241s
└Intern.cstep --------------------------   0.0%  97.9%       0   71.965s
└Intern.cstep' -------------------------   0.0%  97.9%       0   71.965s
 ├─extractSimp -------------------------   0.0%  87.0%      10   71.207s
 │└Intern.extractCorrectCrush_new ------   0.0%  87.0%      20   71.188s
 │└Lrewrite_new ------------------------   0.0%  85.6%       0   16.354s
 │└Lrewrite_wrapper --------------------  85.4%  85.6%       0   16.354s
 │└Lrewrite_new' -----------------------  73.2%  85.4%     808    7.740s
 │ ├─find_Lrewrite_lemma ---------------  33.5%  33.5%     774    0.694s
 │ │ ├─eauto (int_or_var_opt) (int_or_va  20.4%  30.9%     774    0.694s
 │ │ │└Lproc ---------------------------   6.8%   6.8%      60    0.549s
 │ │ │└now (tactic) --------------------   0.0%   5.0%      60    0.491s
 │ │ │└t -------------------------------   0.0%   5.0%      60    0.491s
 │ │ │└Lproc' --------------------------   2.8%   4.9%    2973    0.018s
 │ │ │└constructor ---------------------   2.1%   2.1%    1612    0.016s
 │ │ └─eassumption ---------------------   2.5%   2.5%     709    0.018s
 │ ├─Lbeta -----------------------------   0.0%  33.3%      99    0.951s
 │ │└Lbeta' ----------------------------   0.1%  33.2%      99    0.951s
 │ │└simplify_L' -----------------------   0.1%  32.3%       0    0.931s
 │ │ ├─assert (pp : Reflection.Proc phi)   0.0%  21.8%      99    0.556s
 │ │ │└ProcPhi -------------------------   0.0%  21.8%      99    0.556s
 │ │ │└ProcPhi' ------------------------  20.0%  21.6%    1599    0.553s
 │ │ │ ├─destruct H as [eq| H] ---------  10.0%  10.0%    1500    0.051s
 │ │ │ ├─Lproc -------------------------   6.6%   6.6%    1500    0.028s
 │ │ │ │└now (tactic) ------------------   0.0%   4.2%    1500    0.023s
 │ │ │ │└t -----------------------------   0.0%   4.2%    1500    0.023s
 │ │ │ │└Lproc' ------------------------   1.6%   4.2%    1792    0.023s
 │ │ │ │└apply closed_dcl --------------   2.5%   2.5%    1500    0.023s
 │ │ │ └─rewrite <- eq -----------------   2.6%   2.6%    1500    0.028s
 │ │ ├─allVars -------------------------   0.0%   4.1%       0    0.162s
 │ │ │└allVars' ------------------------   4.1%   4.1%       0    0.161s
 │ │ │└addToList -----------------------   0.1%   3.7%       0    0.019s
 │ │ │└AddFvTail -----------------------   3.6%   3.6%       0    0.019s
 │ │ └─reifyTerm -----------------------   2.9%   2.9%       0    0.125s
 │ ├─useFixHypo ------------------------  11.2%  11.2%     709    0.050s
 │ │└eauto (int_or_var_opt) (int_or_var_   9.9%  10.0%     709    0.044s
 │ ├─Lreflexivity ----------------------   2.8%   2.8%       0    0.014s
 │ └─Ltransitivity ---------------------   0.1%   2.7%    3330    0.011s
 │  └eapply star_trans -----------------   2.6%   2.6%    1665    0.011s
 ├─Lproc -------------------------------   4.4%   4.4%       9    0.633s
 │└now (tactic) ------------------------   0.0%   4.1%       9    0.598s
 │└t -----------------------------------   0.0%   4.1%       9    0.598s
 │└Lproc' ------------------------------   2.0%   4.1%    2271    0.023s
 │└constructor -------------------------   2.1%   2.1%    1276    0.019s
 └─step --------------------------------   3.9%   3.9%       4    3.910s
  └extractSimp -------------------------   0.0%   3.8%       3    2.218s
  └Intern.extractCorrectCrush_new ------   0.0%   3.8%       6    2.161s
  └Lrewrite_new ------------------------   0.0%   3.7%       0    2.160s
  └Lrewrite_wrapper --------------------   3.6%   3.7%       0    2.160s
  └Lrewrite_new' -----------------------   2.5%   3.6%      18    2.143s
  └Lbeta -------------------------------   0.0%   2.9%       5    0.615s
  └Lbeta' ------------------------------   0.0%   2.9%       5    0.615s
  └simplify_L' -------------------------   0.0%   2.8%       0    0.598s
*)

(*
With time:
 tactic                                   local  total   calls       max
────────────────────────────────────────┴──────┴──────┴───────┴─────────┘
─extract -------------------------------   0.0% 100.0%       1  156.385s
 ├─computable using (open_constr) ------   0.0%  97.6%       1  152.579s
 │└Intern.cstep ------------------------   0.0%  97.4%       0   92.135s
 │└Intern.cstep' -----------------------   0.0%  97.4%       0   92.135s
 │ ├─extractSimp -----------------------   0.0%  70.5%       8   90.958s
 │ │└Intern.extractCorrectCrush_new ----   0.0%  70.5%      16   90.898s
 │ │ ├─Lrewrite_new --------------------   0.0%  66.0%       0   21.996s
 │ │ │└Lrewrite_wrapper ----------------  65.9%  66.0%       0   21.996s
 │ │ │└Lrewrite_new' -------------------  55.9%  65.9%     782    9.255s
 │ │ │ ├─Lbeta -------------------------   0.0%  23.3%      91    1.639s
 │ │ │ │└Lbeta' ------------------------   0.1%  23.3%      91    1.638s
 │ │ │ │└simplify_L' -------------------   0.1%  22.9%       0    1.608s
 │ │ │ │ ├─assert (pp : Reflection.Proc    0.0%  15.6%      91    0.926s
 │ │ │ │ │└ProcPhi ---------------------   0.0%  15.6%      91    0.926s
 │ │ │ │ │└ProcPhi' --------------------  14.4%  15.5%    1395    0.923s
 │ │ │ │ │ ├─destruct H as [eq| H] -----   6.2%   6.2%    1304    0.049s
 │ │ │ │ │ └─Lproc ---------------------   6.0%   6.0%    1304    0.067s
 │ │ │ │ │  └now (tactic) --------------   0.0%   3.9%    1304    0.047s
 │ │ │ │ │  └t -------------------------   0.0%   3.9%    1304    0.047s
 │ │ │ │ │  └Lproc' --------------------   2.0%   3.9%    1564    0.043s
 │ │ │ │ └─allVars ---------------------   0.0%   3.1%       0    0.326s
 │ │ │ │  └allVars' --------------------   3.1%   3.1%       0    0.326s
 │ │ │ │  └addToList -------------------   0.1%   2.8%       0    0.025s
 │ │ │ │  └AddFvTail -------------------   2.8%   2.8%       0    0.025s
 │ │ │ ├─find_Lrewrite_lemma -----------  21.8%  21.8%     756    0.981s
 │ │ │ │ ├─eauto (int_or_var_opt) (int_o  11.4%  18.7%     756    0.981s
 │ │ │ │ │└Lproc -----------------------   6.1%   6.1%      60    0.851s
 │ │ │ │ │└now (tactic) ----------------   0.0%   4.3%      60    0.737s
 │ │ │ │ │└t ---------------------------   0.0%   4.3%      60    0.737s
 │ │ │ │ │└Lproc' ----------------------   2.8%   4.2%    2973    0.042s
 │ │ │ │ └─eassumption -----------------   3.0%   3.0%     691    0.113s
 │ │ │ ├─useFixHypo --------------------  13.6%  13.6%     691    0.494s
 │ │ │ │└eauto (int_or_var_opt) (int_or_  11.8%  11.9%     691    0.442s
 │ │ │ └─Ltransitivity -----------------   0.1%   2.8%    3024    0.044s
 │ │ │  └eapply redLe_trans ------------   2.7%   2.7%    1512    0.044s
 │ │ └─Lreflexivity --------------------   3.8%   3.8%      19    1.186s
 │ │  └Lproc ---------------------------   3.8%   3.8%      19    1.177s
 │ │  └now (tactic) --------------------   0.0%   3.4%      19    1.067s
 │ │  └t -------------------------------   0.0%   3.4%      19    1.066s
 │ │  └Lproc' --------------------------   1.9%   3.4%    1695    0.049s
 │ ├─loop ------------------------------  11.6%  11.6%       7   18.172s
 │ │└extractSimp -----------------------   0.0%  11.4%       2    9.039s
 │ │└Intern.extractCorrectCrush_new ----   0.0%  11.4%       4    7.596s
 │ │└Lrewrite_new ----------------------   0.0%   9.7%       0    7.594s
 │ │└Lrewrite_wrapper ------------------   9.6%   9.7%       0    7.594s
 │ │└Lrewrite_new' ---------------------   7.8%   9.6%      26    7.504s
 │ │└Lbeta -----------------------------   0.0%   6.9%       8    1.396s
 │ │└Lbeta' ----------------------------   0.0%   6.9%       8    1.395s
 │ │└simplify_L' -----------------------   0.0%   6.5%       0    1.326s
 │ │└assert (pp : Reflection.Proc phi) b   0.0%   3.5%       8    0.731s
 │ │└ProcPhi ---------------------------   0.0%   3.5%       8    0.731s
 │ │└ProcPhi' --------------------------   3.2%   3.4%     204    0.723s
 │ ├─Lproc -----------------------------   5.3%   5.3%       9    1.289s
 │ │└now (tactic) ----------------------   0.0%   5.0%       9    1.227s
 │ │└t ---------------------------------   0.0%   5.0%       9    1.227s
 │ │└Lproc' ----------------------------   2.9%   5.0%    2271    0.055s
 │ │└constructor -----------------------   2.1%   2.1%    1276    0.034s
 │ ├─step ------------------------------   3.9%   4.0%       4    6.233s
 │ │└extractSimp -----------------------   0.0%   3.7%       3    3.072s
 │ │└Lsimpl ----------------------------   0.0%   3.7%       3    3.072s
 │ │└Lbeta -----------------------------   0.0%   3.5%       7    1.332s
 │ │└Lbeta' ----------------------------   1.8%   3.5%       6    1.332s
 │ │└simplify_L' -----------------------   0.0%   3.4%       0    1.307s
 │ └─destruct tt -----------------------   3.5%   3.5%      13    0.526s
 └─Intern.extractAs --------------------   0.0%   2.4%       1    3.806s
  └run_template_program (constr) (tactic   2.4%   2.4%       1    3.805s
 *)
solverec.
(*recRel_prettify_arith.
unfold substP_keepTrack'_time.
all:fold substP_keepTrack'_time.
all:change (N.size_nat 1) with 1%nat.
all:try rewrite !Nat.min_0_r.
all:try pose (Nat.le_min_r x0 1).
all:cbn [length].
all:try abstract Lia.nia.*)
all:fail.
Check "success modulo QED., TODO: use recursion instead fix".
Admitted.*)


(**
 Morphisms in the bicat of univalent categories

 Contents:
 1. Faithful 1-cells
 2. Fully faithful 1-cells
 3. Esos in 1-types
 4. (eso, ff)-factorization
 5. Esos are closed under pullback
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Morphisms.FullyFaithful.
Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms.
Require Import UniMath.Bicategories.Morphisms.Eso.
Require Import UniMath.Bicategories.Limits.Pullbacks.
Require Import UniMath.Bicategories.Limits.Examples.OneTypesLimits.

Local Open Scope cat.

Definition pr1_image
           {X Y : UU}
           (f : X → Y)
  : image f → Y
  := pr1.

Definition isInjective_pr1_image
           {X Y : UU}
           (f : X → Y)
  : isInjective (pr1_image f).
Proof.
  intros y₁ y₂.
  refine (pr2 (path_sigma_hprop
                 (λ (y : Y), ∥ hfiber f y ∥)
                 y₁ y₂
                 _)).
  apply ishinh.
Qed.

Definition isofhlevel_image
           {X Y : UU}
           (f : X → Y)
           {n : nat}
           (HY : isofhlevel (S n) Y)
  : isofhlevel (S n) (image f).
Proof.
  unfold image.
  use isofhleveltotal2.
  - exact HY.
  - intro y.
    apply isofhlevelsnprop.
    apply ishinh.
Defined.

Definition HLevel_image
           {n : nat}
           {X : UU}
           {Y : HLevel (S n)}
           (f : X → pr1 Y)
  : HLevel (S n).
Proof.
  refine (image f ,, _).
  apply isofhlevel_image.
  exact (pr2 Y).
Defined.

Section ImageMap.
  Context {X I₁ I₂ Y : UU}
          {f₁ : X → I₁}
          (Hf₁ : issurjective f₁)
          (f₂ : X → I₂)
          (m₁ : I₁ → Y)
          {m₂ : I₂ → Y}
          (Hm₂ : isInjective m₂)
          (p : ∏ (x : X), m₂(f₂ x) = m₁(f₁ x)).

  Definition image_function_help
             (i : I₁)
    : ∃! (x : I₂), m₂ x = m₁ i.
  Proof.
    use (factor_through_squash _ _ (Hf₁ i)).
    {
      apply isapropiscontr.
    }
    intros x.
    use iscontraprop1.
    - apply (isinclweqonpaths _ Hm₂).
    - simple refine (f₂ (pr1 x) ,, _).
      exact (p (pr1 x) @ maponpaths m₁ (pr2 x)).
  Defined.

  Definition image_function
    : I₁ → I₂
    := λ i, pr11 (image_function_help i).
End ImageMap.

(**
 1. Faithful 1-cells
 *)
Definition one_types_is_incl_faithful_1cell
           {X Y : one_types}
           (f : X --> Y)
           (Hf : ∏ (x y : (X : one_type)), isincl (@maponpaths _ _ f x y))
  : faithful_1cell f.
Proof.
  intros z g₁ g₂ α₁ α₂ p.
  use funextsec.
  intro x.
  cbn in * ; unfold homotfun in *.
  pose (Hf (g₁ x) (g₂ x) (maponpaths f (α₂ x))) as i.
  pose (proofirrelevance _ i (α₁ x ,, eqtohomot p x) (α₂ x ,, idpath _)) as k.
  exact (maponpaths pr1 k).
Qed.

Definition one_types_faithful_1cell_is_incl
           {X Y : one_types}
           (f : X --> Y)
           (Hf : faithful_1cell f)
  : ∏ (x y : (X : one_type)), isincl (@maponpaths _ _ f x y).
Proof.
  intros x y ; cbn in *.
  use isinclweqonpaths.
  intros p q.
  use isweqimplimpl.
  - intros α.
    pose (eqtohomot
            (Hf X (λ _, x) (λ _, y)
                (λ _, p) (λ _, q)
                (funextsec _ _ _ (λ _, α)))
            x)
      as fp.
    exact fp.
  - use invproofirrelevance.
    intros ? ?.
    apply X.
  - use invproofirrelevance.
    intros ? ?.
    apply Y.
Qed.

Definition one_types_is_incl_weq_faithful_1cell
           {X Y : one_types}
           (f : X --> Y)
  : (∏ (x y : (X : one_type)), isincl (@maponpaths _ _ f x y))
    ≃
    faithful_1cell f.
Proof.
  use weqimplimpl.
  - exact (one_types_is_incl_faithful_1cell f).
  - exact (one_types_faithful_1cell_is_incl f).
  - do 2 (use impred ; intro).
    apply isapropisincl.
  - apply isaprop_faithful_1cell.
Qed.

(**
 2. Fully faithful 1-cells
 *)
Definition one_types_isInjective_fully_faithful_1cell
           {X Y : one_types}
           (f : X --> Y)
           (Hf : isInjective f)
  : fully_faithful_1cell f.
Proof.
  use make_fully_faithful.
  - apply one_types_is_incl_faithful_1cell.
    intros x y.
    apply isinclweq.
    apply Hf.
  - intros Z g₁ g₂ αf ; cbn in * ; unfold homotfun in *.
    simple refine (_ ,, _).
    + intro x.
      apply (invmap (make_weq _ (Hf (g₁ x) (g₂ x)))).
      exact (αf x).
    + use funextsec.
      intro x.
      apply (homotweqinvweq (make_weq _ (Hf (g₁ x) (g₂ x)))).
Qed.

Definition one_types_fully_faithful_isInjective
           {X Y : one_types}
           (f : X --> Y)
           (Hf : fully_faithful_1cell f)
  : isInjective f.
Proof.
  intros x y ; cbn in *.
  use isweq_iso.
  - intro p.
    exact (pr1 (pr2 Hf X (λ _, x) (λ _, y) (λ _, p)) x).
  - intro p ; simpl.
    pose (pr1 Hf
               _ _ _
               (pr1 (pr2 Hf X (λ _ : X, x) (λ _ : X, y) (λ _ : X, maponpaths f p)))
               (λ _, p))
      as q.
    cbn in q.
    refine (eqtohomot (q _) x).
    unfold homotfun.
    use funextsec.
    intro ; cbn.
    exact (eqtohomot (pr2 (pr2 Hf X (λ _, x) (λ _, y) (λ _, maponpaths f p))) _).
  - intros p.
    exact (eqtohomot (pr2 (pr2 Hf X (λ _, x) (λ _, y) (λ _, p))) x).
Qed.

Definition one_types_isInjective_weq_fully_faithful
           {X Y : one_types}
           (f : X --> Y)
  : isInjective f ≃ fully_faithful_1cell f.
Proof.
  use weqimplimpl.
  - exact (one_types_isInjective_fully_faithful_1cell f).
  - exact (one_types_fully_faithful_isInjective f).
  - apply isaprop_isInjective.
  - apply isaprop_fully_faithful_1cell.
Qed.

(**
 3. Esos in 1-types
 *)
Section IsSurjectiveEsoFull.
  Context {X Y : one_types}
          {f : X --> Y}
          (Hf : issurjective f)
          {W₁ W₂ : one_types}
          {m : W₁ --> W₂}
          (Hm : fully_faithful_1cell m)
          {g₁ g₂ : Y --> W₁}
          (p₁ : f · g₁ ==> f · g₂)
          (p₂ : g₁ · m ==> g₂ · m)
          (q : (p₁ ▹ m) • rassociator f g₂ m = rassociator f g₁ m • (f ◃ p₂)).

  Definition issurjective_is_eso_full_lift_2
    : g₁ ==> g₂.
  Proof.
    intro x.
    apply (invmap
             (make_weq
                _
                (one_types_fully_faithful_isInjective _ Hm (g₁ x) (g₂ x)))).
    exact (p₂ x).
  Defined.

  Definition issurjective_is_eso_full_lift_2_left
    : f ◃ issurjective_is_eso_full_lift_2 = p₁.
  Proof.
    use funextsec.
    intro x.
    pose (H := homotinvweqweq
                 (make_weq
                    _
                    (one_types_fully_faithful_isInjective _ Hm (g₁(f x)) (g₂(f x))))).
    refine (!(H _) @ _ @ H _).
    apply maponpaths.
    etrans.
    {
      apply homotweqinvweq.
    }
    refine (!(eqtohomot q x) @ _).
    apply pathscomp0rid.
  Qed.

  Definition issurjective_is_eso_full_lift_2_right
    : issurjective_is_eso_full_lift_2 ▹ m = p₂.
  Proof.
    use funextsec.
    intro x.
    apply (homotweqinvweq
             (make_weq
                _
                (one_types_fully_faithful_isInjective _ Hm (g₁ x) (g₂ x)))).
  Qed.
End IsSurjectiveEsoFull.

Definition issurjective_is_eso_full
           {X Y : one_types}
           {f : X --> Y}
           (Hf : issurjective f)
  : is_eso_full f.
Proof.
  intros W₁ W₂ m Hm g₁ g₂ p₁ p₂ q.
  simple refine (_ ,, _ ,, _).
  - exact (issurjective_is_eso_full_lift_2 Hm p₂).
  - exact (issurjective_is_eso_full_lift_2_left Hm _ _ q).
  - apply issurjective_is_eso_full_lift_2_right.
Qed.

Definition issurjective_is_eso_faithful
           {X Y : one_types}
           {f : X --> Y}
           (Hf : issurjective f)
  : is_eso_faithful f.
Proof.
  intros W₁ W₂ m Hm g₁ g₂ p₁ p₂ q₁ q₂.
  use funextsec.
  intro x.
  use (invmaponpathsincl
         _
         (one_types_faithful_1cell_is_incl
            m
            (pr1 Hm)
            (g₁ x) (g₂ x))).
  exact (eqtohomot q₂ x).
Qed.

Section IsSurjectiveIsEsoEssentiallySurjective.
  Context {X₁ X₂ Y₁ Y₂ : one_types}
          {f : X₁ --> X₂}
          (Hf : issurjective f)
          {m : Y₁ --> Y₂}
          (Hm : isInjective m)
          {g₁ : X₁ --> Y₁}
          {g₂ : X₂ --> Y₂}
          (p : invertible_2cell (g₁ · m) (f · g₂)).

  Let I₁ : UU := image g₁.
  Let I₂ : UU := image g₂.

  Definition issurjective_is_eso_lift_1
    : X₂ --> Y₁
    := image_function Hf g₁ g₂ Hm (pr1 p).

  Definition issurjective_is_eso_lift_1_right
    : issurjective_is_eso_lift_1 · m ==> g₂.
  Proof.
    intro x.
    exact (pr21 (image_function_help Hf g₁ g₂ Hm (pr1 p) x)).
  Defined.

  (**
   The equation of this one is derived from `issurjective_is_eso_lift_1_eq`
   *)
  Definition issurjective_is_eso_lift_1_left
    : f · issurjective_is_eso_lift_1 ==> g₁.
  Proof.
    intro x.
    exact (invmap
             (make_weq
                _
                (Hm (issurjective_is_eso_lift_1 (f x)) (g₁ x)))
             (issurjective_is_eso_lift_1_right (f x) @ ! pr1 p x)).
  Defined.

  Definition issurjective_is_eso_lift_1_eq
    : (issurjective_is_eso_lift_1_left ▹ m) • p
      =
      rassociator _ _ _ • (f ◃ issurjective_is_eso_lift_1_right).
  Proof.
    use funextsec.
    intro x.
    cbn ; unfold homotcomp, homotfun, funhomotsec.
    use hornRotation_rr.
    use (invmaponpathsweq
           (invweq (make_weq _ (Hm (issurjective_is_eso_lift_1 (f x)) (g₁ x))))).
    apply (homotinvweqweq
             (make_weq _ (Hm (issurjective_is_eso_lift_1 (f x)) (g₁ x)))).
  Qed.
End IsSurjectiveIsEsoEssentiallySurjective.

Definition issurjective_is_eso_essentially_surjective
           {X₁ X₂ : one_types}
           {f : X₁ --> X₂}
           (Hf : issurjective f)
  : is_eso_essentially_surjective f.
Proof.
  intros Y₁ Y₂ m Hm' g₁ g₂ p.
  pose (Hm := one_types_fully_faithful_isInjective _ Hm').
  simple refine (_ ,, _ ,, _ ,, _).
  - exact (issurjective_is_eso_lift_1 Hf Hm p).
  - use make_invertible_2cell.
    + exact (issurjective_is_eso_lift_1_left Hf Hm p).
    + apply one_type_2cell_iso.
  - use make_invertible_2cell.
    + exact (issurjective_is_eso_lift_1_right Hf Hm p).
    + apply one_type_2cell_iso.
  - exact (issurjective_is_eso_lift_1_eq Hf Hm p).
Defined.

Definition issurjective_is_eso
           {X Y : one_types}
           {f : X --> Y}
           (Hf : issurjective f)
  : is_eso f.
Proof.
  use make_is_eso.
  - exact one_types_is_univalent_2_1.
  - exact (issurjective_is_eso_full Hf).
  - exact (issurjective_is_eso_faithful Hf).
  - exact (issurjective_is_eso_essentially_surjective Hf).
Defined.

Section IsEsoIsSurjective.
  Context {X Y : one_types}
          {f : X --> Y}
          (Hf : is_eso f).

  Let im : one_types := HLevel_image f.
  Let fim : X --> im := prtoimage f.
  Let π : im --> Y := pr1_image f.

  Definition is_eso_issurjective_inv2cell
    : invertible_2cell
        (fim · π)
        (f · id₁ Y).
  Proof.
    use make_invertible_2cell.
    - exact (λ _, idpath _).
    - apply one_type_2cell_iso.
  Defined.

  Local Definition is_eso_issurjective_help_map
    : Y --> im
    := is_eso_lift_1
         _
         Hf
         (one_types_isInjective_fully_faithful_1cell
            π
            (isInjective_pr1_image f))
         (prtoimage f)
         (id₁ _)
         is_eso_issurjective_inv2cell.

  Let φ := is_eso_issurjective_help_map.

  Definition is_eso_issurjective
    : issurjective f.
  Proof.
    intro y.
    use (factor_through_squash _ _ (pr2 (φ y))).
    {
      apply ishinh.
    }
    intros x.
    apply hinhpr.
    refine (pr1 x ,, _).
    refine (pr2 x @ _).
    exact (pr1 (is_eso_lift_1_comm_right
                  _
                  Hf
                  (one_types_isInjective_fully_faithful_1cell
                     π
                     (isInjective_pr1_image f))
                  (prtoimage f)
                  (id₁ _)
                  is_eso_issurjective_inv2cell)
               y).
  Qed.
End IsEsoIsSurjective.

Definition issurjective_weq_is_eso
           {X Y : one_types}
           (f : X --> Y)
  : issurjective f ≃ is_eso f.
Proof.
  use weqimplimpl.
  - exact issurjective_is_eso.
  - exact is_eso_issurjective.
  - apply isapropissurjective.
  - apply isaprop_is_eso.
    exact one_types_is_univalent_2_1.
Defined.

(**
 4. (eso, ff)-factorization
 *)
Definition eso_ff_factorization_one_types
  : eso_ff_factorization one_types.
Proof.
  intros X Y f.
  refine (HLevel_image f ,, _).
  refine (pr1_image f ,, prtoimage f ,, _ ,, _ ,, _).
  - apply one_types_isInjective_fully_faithful_1cell.
    apply isInjective_pr1_image.
  - apply issurjective_is_eso.
    apply issurjprtoimage.
  - use make_invertible_2cell.
    + intro x.
      apply idpath.
    + apply one_type_2cell_iso.
Defined.

(**
 5. Esos are closed under pullback
 *)
Definition is_eso_closed_under_pb_one_types
  : is_eso_closed_under_pb (_ ,, one_types_has_pb).
Proof.
  intros X Y Z f Hf' g ; cbn in *.
  use issurjective_is_eso.
  pose (Hf := is_eso_issurjective Hf').
  intros y.
  use (factor_through_squash _ _ (Hf (g y))).
  {
    apply ishinh.
  }
  intros x.
  apply hinhpr.
  exact (((pr1 x ,, y) ,, !(pr2 x)) ,, idpath _).
Defined.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** The abstract domain for value numbering, used in common
    subexpression elimination. *)

Require Import Coqlib.
Require Import Maps.
Require Import AST.
Require Import Values.
Require Import Memory.
Require Import Op.
Require Import Registers.
Require Import RTL.

(** Value numbers are represented by positive integers.  Equations are
  of the form [valnum = rhs] or [valnum >= rhs], where the right-hand
  sides [rhs] are either arithmetic operations or memory loads, [=] is
  strict equality of values, and [>=] is the "more defined than" relation
  over values. *)

Definition valnum := positive.

Inductive rhs : Type :=
  | Op: operation -> list valnum -> rhs
  | Load: memory_chunk -> addressing -> list valnum -> rhs.

Inductive equation : Type :=
  | Eq (v: valnum) (strict: bool) (r: rhs).

Definition eq_valnum: forall (x y: valnum), {x=y}+{x<>y} := peq.

Definition eq_list_valnum: forall (x y: list valnum), {x=y}+{x<>y} := list_eq_dec peq.

Definition eq_rhs (x y: rhs) : {x=y}+{x<>y}.
Proof.
  generalize chunk_eq eq_operation eq_addressing eq_valnum eq_list_valnum.
  decide equality.
Defined.

(** A value numbering is a collection of equations between value numbers
  plus a partial map from registers to value numbers.  Additionally,
  we maintain the next unused value number, so as to easily generate
  fresh value numbers.  We also maintain a reverse mapping from value
  numbers to registers, redundant with the mapping from registers to
  value numbers, in order to speed up some operations. *)

Record numbering : Type := mknumbering {
  num_next: valnum;                  (**r first unused value number *)
  num_eqs: list equation;            (**r valid equations *)
  num_reg: PTree.t valnum;           (**r mapping register to valnum *)
  num_val: PMap.t (list reg)         (**r reverse mapping valnum to regs containing it *)
}.

Definition empty_numbering :=
  {| num_next := 1%positive;
     num_eqs  := nil;
     num_reg  := PTree.empty _;
     num_val  := PMap.init nil |}.

(** A numbering is well formed if all value numbers mentioned are below
  [num_next].  Moreover, the [num_val] reverse mapping must be consistent
  with the [num_reg] direct mapping. *)

Definition valnums_rhs (r: rhs): list valnum :=
  match r with
  | Op op vl => vl
  | Load chunk addr vl => vl
  end.

Definition wf_rhs (next: valnum) (r: rhs) : Prop :=
forall v, In v (valnums_rhs r) -> Plt v next.

Definition wf_equation (next: valnum) (e: equation) : Prop :=
  match e with Eq l str r => Plt l next /\ wf_rhs next r end.

Record wf_numbering (n: numbering) : Prop := {
  wf_num_eqs: forall e,
      In e n.(num_eqs) -> wf_equation n.(num_next) e;
  wf_num_reg: forall r v,
      PTree.get r n.(num_reg) = Some v -> Plt v n.(num_next);
  wf_num_val: forall r v,
      In r (PMap.get v n.(num_val)) -> PTree.get r n.(num_reg) = Some v
}.

Hint Resolve wf_num_eqs wf_num_reg wf_num_val: cse.

(** Satisfiability of numberings.  A numbering holds in a concrete
  execution state if there exists a valuation assigning values to
  value numbers that satisfies the equations and register mapping
  of the numbering. *)

Definition valuation := valnum -> val.

Inductive rhs_eval_to (valu: valuation) (ge: genv) (sp: val) (m: mem):
                                                     rhs -> val -> Prop :=
  | op_eval_to: forall op vl v,
      eval_operation ge sp op (map valu vl) m = Some v ->
      rhs_eval_to valu ge sp m (Op op vl) v
  | load_eval_to: forall chunk addr vl a v,
      eval_addressing ge sp addr (map valu vl) = Some a ->
      Mem.loadv chunk m a = Some v ->
      rhs_eval_to valu ge sp m (Load chunk addr vl) v.

Inductive equation_holds (valu: valuation) (ge: genv) (sp: val) (m: mem):
                                                      equation -> Prop :=
  | eq_holds_strict: forall l r,
      rhs_eval_to valu ge sp m r (valu l) ->
      equation_holds valu ge sp m (Eq l true r)
  | eq_holds_lessdef: forall l r v,
      rhs_eval_to valu ge sp m r v -> Val.lessdef v (valu l) ->
      equation_holds valu ge sp m (Eq l false r).

Record numbering_holds (valu: valuation) (ge: genv) (sp: val)
                       (rs: regset) (m: mem) (n: numbering) : Prop := {
  num_holds_wf:
     wf_numbering n;
  num_holds_eq: forall eq,
     In eq n.(num_eqs) -> equation_holds valu ge sp m eq;
  num_holds_reg: forall r v,
     n.(num_reg)!r = Some v -> rs#r = valu v
}.

Hint Resolve num_holds_wf num_holds_eq num_holds_reg: cse.

Lemma empty_numbering_holds:
  forall valu ge sp rs m,
  numbering_holds valu ge sp rs m empty_numbering.
Proof.
  intros; split; simpl; intros.
- split; simpl; intros.
  + contradiction.
  + rewrite PTree.gempty in H; discriminate.
  + rewrite PMap.gi in H; contradiction.
- contradiction.
- rewrite PTree.gempty in H; discriminate.
Qed.


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

Require Import Relations Morphisms.
Require Import Program.
Require Import Le Gt Minus Bool Setoid.
Set Implicit Arguments.

Module Type T.
 Parameter Loc: Type.
 Parameter Val: Loc -> Type.
 Parameter Loc_dec: forall i j: Loc, {i=j}+{i<>j}.
 Inductive empty_set : Type :=.
End T.


Require Import Setoid.

Definition proj (P Q : Prop) := P.

Lemma foo (P : Prop) : proj P P = P.
Admitted.
Lemma trueI : True <-> True.
Admitted.
Goal True.
  Fail setoid_rewrite foo.
  Fail setoid_rewrite trueI.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Defining type safety, page 67.

*)
(* DONE *)

Set Implicit Arguments.
Require Export LanguageModuleDef.
Require Export AlphaConversion.
Require Export CpdtTactics.
Require Export Case.
Require Export TacticNotations.
Require Export StaticSemanticsKindingAndContextWellFormednessLemmas.
Require Export StaticSemanticsKindingLemmas.

Lemma A_1_Context_Weakening_1:
  forall (d : Delta) (tau : Tau) (k : Kappa),
    WFD d ->
    K d tau k ->
    forall (d' : Delta),
      D.extends d d' = true ->
      WFD d' ->
      K d' tau k.
Proof.
  intros d tau k WFDder Kder.
  pose proof WFDder as WFDder'.
  apply WFD_implies_nodup in WFDder'.
  K_ind_cases (induction Kder) Case.
  Case "K d cint B".
   intros.
   constructor.
  Case "K d (tv_t alpha) B".
   intros.
   apply K_B.
   apply D.map_extends_some_agreement with (c:= d); try assumption.
   apply WFD_implies_nodup in H1; try assumption.
  Case "K d (ptype (tv_t alpha)) B".
   intros.
   constructor.
   apply D.map_extends_some_agreement with (c:= d); try assumption.
   apply WFD_implies_nodup in H1; try assumption.
  Case "K d tau A".
   intros.
   constructor; try assumption.
   apply IHKder; try assumption.
  Case "K d (cross t0 t1) A".
   intros.
   apply K_cross; try assumption.
   apply IHKder1; try assumption.
   apply IHKder2; try assumption.
  Case "K d (arrow t0 t1) A".
   intros.
   apply K_arrow; try assumption.
   apply IHKder1; try assumption.
   apply IHKder2; try assumption.
  Case "K d (ptype tau) B".
   intros.
   apply K_ptype; try assumption.
   apply IHKder; try assumption.
  Case "K d (utype alpha k tau) A".
   intros.
   apply K_utype; try assumption.
   constructor;  try assumption.
   AdmitAlphaConversion.
   AdmitAlphaConversion.
   apply IHKder with (d':= (D.ctxt alpha k d')) in H; try assumption.
   unfold D.nodup.
   fold D.nodup.
   rewrite H0.
   assumption.
   apply D.extends_l_weak_r_str; try assumption.
   AdmitAlphaConversion.
   apply WFD_implies_nodup; try assumption.
   constructor; try assumption.
   AdmitAlphaConversion.
  Case "K d (etype p alpha k tau) A)".
   intros.
   apply K_etype; try assumption.
   constructor;  try assumption.
   AdmitAlphaConversion.
   AdmitAlphaConversion.
   apply IHKder with (d':= (D.ctxt alpha k d')) in H; try assumption.
   unfold D.nodup.
   fold D.nodup.
   rewrite H0.
   assumption.
   apply D.extends_l_weak_r_str; try assumption.
   AdmitAlphaConversion.
   apply WFD_implies_nodup; try assumption.
   constructor; try assumption.
   AdmitAlphaConversion.
Qed.

Lemma A_1_Context_Weakening_2:
  forall (u : Upsilon),
    WFU u ->
    forall (x : TM.EV.T) (p : Path) (tau : Tau),
    U.map u (x,p) = Some tau ->
    forall (d : Delta),
      WFD d ->
      K d tau A.
Proof.
  intros u WFUder.
  induction WFUder.
 Case "WFU []".
   intros.
   inversion H.
 Case "WFU ([(x, p, tau)] ++ u)".
  intros.
  unfold uctxt in H1.
  unfold U.map in H1.
  fold U.map in H1.
  case_eq(U.K_eq (x0, p0) (x,p)); intros; rewrite H3 in H1.
  inversion H1.
  subst.
  apply K_weakening with (d:= ddot); try assumption.
  constructor.
  apply D.empty_extended_by_all.
  apply IHWFUder with (d:= d) in H1; try assumption.
Qed.