Quelle  W.thy

(* Title:     MiniML/W.thy
   Author:    Dieter Nazareth, Wolfgang Naraschewski and Tobias Nipkow
   Copyright  1996 TU Muenchen
   2024: Conversion to Isar by LCP
*)

section     Muenchen

theory W
  imports MiniML
begin

type_synonym(*  nat"

\<comment> ‹type inference algorithm W›
fun W :: "[expr, ctxt, nat] => result_W" where
  "W (Var i) A n =  
     (if i < length A then Some( id_subst,   
                                 bound_typ_inst (λb. TVar(b+n)) (A!i),   
                                 n + (min_new_bound_tv (A!i)) )  
                      else None)"

| "W (Abs e) A n = ( (S,t,m) := W e ((FVar n)#A) (Suc n);
                     Some( S, (S n) -> t, m) )"

| "W (App e1 e2) A n = ( (S1,t1,m1) := W e1 A n;
                         (S2,t2,m2) := W e2 ($S1 A) m1;
                         U := mgu ($S2 t1) (t2 -> (TVar m2));
                         Some( $U ∘ $S2 ∘ S1, U m2, Suc m2) )"

| "W (LET e1 e2) A n = ( (S1,t1,m1) := W e1 A n;
                         (S2,t2,m2) := W e2 ((gen*
                         ( $2<>,type inference algorithm W› "expr,t nt] => resW"


declare Suc_le_lessD [simp]

inductive_simps _pe_simps                                 >b. TVar(b+n),
  "A ⊨2m): W ($1A 1;U =mu(S 1 t > TVar m2))
  "A <turnstile  S1, t2, m2) )"
  "A ⊨ Var n :: t"
  "Aturnstile LET e1 e2 ::t"


\<comment> ‹the resulting type variable is always greater or equal than the given one›
lemma W_var_ge:
  "W e A n  = Some (S,t,m) \<Longrightarrow> n \<le> m"
proof (induction e arbitrary: A n S t m)
  case Var thus ?case by (auto split: if_splits)
next
  case Abs thus ?case by (fastforce split: split_option_bind_asm)
next
  case App thus ?case by (fastforce split: split_option_bind_asm)
next
  case LET thus ?case by (fastforce split: split_option_bind_asm)
qed

declare W_var_ge [simp] (* FIXME*)

lemma W_var_geD: 
  "Some (S,t,m) = W e A n ==> n≤m"
  by (metis W_var_ge)


lemma new_tv_compatible_W: 
  "new_tv n A ==> Some (S,t,m) = W e A n ==> new_tv m A"
  by (metis W_var_ge new_tv_le)

lemma new_tv_bound_typ_inst_sch: 
  "new_tv n sch ==> new_tv (n + (min_new_bound_tv sch)) (bound_typ_inst (λb. TVar (b + n)) sch)"
proof (induction sch)
  case FVar thus ?case by simp
next
  case BVar thus ?case by simp
next
  case SFun thus ?case by(auto simp add: max_def nle_le dest: new_tv_le add_left_mono)
qed

― ‹resulting type variable is new›
lemma new_tv_W [rule_format]: 
  "∀n A S t m. new_tv n A ⟶ W e A n = Some (S,t,m) ⟶
               new_tv m S ∧ LET e1 e2 ::t"
proof (induction e)
  case"W A nn SomStm <> n <le m"
    by (auto simpary
next
  case
    
    by (metis_Consw_tv_SucW
next
  case App ?case
    apply  (imp split: split_option_bind)
    by (smt (verit, ccfv_threshold) W_var_geD fun.map_comp lessI mgu_new new_tv_Fun new_tv_Suc new_tv_le new_tv_subst new_tv_subst_comp_1 new_tv_subst_scheme_list new_tv_subst_te)
next
  case LET thus ?case
    apply (simp split: split_option_bind)
    by (metis W_var_ge new_tv_Cons new_tv_compatible_gen new_tv_le new_tv_subst_comp_1 new_tv_subst_scheme_list)
qed

lemma free_tv_bound_typ_inst1:
  "v ∉ free_tv sch ==> v ∈ free_tv (bound_typ_inst (TVar ∘ S) sch) ==> ∃x. v = S"
  by (induction sch)auto

lemma  W_var_genew_tv_le)
  "W e A n = Some (S,tm \Longrightarrow
          >free_tv S ∨free_tv t) ==> v∈
proof (induction e arbitrary: n A S t m v)
  case (Var i)
  show ?case
  proof (cases "v
    case 
    with
      by(etis(1) free_tv_nth_A_impl_free_tv_A)
  next
    case False new_tv_W]: 
    with Var show ?thesis
      by (forcempl_free_tv_A_nd_typ_inst1
          split: if_split_asm
  qed
next
  m 
  then re"e(FVn # A) (Suc n) = So (S1, t1, n1)"
    by (metis) .(2) not_None_eq option_bind_eq_None prod_cases3)
  then (, ccfv_threshold .map_complessI new_tv_Fun new_tv_le new_tv_subst_comp_1 new_tv_subst_te
    using?
    by (force:codD)
nextbymetis W_var_genew_tv_Consnew_tv_compatible_gen new_tv_subst_comp_1)
  case (Appfree_tv_bound_typ_inst1
  then show ?case
  proof (clarsimpWeAn  (Stm \>
    fix(<>free_tv v∈ v<n <Longrightarrow free_tvA
    assume v: "v ∈proofsesv in fre(A!i)")
      
      and: "W A n = Some (S', t' )"
      and
      and: "gu $ t') (t1 -> TVar n2) =So S2"
     n1n1 n2"
      using e1 b aut
    show "\in>free_tv
      using v nAS 
proof
       v1\ free_tv ($ S2 ∘
      thenv< e_tv free_tv (λ
        by ( Abs [of"nA"Suc vs
            setD
      moreover
      have "free_tv S2 ⊆ free_tv ($ S2 ∘ S') ∨ free_tv (S2 n2)"
        usingmgu mgu_freeby fastforce
      ultimately
      show "v <> free_tv A"
        using.IH open<n›  codD 
        smt_ee_tv_app_subst_te
            funhaven<>n1
    next
      assume: " in free_tv (S2 n2)"
      then have "v < n1"
        using.premslinarith
      then free_tv S2 <on v<n› e1st_scheme_list 
        using.compct_trans2
      then show "v ∈"
        using App.IH  \>v<n›v<n1›e1bst_scheme_list
        by tit _st
            usingblast
    qed
  u Appv<n› ‹› e1 e2 codD free_tv_app_subst_scheme_list
next
  ( nASt2 n3 v) 
  then show ?case
  proof (p:plit_option_bind_asmsm.it_asm
    fix S1 t1 n2 S2
    assumev< free_tv ($ S2 \<circ> S1 >v \<in> free_tv t2"
      and "v < n"
      and "W nme S12java.lang.StringIndexOutOfBoundsException: Index 40 out of bounds for length 40
      and "W e2 (gen ($ S1 A) t1 # $ S1 A) n2 = Some (S2, t2, n3)"
    with LET.IH
    show"  ome 1
      byeritn_iffvar_geDgeD codD free_tv_app_subst_scheme_list 
          _mp_scheme_list
  
ue2

lemmajava.lang.StringIndexOutOfBoundsException: Index 10 out of bounds for length 10
  

lemmaa


\<comment> \<open>correctness of W with respecto{ext_ype<>
lemma W_correct_lemma: "\<lbrakk>new_tv n A; Some (S,t,m) = W e A n\rbrakk>\<Longrightarrow> $S A \<turnstile> e :: t"
roofinductionduction"arbitraryitraryS mn
  case Var thus
    using is_bound_typ_instance byto f_splits
next
  case showase
    apply (simp split 1e2java.lang.StringIndexOutOfBoundsException: Index 19 out of bounds for length 19
    by (metis AbsI app_subst_Cons and  Sa $)java.lang.StringIndexOutOfBoundsException: Index 56 out of bounds for length 56
        new_tv_FVar new_tv_Suc)
next
  case metis.)r_geDWe21
  then show ?casese
  proof (simp split: split_option_bind_asm prod.splits)
    fix S1 t1 n1 S2 t2 n2 S3
    assume e1: "W e1 AthenhaveveRSa
      and : 2  1n1met2"
      and mgu: "mgu ($ S2 t1) (t2 -> TVar n2) = Some S3"
is
    proof (ruleas_type_type.)
      tis comp_scheme_listt)
        _yburger
      with App show "$
        yiso_typestypes) pebst_Fun ep_subst_TVar_r as_type_cl_subt_comp_scheme_liste_listlist
      show "$proof troree_eq_subst_scheme_listlist
        using e1 e2 mgu App
        by (show"aa$(xjava.lang.StringIndexOutOfBoundsException: Index 31 out of bounds for length 31
            subst_comp_scheme_listnalast
    qed
  qed
next
  ( ) sse
  proof (simp split: bydef <ma \<noteq> na\<close> comp_apply)
    fix(simpimpadde1
    assume "new_tv n A"
      andn( A( #   <> 2:'"
      and e2: "W e2 (gen ($ S1 
    show "$ (<>.  )\>LET e1 e2 :: t"
    of(rule has_typeypeETI
      show "$ (\<lambda>a. $ S2 (S1 a)) <>e1 :: $ S2 t1"
        using LET e1 by (metis (no_types, lifting) has_type_cl_sub subst_comp_scheme_list)
      have "free_tv S2 \<inter> (free_tv t1 - free_tv ($ S1 A)) = {}"
        using e1 e2 LET
        by (smt (verit) DiffD2 Diff_subset free_tv_W free_tv_gen_cons
            free_tv_le_new_tv new_tv_W subsetD weaken_A_Int_B_eq_empty)
      then
      show "gen ($ (\<lambda>a. $ S2 (S1 a)) A) ($ S2 t1) # $ (\<lambda>a. $ S2 (S1 a)) A \<turnstile> e2 :: t"
        using e1 e2 LET
        by (metis app_subst_Cons gen_subst_commutes new_tv_Cons new_tv_W new_tv_compatible_W
            new_tv_compatible_gen new_tv_subst_scheme_list subst_comp_scheme_list)
    qed
  qed
qed

\<comment> \<open>Completeness of W w.r.t. @{text has_type}\<close>
lemma W_complete_lemma: 
  "\<lbrakk>$S' A \<turnstile> e :: t'; new_tv n A\<rbrakk> \<Longrightarrow>
   \<exists>S t. (\<exists>m. W e A n = Some (S,t,m)) \<and> (\<exists>R. $S' A = $R ($S A) \<and> t' = $R t)"
proof (induction e arbitrary: S' A t' n)
  case (Var u) thus ?case
  proof (clarsimp simp add: has_type_simps is_bound_typ_instance)
    fix S :: "nat \<Rightarrow> typ"
    assume A: "new_tv n A" "u < length A"
    show "\<exists>R. $ S' A = $ R A \<and> 
      bound_typ_inst S ($ S' A ! u) = $ R (bound_typ_inst (\<lambda>b. TVar (b + n)) (A ! u))"
    proof (intro exI conjI)
      show "$ S' A = $ (\<lambda>x. if x < n then S' x else S (x - n)) A"
        using Var.prems(2) new_if_subst_type_scheme_list by force
      show "bound_typ_inst S ($ S' A ! u) = $ (\<lambda>x. if x < n then S' x else S (x - n)) (bound_typ_inst (\<lambda>b. TVar (b + n)) (A ! u))"
        using A 
        by (simp add: new_if_subst_type_scheme  new_tv_nth_nat_A o_def nth_subst
                 flip: bound_typ_inst_composed_subst)
    qed
  qed
next
  case (Abs e S' A t' n) 
  then obtain t1 t2 where "t' = t1 -> t2" "mk_scheme t1 # $ S' A \<turnstile> e :: t2"
    by (auto simp: has_type_simps)
  with Abs.prems Abs.IH[of "\<lambda>x. if x=n then t1 else (S' x)" "(FVar n) #A" t2 "Suc n"]
  show ?case
    by (force dest!: mk_scheme_injective)
next
  case (App e1 e2) 
  then obtain t2 where e2t: "$ S' A \<turnstile> e2 :: t2"  and e1t: "$ S' A \<turnstile> e1 :: t2 -> t'"
    by (auto simp: has_type_simps)
  then obtain S t m R 
    where e1: "W e1 A n = Some (S, t, m)" and R: "$ S' A = $ R ($ S A)" "t2 -> t' = $ R t"
    using App by blast
  with App.prems have new_tv_m: "new_tv m ($ S A)"
    by (metis new_tv_W new_tv_compatible_W new_tv_subst_scheme_list)
  with App R
  obtain Sa ta ma Ra where We2: "W e2 ($ S A) m = Some (Sa, ta, ma)"
           and RSA: "$ R ($ S A) = $ Ra ($ Sa ($ S A))" 
           and t2eq: "t2 = $ Ra ta"
    by (metis e2t)
  define F where "F \<equiv> (\<lambda>x. if x = ma then t'
                            else if x \<in> free_tv t - free_tv Sa then R x
                            else Ra x)"
  have "ma \<notin> free_tv t"
    by (metis App.prems(2) W_var_geD We2 e1 new_tv_W new_tv_le
        new_tv_not_free_tv)
  have "$ F (Sa na) = R na" if "na \<in> free_tv t" for na
  proof -
    have "na \<noteq> ma"
      using \<open>ma \<notin> free_tv t\<close> that by auto
    show ?thesis
    proof (cases "na \<in> free_tv Sa")
      case True
      then have "R na = $ Ra (Sa na)"
        by (metis (lifting) App.prems(2) RSA We2 e1 eq_subst_scheme_list_eq_free free_tv_W
            free_tv_le_new_tv new_tv_W subst_comp_scheme_list that)
      then show ?thesis
        by (metis F_def True We2 new_tv_m codD cod_app_subst eq_free_eq_subst_te
            new_tv_W new_tv_not_free_tv weaken_not_elem_A_minus_B)
    next
      case False
      then show ?thesis
        using not_free_impl_id [OF False] \<open>na \<noteq> ma\<close> that
        by (simp add: F_def)
    qed
  qed
  then have *: "$ F ($ Sa t) = $ Ra ta -> t'"
    using eq_free_eq_subst_te subst_comp_te using R t2eq by fastforce
  moreover have "Ra na = F na"
    if "na \<in> free_tv ta" for na
  proof -
    have "na \<noteq> ma"
      using We2 new_tv_W new_tv_m new_tv_not_free_tv that by blast
    show ?thesis
    proof (cases "na \<in> free_tv t - free_tv Sa")
      case True
      then have "$ R ($ S A) = $ (\<lambda>x. $ Ra (Sa x)) ($ S A)"
        by (metis RSA subst_comp_scheme_list)
      then have "Ra na = R na"
        by (metis that App.prems(2) DiffE True Type.app_subst_TVar We2 free_tv_W e1 
            eq_subst_scheme_list_eq_free free_tv_le_new_tv new_tv_W not_free_impl_id)
      with \<open>na \<noteq> ma\<close> True show ?thesis
        by (simp add: F_def)
    next
      case False
      then show ?thesis
        using F_def \<open>na \<noteq> ma\<close> by presburger
    qed
  qed
  ultimately have "$ F ($ Sa t) = $ F (ta -> (TVar ma))"
    by (metis eq_free_eq_subst_te F_def Type.app_subst_Fun Type.app_subst_TVar)
  with mgu_Some obtain Sx Rb where Sx: "mgu ($ Sa t) (ta -> TVar ma) = Some Sx" 
    and Rb: "F = $ Rb \<circ> Sx"
    using mgu_mg by blast
  have t': "t' = $ Rb (Sx ma)"
    by (metis F_def Rb comp_def)
  have "$ Ra ($ Sa ($ S A)) = $ (\<lambda>x. $ Rb (Sx x)) ($ Sa ($ S A))"
  proof (intro eq_free_eq_subst_scheme_list)
    fix na :: nat
    assume na: "na \<in> free_tv ($ Sa ($ S A))"
    then have "ma \<noteq> na"
      by (metis We2 new_tv_W new_tv_compatible_W new_tv_m new_tv_not_free_tv
          new_tv_subst_scheme_list)
    show "Ra na = $ Rb (Sx na)"
    proof (cases "na \<in> free_tv t - free_tv Sa")
      case True
      then have "na \<in> cod Sa \<union> free_tv ($ S A)"
        using free_tv_app_subst_scheme_list na by blast
      with \<open>ma \<noteq> na\<close> Rb show ?thesis
        by (smt (verit, ccfv_SIG) DiffD2 F_def RSA Rb Type.app_subst_TVar Un_iff codD
            comp_apply eq_subst_scheme_list_eq_free not_free_impl_id subst_comp_scheme_list)
    next
      case False
      then show ?thesis
        by (metis F_def Rb \<open>ma \<noteq> na\<close> comp_apply)
    qed
  qed
  then have "$ S' A = $ Rb ($ ($ Sx \<circ> $ Sa \<circ> S) A)"
    by (metis (no_types, lifting) ext R(1) RSA comp_apply fun.map_comp
        subst_comp_scheme_list)
  with We2 Sx show ?case
    by (auto simp add: e1 t')
next
  case (LET e1 e2) 
  then obtain t1 where t1: "$ S' A \<turnstile> e1 :: t1" "gen ($ S' A) t1 # $ S' A \<turnstile> e2 :: t'"
    by (auto simp: has_type_simps)
  then obtain S t m R where e1: "W e1 A n = Some (S, t, m)" "$ S' A = $ R ($ S A)"
      and "gen ($ R ($ S A)) ($ R t) # $ R ($ S A) \<turnstile> e2 :: t'"
    using LET by metis
  then have "$ R (gen ($ S A) t) # $ R ($ S A) \<turnstile> e2 :: t'"
    using gen_bound_typ_instance has_type_le_env le_env_Cons le_env_refl
    by presburger
  moreover
  have "new_tv m (gen ($ S A) t) \<and> new_tv m ($ S A)"
    using LET.prems e1
    by (metis new_tv_W new_tv_compatible_W new_tv_compatible_gen new_tv_subst_scheme_list)
  ultimately show ?case
    using LET.IH(2)[of R "gen ($ S A) t # $ S A" t' m] e1 subst_comp_scheme_list
    by auto
qed

theorem W_complete: 
  "[] \<turnstile> e :: t' \<Longrightarrow> \<exists>S t m. W e [] n = Some(S,t,m) \<and> (\<exists>R. t' = $ R t)"
  by (metis W_complete_lemma app_subst_Nil new_tv_Nil)

end