(** Authors: Jianzhou Zhao. *)

Require Export Metatheory.
Require Import LinF_Definitions.
Require Import LinF_Infrastructure.
Require Import LinF_Lemmas.
Require Import LinF_Soundness.
Require Import LinF_Parametricity.

Export Parametricity.

(***************************************************************)
(*                 Beta Eta Equivalence                                     *)
(***************************************************************)
Inductive beta_eta_eq : exp -> exp -> Prop :=
  | bee_refl : forall e,
      expr e -> beta_eta_eq e e
  | bee_sym : forall e e',
      beta_eta_eq e' e -> beta_eta_eq e e'
  | bee_trans : forall e e' e'',
      beta_eta_eq e e' -> beta_eta_eq e' e'' -> beta_eta_eq e e''
  | bee_red : forall e v,
      bigstep_red e v -> beta_eta_eq e v
  | bee_app : forall e1 e2 e2',
      expr (exp_app e1 e2) ->
      beta_eta_eq e2 e2' -> beta_eta_eq (exp_app e1 e2) (exp_app e1 e2')
  .

Hint Constructors beta_eta_eq.

Lemma bee_reflexivity : forall e,
  expr e -> beta_eta_eq e e.
intros; auto.
Qed.

Lemma bee_symm : forall e e',
  beta_eta_eq e e' -> beta_eta_eq e' e.
intros.
  induction H; eauto.
Qed.

Lemma bee_transitivity : forall e e' e'',
  beta_eta_eq e e' -> beta_eta_eq e' e'' -> beta_eta_eq e e''.
intros.
  generalize dependent e''.
  induction H; intros; eauto.
Qed.

(***************************************************************)
(*                               Relations                                            *)
(***************************************************************)
Definition Rfun (A A':typ) (f:exp) K (v v':exp) : Prop :=
  value (v) /\ value (v') /\
  typing nil nil v A /\ typing nil nil v' A' /\
  typing nil nil f (typ_arrow K A A') /\
  beta_eta_eq (exp_app f v) v'
  .
Definition Rid (A:typ) (v v':exp) : Prop :=
  value v /\ value v' /\
  typing nil nil v A /\ typing nil nil v' A /\ beta_eta_eq v v'.

Lemma Rfun_wfr : forall A A' K Q a,
  wf_typ nil A K ->
  wf_typ nil A' K ->
  wfr (Rfun A A' a Q) A A' K.
Proof.
  intros.
  split; auto.
Qed.

Lemma Rid_wfr : forall A K,
  wf_typ nil A K ->
  wfr (Rid A) A A K.
Proof.
  intros.
  split; auto.
Qed.

(***************************************************************)
(*                 Fundamental Parametricity                            *)
(***************************************************************)
Corollary fundamental_parametricity: forall e t,
   typing nil nil e t ->
   F_related_terms t rho_nil delta_nil delta_nil e e.
Proof.
  intros.
  assert (apply_delta_subst delta_nil (apply_gamma_subst gamma_nil (apply_gamma_subst gamma_nil e)) = e) as Heq; auto.
  rewrite <- Heq.
  eapply parametricity; eauto.
Qed.

(***************************************************************)
(*                             Termination                                          *)
(***************************************************************)
Lemma termination : forall e t dsubst dsubst' gsubst gsubst' rsubst,
   F_related_terms t rsubst dsubst dsubst'
                                 (apply_delta_subst dsubst (apply_gamma_subst gsubst e))
                                 (apply_delta_subst dsubst' (apply_gamma_subst gsubst' e)) ->
   exists v, exists v',
     normalize (apply_delta_subst dsubst (apply_gamma_subst gsubst e)) v /\
     normalize (apply_delta_subst dsubst' (apply_gamma_subst gsubst' e)) v' /\
     F_related_values t rsubst dsubst dsubst' v v'.
Proof.
  intros e t dsubst dsubst' gsubst gsubst' rsubst Hrel.
  destruct Hrel as [v [v' Hrel]]. decompose [and] Hrel.
  exists (v). exists (v').
  split; auto.
Qed.

(***************************************************************)
(*                             Identification                                         *)
(***************************************************************)
(*
  \I : \X. X-> X. \A. \A'. \a: A-> A'. a I[A] = I[A'] a

  The above lemma implies the polymophic function I can only be
  identity function. This can be proved by contradiction.

  The definition of identity function is
    \X. \v:X. I[X]v = v,  where '=' should be the beta-eta-equivalence.
  The negation of the above defn is
    ex X, ex v:X, I[X]v <> v

  If I is not an identity function, without lose of generality, suppose
       exist X0, exists v0:X0, s.t. I[X0] v0 = v' <> v0
  We can pick a function a:X0->X0 which is defined as
    a[u] = v0 if u = v'
    a[u] = u otherwise
  then,
     a I[X0] v0 = a (I[X0] v0) = a v' = v0
     I[X0] a v0 = I[X0] (a v0) = I[X0] v0 = v'
  We proved a I[X0] v0 <> I[X0] a v0 since v0 <> v',
  but this is contradictary to
     \I : \X. X-> X. \A. \A'. \a: A-> A'. a I[A] = I[A'] a
   which we are proving below.

  So I can only be an identity function.
*)
Lemma Identification : forall Id A A' Q K,
  typing nil nil Id (typ_all Q (typ_arrow K (typ_bvar 0) (typ_bvar 0))) ->
  (forall x y R, exists X,
   wf_typ ([(X, bind_kn Q)]) (typ_fvar X) Q ->
   wfr R A A' Q ->
   F_related_terms (typ_fvar X)
                                 ([(X,R)])
                                 ([(X,A)])
                                 ([(X,A')])
                                  x y ->
   F_related_terms (typ_fvar X)
                                 ([(X,R)])
                                 ([(X,A)])
                                 ([(X,A')])
                                 (exp_app (exp_tapp Id A) x) (exp_app (exp_tapp Id A') y)).
Proof.
  intros Id A A' Q K Htyping x y R.
  assert (wf_typ nil (typ_all Q (typ_arrow K (typ_bvar 0) (typ_bvar 0))) kn_lin) as WFT.
    apply typing_regular in Htyping. decompose [and] Htyping; auto.

  assert (F_related_terms (typ_all Q (typ_arrow K (typ_bvar 0) (typ_bvar 0))) rho_nil delta_nil delta_nil Id Id) as Frel_All.
    apply fundamental_parametricity; auto.
  destruct Frel_All as [v [v' [Htypingid [Htypingid' [Hn [Hn' Frel_All]]]]]].

  apply F_related_values_all_leq in Frel_All.
  destruct Frel_All as [Hv [Hv' [L' Hall]]]; subst.

  pick fresh X.
  exists (X). intros WFTvar Hwfr Hterm.
  assert (X `notin` L') as Fr'. auto.
  destruct (@Hall X A A' R Fr') as [w [w' [Hnorm_vt2w [Hnorm_v't2'w' Hrel_wft]]]]; auto.
  unfold open_tt in*. simpl in *.

  assert (wf_typ ((X, bind_kn Q)::nil) (typ_arrow K (typ_fvar X) (typ_fvar X)) K) as WFT'.
    eapply wf_typ_arrow; eauto.

  apply F_related_values_arrow_leq in Hrel_wft.
  destruct Hrel_wft as [Hw [Hw' Harrow]]; subst.
  simpl_env in *.
  assert ((if X==X then A else typ_fvar X) = A) as Heq.
    destruct (X==X); auto. contradict n; auto.
  assert ((if X==X then A' else typ_fvar X) = A') as Heq'.
    destruct (X==X); auto. contradict n; auto.
  simpl in *.
  rewrite Heq in *. rewrite Heq' in *. clear Heq Heq'.

  destruct Hterm as [v0 [v'0 [Htypingv0 [Htypingv'0 [Hnorm [Hnorm' Hrel]]]]]]; subst.

  destruct (@Harrow v0 v'0) as [u [u' [Hn_wxu [Hn_w'x'u' Hrel_wft2]]]]; auto.
    simpl in Htypingv0.
    assert ((if X==X then A else typ_fvar X) = A).
      destruct (X==X); auto. contradict n; auto.
    rewrite H in Htypingv0.
    eapply preservation_normalization; eauto.

    simpl in Htypingv'0.
    assert ((if X==X then A' else typ_fvar X) = A').
      destruct (X==X); auto. contradict n; auto.
    rewrite H in Htypingv'0.
    eapply preservation_normalization; eauto.

  assert (normalize (exp_tapp Id A) w).
      apply congr_tapp with (v1:=v); auto.
      eapply type_from_wf_typ with (E:=@nil (atom*binding)); eauto using wfr_left_inv.

  assert (normalize (exp_tapp Id A') w').
      apply congr_tapp with (v1:=v'); auto.
      eapply type_from_wf_typ with (E:=@nil (atom*binding)); eauto using wfr_right_inv.

  assert (normalize (exp_app (exp_tapp Id A) x) u).
      apply congr_app with (v1:=w) (v2:=v0); auto.
        apply expr_tapp; auto.
          eapply type_from_wf_typ; eauto using wfr_left_inv.

  assert (normalize (exp_app (exp_tapp Id A') y) u').
      apply congr_app with (v1:=w') (v2:=v'0); auto.
        apply expr_tapp; auto.
          eapply type_from_wf_typ; eauto using wfr_right_inv.

  unfold F_related_terms. exists(u). exists(u').
    split; simpl.
    destruct (X==X); try solve [contradict n; auto].
    apply typing_app with (T1:=A) (K:=K) (D1:=nil) (D2:=nil); auto.
      assert (open_tt (typ_arrow K (typ_bvar 0) (typ_bvar 0)) A = typ_arrow K A A) as Heq.
        unfold open_tt. auto.
      rewrite <- Heq.
      eapply typing_tapp; eauto using wfr_left_inv.
        simpl in Htypingv0.
        assert ((if X==X then A else typ_fvar X) = A) as Heq.
          destruct (X==X); auto. contradict n; auto.
        rewrite Heq in Htypingv0.
        assumption.

    split; simpl.
    destruct (X==X); try solve [contradict n; auto].
    eapply typing_app with (T1:=A')(K:=K) (D1:=nil) (D2:=nil); auto.
      assert (open_tt (typ_arrow K (typ_bvar 0) (typ_bvar 0)) A' = typ_arrow K A' A') as Heq.
        unfold open_tt. auto.
      rewrite <- Heq.
      eapply typing_tapp; eauto using wfr_right_inv.
        simpl in Htypingv'0.
        assert ((if X==X then A' else typ_fvar X) = A') as Heq.
          destruct (X==X); auto. contradict n; auto.
        rewrite Heq in Htypingv'0.
        assumption.

    split; auto.
Qed.

Corollary  Rearrangement_Identification : forall Id a A A' K,
  typing nil nil Id (typ_all kn_lin (typ_arrow K (typ_bvar 0) (typ_bvar 0))) ->
  typing nil nil a (typ_arrow K A A') ->
  (forall x,
    typing nil nil x A ->
    (exists x0, normalize x x0) ->
    (exists x'0, normalize (exp_app a x) x'0) ->
    (exists y0, exists y'0,
     normalize (exp_app (exp_tapp Id A) x) y0 /\
     normalize (exp_app (exp_tapp Id A') (exp_app a x)) y'0 /\
     Rfun A A' a K y0 y'0)
  ).
Proof.
  intros Id a A A' K Htypingid Htypinga x Htypingx Hn_xx0 Hn_axx'0.
  assert (wf_typ nil A kn_lin) as HwftA. auto.
  assert (wf_typ nil A' kn_lin) as HwftA'.
    apply typing_regular in Htypinga. decompose [and] Htypinga.
    apply wft_arrow_inv in H3. destruct H3; auto.
  destruct (@Identification Id A A' kn_lin K Htypingid x (exp_app a x) (Rfun A A' a K)) as [X JJ].

  (* x and  (exp_app a x) are related as Rfun*)
  assert (wf_typ ((X, bind_kn kn_lin)::nil) (typ_fvar X) kn_lin) as WFT.
    apply wf_typ_var; unfold binds; simpl; auto.

  destruct Hn_xx0 as [x0 [Hbrc_xx0 Hx0]].
  destruct Hn_axx'0 as [x'0 [Hbrc_axx'0 Hx'0]].
  assert (F_related_terms (typ_fvar X)
                                 ([(X,(Rfun A A' a K))])
                                 ([(X, A)])
                                 ([(X, A')])
                                  x (exp_app a x)).
    Case "Fterms".
    exists (x0). exists (x'0).
      split; simpl.
      SCase "Typing".
      destruct (X==X); auto; contradict n; auto.

      split; simpl.
      SCase "Typing".
      destruct (X==X).
        apply typing_app with (T1:=A) (D1:=nil) (D2:=nil) (K:=K); auto.
        contradict n; auto.

      unfold normalize.
      split; auto.
      split; auto.
      SCase "Fvalues".
        apply F_related_values_fvar_req. simpl.
        exists(Rfun A A' a K).
        repeat(split; auto).
           SSCase "Typing".
           destruct (X==X); try solve [contradict n; auto].
             apply preservation_normalization with (e:=x); auto.
               unfold normalize; auto.
           SSCase "Typing".
           destruct (X==X); try solve [contradict n; auto].
             apply preservation_normalization with (e:=exp_app a x); auto.
               apply typing_app with (T1:=A)(D1:=nil) (D2:=nil) (K:=K); auto.
                 unfold normalize; auto.
           SSCase "Beta-Eta-Equivalence".
           apply bee_trans with (e':=(exp_app a x)); auto.

  (* Id[A] x and  Id[A'] (exp_app a x) are related as Rfun*)
  apply JJ in H; auto using Rfun_wfr.
  subst.
  destruct H as [v [v' [Htypingv [Htypingv' [[Hbrc Hv] [[Hbrc' Hv'] [R [Hb [_ [_ Hrel]]]]]]]]]]; subst.
  exists (v). exists (v'). unfold normalize.
  unfold Rfun.
  repeat(split; auto).
    Case "Typing".
    apply preservation_normalization with (e:=exp_app (exp_tapp Id A) x); auto.
      apply typing_app with (T1:=A)(D1:=nil) (D2:=nil) (K:=K); auto.
        assert (open_tt (typ_arrow K (typ_bvar 0) (typ_bvar 0)) A = typ_arrow K A A).
          unfold open_tt. auto.
        rewrite <- H.
        apply typing_tapp with (K:=kn_lin); auto.
      unfold normalize; auto.
    Case "Typing".
    apply preservation_normalization with (e:=exp_app (exp_tapp Id A') (exp_app a x)); auto.
      apply typing_app with (T1:=A')(D1:=nil) (D2:=nil) (K:=K); auto.
        assert (open_tt (typ_arrow K (typ_bvar 0) (typ_bvar 0)) A' = typ_arrow K A' A').
          unfold open_tt. auto.
        rewrite <- H.
        apply typing_tapp with (K:=kn_lin); auto.
          apply typing_app with (T1:=A)(D1:=nil) (D2:=nil) (K:=K); auto.
      unfold normalize; auto.
    Case "Beta-Eta-Equivalence".
    analyze_binds Hb; subst.
      unfold In_rel in Hrel. decompose [and] Hrel.
      unfold Rfun in Hrel. decompose [and] Hrel.
      assumption.
Qed.

Corollary  EQ_Identification : forall Id K,
  typing nil nil Id (typ_all kn_lin (typ_arrow K (typ_bvar 0) (typ_bvar 0))) ->
  (forall x y A,
    Rid A x y ->
    (exists x0, normalize x x0) ->
    (exists y0, normalize y y0) ->
    (exists x'0, exists y'0,
      normalize (exp_app (exp_tapp Id A) x) x'0 /\
      normalize (exp_app (exp_tapp Id A) y) y'0 /\
      Rid A x'0 y'0)
  ).
Proof.
  intros Id K Htypingid x y A HRid Hn_xx0  Hn_yy0.
  unfold Rid in *. destruct HRid as [Hvx [Hvy [Htypingx [Htypingy Heq_xy]]]].
  destruct Hn_xx0 as [x0 [Hbrc_xx0 Hx0]].
  destruct Hn_yy0 as [y0 [Hbrc_yy0 Hy0]].
  destruct (@Identification Id A A kn_lin K Htypingid x y (Rid A)) as [X JJ].

  assert (wf_typ ((X, bind_kn kn_lin)::nil) (typ_fvar X) kn_lin) as WFT.
    apply wf_typ_var.
       unfold binds. simpl. auto.
       simpl_env. apply binds_one_3; auto.

  assert (F_related_terms (typ_fvar X)
                                 ([(X,(Rid A))])
                                 ([(X, A)])
                                 ([(X, A)])
                                  x y).
    unfold F_related_terms. exists (x0). exists (y0).
      unfold normalize.
      split; simpl.
      destruct (X==X); auto; try solve [contradict n; auto].
      split; simpl.
      destruct (X==X); auto; try solve [contradict n; auto].
      split; auto.
      split; auto.
      apply F_related_values_fvar_req. simpl.
      exists(Rid A).
      repeat(split; auto).
         destruct (X==X); try solve [contradict n; auto].
           apply preservation_normalization with (e:=x); auto.
            unfold normalize. auto.
         destruct (X==X); try solve [contradict n; auto].
           apply preservation_normalization with (e:=y); auto.
            unfold normalize. auto.
         apply bee_trans with (e':=x); auto.
            apply bee_trans with (e':=y); auto.

  apply JJ in H; auto using Rid_wfr. subst.
  destruct H as [v [v' [Htypingv [Htypingv' [[Hbrc Hv] [[Hbrc' Hv'] [R [Hb [_ [_ Hrel]]]]]]]]]]; subst.
  exists (v). exists (v').
  repeat(split; auto).
    apply preservation_normalization with (e:=(exp_app (exp_tapp Id A) x)); auto.
      apply typing_app with (T1:=A)(D1:=nil) (D2:=nil) (K:=K); auto.
        assert (open_tt (typ_arrow K (typ_bvar 0) (typ_bvar 0)) A = typ_arrow K A A).
          unfold open_tt. auto.
        rewrite <- H.
        apply typing_tapp with (K:=kn_lin); auto.
            unfold normalize. auto.
    apply preservation_normalization with (e:=(exp_app (exp_tapp Id A) y)); auto.
      apply typing_app with (T1:=A)(D1:=nil) (D2:=nil) (K:=K); auto.
        assert (open_tt (typ_arrow K (typ_bvar 0) (typ_bvar 0)) A = typ_arrow K A A).
          unfold open_tt. auto.
        rewrite <- H.
        apply typing_tapp with (K:=kn_lin); auto.
            unfold normalize. auto.
    analyze_binds Hb; subst.
      unfold In_rel in Hrel. decompose [and] Hrel.
      unfold Rid in Hrel. decompose [and] Hrel.
      assumption.
Qed.

(***************************************************************)
(*                             Boolean Function                                *)
(***************************************************************)
(*
  \B : \X. X->X-> X.
     \A. \A'. \a: A-> A'.
          \t: A. \f: A.
           a (B[A] t f)  = B[A'] (a t) (a f)

  The above lemma implies the polymophic function I can only be
  Boolean function. This can be proved by contradiction.

  The definition of Boolean function is
    \X. \t:X. \f:X. B[X] t f = t \/ B[X] t f = f ,
    where '=' should be the beta-eta-equivalence.
  The negation of the above defn is
    ex X, ex t:X, ex f:X, B[X] t f <> t /\ B[X] t f <> f ,

  If B is not an identity function, without lose of generality, suppose
    ex X0, ex t0:X0, ex f0:X0, B[X0] t0 f0 = v /\ v <> t0 /\ v <> f0,

  We can pick a function a:X0->X0 which is defined as
    a[u] = t0 if u = v
    a[u] = u otherwise
  then,
     a (B[X0] t0 f0) = a v = t0
     I[X0] (a t0) (a f0)= I[X0] t0 f0 = v
  We proved a (B[X0] t0 f0) <> I[X0] (a t0) (a f0) since t0 <> v,
  but this is contradictary to
  \B : \X. X->X-> X.
     \A. \A'. \a: A-> A'.
          \t: A. \f: A.
           a (B[A] t f)  = B[A'] (a t) (a f)
   which we are proving below.

  So I can only be an boolean function.
*)
Lemma CBoolean : forall CBool A A' Q K K',
  typing nil nil CBool (typ_all Q (typ_arrow K (typ_bvar 0) (typ_arrow K' (typ_bvar 0) (typ_bvar 0)))) ->
  (forall t1 t2 f1 f2 R, exists X,
   wf_typ ([(X,bind_kn Q)]) (typ_fvar X) Q->
   wfr R A A' Q->
   F_related_terms (typ_fvar X)
                                 ([(X,R)])
                                 ([(X,A)])
                                 ([(X,A')])
                                 t1 t2 ->
   F_related_terms (typ_fvar X)
                                 ([(X,R)])
                                 ([(X,A)])
                                 ([(X,A')])
                                 f1 f2 ->
   F_related_terms (typ_fvar X)
                                 ([(X,R)])
                                 ([(X,A)])
                                 ([(X,A')])
                                 (exp_app (exp_app (exp_tapp CBool A) t1) f1)
                                 (exp_app (exp_app (exp_tapp CBool A') t2) f2)).
Proof.
  intros CBool A A' Q K K' Htyping_bool t1 t2 f1 f2 R.
  assert (wf_typ nil (typ_all Q (typ_arrow K (typ_bvar 0) (typ_arrow K' (typ_bvar 0) (typ_bvar 0)))) K) as WFT.
    apply wf_typ_all with (L:={}).
      intros X Hfv.
      unfold open_tt. simpl. simpl_env.
      eapply wf_typ_arrow with (K1:=Q)(K2:=K'); eauto.
        eapply wf_typ_arrow; eauto.

  assert (F_related_terms (typ_all Q (typ_arrow K (typ_bvar 0) (typ_arrow K' (typ_bvar 0) (typ_bvar 0)))) rho_nil delta_nil delta_nil CBool CBool) as Frel_All.
    apply fundamental_parametricity; auto.
  destruct Frel_All as [v [v' [Htypingid [Htypingid' [Hn [Hn' Frel_All]]]]]].

  apply F_related_values_all_leq in Frel_All.
  destruct Frel_All as [Hv [Hv' [L' Hall]]]; subst.

  pick fresh X.
  exists (X). intros WFTvar Hwfr Htermt Htermf.
  assert (X `notin` L') as Fr'. auto.
  destruct (@Hall X A A' R Fr') as [w [w' [Hnorm_vt2w [Hnorm_v't2'w' Hrel_wft]]]]; auto.
  unfold open_tt in*. simpl in *.

  assert (wf_typ ((X, bind_kn Q)::nil) (typ_arrow K (typ_fvar X) (typ_arrow K' (typ_fvar X) (typ_fvar X))) K) as WFT'; eauto.

  apply F_related_values_arrow_leq in Hrel_wft.
  destruct Hrel_wft as [Hw [Hw' Harrow]]; subst.
  simpl_env in *.
  assert ((if X==X then A else typ_fvar X) = A) as Heq.
    destruct (X==X); auto. contradict n; auto.
  assert ((if X==X then A' else typ_fvar X) = A') as Heq'.
    destruct (X==X); auto. contradict n; auto.
  simpl in *.
  rewrite Heq in *. rewrite Heq' in *. clear Heq Heq'.

  destruct Htermt as [v0 [v'0 [Htypingv0 [Htypingv'0 [Hnorm [Hnorm' Hrelt]]]]]]; subst.
  destruct (@Harrow v0 v'0) as [u [u' [Hn_wxu [Hn_w'x'u' Hrel_wft2]]]]; auto.
    simpl in Htypingv0.
    assert ((if X==X then A else typ_fvar X) = A).
      destruct (X==X); auto. contradict n; auto.
    rewrite H in Htypingv0.
    eapply preservation_normalization; eauto.

    simpl in Htypingv'0.
    assert ((if X==X then A' else typ_fvar X) = A').
      destruct (X==X); auto. contradict n; auto.
    rewrite H in Htypingv'0.
    eapply preservation_normalization; eauto.

  apply F_related_values_arrow_leq in Hrel_wft2.
  simpl_env in *.
  destruct Hrel_wft2 as [Hu [Hu' Harrow']]; subst.
  assert ((if X==X then A else typ_fvar X) = A) as Heq.
    destruct (X==X); auto. contradict n; auto.
  assert ((if X==X then A' else typ_fvar X) = A') as Heq'.
    destruct (X==X); auto. contradict n; auto.
  simpl in *.
  rewrite Heq in *. rewrite Heq' in *. clear Heq Heq'.

  destruct Htermf as [v1 [v'1 [Htypingv1 [Htypingv'1 [Hnorm1 [Hnorm1' Hrelf]]]]]]; subst.
  destruct (@Harrow' v1 v'1) as [x [x' [Hn_uxu0 [Hn_u'x'u'0 Hrel_wft22]]]]; auto.
    simpl in Htypingv1.
    assert ((if X==X then A else typ_fvar X) = A).
      destruct (X==X); auto. contradict n; auto.
    rewrite H in Htypingv1.
    eapply preservation_normalization; eauto.

    simpl in Htypingv'1.
    assert ((if X==X then A' else typ_fvar X) = A').
      destruct (X==X); auto. contradict n; auto.
    rewrite H in Htypingv'1.
    eapply preservation_normalization; eauto.

  assert (wf_typ nil A Q) as wft_A.
      apply wfr_left_inv in Hwfr; auto.

  assert (type A) as TypeA. eauto using type_from_wf_typ.

  assert (wf_typ nil A' Q) as wft_A'.
      apply wfr_right_inv in Hwfr; auto.

  assert (type A') as TypeA'. eauto using type_from_wf_typ.

  assert (normalize (exp_tapp CBool A) w).
      apply congr_tapp with (v1:=v); auto.

  assert (normalize (exp_tapp CBool A') w').
      apply congr_tapp with (v1:=v'); auto.

  assert (normalize (exp_app (exp_tapp CBool A) t1) u).
      apply congr_app with (v1:=w) (v2:=v0); auto.

  assert (normalize (exp_app (exp_tapp CBool A') t2) u').
      apply congr_app with (v1:=w') (v2:=v'0); auto.

  assert (normalize (exp_app (exp_app (exp_tapp CBool A) t1) f1) x).
      apply congr_app with (v1:=u) (v2:=v1); auto.

  assert (normalize (exp_app (exp_app (exp_tapp CBool A') t2) f2) x').
      apply congr_app with (v1:=u') (v2:=v'1); auto.

  unfold F_related_terms. exists (x). exists (x').
    split; simpl.
    destruct (X==X); try solve [contradict n; auto].
    apply typing_app with (T1:=A)(D1:=nil) (D2:=nil) (K:=K'); auto.
      apply typing_app with (T1:=A)(D1:=nil) (D2:=nil) (K:=K); auto.
        assert (open_tt (typ_arrow K (typ_bvar 0) (typ_arrow K' (typ_bvar 0) (typ_bvar 0))) A = typ_arrow K A (typ_arrow K' A A)) as Heq.
          unfold open_tt. auto.
        rewrite <- Heq.
        apply typing_tapp with (K:=Q); auto.

        simpl in Htypingv1.
        assert ((if X==X then A else typ_fvar X) = A) as Heq.
          destruct (X==X); auto; contradict n; auto.
        rewrite Heq in Htypingv1; auto.

    split; simpl.
    destruct (X==X); try solve [contradict n; auto].
    apply typing_app with (T1:=A')(D1:=nil) (D2:=nil) (K:=K'); auto.
      apply typing_app with (T1:=A')(D1:=nil) (D2:=nil) (K:=K); auto.
        assert (open_tt (typ_arrow K (typ_bvar 0) (typ_arrow K' (typ_bvar 0) (typ_bvar 0))) A' = typ_arrow K A' (typ_arrow K' A' A')) as Heq.
          unfold open_tt. auto.
        rewrite <- Heq.
        apply typing_tapp with (K:=Q); auto.

        simpl in Htypingv'1.
        assert ((if X==X then A' else typ_fvar X) = A') as Heq.
          destruct (X==X); auto; contradict n; auto.
        rewrite Heq in Htypingv'1; auto.

    split; auto.
Qed.

Corollary  Rearrangement_CBoolean : forall CBool a A A' K K' Q,
  typing nil nil CBool (typ_all kn_lin (typ_arrow K (typ_bvar 0) (typ_arrow K' (typ_bvar 0) (typ_bvar 0)))) ->
  typing nil nil a (typ_arrow Q A A') ->
  (forall t f,
    typing nil nil t A ->
    typing nil nil f A ->
    (exists t0, normalize t t0) ->
    (exists t'0, normalize (exp_app a t) t'0) ->
    (exists f0, normalize f f0) ->
    (exists f'0, normalize (exp_app a f) f'0) ->
    (exists v, exists v',
      normalize (exp_app (exp_app (exp_tapp CBool A) t) f) v /\
      normalize (exp_app (exp_app (exp_tapp CBool A') (exp_app a t)) (exp_app a f)) v' /\
      Rfun A A' a Q v v')
  ).
Proof.
  intros CBool a A A' K K' Q Htypingid Htypinga t f
    Htypingt Htypingf Hn_tt0 Hn_att'0 Hn_ff0 Hn_aff'0.
  assert (wf_typ nil A kn_lin) as HwftA. auto.
  assert (wf_typ nil A' kn_lin) as HwftA'.
    apply typing_regular in Htypinga. decompose [and] Htypinga.
    apply wft_arrow_inv in H3. destruct H3; auto.
  destruct (@CBoolean CBool A A' kn_lin K K' Htypingid t (exp_app a t) f (exp_app a f) (Rfun A A' a Q)) as [X JJ].

(**)
  assert (wf_typ ((X, bind_kn kn_lin)::nil) (typ_fvar X) kn_lin) as WFT.
    apply wf_typ_var; unfold binds; simpl; auto.

  destruct Hn_tt0 as [t0 [Hbrc_tt0 Ht0]].
  destruct Hn_att'0 as [t'0 [Hbrc_att'0 Ht'0]].
  assert (F_related_terms (typ_fvar X)
                                 ([(X,(Rfun A A' a Q))])
                                 ([(X, A)])
                                 ([(X, A')])
                                  t (exp_app a t)).
    unfold F_related_terms. exists (t0). exists (t'0).
      split; simpl.
      destruct (X==X); auto; contradict n; auto.

      split; simpl.
      destruct (X==X).
        apply typing_app with (T1:=A)(D1:=nil) (D2:=nil) (K:=Q); auto.
        contradict n; auto.

      unfold normalize.
      split; auto.
      split; auto.
        apply F_related_values_fvar_req. simpl.
        exists(Rfun A A' a Q).
        repeat(split; auto).
           destruct (X==X); try solve [contradict n; auto].
             apply preservation_normalization with (e:=t); auto.
               unfold normalize; auto.
           destruct (X==X); try solve [contradict n; auto].
             apply preservation_normalization with (e:=exp_app a t); auto.
               apply typing_app with (T1:=A)(D1:=nil) (D2:=nil) (K:=Q); auto.
                 unfold normalize; auto.
           apply bee_trans with (e':=exp_app a t); auto.
(**)

  destruct Hn_ff0 as [f0 [Hbrc_ff0 Hf0]].
  destruct Hn_aff'0 as [f'0 [Hbrc_aff'0 Hf'0]].
  assert (F_related_terms (typ_fvar X)
                                 ([(X,(Rfun A A' a Q))])
                                 ([(X, A)])
                                 ([(X, A')])
                                  f (exp_app a f)).
    unfold F_related_terms. exists (f0). exists (f'0).
      split; simpl.
        destruct (X==X); auto; contradict n; auto.
      split; simpl.
      destruct (X==X).
        apply typing_app with (T1:=A)(D1:=nil) (D2:=nil) (K:=Q); auto.
        contradict n; auto.

      unfold normalize.
      split; auto.
      split; auto.
        apply F_related_values_fvar_req. simpl.
        exists(Rfun A A' a Q).
        repeat(split; auto).
         destruct (X==X); try solve [contradict n; auto].
            apply preservation_normalization with (e:=f); auto.
               unfold normalize; auto.
         destruct (X==X); try solve [contradict n; auto].
           apply preservation_normalization with (e:=exp_app a f); auto.
             apply typing_app with (T1:=A)(D1:=nil) (D2:=nil) (K:=Q); auto.
             unfold normalize; auto.
         apply bee_trans with (e':=exp_app a f); auto.
(**)

  apply JJ in H; auto using Rfun_wfr. subst.
  destruct H as [v [v' [Htypingv [Htypingv' [[Hbrc Hv] [[Hbrc' Hv'] [R [Hb [_ [_ Hrel]]]]]]]]]]; subst.
  exists (v). exists (v'). unfold normalize.
  unfold Rfun.
  repeat(split; auto).
    apply preservation_normalization with (e:=(exp_app (exp_app (exp_tapp CBool A) t) f)); auto.
      apply typing_app with (T1:=A)(D1:=nil) (D2:=nil) (K:=K'); auto.
        apply typing_app with (T1:=A)(D1:=nil) (D2:=nil) (K:=K); auto.
          assert (open_tt (typ_arrow K (typ_bvar 0) (typ_arrow K' (typ_bvar 0) (typ_bvar 0))) A = typ_arrow K A (typ_arrow K' A A)) as Heq.
            unfold open_tt. auto.
          rewrite <- Heq.
          apply typing_tapp with (K:=kn_lin); auto.
      unfold normalize; auto.
    apply preservation_normalization with (e:=(exp_app (exp_app (exp_tapp CBool A') (exp_app a t)) (exp_app a f))); auto.
      apply typing_app with (T1:=A')(D1:=nil) (D2:=nil) (K:=K'); auto.
        apply typing_app with (T1:=A')(D1:=nil) (D2:=nil) (K:=K); auto.
          assert (open_tt (typ_arrow K (typ_bvar 0) (typ_arrow K' (typ_bvar 0) (typ_bvar 0))) A' = typ_arrow K A' (typ_arrow K' A' A')) as Heq.
            unfold open_tt. auto.
          rewrite <- Heq.
          apply typing_tapp with (K:=kn_lin) ; auto.
        apply typing_app with (T1:=A)(D1:=nil) (D2:=nil) (K:=Q); auto.
        apply typing_app with (T1:=A)(D1:=nil) (D2:=nil) (K:=Q); auto.
          unfold normalize; auto.
    analyze_binds Hb; subst.
      unfold In_rel in Hrel. decompose [and] Hrel.
      unfold Rfun in Hrel. decompose [and] Hrel; assumption.
Qed.

Corollary  CBool_Identification : forall CBool K K',
  typing nil nil CBool (typ_all kn_lin (typ_arrow K (typ_bvar 0) (typ_arrow K' (typ_bvar 0) (typ_bvar 0)))) ->
  (forall t1 t2 f1 f2 A,
    Rid A t1 t2 -> Rid A f1 f2 ->
    (exists vt1, normalize t1 vt1) ->
    (exists vt2, normalize t2 vt2) ->
    (exists vf1, normalize f1 vf1) ->
    (exists vf2, normalize f2 vf2) ->
    (exists v, exists v',
      normalize (exp_app (exp_app (exp_tapp CBool A) t1) f1) v /\
      normalize (exp_app (exp_app (exp_tapp CBool A) t2) f2) v' /\
      Rid A v v')
  ).
Proof.
  intros CBool K K' Htyping_bool t1 t2 f1 f2 A HRidt HRidf Hn_t1vt1 Hn_t2vt2 Hn_f1vf1 Hn_f2vf2.
  unfold Rid in *.
  destruct HRidt as [Ht1 [Ht2 [Htypingt1 [Htypingt2 Heq_t1t2]]]].
  destruct Hn_t1vt1 as [vt1 [Hbrc_t1v1 Hvt1]].
  destruct Hn_t2vt2 as [vt2 [Hbrc_t2v2 Hvt2]].
  destruct HRidf as [Hf1 [Hf2 [Htypingf1 [Htypingf2 Heq_f1f2]]]].
  destruct Hn_f1vf1 as [vf1 [Hbrc_f1v1 Hvf1]].
  destruct Hn_f2vf2 as [vf2 [Hbrc_f2v2 Hvf2]].
  destruct (@CBoolean CBool A A kn_lin K K' Htyping_bool t1 t2 f1 f2 (Rid A)) as [X JJ].

  assert (wfr (Rid A) A A kn_lin) as WFR.
    split; auto.

  assert (wf_typ ((X, bind_kn kn_lin)::nil) (typ_fvar X) kn_lin) as WFT.
    apply wf_typ_var.
       unfold binds. simpl. auto.
       simpl_env. apply binds_one_3; auto.

  assert (F_related_terms (typ_fvar X)
                                 ([(X,(Rid A))])
                                 ([(X, A)])
                                 ([(X, A)])
                                  t1 t2).
    unfold F_related_terms. exists (vt1). exists (vt2).
      unfold normalize.
      split; simpl.
      destruct (X==X); auto; try solve [contradict n; auto].
      split; simpl.
      destruct (X==X); auto; try solve [contradict n; auto].
      split; auto.
      split; auto.
        apply F_related_values_fvar_req. simpl.
        exists(Rid A).
        repeat(split; auto).
          destruct (X==X); try solve [contradict n; auto].
            apply preservation_normalization with (e:=t1); auto.
              unfold normalize. auto.
          destruct (X==X); try solve [contradict n; auto].
           apply preservation_normalization with (e:=t2); auto.
              unfold normalize. auto.
          apply bee_trans with (e':=t1); auto.
             apply bee_trans with (e':=t2); auto.

  assert (F_related_terms (typ_fvar X)
                                 ([(X,(Rid A))])
                                 ([(X, A)])
                                 ([(X, A)])
                                  f1 f2).
    unfold F_related_terms. exists (vf1). exists (vf2).
      unfold normalize.
      split; simpl.
      destruct (X==X); auto; try solve [contradict n; auto].
      split; simpl.
      destruct (X==X); auto; try solve [contradict n; auto].
      split; auto.
      split; auto.
        apply F_related_values_fvar_req. simpl.
        exists(Rid A).
        repeat(split; auto).
          destruct (X==X); try solve [contradict n; auto].
            apply preservation_normalization with (e:=f1); auto.
               unfold normalize. auto.
          destruct (X==X); try solve [contradict n; auto].
             apply preservation_normalization with (e:=f2); auto.
               unfold normalize. auto.
          apply bee_trans with (e':=f1); auto.
              apply bee_trans with (e':=f2); auto.

  apply JJ in H; auto using Rid_wfr. subst.
  destruct H as [v [v' [Htypingv [Htypingv' [[Hbrc Hv] [[Hbrc' Hv'] [R [Hb [_ [_ Hrel]]]]]]]]]]; subst.
  exists (v). exists (v').
  repeat(split; auto).
    apply preservation_normalization with (e:=(exp_app (exp_app (exp_tapp CBool A) t1) f1)); auto.
      apply typing_app with (T1:=A)(D1:=nil) (D2:=nil) (K:=K'); auto.
        apply typing_app with (T1:=A)(D1:=nil) (D2:=nil) (K:=K); auto.
          assert (open_tt (typ_arrow K (typ_bvar 0) (typ_arrow K' (typ_bvar 0) (typ_bvar 0))) A = typ_arrow K A (typ_arrow K' A A)) as Heq.
            unfold open_tt. auto.
          rewrite <- Heq.
          apply typing_tapp with (K:=kn_lin) ; auto.
            unfold normalize. auto.
    apply preservation_normalization with (e:=(exp_app (exp_app (exp_tapp CBool A) t2) f2)); auto.
      apply typing_app with (T1:=A)(D1:=nil) (D2:=nil) (K:=K'); auto.
        apply typing_app with (T1:=A)(D1:=nil) (D2:=nil) (K:=K); auto.
          assert (open_tt (typ_arrow K (typ_bvar 0) (typ_arrow K' (typ_bvar 0) (typ_bvar 0))) A = typ_arrow K A (typ_arrow K' A A)) as Heq.
            unfold open_tt. auto.
          rewrite <- Heq.
          apply typing_tapp with (K:=kn_lin); auto.
            unfold normalize. auto.
    analyze_binds Hb; subst.
      unfold In_rel in Hrel. decompose [and] Hrel.
      unfold Rid in Hrel. decompose [and] Hrel.
      assumption.
Qed.

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


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 P : Universe, ((wd_ A B /\ (wd_ A C /\ (col_ A B P /\ col_ A B C))) -> col_ A C P)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import List EquivDec FunctionalExtensionality Lia Eqdep_dec.

Require Import LibUtils.
Require Import Isomorphism ListAdd BasicUtils.

Class FiniteType (A:Type) :=
 { fin_elms  : list A ;
  fin_finite : forall x:A, In x fin_elms
 }.

Lemma FiniteType_equivlist {A:Type} (fin1:FiniteType A) (fin2:FiniteType A) :
  equivlist (@fin_elms _ fin1) (@fin_elms _ fin2).
Proof.
  destruct fin1 as [??]
  ; destruct fin2 as [??].
  split; intuition.
Qed.

Program Instance FiniteType_iso {A B} {iso:Isomorphism A B} {fin:FiniteType A} : FiniteType B
  := {
  fin_elms:= (List.map iso_f fin_elms)
    }.
Next Obligation.
  apply in_map_iff.
  exists (iso_b x).
  split.
  - now rewrite iso_f_b.
  - apply fin_finite.
Qed.

Lemma in_dec_nd_pf_irrel {A:Type} {dec:EqDec A eq} {a:A} {l:list A} (nd:NoDup l) (pf1 pf2:In a l) :
  pf1 = pf2.
Proof.
  induction l.
  - inversion pf1.
  - simpl in pf1, pf2.
    invcs nd.
    destruct pf1; destruct pf2.
    + f_equal.
      apply UIP_dec.
      apply dec.
    + congruence.
    + congruence.
    + f_equal.
      auto.
Qed.

(* When we have a decidable equality, we can define a version of In which
   has only unique proofs. This is important for avoiding proof irrelevance.
 *)
Fixpoint Inb {A} {dec:EqDec A eq} (a:A) l
  := match l with
     | nil => false
     | b::m => if b == a then
               true
             else Inb a m
     end.

Definition In_strong {A} {dec:EqDec A eq} (a:A) l := Inb a l = true.

Lemma In_strong_In {A} {dec:EqDec A eq} (a:A) l : In_strong a l -> In a l.
Proof.
  unfold In_strong.
  induction l; simpl; intuition.
  destruct (equiv_dec a0 a); intuition.
Qed.

Lemma In_In_strong {A} {dec:EqDec A eq} (a:A) l : In a l -> In_strong a l.
Proof.
  unfold In_strong.
  induction l; simpl; trivial.
  - intuition.
  - destruct (equiv_dec a0 a); simpl; intuition.
Qed.

Lemma in_strong_dec_pf_irrel_helper
  {SBP:Prop} (v:{SBP} + {~SBP}) (P:Prop)

    (pf1 pf2 : if v then True else P)
    (IH : forall pf1 pf2 : P, pf1 = pf2) : pf1 = pf2.
Proof.
  destruct v.
  - destruct pf1; destruct pf2; trivial.
  - apply IH.
Qed.

Lemma in_strong_dec_pf_irrel {A:Type} {dec:EqDec A eq} {a:A} {l:list A} (pf1 pf2:In_strong a l) :
  pf1 = pf2.
Proof.
  apply UIP_dec.
  apply equiv_dec.
Qed.

Program Fixpoint FiniteType_fun_dep_elems_aux {A:Type} {dec:EqDec A eq} {B:A->Type} (la:list A)
        {struct la} : (forall x, In_strong x la -> list (B x)) -> list (forall a, In_strong a la -> B a)
  := match la as la' return (forall x, In_strong x la' -> list (B x)) -> list (forall a, In_strong a la' -> B a) with
     | nil => fun _ => _ :: nil
     | a::xs => fun lb => let rest := FiniteType_fun_dep_elems_aux xs (fun x inx => lb x _) in
                     let lbx := lb a _ in
                     List.concat (List.map (fun b => List.map (fun x => _) rest) lbx)
     end.
Next Obligation.
  unfold In_strong in *.
  simpl.
  rewrite inx.
  now destruct (a == x).
Defined.
Next Obligation.
  unfold In_strong in *.
  simpl.
  now destruct (a == a); [| congruence].
Defined.
Next Obligation.
  destruct (a == a0).
  - now destruct e.
  - apply x.
    unfold In_strong in *.
    simpl in H.
    destruct (a == a0); trivial.
    congruence.
Defined.

Definition FiniteType_fun_dep_elems
        {A:Type} {dec:EqDec A eq} {B:A->Type} (finA:FiniteType A) (finB:forall a, FiniteType (B a))
  : list (forall a, B a)
  := List.map (fun X a => X a (In_In_strong _ _ (fin_finite a))) (FiniteType_fun_dep_elems_aux (B:=B) fin_elms (fun a ina => fin_elms)).

Lemma FiniteType_fun_dep_elems_aux_all
      {A:Type} {dec:EqDec A eq} {B:A->Type} (la:list A)
      (lb:forall a, In_strong a la -> list (B a))
      (lbf:forall a pf x, In x (lb a pf))
  : forall x:(forall a:A, In_strong a la -> B a), In x (FiniteType_fun_dep_elems_aux la lb).
Proof.
  revert lb lbf.
  induction la; simpl; intros lb lbf x.
  - left.
    apply FunctionalExtensionality.functional_extensionality_dep; intros a.
    apply FunctionalExtensionality.functional_extensionality_dep; intros ina.
    intuition.
  - specialize (IHla (fun (x0 : A) (inx : In_strong x0 la) => lb x0 (FiniteType_fun_dep_elems_aux_obligation_2 A dec a la x0 inx))).
    cut_to IHla; [| intros; apply lbf].
    rewrite concat_In.
    refine (ex_intro _ (List.map _
                                 (FiniteType_fun_dep_elems_aux la
                                                           (fun (x0 : A) (inx : In_strong x0 la) => lb x0 (FiniteType_fun_dep_elems_aux_obligation_2 A dec a la x0 inx)))) _).
    split.
    rewrite in_map_iff.
    eexists; split; [reflexivity | ].
    + apply (lbf a (FiniteType_fun_dep_elems_aux_obligation_3 A dec a la) (x a (FiniteType_fun_dep_elems_aux_obligation_3 A dec a la))).
    + apply in_map_iff.
      exists (fun a' pfin => x a' (FiniteType_fun_dep_elems_aux_obligation_2 A dec a la a' pfin)).
      split; trivial.
      apply FunctionalExtensionality.functional_extensionality_dep; intros a'.
      apply FunctionalExtensionality.functional_extensionality_dep; intros ina'.
      unfold FiniteType_fun_dep_elems_aux_obligation_4.
      clear.
      revert ina'.
      unfold In_strong.
      simpl.
      pattern (a == a') at 2.
      destruct (a == a'); simpl; intros.
      * destruct e.
        f_equal.
        apply in_strong_dec_pf_irrel.
      * f_equal.
        apply in_strong_dec_pf_irrel.
Qed.

Lemma FiniteType_fun_dep_elems_all
      {A:Type} {dec:EqDec A eq} {B:A->Type} (finA:FiniteType A) (finB:forall a, FiniteType (B a))
  : forall x:(forall a:A, B a), In x (FiniteType_fun_dep_elems finA finB).
Proof.
  unfold FiniteType_fun_dep_elems; simpl.
  intros.
  generalize (FiniteType_fun_dep_elems_aux_all fin_elms (B:=B) (fun a _ => fin_elms))
  ; intros HH.
  specialize (HH (fun a _ xx => (fin_finite xx))).
  apply List.in_map_iff.
  exists (fun a _ => x a).
  split; trivial.
Qed.

Instance FiniteType_fun_dep {A:Type} {dec:EqDec A eq} {B:A->Type} (finA:FiniteType A) (finB:forall a, FiniteType (B a)): FiniteType (forall a : A, B a) :=
  {|
  fin_elms := FiniteType_fun_dep_elems finA finB
  ; fin_finite := FiniteType_fun_dep_elems_all finA finB
|}.

Instance FiniteType_fun {A:Type} {dec:EqDec A eq} {B} (finA:FiniteType A) (finB:FiniteType B): FiniteType (A -> B) :=
  @FiniteType_fun_dep A dec (fun _ => B) finA (fun _ => finB).

Lemma concat_length {A:Type} (l:list (list A)) : length (concat l) = fold_right plus 0 (map (@length _) l).
Proof.
  induction l; simpl; trivial.
  now rewrite app_length, IHl.
Qed.

Lemma fold_right_add_const {A:Type} c (l:list A) :
  fold_right Nat.add 0
    (map (fun _  => c) l) =  c * length l.
Proof.
  induction l; simpl; trivial.
  rewrite IHl; simpl.
  rewrite NPeano.Nat.mul_succ_r.
  now rewrite NPeano.Nat.add_comm.
Qed.

Lemma fold_right_mult_const {A:Type} c (l:list A) :
  fold_right Nat.mul 1
    (map (fun _  => c) l) =  NPeano.Nat.pow c (length l).
Proof.
  induction l; simpl; trivial.
  now rewrite IHl; simpl.
Qed.

Lemma FiniteType_fun_dep_size {A:Type} {dec:EqDec A eq} {B:A->Type} (finA:FiniteType A) (finB:forall a, FiniteType (B a))
  : length (@fin_elms _ (FiniteType_fun_dep finA finB)) =
    fold_right Nat.mul 1 (List.map (fun a => length (@fin_elms _ (finB a))) (@fin_elms _ finA)).
Proof.
  destruct finA.
  unfold fin_elms; simpl.
  unfold FiniteType_fun_dep_elems.
  rewrite map_length.
  simpl.
  clear fin_finite0.
  induction fin_elms0; simpl; trivial; intros.
  rewrite concat_length.
  rewrite map_map.
  rewrite (map_ext _ (fun x : B a =>
        length
          (FiniteType_fun_dep_elems_aux fin_elms0 (fun (x0 : A) (_ : In_strong x0 fin_elms0) => fin_elms))))
    by (intros; now rewrite map_length).
  rewrite fold_right_add_const.
  rewrite NPeano.Nat.mul_comm.
  now rewrite <- IHfin_elms0.
Qed.

Lemma FiniteType_fun_size {A:Type} {dec:EqDec A eq} {B:Type} (finA:FiniteType A) (finB:FiniteType B)
  : length (@fin_elms _ (FiniteType_fun finA finB)) = NPeano.pow (length (@fin_elms _ finB)) (length (@fin_elms _ finA)).
Proof.
  unfold FiniteType_fun.
  rewrite FiniteType_fun_dep_size.
  apply fold_right_mult_const.
Qed.

Global Program Instance fin_finite_prod {A B} (finA:FiniteType A) (finB:FiniteType B) : FiniteType (A*B)
  := { fin_elms := list_prod fin_elms fin_elms }.
Next Obligation.
  apply in_prod_iff.
  split; apply fin_finite.
Qed.

Fixpoint list_dep_prod {A : Type} {B : A -> Type}(l:list A) (l': forall a:A, list (B a)) :
  list (sigT B) :=
  match l with
  | nil => nil
  | cons x t => map (fun y: B x => existT _ x y) (l' x) ++(list_dep_prod t l')
  end.

Lemma in_dep_prod_aux {A : Type} {B : A -> Type} :
  forall (x:A) (y:B x) (l:list (B x)),
    In y l -> In (existT _ x y) (map (fun y0:B x => existT _ x y0) l).
Proof.
  induction l;
    [ simpl; auto
    | simpl; destruct 1 as [H1| ];
      [ left; rewrite H1; trivial | right; auto ] ].
Qed.

Lemma in_dep_prod {A : Type} {B : A -> Type}:
  forall (l:list A) (l':forall a:A, list (B a)) (x:A) (y:B x),
    In x l -> In y (l' x) -> In (existT _ x y) (list_dep_prod l l').
Proof.
  induction l;
    [ simpl; tauto
    | simpl; intros; apply in_or_app; destruct H];
    [ left; rewrite H; apply in_dep_prod_aux; auto | right; auto ].
Qed.

Lemma in_dep_prod_iff {A:Type} {B : A -> Type} :
  forall (l:list A)(l':forall a, list (B a))(x:A)(y:B x),
    In (existT _ x y) (list_dep_prod l l') <-> In x l /\ In y (l' x).
Proof.
  split; [ | intros; apply in_dep_prod; intuition ].
  induction l; simpl; intros.
  + intuition.
  + destruct (in_app_or _ _ _ H); clear H.
    -- rewrite in_map_iff in H0.
       destruct H0 as [z [H2 H3]].
       injection H2; intuition.
       subst ; clear H.
       (* This is equivalent to assuming Streicher's Axiom K (?). *)
       generalize (Eqdep.EqdepTheory.inj_pair2 A B _ _ _ H2); intros.
       now subst.
    -- intuition.
Qed.

Global Program Instance fin_finite_dep_prod {A B} (finA : FiniteType A)
  (finB : forall a:A, FiniteType (B a))
  : FiniteType (sigT B).
Next Obligation.
  apply list_dep_prod.
  + destruct finA ; auto.
  + intros a. destruct (finB a); auto.
Defined.
Next Obligation.
  unfold fin_finite_dep_prod_obligation_1.
  rewrite in_dep_prod_iff.
  destruct finA as [la Hla]; split; auto.
  destruct (finB x) as [lb Hlb]; auto.
Qed.

(* uses functional extensionality *)
Local Instance eqdec_finite_fun_ext {A B} {fin:FiniteType A} {decA:EqDec A eq} {decB:EqDec B eq}:
  EqDec (A -> B) eq.
Proof.
  intros ??.
  cut ({forall a, In a fin_elms -> x a = y a} + {~ (forall a, In a fin_elms -> x a = y a)}).
  {
    intros [?|?].
    - left; apply functional_extensionality; intros a.
      apply e; apply fin_finite.
    - right; intros eqq.
      red in eqq.
      subst.
      now apply n; intros.
  }
  destruct fin; simpl.
  clear fin_finite0.
  induction fin_elms0.
  - left; simpl; tauto.
  - destruct (decB (x a) (y a)).
    + destruct IHfin_elms0.
      * left; simpl; intros a' [?|inn]; subst; auto.
      * right; intros HH; simpl in *; eauto.
    + right; intros HH; simpl in *.
      elim c; apply HH; eauto.
Qed.

(* uses functional extensionality *)
Local Instance eqdec_finite_fun_dep_ext {A} {B:A->Type} {fin:FiniteType A} {decA:EqDec A eq} {decB:forall a, EqDec (B a) eq}:
  EqDec (forall a, B a) eq.
Proof.
  intros ??.
  cut ({forall a, In a fin_elms -> x a = y a} + {~ (forall a, In a fin_elms -> x a = y a)}).
  {
    intros [?|?].
    - left; apply functional_extensionality_dep; intros a.
      apply e; apply fin_finite.
    - right; intros eqq.
      red in eqq.
      subst.
      now apply n; intros.
  }
  destruct fin; simpl.
  clear fin_finite0.
  induction fin_elms0.
  - left; simpl; tauto.
  - destruct (decB _ (x a) (y a)).
    + destruct IHfin_elms0.
      * left; simpl; intros a' [?|inn]; subst; auto.
      * right; intros HH; simpl in *; eauto.
    + right; intros HH; simpl in *.
      elim c; apply HH; eauto.
Qed.

Definition bounded_nat_finite_list n : list {x : nat | (x < n)%nat}.
Proof.
  induction n.
  - exact nil.
  - apply cons.
    + exists n; lia.
    + eapply List.map; [| exact IHn].
      intros [x ?].
      exists x; lia.
Defined.

Lemma bounded_nat_finite_list_proj n : List.map (@proj1_sig _ _) (bounded_nat_finite_list n) = rev (seq 0 n).
Proof.
  induction n; trivial.
  rewrite ListAdd.seq_Sn.
  rewrite List.rev_app_distr.
  simpl rev.
  simpl.
  rewrite List.map_map; simpl.
  rewrite <- IHn.
  f_equal.
  now apply map_ext; intros [??].
Qed.

Global Program Instance bounded_nat_finite n : FiniteType {x : nat | (x < n)%nat}
  := {|
  (* put them in numeric order for the convenience of users *)
  fin_elms := rev (bounded_nat_finite_list n)
    |}.
Next Obligation.
  apply -> in_rev.
  assert (inn:In x (rev (seq 0 n))).
  - apply -> in_rev.
    apply in_seq; lia.
  - rewrite <- (bounded_nat_finite_list_proj n) in inn.
    apply in_map_iff in inn.
    destruct inn as [[??] [??]].
    simpl in *; subst.
    erewrite index_pf_irrel; eauto.
Qed.

Definition bounded_nat_finite_list' n : list {x : nat | (x <= n)%nat}.
Proof.
  induction n.
  - exact nil.
  - apply cons.
    + exists n; lia.
    + eapply List.map; [| exact IHn].
      intros [x ?].
      exists x; lia.
Defined.

Lemma bounded_nat_fin_finite_list_proj' n :
  List.map (@proj1_sig _ _) (bounded_nat_finite_list' n) = rev (seq 0 n).
Proof.
  induction n; trivial.
  rewrite ListAdd.seq_Sn.
  rewrite List.rev_app_distr.
  simpl rev.
  simpl.
  rewrite List.map_map; simpl.
  rewrite <- IHn.
  f_equal.
  now apply map_ext; intros [??].
Qed.

  Program Definition bounded_nat_lt_le j (x : {m:nat | (m < j)%nat}) :
    {m : nat | (m <= j)%nat} := exist _ (proj1_sig x) _.

  Program Definition bounded_nat_lt_succ_le j (x : {m:nat | (m < j)%nat}) :
    {m : nat | (m <= S j)%nat} := exist _ (proj1_sig x) _.
  Next Obligation.
    lia.
  Defined.

  Program Definition bounded_nat_lt_succ_lt j (x : {m:nat | (m < j)%nat}) :
    {m : nat | (m < S j)%nat} := exist _ (proj1_sig x) _.

  Program Definition bounded_nat_le_succ_lt j (x : {m:nat | (m <= j)%nat}) :
    {m : nat | (m < S j)%nat} := exist _ (proj1_sig x) _.
  Next Obligation.
    lia.
  Defined.

  Program Definition bounded_nat_lt_succ_le j (x : {m:nat | (m < S j)%nat}) :
    {m : nat | (m <= j)%nat} := exist _ (proj1_sig x) _.
  Next Obligation.
    lia.
  Defined.

  Section find_ind.

    Lemma nth_error_nil {A} n : nth_error (@nil A) n = None.
    Proof.
      now destruct n; simpl.
    Qed.

    Context  {A} {dec:EqDec A eq}.

    Fixpoint find_index_aux (l:list A) a (index:nat) : option nat
      := match l with
         | nil => None
         | a'::l' => if a == a'
                   then Some index
                   else find_index_aux l' a (S index)
         end.

    Definition find_index (l:list A) a : option nat
      := find_index_aux l a 0%nat.

    Lemma find_index_aux_bounds {l:list A} {a} {index:nat} {n} :
      find_index_aux l a index = Some n ->
      index <= n < length l + index.
    Proof.
      revert index n.
      induction l; simpl; [congruence |]; intros index n eqq.
      match_destr_in eqq.
      - invcs eqq.
        lia.
      - specialize (IHl _ _ eqq).
        lia.
    Qed.

    Lemma find_index_bound {l:list A} {a} {n} :
      find_index l a = Some n ->
      n < length l.
    Proof.
      unfold find_index; intros HH.
      generalize (find_index_aux_bounds HH); lia.
    Qed.

    Lemma find_index_aux_correct {l:list A} {a} {index:nat} {n} :
      find_index_aux l a index = Some n ->
      nth_error l (n-index)%nat = Some a.
    Proof.
      revert index.
      induction l; simpl; [congruence |].
      intros index eqq.
      match_destr_in eqq.
      - invcs eqq.
        rewrite PeanoNat.Nat.sub_diag; simpl.
        congruence.
      - specialize (IHl _ eqq).
        generalize (find_index_aux_bounds eqq); intros le1.
        destruct n; [lia |].
        replace (S n - index)%nat with (S (n - index))%nat by lia.
        simpl.
        now replace (S n - S index)%nat with (n - index)%nat in IHl by lia.
    Qed.

    Lemma find_index_correct {l:list A} {a} {n} :
      find_index l a = Some n ->
      nth_error l n = Some a.
    Proof.
      intros HH.
      specialize (find_index_aux_correct HH).
      now rewrite PeanoNat.Nat.sub_0_r.
    Qed.

    Lemma find_index_aux_first {l:list A} {a} {index:nat} {n} :
      find_index_aux l a index = Some n ->
      forall t,
      nth_error l t = Some a ->
      (n-index)%nat <= t.
    Proof.
      revert index.
      induction l; simpl; [congruence |].
      intros index eqq.
      match_destr_in eqq.
      - invcs eqq.
        rewrite PeanoNat.Nat.sub_diag; simpl.
        lia.
      - specialize (IHl _ eqq).
        intros [|]; simpl; intros eqq2.
        + congruence.
        + specialize (IHl _ eqq2).
          lia.
    Qed.

    Lemma find_index_first {l:list A} {a} {index:nat} {n} :
      find_index l a = Some n ->
      forall t,
      nth_error l t = Some a ->
      n <= t.
    Proof.
      intros eqq t eqq2.
      specialize (find_index_aux_first eqq _ eqq2).
      lia.
    Qed.

    Lemma find_index_aux_complete {l:list A} {a} {index:nat} :
      In a l ->
      {t' | find_index_aux l a index = Some t'}.
    Proof.
      revert index.
      induction l; simpl; intros index eqq; [tauto |].
      - match_destr.
        + red in e; subst; eauto.
        + destruct (IHl (S index)); [| eauto].
          destruct eqq; trivial.
          congruence.
    Qed.

    Lemma find_index_complete {l:list A} {a} :
      In a l ->
      { t' | find_index l a = Some t'}.
    Proof.
      intros.
      now apply find_index_aux_complete.
    Qed.

  End find_ind.

  Section fin_ind.
    Context {A} {dec:EqDec A eq} (fin:FiniteType A).

    Program Instance fin_finite_nodup : FiniteType A
      := {|
        fin_elms := nodup dec fin_elms
      |}.
    Next Obligation.
      apply nodup_In.
      apply fin_finite.
    Qed.

    Definition fin_finite_index (a:A) : nat
      := proj1_sig (find_index_complete (fin_finite (FiniteType:=fin_finite_nodup) a)).

    Lemma fin_finite_index_correct a :
      nth_error (fin_elms (FiniteType:=fin_finite_nodup)) (fin_finite_index a) = Some a.
    Proof.
      unfold fin_finite_index, proj1_sig; match_destr.
      now apply find_index_correct.
    Qed.

    Lemma fin_finite_index_bound a :
      fin_finite_index a < length (nodup dec (fin_elms (FiniteType:=fin))).
    Proof.
      unfold fin_finite_index, proj1_sig; match_destr.
      now apply find_index_bound in e.
    Qed.

    Lemma bounded_index_pf_irrel n m1 m2 pf1 pf2 :
      m1 = m2 ->
      exist (fun n' : nat => (n' < n)%nat) m1 pf1 =
        exist (fun n' : nat => (n' < n)%nat) m2 pf2.
    Proof.
      intros eqq.
      destruct eqq.
      assert (pf1 = pf2) by apply digit_pf_irrel.
      congruence.
  Qed.

    Definition nth_error_len_some (l:list A) (n:nat) (pf:n < length l) :
      { x | nth_error l n = Some x}.
    Proof.
      apply nth_error_Some in pf.
      destruct (nth_error l n); [eauto | congruence].
    Qed.

    Program Instance finite_index_iso : Isomorphism A {m:nat | (m < length (nodup dec (fin_elms (FiniteType:=fin))))%nat}
      := {|
        iso_f a := exist _ _ (fin_finite_index_bound a)
      ; iso_b x := proj1_sig (nth_error_len_some (fin_elms (FiniteType:=fin_finite_nodup)) x _)
      |}.
    Next Obligation.
      apply bounded_index_pf_irrel.
      unfold proj1_sig; match_destr.
      unfold fin_finite_index, proj1_sig; match_destr.
      apply find_index_correct in e0.
      simpl in e0.
      eapply NoDup_nth_error; try now rewrite e, e0.
      - apply NoDup_nodup.
      - apply nth_error_Some.
        congruence.
    Qed.
    Next Obligation.
      unfold proj1_sig; match_destr.
      rewrite fin_finite_index_correct in e.
      congruence.
    Qed.

  End fin_ind.

  Program Global Instance bool_finite : FiniteType bool
    := {|
      fin_elms := (true::false::nil)
    |}.
Next Obligation.
  destruct x; simpl; tauto.
Qed.


From Hammer Require Import Hammer.

Require Import Bool.
Require Import Sumbool.
Require Import NArith.
Require Import Ndigits.
Require Import Ndec.

Global Set Asymmetric Patterns.

Definition ad := N.

Section MapDefs.

Variable A : Type.

Inductive Map :=
| M0 : Map
| M1 : ad -> A -> Map
| M2 : Map -> Map -> Map.

Lemma option_sum : forall o:option A, {y : A | o = Some y} + {o = None}.
Proof. hammer_hook "Map" "Map.option_sum".
simple induction o.
left. split with a. reflexivity.
right. reflexivity.
Qed.

Fixpoint MapGet (m:Map) : ad -> option A :=
match m with
| M0 => fun a:ad => None
| M1 x y => fun a:ad => if N.eqb x a then Some y else None
| M2 m1 m2 =>
fun a:ad =>
match a with
| N0 => MapGet m1 N0
| Npos xH => MapGet m2 N0
| Npos (xO p) => MapGet m1 (Npos p)
| Npos (xI p) => MapGet m2 (Npos p)
end
end.

Definition newMap := M0.

Definition MapSingleton := M1.

Definition eqm (g g':ad -> option A) := forall a:ad, g a = g' a.

Lemma newMap_semantics : eqm (MapGet newMap) (fun a:ad => None).
Proof. hammer_hook "Map" "Map.newMap_semantics".
simpl in |- *. unfold eqm in |- *. trivial.
Qed.

Lemma MapSingleton_semantics :
forall (a:ad) (y:A),
eqm (MapGet (MapSingleton a y))
(fun a':ad => if N.eqb a a' then Some y else None).
Proof. hammer_hook "Map" "Map.MapSingleton_semantics".
simpl in |- *. unfold eqm in |- *. trivial.
Qed.

Lemma M1_semantics_1 : forall (a:ad) (y:A), MapGet (M1 a y) a = Some y.
Proof. hammer_hook "Map" "Map.M1_semantics_1".
unfold MapGet in |- *. intros. rewrite (Neqb_correct a). reflexivity.
Qed.

Lemma M1_semantics_2 :
forall (a a':ad) (y:A), N.eqb a a' = false -> MapGet (M1 a y) a' = None.
Proof. hammer_hook "Map" "Map.M1_semantics_2".
intros. simpl in |- *. rewrite H. reflexivity.
Qed.

Lemma Map2_semantics_1 :
forall m m':Map,
eqm (MapGet m) (fun a:ad => MapGet (M2 m m') (N.double a)).
Proof. hammer_hook "Map" "Map.Map2_semantics_1".
unfold eqm in |- *. simple induction a; trivial.
Qed.

Lemma Map2_semantics_1_eq :
forall (m m':Map) (f:ad -> option A),
eqm (MapGet (M2 m m')) f -> eqm (MapGet m) (fun a:ad => f (N.double a)).
Proof. hammer_hook "Map" "Map.Map2_semantics_1_eq".
unfold eqm in |- *.
intros.
rewrite <- (H (N.double a)).
exact (Map2_semantics_1 m m' a).
Qed.

Lemma Map2_semantics_2 :
forall m m':Map,
eqm (MapGet m') (fun a:ad => MapGet (M2 m m') (Ndouble_plus_one a)).
Proof. hammer_hook "Map" "Map.Map2_semantics_2".
unfold eqm in |- *. simple induction a; trivial.
Qed.

Lemma Map2_semantics_2_eq :
forall (m m':Map) (f:ad -> option A),
eqm (MapGet (M2 m m')) f ->
eqm (MapGet m') (fun a:ad => f (Ndouble_plus_one a)).
Proof. hammer_hook "Map" "Map.Map2_semantics_2_eq".
unfold eqm in |- *.
intros.
rewrite <- (H (Ndouble_plus_one a)).
exact (Map2_semantics_2 m m' a).
Qed.

Lemma MapGet_M2_bit_0_0 :
forall a:ad,
Nbit0 a = false ->
forall m m':Map, MapGet (M2 m m') a = MapGet m (N.div2 a).
Proof. hammer_hook "Map" "Map.MapGet_M2_bit_0_0".
simple induction a; trivial. simple induction p. intros. discriminate H0.
trivial.
intros. discriminate H.
Qed.

Lemma MapGet_M2_bit_0_1 :
forall a:ad,
Nbit0 a = true ->
forall m m':Map, MapGet (M2 m m') a = MapGet m' (N.div2 a).
Proof. hammer_hook "Map" "Map.MapGet_M2_bit_0_1".
simple induction a. intros. discriminate H.
simple induction p. trivial.
intros. discriminate H0.
trivial.
Qed.

Lemma MapGet_M2_bit_0_if :
forall (m m':Map) (a:ad),
MapGet (M2 m m') a =
(if Nbit0 a then MapGet m' (N.div2 a) else MapGet m (N.div2 a)).
Proof. hammer_hook "Map" "Map.MapGet_M2_bit_0_if".
intros. elim (sumbool_of_bool (Nbit0 a)). intro H. rewrite H.
apply MapGet_M2_bit_0_1; assumption.
intro H. rewrite H. apply MapGet_M2_bit_0_0; assumption.
Qed.

Lemma MapGet_M2_bit_0 :
forall (m m' m'':Map) (a:ad),
(if Nbit0 a then MapGet (M2 m' m) a else MapGet (M2 m m'') a) =
MapGet m (N.div2 a).
Proof. hammer_hook "Map" "Map.MapGet_M2_bit_0".
intros. elim (sumbool_of_bool (Nbit0 a)). intro H. rewrite H.
apply MapGet_M2_bit_0_1; assumption.
intro H. rewrite H. apply MapGet_M2_bit_0_0; assumption.
Qed.

Lemma Map2_semantics_3 :
forall m m':Map,
eqm (MapGet (M2 m m'))
(fun a:ad =>
match Nbit0 a with
| false => MapGet m (N.div2 a)
| true => MapGet m' (N.div2 a)
end).
Proof. hammer_hook "Map" "Map.Map2_semantics_3".
unfold eqm in |- *.
simple induction a; trivial.
simple induction p; trivial.
Qed.

Lemma Map2_semantics_3_eq :
forall (m m':Map) (f f':ad -> option A),
eqm (MapGet m) f ->
eqm (MapGet m') f' ->
eqm (MapGet (M2 m m'))
(fun a:ad =>
match Nbit0 a with
| false => f (N.div2 a)
| true => f' (N.div2 a)
end).
Proof. hammer_hook "Map" "Map.Map2_semantics_3_eq".
unfold eqm in |- *.
intros.
rewrite <- (H (N.div2 a)).
rewrite <- (H0 (N.div2 a)).
exact (Map2_semantics_3 m m' a).
Qed.

Fixpoint MapPut1 (a:ad) (y:A) (a':ad) (y':A) (p:positive) {struct p} :
Map :=
match p with
| xO p' =>
let m := MapPut1 (N.div2 a) y (N.div2 a') y' p' in
match Nbit0 a with
| false => M2 m M0
| true => M2 M0 m
end
| _ =>
match Nbit0 a with
| false => M2 (M1 (N.div2 a) y) (M1 (N.div2 a') y')
| true => M2 (M1 (N.div2 a') y') (M1 (N.div2 a) y)
end
end.

Lemma MapGet_if_commute :
forall (b:bool) (m m':Map) (a:ad),
MapGet (if b then m else m') a = (if b then MapGet m a else MapGet m' a).
Proof. hammer_hook "Map" "Map.MapGet_if_commute".
intros. case b; trivial.
Qed.

Lemma MapGet_if_same :
forall (m:Map) (b:bool) (a:ad), MapGet (if b then m else m) a = MapGet m a.
Proof. hammer_hook "Map" "Map.MapGet_if_same".
simple induction b; trivial.
Qed.

Lemma MapGet_M2_bit_0_2 :
forall (m m' m'':Map) (a:ad),
MapGet (if Nbit0 a then M2 m m' else M2 m' m'') a =
MapGet m' (N.div2 a).
Proof. hammer_hook "Map" "Map.MapGet_M2_bit_0_2".
intros. rewrite MapGet_if_commute. apply MapGet_M2_bit_0.
Qed.

Lemma MapPut1_semantics_1 :
forall (p:positive) (a a':ad) (y y':A),
Nxor a a' = Npos p -> MapGet (MapPut1 a y a' y' p) a = Some y.
Proof. hammer_hook "Map" "Map.MapPut1_semantics_1".
simple induction p. intros. unfold MapPut1 in |- *. rewrite MapGet_M2_bit_0_2. apply M1_semantics_1.
intros. simpl in |- *. rewrite MapGet_M2_bit_0_2. apply H. rewrite <- Nxor_div2. rewrite H0.
reflexivity.
intros. unfold MapPut1 in |- *. rewrite MapGet_M2_bit_0_2. apply M1_semantics_1.
Qed.

Lemma MapPut1_semantics_2 :
forall (p:positive) (a a':ad) (y y':A),
Nxor a a' = Npos p -> MapGet (MapPut1 a y a' y' p) a' = Some y'.
Proof. hammer_hook "Map" "Map.MapPut1_semantics_2".
simple induction p. intros. unfold MapPut1 in |- *. rewrite (Nneg_bit0_2 a a' p0 H0).
rewrite if_negb. rewrite MapGet_M2_bit_0_2. apply M1_semantics_1.
intros. simpl in |- *. rewrite (Nsame_bit0 a a' p0 H0). rewrite MapGet_M2_bit_0_2.
apply H. rewrite <- Nxor_div2. rewrite H0. reflexivity.
intros. unfold MapPut1 in |- *. rewrite (Nneg_bit0_1 a a' H). rewrite if_negb.
rewrite MapGet_M2_bit_0_2. apply M1_semantics_1.
Qed.

Lemma MapGet_M2_both_None :
forall (m m':Map) (a:ad),
MapGet m (N.div2 a) = None ->
MapGet m' (N.div2 a) = None -> MapGet (M2 m m') a = None.
Proof. hammer_hook "Map" "Map.MapGet_M2_both_None".
intros. rewrite (Map2_semantics_3 m m' a).
case (Nbit0 a); assumption.
Qed.

Lemma MapPut1_semantics_3 :
forall (p:positive) (a a' a0:ad) (y y':A),
Nxor a a' = Npos p ->
N.eqb a a0 = false ->
N.eqb a' a0 = false -> MapGet (MapPut1 a y a' y' p) a0 = None.
Proof. hammer_hook "Map" "Map.MapPut1_semantics_3".
simple induction p. intros. unfold MapPut1 in |- *. elim (Nneq_elim a a0 H1). intro. rewrite H3. rewrite if_negb.
rewrite MapGet_M2_bit_0_2. apply M1_semantics_2. apply Ndiv2_bit_neq. assumption.
rewrite (Nneg_bit0_2 a a' p0 H0) in H3. rewrite (negb_intro (Nbit0 a')).
rewrite (negb_intro (Nbit0 a0)). rewrite H3. reflexivity.
intro. elim (Nneq_elim a' a0 H2). intro. rewrite (Nneg_bit0_2 a a' p0 H0). rewrite H4.
rewrite (negb_elim (Nbit0 a0)). rewrite MapGet_M2_bit_0_2.
apply M1_semantics_2; assumption.
intro; case (Nbit0 a); apply MapGet_M2_both_None; apply M1_semantics_2;
assumption.
intros. simpl in |- *. elim (Nneq_elim a a0 H1). intro. rewrite H3. rewrite if_negb.
rewrite MapGet_M2_bit_0_2. reflexivity.
intro. elim (Nneq_elim a' a0 H2). intro. rewrite (Nsame_bit0 a a' p0 H0). rewrite H4.
rewrite if_negb. rewrite MapGet_M2_bit_0_2. reflexivity.
intro. cut (Nxor (N.div2 a) (N.div2 a') = Npos p0). intro.
case (Nbit0 a); apply MapGet_M2_both_None; trivial; apply H;
assumption.
rewrite <- Nxor_div2. rewrite H0. reflexivity.
intros. simpl in |- *. elim (Nneq_elim a a0 H0). intro. rewrite H2. rewrite if_negb.
rewrite MapGet_M2_bit_0_2. apply M1_semantics_2. apply Ndiv2_bit_neq. assumption.
rewrite (Nneg_bit0_1 a a' H) in H2. rewrite (negb_intro (Nbit0 a')).
rewrite (negb_intro (Nbit0 a0)). rewrite H2. reflexivity.
intro. elim (Nneq_elim a' a0 H1). intro. rewrite (Nneg_bit0_1 a a' H). rewrite H3.
rewrite (negb_elim (Nbit0 a0)). rewrite MapGet_M2_bit_0_2.
apply M1_semantics_2; assumption.
intro. case (Nbit0 a); apply MapGet_M2_both_None; apply M1_semantics_2;
assumption.
Qed.

Lemma MapPut1_semantics :
forall (p:positive) (a a':ad) (y y':A),
Nxor a a' = Npos p ->
eqm (MapGet (MapPut1 a y a' y' p))
(fun a0:ad =>
if N.eqb a a0
then Some y
else if N.eqb a' a0 then Some y' else None).
Proof. hammer_hook "Map" "Map.MapPut1_semantics".
unfold eqm in |- *. intros. elim (sumbool_of_bool (N.eqb a a0)). intro H0. rewrite H0.
rewrite <- (Neqb_complete _ _ H0). exact (MapPut1_semantics_1 p a a' y y' H).
intro H0. rewrite H0. elim (sumbool_of_bool (N.eqb a' a0)). intro H1.
rewrite <- (Neqb_complete _ _ H1). rewrite (Neqb_correct a').
exact (MapPut1_semantics_2 p a a' y y' H).
intro H1. rewrite H1. exact (MapPut1_semantics_3 p a a' a0 y y' H H0 H1).
Qed.

Lemma MapPut1_semantics' :
forall (p:positive) (a a':ad) (y y':A),
Nxor a a' = Npos p ->
eqm (MapGet (MapPut1 a y a' y' p))
(fun a0:ad =>
if N.eqb a' a0
then Some y'
else if N.eqb a a0 then Some y else None).
Proof. hammer_hook "Map" "Map.MapPut1_semantics'".
unfold eqm in |- *. intros. rewrite (MapPut1_semantics p a a' y y' H a0).
elim (sumbool_of_bool (N.eqb a a0)). intro H0. rewrite H0.
rewrite <- (Neqb_complete a a0 H0). rewrite (Neqb_comm a' a).
rewrite (Nxor_eq_false a a' p H). reflexivity.
intro H0. rewrite H0. reflexivity.
Qed.

Fixpoint MapPut (m:Map) : ad -> A -> Map :=
match m with
| M0 => M1
| M1 a y =>
fun (a':ad) (y':A) =>
match Nxor a a' with
| N0 => M1 a' y'
| Npos p => MapPut1 a y a' y' p
end
| M2 m1 m2 =>
fun (a:ad) (y:A) =>
match a with
| N0 => M2 (MapPut m1 N0 y) m2
| Npos xH => M2 m1 (MapPut m2 N0 y)
| Npos (xO p) => M2 (MapPut m1 (Npos p) y) m2
| Npos (xI p) => M2 m1 (MapPut m2 (Npos p) y)
end
end.

Lemma MapPut_semantics_1 :
forall (a:ad) (y:A) (a0:ad),
MapGet (MapPut M0 a y) a0 = MapGet (M1 a y) a0.
Proof. hammer_hook "Map" "Map.MapPut_semantics_1".
trivial.
Qed.

Lemma MapPut_semantics_2_1 :
forall (a:ad) (y y':A) (a0:ad),
MapGet (MapPut (M1 a y) a y') a0 =
(if N.eqb a a0 then Some y' else None).
Proof. hammer_hook "Map" "Map.MapPut_semantics_2_1".
simpl in |- *. intros. rewrite (Nxor_nilpotent a). trivial.
Qed.

Lemma MapPut_semantics_2_2 :
forall (a a':ad) (y y':A) (a0 a'':ad),
Nxor a a' = a'' ->
MapGet (MapPut (M1 a y) a' y') a0 =
(if N.eqb a' a0 then Some y' else if N.eqb a a0 then Some y else None).
Proof. hammer_hook "Map" "Map.MapPut_semantics_2_2".
simple induction a''. intro. rewrite (Nxor_eq _ _ H). rewrite MapPut_semantics_2_1.
case (N.eqb a' a0); trivial.
intros. simpl in |- *. rewrite H. rewrite (MapPut1_semantics p a a' y y' H a0).
elim (sumbool_of_bool (N.eqb a a0)). intro H0. rewrite H0. rewrite <- (Neqb_complete _ _ H0).
rewrite (Neqb_comm a' a). rewrite (Nxor_eq_false _ _ _ H). reflexivity.
intro H0. rewrite H0. reflexivity.
Qed.

Lemma MapPut_semantics_2 :
forall (a a':ad) (y y':A) (a0:ad),
MapGet (MapPut (M1 a y) a' y') a0 =
(if N.eqb a' a0 then Some y' else if N.eqb a a0 then Some y else None).
Proof. hammer_hook "Map" "Map.MapPut_semantics_2".
intros. apply MapPut_semantics_2_2 with (a'' := Nxor a a'); trivial.
Qed.

Lemma MapPut_semantics_3_1 :
forall (m m':Map) (a:ad) (y:A),
MapPut (M2 m m') a y =
(if Nbit0 a
then M2 m (MapPut m' (N.div2 a) y)
else M2 (MapPut m (N.div2 a) y) m').
Proof. hammer_hook "Map" "Map.MapPut_semantics_3_1".
simple induction a. trivial.
simple induction p; trivial.
Qed.

Lemma MapPut_semantics :
forall (m:Map) (a:ad) (y:A),
eqm (MapGet (MapPut m a y))
(fun a':ad => if N.eqb a a' then Some y else MapGet m a').
Proof. hammer_hook "Map" "Map.MapPut_semantics".
unfold eqm in |- *. simple induction m. exact MapPut_semantics_1.
intros. unfold MapGet at 2 in |- *. apply MapPut_semantics_2; assumption.
intros. rewrite MapPut_semantics_3_1. rewrite (MapGet_M2_bit_0_if m0 m1 a0).
elim (sumbool_of_bool (Nbit0 a)). intro H1. rewrite H1. rewrite MapGet_M2_bit_0_if.
elim (sumbool_of_bool (Nbit0 a0)). intro H2. rewrite H2.
rewrite (H0 (N.div2 a) y (N.div2 a0)). elim (sumbool_of_bool (N.eqb a a0)).
intro H3. rewrite H3. rewrite (Ndiv2_eq _ _ H3). reflexivity.
intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (Ndiv2_bit_neq _ _ H3 H1). reflexivity.
intro H2. rewrite H2. rewrite (Neqb_comm a a0). rewrite (Nbit0_neq a0 a H2 H1).
reflexivity.
intro H1. rewrite H1. rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (Nbit0 a0)).
intro H2. rewrite H2. rewrite (Nbit0_neq a a0 H1 H2). reflexivity.
intro H2. rewrite H2. rewrite (H (N.div2 a) y (N.div2 a0)).
elim (sumbool_of_bool (N.eqb a a0)). intro H3. rewrite H3.
rewrite (Ndiv2_eq a a0 H3). reflexivity.
intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (Ndiv2_bit_neq a a0 H3 H1). reflexivity.
Qed.

Fixpoint MapPut_behind (m:Map) : ad -> A -> Map :=
match m with
| M0 => M1
| M1 a y =>
fun (a':ad) (y':A) =>
match Nxor a a' with
| N0 => m
| Npos p => MapPut1 a y a' y' p
end
| M2 m1 m2 =>
fun (a:ad) (y:A) =>
match a with
| N0 => M2 (MapPut_behind m1 N0 y) m2
| Npos xH => M2 m1 (MapPut_behind m2 N0 y)
| Npos (xO p) => M2 (MapPut_behind m1 (Npos p) y) m2
| Npos (xI p) => M2 m1 (MapPut_behind m2 (Npos p) y)
end
end.

Lemma MapPut_behind_semantics_3_1 :
forall (m m':Map) (a:ad) (y:A),
MapPut_behind (M2 m m') a y =
(if Nbit0 a
then M2 m (MapPut_behind m' (N.div2 a) y)
else M2 (MapPut_behind m (N.div2 a) y) m').
Proof. hammer_hook "Map" "Map.MapPut_behind_semantics_3_1".
simple induction a. trivial.
simple induction p; trivial.
Qed.

Lemma MapPut_behind_as_before_1 :
forall a a' a0:ad,
N.eqb a' a0 = false ->
forall y y':A,
MapGet (MapPut (M1 a y) a' y') a0 =
MapGet (MapPut_behind (M1 a y) a' y') a0.
Proof. hammer_hook "Map" "Map.MapPut_behind_as_before_1".
intros a a' a0. simpl in |- *. intros H y y'. elim (N.discr (Nxor a a')). intro H0. elim H0.
intros p H1. rewrite H1. reflexivity.
intro H0. rewrite H0. rewrite (Nxor_eq _ _ H0). rewrite (M1_semantics_2 a' a0 y H).
exact (M1_semantics_2 a' a0 y' H).
Qed.

Lemma MapPut_behind_as_before :
forall (m:Map) (a:ad) (y:A) (a0:ad),
N.eqb a a0 = false ->
MapGet (MapPut m a y) a0 = MapGet (MapPut_behind m a y) a0.
Proof. hammer_hook "Map" "Map.MapPut_behind_as_before".
simple induction m. trivial.
intros a y a' y' a0 H. exact (MapPut_behind_as_before_1 a a' a0 H y y').
intros. rewrite MapPut_semantics_3_1. rewrite MapPut_behind_semantics_3_1.
elim (sumbool_of_bool (Nbit0 a)). intro H2. rewrite H2. rewrite MapGet_M2_bit_0_if.
rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (Nbit0 a0)). intro H3.
rewrite H3. apply H0. rewrite <- H3 in H2. exact (Ndiv2_bit_neq a a0 H1 H2).
intro H3. rewrite H3. reflexivity.
intro H2. rewrite H2. rewrite MapGet_M2_bit_0_if. rewrite MapGet_M2_bit_0_if.
elim (sumbool_of_bool (Nbit0 a0)). intro H3. rewrite H3. reflexivity.
intro H3. rewrite H3. apply H. rewrite <- H3 in H2. exact (Ndiv2_bit_neq a a0 H1 H2).
Qed.

Lemma MapPut_behind_new :
forall (m:Map) (a:ad) (y:A),
MapGet (MapPut_behind m a y) a =
match MapGet m a with
| Some y' => Some y'
| _ => Some y
end.
Proof. hammer_hook "Map" "Map.MapPut_behind_new".
simple induction m. simpl in |- *. intros. rewrite (Neqb_correct a). reflexivity.
intros. elim (N.discr (Nxor a a1)). intro H. elim H. intros p H0. simpl in |- *.
rewrite H0. rewrite (Nxor_eq_false a a1 p). exact (MapPut1_semantics_2 p a a1 a0 y H0).
assumption.
intro H. simpl in |- *. rewrite H. rewrite <- (Nxor_eq _ _ H). rewrite (Neqb_correct a).
exact (M1_semantics_1 a a0).
intros. rewrite MapPut_behind_semantics_3_1. rewrite (MapGet_M2_bit_0_if m0 m1 a).
elim (sumbool_of_bool (Nbit0 a)). intro H1. rewrite H1. rewrite (MapGet_M2_bit_0_1 a H1).
exact (H0 (N.div2 a) y).
intro H1. rewrite H1. rewrite (MapGet_M2_bit_0_0 a H1). exact (H (N.div2 a) y).
Qed.

Lemma MapPut_behind_semantics :
forall (m:Map) (a:ad) (y:A),
eqm (MapGet (MapPut_behind m a y))
(fun a':ad =>
match MapGet m a' with
| Some y' => Some y'
| _ => if N.eqb a a' then Some y else None
end).
Proof. hammer_hook "Map" "Map.MapPut_behind_semantics".
unfold eqm in |- *. intros. elim (sumbool_of_bool (N.eqb a a0)). intro H. rewrite H.
rewrite (Neqb_complete _ _ H). apply MapPut_behind_new.
intro H. rewrite H. rewrite <- (MapPut_behind_as_before m a y a0 H).
rewrite (MapPut_semantics m a y a0). rewrite H. case (MapGet m a0); trivial.
Qed.

Definition makeM2 (m m':Map) :=
match m, m' with
| M0, M0 => M0
| M0, M1 a y => M1 (Ndouble_plus_one a) y
| M1 a y, M0 => M1 (N.double a) y
| _, _ => M2 m m'
end.

Lemma makeM2_M2 :
forall m m':Map, eqm (MapGet (makeM2 m m')) (MapGet (M2 m m')).
Proof. hammer_hook "Map" "Map.makeM2_M2".
unfold eqm in |- *. intros. elim (sumbool_of_bool (Nbit0 a)). intro H.
rewrite (MapGet_M2_bit_0_1 a H m m'). case m'. case m. reflexivity.
intros a0 y. simpl in |- *. rewrite (Nodd_not_double a H a0). reflexivity.
intros m1 m2. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_1. reflexivity.
assumption.
case m. intros a0 y. simpl in |- *. elim (sumbool_of_bool (N.eqb a0 (N.div2 a))).
intro H0. rewrite H0. rewrite (Neqb_complete _ _ H0). rewrite (Ndiv2_double_plus_one a H).
rewrite (Neqb_correct a). reflexivity.
intro H0. rewrite H0. rewrite (Neqb_comm a0 (N.div2 a)) in H0.
rewrite (Nnot_div2_not_double_plus_one a a0 H0). reflexivity.
intros a0 y0 a1 y1. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_1. reflexivity.
assumption.
intros m1 m2 a0 y. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_1. reflexivity.
assumption.
intros m1 m2. unfold makeM2 in |- *.
cut (MapGet (M2 m (M2 m1 m2)) a = MapGet (M2 m1 m2) (N.div2 a)).
case m; trivial.
exact (MapGet_M2_bit_0_1 a H m (M2 m1 m2)).
intro H. rewrite (MapGet_M2_bit_0_0 a H m m'). case m. case m'. reflexivity.
intros a0 y. simpl in |- *. rewrite (Neven_not_double_plus_one a H a0). reflexivity.
intros m1 m2. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_0. reflexivity.
assumption.
case m'. intros a0 y. simpl in |- *. elim (sumbool_of_bool (N.eqb a0 (N.div2 a))). intro H0.
rewrite H0. rewrite (Neqb_complete _ _ H0). rewrite (Ndiv2_double a H).
rewrite (Neqb_correct a). reflexivity.
intro H0. rewrite H0. rewrite (Neqb_comm (N.double a0) a).
rewrite (Neqb_comm a0 (N.div2 a)) in H0. rewrite (Nnot_div2_not_double a a0 H0).
reflexivity.
intros a0 y0 a1 y1. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_0. reflexivity.
assumption.
intros m1 m2 a0 y. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_0. reflexivity.
assumption.
intros m1 m2. unfold makeM2 in |- *. exact (MapGet_M2_bit_0_0 a H (M2 m1 m2) m').
Qed.

Fixpoint MapRemove (m:Map) : ad -> Map :=
match m with
| M0 => fun _:ad => M0
| M1 a y =>
fun a':ad => match N.eqb a a' with
| true => M0
| false => m
end
| M2 m1 m2 =>
fun a:ad =>
if Nbit0 a
then makeM2 m1 (MapRemove m2 (N.div2 a))
else makeM2 (MapRemove m1 (N.div2 a)) m2
end.

Lemma MapRemove_semantics :
forall (m:Map) (a:ad),
eqm (MapGet (MapRemove m a))
(fun a':ad => if N.eqb a a' then None else MapGet m a').
Proof. hammer_hook "Map" "Map.MapRemove_semantics".
unfold eqm in |- *. simple induction m. simpl in |- *. intros. case (N.eqb a a0); trivial.
intros. simpl in |- *. elim (sumbool_of_bool (N.eqb a1 a2)). intro H. rewrite H.
elim (sumbool_of_bool (N.eqb a a1)). intro H0. rewrite H0. reflexivity.
intro H0. rewrite H0. rewrite (Neqb_complete _ _ H) in H0. exact (M1_semantics_2 a a2 a0 H0).
intro H. elim (sumbool_of_bool (N.eqb a a1)). intro H0. rewrite H0. rewrite H.
rewrite <- (Neqb_complete _ _ H0) in H. rewrite H. reflexivity.
intro H0. rewrite H0. rewrite H. reflexivity.
intros. change
(MapGet
(if Nbit0 a
then makeM2 m0 (MapRemove m1 (N.div2 a))
else makeM2 (MapRemove m0 (N.div2 a)) m1) a0 =
(if N.eqb a a0 then None else MapGet (M2 m0 m1) a0))
in |- *.
elim (sumbool_of_bool (Nbit0 a)). intro H1. rewrite H1.
rewrite (makeM2_M2 m0 (MapRemove m1 (N.div2 a)) a0). elim (sumbool_of_bool (Nbit0 a0)).
intro H2. rewrite MapGet_M2_bit_0_1. rewrite (H0 (N.div2 a) (N.div2 a0)).
elim (sumbool_of_bool (N.eqb a a0)). intro H3. rewrite H3. rewrite (Ndiv2_eq _ _ H3).
reflexivity.
intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (Ndiv2_bit_neq _ _ H3 H1).
rewrite (MapGet_M2_bit_0_1 a0 H2 m0 m1). reflexivity.
assumption.
intro H2. rewrite (MapGet_M2_bit_0_0 a0 H2 m0 (MapRemove m1 (N.div2 a))).
rewrite (Neqb_comm a a0). rewrite (Nbit0_neq _ _ H2 H1).
rewrite (MapGet_M2_bit_0_0 a0 H2 m0 m1). reflexivity.
intro H1. rewrite H1. rewrite (makeM2_M2 (MapRemove m0 (N.div2 a)) m1 a0).
elim (sumbool_of_bool (Nbit0 a0)). intro H2. rewrite MapGet_M2_bit_0_1.
rewrite (MapGet_M2_bit_0_1 a0 H2 m0 m1). rewrite (Nbit0_neq a a0 H1 H2). reflexivity.
assumption.
intro H2. rewrite MapGet_M2_bit_0_0. rewrite (H (N.div2 a) (N.div2 a0)).
rewrite (MapGet_M2_bit_0_0 a0 H2 m0 m1). elim (sumbool_of_bool (N.eqb a a0)). intro H3.
rewrite H3. rewrite (Ndiv2_eq _ _ H3). reflexivity.
intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (Ndiv2_bit_neq _ _ H3 H1). reflexivity.
assumption.
Qed.

Fixpoint MapCard (m:Map) : nat :=
match m with
| M0 => 0
| M1 _ _ => 1
| M2 m m' => MapCard m + MapCard m'
end.

Fixpoint MapMerge (m:Map) : Map -> Map :=
match m with
| M0 => fun m':Map => m'
| M1 a y => fun m':Map => MapPut_behind m' a y
| M2 m1 m2 =>
fun m':Map =>
match m' with
| M0 => m
| M1 a' y' => MapPut m a' y'
| M2 m'1 m'2 => M2 (MapMerge m1 m'1) (MapMerge m2 m'2)
end
end.

Lemma MapMerge_semantics :
forall m m':Map,
eqm (MapGet (MapMerge m m'))
(fun a0:ad =>
match MapGet m' a0 with
| Some y' => Some y'
| None => MapGet m a0
end).
Proof. hammer_hook "Map" "Map.MapMerge_semantics".
unfold eqm in |- *. simple induction m. intros. simpl in |- *. case (MapGet m' a); trivial.
intros. simpl in |- *. rewrite (MapPut_behind_semantics m' a a0 a1). reflexivity.
simple induction m'. trivial.
intros. unfold MapMerge in |- *. rewrite (MapPut_semantics (M2 m0 m1) a a0 a1).
elim (sumbool_of_bool (N.eqb a a1)). intro H1. rewrite H1. rewrite (Neqb_complete _ _ H1).
rewrite (M1_semantics_1 a1 a0). reflexivity.
intro H1. rewrite H1. rewrite (M1_semantics_2 a a1 a0 H1). reflexivity.
intros. cut (MapMerge (M2 m0 m1) (M2 m2 m3) = M2 (MapMerge m0 m2) (MapMerge m1 m3)).
intro. rewrite H3. rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (N.div2 a)).
rewrite (H m2 (N.div2 a)). rewrite (MapGet_M2_bit_0_if m2 m3 a).
rewrite (MapGet_M2_bit_0_if m0 m1 a). case (Nbit0 a); trivial.
reflexivity.
Qed.

Fixpoint MapDelta (m:Map) : Map -> Map :=
match m with
| M0 => fun m':Map => m'
| M1 a y =>
fun m':Map =>
match MapGet m' a with
| None => MapPut m' a y
| _ => MapRemove m' a
end
| M2 m1 m2 =>
fun m':Map =>
match m' with
| M0 => m
| M1 a' y' =>
match MapGet m a' with
| None => MapPut m a' y'
| _ => MapRemove m a'
end
| M2 m'1 m'2 => makeM2 (MapDelta m1 m'1) (MapDelta m2 m'2)
end
end.

Lemma MapDelta_semantics_comm :
forall m m':Map, eqm (MapGet (MapDelta m m')) (MapGet (MapDelta m' m)).
Proof. hammer_hook "Map" "Map.MapDelta_semantics_comm".
unfold eqm in |- *. simple induction m. simple induction m'; reflexivity.
simple induction m'. reflexivity.
unfold MapDelta in |- *. intros. elim (sumbool_of_bool (N.eqb a a1)). intro H.
rewrite <- (Neqb_complete _ _ H). rewrite (M1_semantics_1 a a2).
rewrite (M1_semantics_1 a a0). simpl in |- *. rewrite (Neqb_correct a). reflexivity.
intro H. rewrite (M1_semantics_2 a a1 a0 H). rewrite (Neqb_comm a a1) in H.
rewrite (M1_semantics_2 a1 a a2 H). rewrite (MapPut_semantics (M1 a a0) a1 a2 a3).
rewrite (MapPut_semantics (M1 a1 a2) a a0 a3). elim (sumbool_of_bool (N.eqb a a3)).
intro H0. rewrite H0. rewrite (Neqb_complete _ _ H0) in H. rewrite H.
rewrite (Neqb_complete _ _ H0). rewrite (M1_semantics_1 a3 a0). reflexivity.
intro H0. rewrite H0. rewrite (M1_semantics_2 a a3 a0 H0).
elim (sumbool_of_bool (N.eqb a1 a3)). intro H1. rewrite H1.
rewrite (Neqb_complete _ _ H1). exact (M1_semantics_1 a3 a2).
intro H1. rewrite H1. exact (M1_semantics_2 a1 a3 a2 H1).
intros. reflexivity.
simple induction m'. reflexivity.
reflexivity.
intros. simpl in |- *. rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a).
rewrite (makeM2_M2 (MapDelta m2 m0) (MapDelta m3 m1) a).
rewrite (MapGet_M2_bit_0_if (MapDelta m0 m2) (MapDelta m1 m3) a).
rewrite (MapGet_M2_bit_0_if (MapDelta m2 m0) (MapDelta m3 m1) a).
rewrite (H0 m3 (N.div2 a)). rewrite (H m2 (N.div2 a)). reflexivity.
Qed.

Lemma MapDelta_semantics_1_1 :
forall (a:ad) (y:A) (m':Map) (a0:ad),
MapGet (M1 a y) a0 = None ->
MapGet m' a0 = None -> MapGet (MapDelta (M1 a y) m') a0 = None.
Proof. hammer_hook "Map" "Map.MapDelta_semantics_1_1".
intros. unfold MapDelta in |- *. elim (sumbool_of_bool (N.eqb a a0)). intro H1.
rewrite (Neqb_complete _ _ H1) in H. rewrite (M1_semantics_1 a0 y) in H. discriminate H.
intro H1. case (MapGet m' a).
rewrite (MapRemove_semantics m' a a0). rewrite H1. trivial.
rewrite (MapPut_semantics m' a y a0). rewrite H1. assumption.
Qed.

Lemma MapDelta_semantics_1 :
forall (m m':Map) (a:ad),
MapGet m a = None ->
MapGet m' a = None -> MapGet (MapDelta m m') a = None.
Proof. hammer_hook "Map" "Map.MapDelta_semantics_1".
simple induction m. trivial.
exact MapDelta_semantics_1_1.
simple induction m'. trivial.
intros. rewrite (MapDelta_semantics_comm (M2 m0 m1) (M1 a a0) a1).
apply MapDelta_semantics_1_1; trivial.
intros. simpl in |- *. rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a).
rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (Nbit0 a)). intro H5. rewrite H5.
apply H0. rewrite (MapGet_M2_bit_0_1 a H5 m0 m1) in H3. exact H3.
rewrite (MapGet_M2_bit_0_1 a H5 m2 m3) in H4. exact H4.
intro H5. rewrite H5. apply H. rewrite (MapGet_M2_bit_0_0 a H5 m0 m1) in H3. exact H3.
rewrite (MapGet_M2_bit_0_0 a H5 m2 m3) in H4. exact H4.
Qed.

Lemma MapDelta_semantics_2_1 :
forall (a:ad) (y:A) (m':Map) (a0:ad) (y0:A),
MapGet (M1 a y) a0 = None ->
MapGet m' a0 = Some y0 -> MapGet (MapDelta (M1 a y) m') a0 = Some y0.
Proof. hammer_hook "Map" "Map.MapDelta_semantics_2_1".
intros. unfold MapDelta in |- *. elim (sumbool_of_bool (N.eqb a a0)). intro H1.
rewrite (Neqb_complete _ _ H1) in H. rewrite (M1_semantics_1 a0 y) in H. discriminate H.
intro H1. case (MapGet m' a).
rewrite (MapRemove_semantics m' a a0). rewrite H1. trivial.
rewrite (MapPut_semantics m' a y a0). rewrite H1. assumption.
Qed.

Lemma MapDelta_semantics_2_2 :
forall (a:ad) (y:A) (m':Map) (a0:ad) (y0:A),
MapGet (M1 a y) a0 = Some y0 ->
MapGet m' a0 = None -> MapGet (MapDelta (M1 a y) m') a0 = Some y0.
Proof. hammer_hook "Map" "Map.MapDelta_semantics_2_2".
intros. unfold MapDelta in |- *. elim (sumbool_of_bool (N.eqb a a0)). intro H1.
rewrite (Neqb_complete _ _ H1) in H. rewrite (Neqb_complete _ _ H1).
rewrite H0. rewrite (MapPut_semantics m' a0 y a0). rewrite (Neqb_correct a0).
rewrite (M1_semantics_1 a0 y) in H. simple inversion H. assumption.
intro H1. rewrite (M1_semantics_2 a a0 y H1) in H. discriminate H.
Qed.

Lemma MapDelta_semantics_2 :
forall (m m':Map) (a:ad) (y:A),
MapGet m a = None ->
MapGet m' a = Some y -> MapGet (MapDelta m m') a = Some y.
Proof. hammer_hook "Map" "Map.MapDelta_semantics_2".
simple induction m. trivial.
exact MapDelta_semantics_2_1.
simple induction m'. intros. discriminate H2.
intros. rewrite (MapDelta_semantics_comm (M2 m0 m1) (M1 a a0) a1).
apply MapDelta_semantics_2_2; assumption.
intros. simpl in |- *. rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a).
rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (Nbit0 a)). intro H5. rewrite H5.
apply H0. rewrite <- (MapGet_M2_bit_0_1 a H5 m0 m1). assumption.
rewrite <- (MapGet_M2_bit_0_1 a H5 m2 m3). assumption.
intro H5. rewrite H5. apply H. rewrite <- (MapGet_M2_bit_0_0 a H5 m0 m1). assumption.
rewrite <- (MapGet_M2_bit_0_0 a H5 m2 m3). assumption.
Qed.

Lemma MapDelta_semantics_3_1 :
forall (a0:ad) (y0:A) (m':Map) (a:ad) (y y':A),
MapGet (M1 a0 y0) a = Some y ->
MapGet m' a = Some y' -> MapGet (MapDelta (M1 a0 y0) m') a = None.
Proof. hammer_hook "Map" "Map.MapDelta_semantics_3_1".
intros. unfold MapDelta in |- *. elim (sumbool_of_bool (N.eqb a0 a)). intro H1.
rewrite (Neqb_complete a0 a H1). rewrite H0. rewrite (MapRemove_semantics m' a a).
rewrite (Neqb_correct a). reflexivity.
intro H1. rewrite (M1_semantics_2 a0 a y0 H1) in H. discriminate H.
Qed.

Lemma MapDelta_semantics_3 :
forall (m m':Map) (a:ad) (y y':A),
MapGet m a = Some y ->
MapGet m' a = Some y' -> MapGet (MapDelta m m') a = None.
Proof. hammer_hook "Map" "Map.MapDelta_semantics_3".
simple induction m. intros. discriminate H.
exact MapDelta_semantics_3_1.
simple induction m'. intros. discriminate H2.
intros. rewrite (MapDelta_semantics_comm (M2 m0 m1) (M1 a a0) a1).
exact (MapDelta_semantics_3_1 a a0 (M2 m0 m1) a1 y' y H2 H1).
intros. simpl in |- *. rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a).
rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (Nbit0 a)). intro H5. rewrite H5.
apply (H0 m3 (N.div2 a) y y'). rewrite <- (MapGet_M2_bit_0_1 a H5 m0 m1). assumption.
rewrite <- (MapGet_M2_bit_0_1 a H5 m2 m3). assumption.
intro H5. rewrite H5. apply (H m2 (N.div2 a) y y').
rewrite <- (MapGet_M2_bit_0_0 a H5 m0 m1). assumption.
rewrite <- (MapGet_M2_bit_0_0 a H5 m2 m3). assumption.
Qed.

Lemma MapDelta_semantics :
forall m m':Map,
eqm (MapGet (MapDelta m m'))
(fun a0:ad =>
match MapGet m a0, MapGet m' a0 with
| None, Some y' => Some y'
| Some y, None => Some y
| _, _ => None
end).
Proof. hammer_hook "Map" "Map.MapDelta_semantics".
unfold eqm in |- *. intros. elim (option_sum (MapGet m' a)). intro H. elim H. intros a0 H0.
rewrite H0. elim (option_sum (MapGet m a)). intro H1. elim H1. intros a1 H2. rewrite H2.
exact (MapDelta_semantics_3 m m' a a1 a0 H2 H0).
intro H1. rewrite H1. exact (MapDelta_semantics_2 m m' a a0 H1 H0).
intro H. rewrite H. elim (option_sum (MapGet m a)). intro H0. elim H0. intros a0 H1.
rewrite H1. rewrite (MapDelta_semantics_comm m m' a).
exact (MapDelta_semantics_2 m' m a a0 H H1).
intro H0. rewrite H0. exact (MapDelta_semantics_1 m m' a H0 H).
Qed.

Definition MapEmptyp (m:Map) := match m with
| M0 => true
| _ => false
end.

Lemma MapEmptyp_correct : MapEmptyp M0 = true.
Proof. hammer_hook "Map" "Map.MapEmptyp_correct".
reflexivity.
Qed.

Lemma MapEmptyp_complete : forall m:Map, MapEmptyp m = true -> m = M0.
Proof. hammer_hook "Map" "Map.MapEmptyp_complete".
simple induction m; trivial. intros. discriminate H.
intros. discriminate H1.
Qed.

End MapDefs.


Require Export DbLib.Environments.
Require Export Linear.Empty.
Require Export Linear.DbLibExt.

(* Context splitting similar to Liam OConnor and Edsko de Vries' approaches *)
(* Liam: http://liamoc.net/posts/2014-01-01-context-split.html *)
Inductive split_single {A} : option A -> option A -> option A -> Prop :=
  | split_none : split_single None None None
  | split_left (v : A) : split_single (Some v) (Some v) None
  | split_right (v : A) : split_single (Some v) None (Some v).

Hint Constructors split_single : linear.

Inductive context_split {A} : env A -> env A -> env A -> Prop :=
  | split_nil : context_split nil nil nil
  | split_cons E E1 E2 v v1 v2
      (SplitElem : split_single v v1 v2)
      (SplitPre : context_split E E1 E2) :
      context_split (v :: E) (v1 :: E1) (v2 :: E2).

Hint Constructors context_split : linear.

(* Basic lemmas about context splitting *)

Lemma split_single_commute : forall A (v : option A) v1 v2,
  split_single v v1 v2 -> split_single v v2 v1.
Proof with boom.
  intros A v v1 v2 Split.
  induction Split...
Qed.

Hint Immediate split_single_commute : linear.

Lemma split_commute : forall A (E : env A) E1 E2,
  context_split E E1 E2 -> context_split E E2 E1.
Proof with boom.
  intros A E E1 E2 Split.
  induction Split...
Qed.

(* NB: split_commute can create loops, so we only apply it at most once using auto *)
Hint Immediate split_commute : linear.

Lemma split_single_assoc : forall A (v v0 v1 v2 v12 : option A),
  split_single v v0 v12 ->
  split_single v12 v1 v2 ->
  (exists v01, split_single v v01 v2 /\ split_single v01 v0 v1).
Proof.
  intros A v v0 v1 v2 v12 Split Split12.
  destruct v; destruct v0; destruct v1; destruct v2; destruct v12;
  inversion Split12; inversion Split; eboom.
Qed.

Hint Resolve split_single_assoc : linear.

Lemma split_assoc : forall A (E E0 E1 E2 E12 : env A),
  context_split E E0 E12 ->
  context_split E12 E1 E2 ->
  (exists E01, context_split E E01 E2 /\ context_split E01 E0 E1).
Proof with eboom.
  intros A E E0 E1 E2 E12 SplitE Split12.
  generalize dependent E1.
  generalize dependent E2.
  induction SplitE as [|E' E0' E12' v v0 v12]; intros.
  Case "empty". inversion Split12; subst...
  Case "cons".
    inversion Split12 as [|? E1' E2' ? v1 v2 SplitSingle12 Split12'].
    subst.
    apply IHSplitE in Split12'.
    destruct Split12' as [E01' [? ?]].
    assert (exists v01, split_single v v01 v2 /\ split_single v01 v0 v1) as [v01 [? ?]]...
Qed.

Hint Resolve split_assoc : linear.

Lemma split_assoc_rev : forall A (E E0 E1 E2 E01 : env A),
  context_split E E01 E2 ->
  context_split E01 E0 E1 ->
  (exists E12, context_split E E0 E12 /\ context_split E12 E1 E2).
Proof with eboom.
  intros A E E0 E1 E2 E01 SplitE Split01.
  assert (exists E21, context_split E E21 E0 /\ context_split E21 E2 E1) as [E21 [? ?]]...
Qed.

Hint Resolve split_assoc_rev : linear.

(* Draw a tree! *)
Lemma split_rotate : forall A (E : env A) E0 E12 E1 E2,
  context_split E E0 E12 ->
  context_split E12 E1 E2 ->
  (exists E02, context_split E E1 E02 /\ context_split E02 E0 E2).
Proof with eboom.
  intros A E E0 E12 E1 E2 SplitE Split12.
  assert (exists E02, context_split E E02 E1 /\ context_split E02 E0 E2) as [? [? ?]]...
Qed.

Lemma split_swap : forall A (E E1 E2 E1a E1b E2a E2b : env A),
  context_split E E1 E2 ->
  context_split E1 E1a E1b ->
  context_split E2 E2a E2b ->
  (exists Ea Eb,
    context_split E Ea Eb /\
    context_split Ea E1a E2a /\
    context_split Eb E1b E2b).
Proof with eboom.
  intros A E E1 E2 E1a E1b E2a E2b SplitE Split1 Split2.
  assert (exists E12a, context_split E E12a E2b /\ context_split E12a E1 E2a) as [E12a [? ?]]...
  assert (exists Ea, context_split E12a E1b Ea /\ context_split Ea E1a E2a) as [Ea [? ?]]...
  assert (exists Eb, context_split E Ea Eb /\ context_split Eb E1b E2b) as [Eb [? ?]]...
Qed.

Lemma split_single_rotate : forall A (v : option A) v0 v12 v1 v2,
  split_single v v0 v12 ->
  split_single v12 v1 v2 ->
  (exists v02, split_single v v1 v02 /\ split_single v02 v0 v2).
Proof with eboom.
  intros A v v0 v12 v1 v2 Split012 Split12.
  destruct v; destruct v0; destruct v1; destruct v2; destruct v12;
  inversion Split012; inversion Split12; eboom.
Qed.

Hint Resolve split_single_rotate : linear.

Lemma context_split_length1 : forall A (E : env A) E1 E2,
  context_split E E1 E2 ->
  length E = length E1.
Proof with boom.
  intros A E E1 E2 Split.
  induction Split; simpl...
Qed.

Hint Resolve context_split_length1 : linear.

Lemma context_split_length1_x : forall A (E : env A) E1 E2 l,
  context_split E E1 E2 ->
  length E = l ->
  length E1 = l.
Proof.
  intros.
  subst l.
  symmetry.
  eauto using context_split_length1.
Qed.

Hint Resolve context_split_length1_x.

(* ASIDE: Note how much more verbose the above proof is if it's done by hand. *)
Lemma context_split_length1_x_bad : forall A (E : env A) E1 E2 l,
  context_split E E1 E2 ->
  length E = l ->
  length E1 = l.
Proof.
  intros A E E1 E2 l Split Len.
  generalize dependent l.
  induction Split;
  [ auto
  | intros;
    simpl in *;
    assert (length E = l - 1); [ omega | assert (length E1 = l - 1); eauto; omega ] ..].
Qed.

Example context_split_length2 : forall A (E : env A) E1 E2 l,
  context_split E E1 E2 ->
  length E = l ->
  length E2 = l.
Proof. eboom. Qed.

Lemma split_single_left : forall A (v : option A) v1,
  split_single v v1 None ->
  v = v1.
Proof with reflexivity.
  intros A v v1 Split.
  inversion Split; subst...
Qed.

Lemma split_single_right : forall A (v : option A) v1,
  split_single v None v1 ->
  v = v1.
Proof. eauto using split_single_commute, split_single_left. Qed.

(* ------------------------------- *)
(* Context splitting and emptiness *)
(* ------------------------------- *)

Lemma split_all_left : forall A (E : env A) E1 E2,
  is_empty E2 ->
  context_split E E1 E2 ->
  E = E1.
Proof with (eauto using split_single_left, f_equal).
  intros A E E1 E2 Empty Split.
  induction Split...
  inversion Empty; subst.
  replace v1 with v...
Qed.

Hint Resolve split_all_left : linear.

Lemma split_all_right : forall A (E : env A) E1 E2,
  is_empty E1 ->
  context_split E E1 E2 ->
  E = E2.
Proof. eboom. Qed.

Lemma split_empty : forall A (E : env A) E1 E2,
  is_empty E ->
  context_split E E1 E2 ->
  is_empty E1 /\ is_empty E2.
Proof with eboom.
  intros A E E1 E2 Empty Split.
  induction Split...
  inversion Empty; subst.
  inversion SplitElem; subst.
  assert (is_empty E1 /\ is_empty E2) as [EmptyE1 EmptyE2]...
Qed.

Lemma split_empty_left : forall A (E : env A) E1 E2,
  is_empty E ->
  context_split E E1 E2 ->
  is_empty E1.
Proof with eboom.
  intros A E E1 E2 Empty Split.
  apply split_empty in Split; destruct Split...
Qed.

Hint Immediate split_empty_left : linear.

Lemma split_empty_right : forall A (E : env A) E1 E2,
  is_empty E ->
  context_split E E1 E2 ->
  is_empty E2.
Proof. eauto using split_empty_left, split_commute. Qed.

Hint Immediate split_empty_right : linear.

(* Example: *)
Example context_split_ex1 : exists E,
  context_split (insert 0 "bool" []) (insert 0 "bool" []) E /\
  is_empty E.
Proof with eboom.
  exists [None]...
  rewrite raw_insert_zero...
Qed.


(*Require Import PeanoNat.*)
Require Import List.
Require Import NAxioms NProperties OrdersFacts.

Notation " [ ] " := nil.
Notation " [ x ] " := (cons x nil).
Notation " [ x , y , .. , z ] " := (cons x (cons y .. (cons z nil) ..)).
Notation " ( x :: l ) " := (cons x l).

(*Using de Bruijn indexes*)
Inductive MLexp : Set :=
  | Var : nat -> MLexp
  | Appl : MLexp -> MLexp -> MLexp
  | Lambda : MLexp -> MLexp
  | Let : nat -> MLexp -> MLexp -> MLexp.

(*We can now see the price we are paying for de Bruijn notatio; readability*)

(*λx.x*)
Compute Lambda (Var 0).

(*let x = λx.x in xx*)
Compute Let 0 (Lambda (Var 0)) (Appl (Var 0) (Var 0)).

Inductive type: Set :=
  | TVar: nat -> type
  | Arrow: type -> type -> type. (*ej. t1->(t2->t2)*)

(*Lenguajes con anotaciones de tipos*)
Inductive MLexpT : Set :=
  | VarT : nat -> MLexpT
  | ApplT : MLexpT -> MLexpT -> MLexpT
  | LambdaT : MLexpT -> type -> MLexpT
  | LetT : nat -> MLexpT -> type -> MLexpT -> MLexpT.

Fixpoint eq_nat n m : bool :=
  match n, m with
    | O, O => true
    | O, S _ => false
    | S _, O => false
    | S n1, S m1 => eq_nat n1 m1
  end.

Fixpoint elem (n:nat) (l:list nat):bool:=
  match l with
  |[] => false
  |(x::xs) => if eq_nat n x then true else elem n xs
  end.

Fixpoint leb (x y: nat): bool :=
match x,y with
  | 0, _ => true
  | _, 0 => false
  | S n', S m' => leb n' m'
end.

Fixpoint max_aux (n:nat) (l:list nat):nat :=
  match l with
  |[] => n
  |(x::xs) => if  (leb x n) then (max_aux n xs) else (max_aux x xs)
  end.

Fixpoint max (l:list nat):nat := max_aux 0 l.

Inductive option (A : Set) : Set :=  | None : (option A)
  | Some : A -> (option A).

Definition substitution := list (nat*type).

Fixpoint apply_subs t:= fix apply_subs1 (s:substitution):=
  match t with
  |TVar n => match s with
             |[] => TVar n
             |((m,t1)::xs) => if eq_nat n m then t1 else apply_subs1 xs
             end
  |Arrow t1 t2 => Arrow (apply_subs t1 s) (apply_subs t2 s)
  end.

Definition ctx := list type.

Definition newVT (l:list nat):type := TVar (S(max l)).

(*A judgement is a triplet of ctx, the converted expression to type annoted expr and the type of the expression.*)

Inductive has_type: Type :=
| ht: ctx -> MLexpT -> type -> has_type.

Fixpoint vtype_list (t:type):list nat :=
  match t with
  |TVar n => [n]
  |Arrow t1 t2 => app (vtype_list t1) (vtype_list t2)
  end.

Fixpoint simpSust (s:substitution):substitution :=
  match s with
  |[]=>[]
  |((n,t)::xs) => match t with
                 |TVar m => if eq_nat n m then simpSust xs else ((n,t)::(simpSust xs))
                 |t1 => ((n,t1)::(simpSust xs))
                 end
  end.

Fixpoint map_subst (s : substitution) (pair: (nat*type)):substitution :=
match s with
  |[] => []
  |((n,t)::xs) => (n, apply_subs t [pair])::(map_subst xs pair)
end.

Fixpoint compSustAux (s1 s2:substitution):substitution :=
match s2 with
  |[] => []
  |(x::xs) => compSustAux (map_subst s1 x) xs
end.

Definition compSust (s1 s2:substitution):substitution := (compSustAux s1 s2) ++ s2.

Fixpoint unify (t1 t2:type):substitution :=
  match t1, t2 with
  |TVar n,TVar m => if eq_nat n m then [] else [(n,TVar m)]
  |TVar n, vt => if elem n (vtype_list vt) then [] else [(n,vt)]
  | Arrow r1 r2, Arrow s1 s2 => let sust1 := unify r1 s1 in let sust2 := unify r2 s2 in compSust sust1 sust2
  |_, _ => []
  end.

Fixpoint erase (e : MLexpT) : MLexp :=
match e with
  | VarT n => Var n
  | ApplT e1 e2 => Appl (erase e1) (erase e2)
  | LambdaT e' _ => Lambda (erase e')
  | LetT n e1 _ e2 => Let n (erase e1) (erase e2)
end.

Fixpoint eqb n m: bool :=
match n, m with
  | 0, 0 => true
  | 0, _ => false
  | _, 0 => false
  | S n', S m' => eqb n' m'
end.

Fixpoint eqType (t1 t2: type): bool :=
match t1,t2 with
  | TVar n, TVar m => eqb n m
  | Arrow r1 r2, Arrow s1 s2 => andb (eqType r1 s1) (eqType r2 s2)
  | r, s => false
end.

Fixpoint getCommonTypes (c1 c2 :ctx) : ctx:=
match c1, c2 with
  | [], _ => []
  | _, [] => []
  | t1::xs, t2::ys => if (eqType t1 t2) then t1::(getCommonTypes xs ys) else getCommonTypes xs ys
end.

Fixpoint applySustCtx (c :ctx) (l : list substitution) : ctx := [].

(*Fixpoint w (e : MLexp) (y : list type) : (has_type*list type) :=
match e with
  | Var x => let z := newVT y in (([z], (VarT x),z), y ++ [z])
  | Appl e1 e2 => let new_type := newVT y in (let ((ctx1, e1',t1), types) := (w e1) in
                                              let ((ctx2, e2',t2), types2) := (w e2) in
                                               let umg := ((getCommonTypes ctx1 ctx2) ++ [(Arrow t1 new_type), (Arrow t2 new_type)])in
                                               (((applySystCtx (ctx1 ++ ctx2) umg), AppT e1' e2', new_type),(vrs1 ++ vrs2 ++ [new_type])))
  |
  |
end.*)

Variable err:ctx.
Variable err2:MLexpT.
Variable err3:type.

Fixpoint type_nat (l: list type) : list nat :=
match l with
  | [] => []
  | (TVar n):: xs => n :: (type_nat xs)
  | x::xs => type_nat xs
end.

Fixpoint algoritmoW (e : MLexp) (y : list type) : has_type :=
match e with
  | Var n => let z := newVT (type_nat y) in ht [z] (VarT n) z
  | Appl e1 e2 => let new_type := newVT (type_nat y) in match algoritmoW  e1 [new_type], algoritmoW e2 [new_type] with
                   | ht ctx1 e1' t1, ht ctx2 e2' t2 => ht (ctx1 ++ ctx2 ++ [(Arrow t1 new_type), (Arrow t2 new_type)]) (ApplT e1' e2') new_type
                  end
  | Lambda e' => let new_type := newVT (type_nat y) in match algoritmoW e' [new_type] with
                   | ht ctx1 e1 t1 => ht (ctx1 ++ [(Arrow t1 new_type)]) (LambdaT e1 t1) new_type
                  end
  | Let n e1 e2 => match algoritmoW e1 [], algoritmoW e2 []with
                   | ht ctx1 e1' t1, ht ctx2 e2' t2 => ht (ctx1 ++ ctx2) (LetT n e1' t1 e2') t2
                  end
end.

Theorem erase_e:  forall (e: MLexp) (c: ctx) (t : type) (e' : MLexpT), algoritmoW e [] = ht c e' t -> erase e' = e.
Proof.
  intros.
  induction e.
  inversion H.
  unfold erase.
  trivial.
  inversion H.
Admitted.

Theorem exitens: forall (e: MLexp), exists (c: ctx) (t : type) (e' : MLexpT), algoritmoW e [] = ht c e' t.
Proof.
  intros.
  induction e.
  unfold algoritmoW.
  exists (newVT (type_nat []) :: []).
  exists (newVT (type_nat [])).
  exists (VarT n).
  trivial.