theory BasicIdentities
  imports "Lexer"
begin

datatype rrexp =
  RZERO
| RONE
| RCHAR char
| RSEQ rrexp rrexp
| RALTS "rrexp list"
| RSTAR rrexp
| RNTIMES rrexp nat

abbreviation
  "RALT r1 r2 \<equiv> RALTS [r1, r2]"

fun
 rnullable :: "rrexp \<Rightarrow> bool"
where
  "rnullable (RZERO) = False"
| "rnullable (RONE) = True"
| "rnullable (RCHAR c) = False"
| "rnullable (RALTS rs) = (\<exists>r \<in> set rs. rnullable r)"
| "rnullable (RSEQ r1 r2) = (rnullable r1 \<and> rnullable r2)"
| "rnullable (RSTAR r) = True"
| "rnullable (RNTIMES r n) = (if n = 0 then True else rnullable r)"

fun
 rder :: "char \<Rightarrow> rrexp \<Rightarrow> rrexp"
where
  "rder c (RZERO) = RZERO"
| "rder c (RONE) = RZERO"
| "rder c (RCHAR d) = (if c = d then RONE else RZERO)"
| "rder c (RALTS rs) = RALTS (map (rder c) rs)"
| "rder c (RSEQ r1 r2) =
     (if rnullable r1
      then RALT   (RSEQ (rder c r1) r2) (rder c r2)
      else RSEQ   (rder c r1) r2)"
| "rder c (RSTAR r) = RSEQ  (rder c r) (RSTAR r)"
| "rder c (RNTIMES r n) = (if n = 0 then RZERO else RSEQ (rder c r) (RNTIMES r (n - 1)))"

fun
  rders :: "rrexp \<Rightarrow> string \<Rightarrow> rrexp"
where
  "rders r [] = r"
| "rders r (c#s) = rders (rder c r) s"

fun rdistinct :: "'a list \<Rightarrow>'a set \<Rightarrow> 'a list"
  where
  "rdistinct [] acc = []"
| "rdistinct (x#xs)  acc =
     (if x \<in> acc then rdistinct xs  acc
      else x # (rdistinct xs  ({x} \<union> acc)))"

lemma rdistinct1:
  assumes "a \<in> acc"
  shows "a \<notin> set (rdistinct rs acc)"
  using assms
  apply(induct rs arbitrary: acc a)
   apply(auto)
  done

lemma rdistinct_does_the_job:
  shows "distinct (rdistinct rs s)"
  apply(induct rs s rule: rdistinct.induct)
  apply(auto simp add: rdistinct1)
  done

lemma rdistinct_concat:
  assumes "set rs \<subseteq> rset"
  shows "rdistinct (rs @ rsa) rset = rdistinct rsa rset"
  using assms
  apply(induct rs)
  apply simp+
  done

lemma distinct_not_exist:
  assumes "a \<notin> set rs"
  shows "rdistinct rs rset = rdistinct rs (insert a rset)"
  using assms
  apply(induct rs arbitrary: rset)
  apply(auto)
  done

lemma rdistinct_on_distinct:
  shows "distinct rs \<Longrightarrow> rdistinct rs {} = rs"
  apply(induct rs)
  apply simp
  using distinct_not_exist by fastforce

lemma distinct_rdistinct_append:
  assumes "distinct rs1" "\<forall>r \<in> set rs1. r \<notin> acc"
  shows "rdistinct (rs1 @ rsa) acc = rs1 @ (rdistinct rsa (acc \<union> set rs1))"
  using assms
  apply(induct rs1 arbitrary: rsa acc)
   apply(auto)[1]
  apply(auto)[1]
  apply(drule_tac x="rsa" in meta_spec)
  apply(drule_tac x="{a} \<union> acc" in meta_spec)
  apply(simp)
  apply(drule meta_mp)
   apply(auto)[1]
  apply(simp)
  done

lemma rdistinct_set_equality1:
  shows "set (rdistinct rs acc) = set rs - acc"
  apply(induct rs acc rule: rdistinct.induct)
  apply(auto)
  done

lemma rdistinct_set_equality:
  shows "set (rdistinct rs {}) = set rs"
  by (simp add: rdistinct_set_equality1)

fun rflts :: "rrexp list \<Rightarrow> rrexp list"
  where
  "rflts [] = []"
| "rflts (RZERO # rs) = rflts rs"
| "rflts ((RALTS rs1) # rs) = rs1 @ rflts rs"
| "rflts (r1 # rs) = r1 # rflts rs"

lemma rflts_def_idiot:
  shows "\<lbrakk> a \<noteq> RZERO; \<nexists>rs1. a = RALTS rs1\<rbrakk> \<Longrightarrow> rflts (a # rs) = a # rflts rs"
  apply(case_tac a)
  apply simp_all
  done

lemma rflts_def_idiot2:
  shows "\<lbrakk>a \<noteq> RZERO; \<nexists>rs1. a = RALTS rs1; a \<in> set rs\<rbrakk> \<Longrightarrow> a \<in> set (rflts rs)"
  apply(induct rs rule: rflts.induct)
  apply(auto)
  done

lemma flts_append:
  shows "rflts (rs1 @ rs2) = rflts rs1 @ rflts rs2"
  apply(induct rs1)
   apply simp
  apply(case_tac a)
       apply simp+
  done

fun rsimp_ALTs :: " rrexp list \<Rightarrow> rrexp"
  where
  "rsimp_ALTs  [] = RZERO"
| "rsimp_ALTs [r] =  r"
| "rsimp_ALTs rs = RALTS rs"

lemma rsimpalts_conscons:
  shows "rsimp_ALTs (r1 # rsa @ r2 # rsb) = RALTS (r1 # rsa @ r2 # rsb)"
  by (metis Nil_is_append_conv list.exhaust rsimp_ALTs.simps(3))

lemma rsimp_alts_equal:
  shows "rsimp_ALTs (rsa @ a # rsb @ a # rsc) = RALTS (rsa @ a # rsb @ a # rsc) "
  by (metis append_Cons append_Nil neq_Nil_conv rsimpalts_conscons)

fun rsimp_SEQ :: " rrexp \<Rightarrow> rrexp \<Rightarrow> rrexp"
  where
  "rsimp_SEQ  RZERO _ = RZERO"
| "rsimp_SEQ  _ RZERO = RZERO"
| "rsimp_SEQ RONE r2 = r2"
| "rsimp_SEQ r1 r2 = RSEQ r1 r2"

fun rsimp :: "rrexp \<Rightarrow> rrexp"
  where
  "rsimp (RSEQ r1 r2) = rsimp_SEQ  (rsimp r1) (rsimp r2)"
| "rsimp (RALTS rs) = rsimp_ALTs  (rdistinct (rflts (map rsimp rs))  {}) "
| "rsimp r = r"

fun
  rders_simp :: "rrexp \<Rightarrow> string \<Rightarrow> rrexp"
where
  "rders_simp r [] = r"
| "rders_simp r (c#s) = rders_simp (rsimp (rder c r)) s"

fun rsize :: "rrexp \<Rightarrow> nat" where
  "rsize RZERO = 1"
| "rsize (RONE) = 1"
| "rsize (RCHAR  c) = 1"
| "rsize (RALTS  rs) = Suc (sum_list (map rsize rs))"
| "rsize (RSEQ  r1 r2) = Suc (rsize r1 + rsize r2)"
| "rsize (RSTAR  r) = Suc (rsize r)"
| "rsize (RNTIMES  r n) = Suc (rsize r) + n"

abbreviation rsizes where
  "rsizes rs \<equiv> sum_list (map rsize rs)"

lemma rder_rsimp_ALTs_commute:
  shows "  (rder x (rsimp_ALTs rs)) = rsimp_ALTs (map (rder x) rs)"
  apply(induct rs)
   apply simp
  apply(case_tac rs)
   apply simp
  apply auto
  done

lemma rsimp_aalts_smaller:
  shows "rsize (rsimp_ALTs  rs) \<le> rsize (RALTS rs)"
  apply(induct rs)
   apply simp
  apply simp
  apply(case_tac "rs = []")
   apply simp
  apply(subgoal_tac "\<exists>rsp ap. rs = ap # rsp")
   apply(erule exE)+
   apply simp
  apply simp
  by(meson neq_Nil_conv)

lemma rSEQ_mono:
  shows "rsize (rsimp_SEQ r1 r2) \<le>rsize (RSEQ r1 r2)"
  apply auto
  apply(induct r1)
       apply auto
      apply(case_tac "r2")
       apply simp_all
     apply(case_tac r2)
          apply simp_all
     apply(case_tac r2)
         apply simp_all
     apply(case_tac r2)
        apply simp_all
     apply(case_tac r2)
         apply simp_all
  apply(case_tac r2)
         apply simp_all
  done

lemma ralts_cap_mono:
  shows "rsize (RALTS rs) \<le> Suc (rsizes rs)"
  by simp

lemma rflts_mono:
  shows "rsizes (rflts rs) \<le> rsizes rs"
  apply(induct rs)
  apply simp
  apply(case_tac "a = RZERO")
   apply simp
  apply(case_tac "\<exists>rs1. a = RALTS rs1")
  apply(erule exE)
   apply simp
  apply(subgoal_tac "rflts (a # rs) = a # (rflts rs)")
   prefer 2

  using rflts_def_idiot apply blast
  apply simp
  done

lemma rdistinct_smaller:
  shows "rsizes (rdistinct rs ss) \<le> rsizes rs"
  apply (induct rs arbitrary: ss)
   apply simp
  by (simp add: trans_le_add2)

lemma rsimp_alts_mono :
  shows "\<And>x. (\<And>xa. xa \<in> set x \<Longrightarrow> rsize (rsimp xa) \<le> rsize xa)  \<Longrightarrow>
      rsize (rsimp_ALTs (rdistinct (rflts (map rsimp x)) {})) \<le> Suc (rsizes x)"
  apply(subgoal_tac "rsize (rsimp_ALTs (rdistinct (rflts (map rsimp x)) {} ))
                    \<le> rsize (RALTS (rdistinct (rflts (map rsimp x)) {} ))")
  prefer 2
  using rsimp_aalts_smaller apply auto[1]
  apply(subgoal_tac "rsize (RALTS (rdistinct (rflts (map rsimp x)) {})) \<le>Suc (rsizes (rdistinct (rflts (map rsimp x)) {}))")
  prefer 2
  using ralts_cap_mono apply blast
  apply(subgoal_tac "rsizes (rdistinct (rflts (map rsimp x)) {}) \<le> rsizes (rflts (map rsimp x))")
  prefer 2
  using rdistinct_smaller apply presburger
  apply(subgoal_tac "rsizes (rflts (map rsimp x)) \<le> rsizes (map rsimp x)")
  prefer 2
  using rflts_mono apply blast
  apply(subgoal_tac "rsizes (map rsimp x) \<le> rsizes x")
  prefer 2

  apply (simp add: sum_list_mono)
  by linarith

lemma rsimp_mono:
  shows "rsize (rsimp r) \<le> rsize r"
  apply(induct r)
  apply simp_all
  apply(subgoal_tac "rsize (rsimp_SEQ (rsimp r1) (rsimp r2)) \<le> rsize (RSEQ (rsimp r1) (rsimp r2))")
    apply force
  using rSEQ_mono
   apply presburger
  using rsimp_alts_mono by auto

lemma idiot:
  shows "rsimp_SEQ RONE r = r"
  apply(case_tac r)
       apply simp_all
  done

lemma idiot2:
  shows " \<lbrakk>r1 \<noteq> RZERO; r1 \<noteq> RONE;r2 \<noteq> RZERO\<rbrakk>
    \<Longrightarrow> rsimp_SEQ r1 r2 = RSEQ r1 r2"
  apply(case_tac r1)
       apply(case_tac r2)
  apply simp_all
     apply(case_tac r2)
  apply simp_all
     apply(case_tac r2)
  apply simp_all
   apply(case_tac r2)
  apply simp_all
  apply(case_tac r2)
         apply simp_all
apply(case_tac r2)
         apply simp_all
  done

lemma rders__onechar:
  shows " (rders_simp r [c]) =  (rsimp (rders r [c]))"
  by simp

lemma rders_append:
  "rders c (s1 @ s2) = rders (rders c s1) s2"
  apply(induct s1 arbitrary: c s2)
  apply(simp_all)
  done

lemma rders_simp_append:
  "rders_simp c (s1 @ s2) = rders_simp (rders_simp c s1) s2"
  apply(induct s1 arbitrary: c s2)
   apply(simp_all)
  done

lemma rders_simp_one_char:
  shows "rders_simp r [c] = rsimp (rder c r)"
  apply auto
  done

fun nonalt :: "rrexp \<Rightarrow> bool"
  where
  "nonalt (RALTS  rs) = False"
| "nonalt r = True"

fun good :: "rrexp \<Rightarrow> bool" where
  "good RZERO = False"
| "good (RONE) = True"
| "good (RCHAR c) = True"
| "good (RALTS []) = False"
| "good (RALTS [r]) = False"
| "good (RALTS (r1 # r2 # rs)) = ((distinct ( (r1 # r2 # rs))) \<and>(\<forall>r' \<in> set (r1 # r2 # rs). good r' \<and> nonalt r'))"
| "good (RSEQ RZERO _) = False"
| "good (RSEQ RONE _) = False"
| "good (RSEQ  _ RZERO) = False"
| "good (RSEQ r1 r2) = (good r1 \<and> good r2)"
| "good (RSTAR r) = True"
| "good (RNTIMES r n) = True"

lemma  k0a:
  shows "rflts [RALTS rs] =   rs"
  apply(simp)
  done

lemma bbbbs:
  assumes "good r" "r = RALTS rs"
  shows "rsimp_ALTs  (rflts [r]) = RALTS rs"
  using  assms
  by (metis good.simps(4) good.simps(5) k0a rsimp_ALTs.elims)

lemma bbbbs1:
  shows "nonalt r \<or> (\<exists> rs. r  = RALTS  rs)"
  by (meson nonalt.elims(3))

lemma good0:
  assumes "rs \<noteq> Nil" "\<forall>r \<in> set rs. nonalt r" "distinct rs"
  shows "good (rsimp_ALTs rs) \<longleftrightarrow> (\<forall>r \<in> set rs. good r)"
  using  assms
  apply(induct  rs rule: rsimp_ALTs.induct)
  apply(auto)
  done

lemma flts1:
  assumes "good r"
  shows "rflts [r] \<noteq> []"
  using  assms
  apply(induct r)
       apply(simp_all)
  using good.simps(4) by blast

lemma flts2:
  assumes "good r"
  shows "\<forall>r' \<in> set (rflts [r]). good r' \<and> nonalt r'"
  using  assms
  apply(induct r)
       apply(simp)
      apply(simp)
     apply(simp)
    prefer 2
    apply(simp)
    apply(auto)[1]

     apply (metis flts1 good.simps(5) good.simps(6) k0a neq_Nil_conv)
    apply (metis flts1 good.simps(5) good.simps(6) k0a neq_Nil_conv)
   apply fastforce
   apply(simp)
  by simp

lemma flts3:
  assumes "\<forall>r \<in> set rs. good r \<or> r = RZERO"
  shows "\<forall>r \<in> set (rflts rs). good r"
  using  assms
  apply(induct rs arbitrary: rule: rflts.induct)
        apply(simp_all)
  by (metis UnE flts2 k0a)

lemma  k0:
  shows "rflts (r # rs1) = rflts [r] @ rflts rs1"
  apply(induct r arbitrary: rs1)
   apply(auto)
  done

lemma good_SEQ:
  assumes "r1 \<noteq> RZERO" "r2 \<noteq> RZERO" " r1 \<noteq> RONE"
  shows "good (RSEQ r1 r2) = (good r1 \<and> good r2)"
  using assms
  apply(case_tac r1)
       apply(simp_all)
  apply(case_tac r2)
          apply(simp_all)
  apply(case_tac r2)
         apply(simp_all)
  apply(case_tac r2)
        apply(simp_all)
  apply(case_tac r2)
         apply(simp_all)
apply(case_tac r2)
         apply(simp_all)
  done

lemma rsize0:
  shows "0 < rsize r"
  apply(induct  r)
       apply(auto)
  done

fun nonnested :: "rrexp \<Rightarrow> bool"
  where
  "nonnested (RALTS []) = True"
| "nonnested (RALTS ((RALTS rs1) # rs2)) = False"
| "nonnested (RALTS (r # rs2)) = nonnested (RALTS rs2)"
| "nonnested r = True"

lemma  k00:
  shows "rflts (rs1 @ rs2) = rflts rs1 @ rflts rs2"
  apply(induct rs1 arbitrary: rs2)
   apply(auto)
  by (metis append.assoc k0)

lemma k0b:
  assumes "nonalt r" "r \<noteq> RZERO"
  shows "rflts [r] = [r]"
  using assms
  apply(case_tac  r)
  apply(simp_all)
  done

lemma nn1qq:
  assumes "nonnested (RALTS rs)"
  shows "\<nexists> rs1. RALTS rs1 \<in> set rs"
  using assms
  apply(induct rs rule: rflts.induct)
  apply(auto)
  done

lemma n0:
  shows "nonnested (RALTS rs) \<longleftrightarrow> (\<forall>r \<in> set rs. nonalt r)"
  apply(induct rs )
   apply(auto)
    apply (metis list.set_intros(1) nn1qq nonalt.elims(3))
  apply (metis nonalt.elims(2) nonnested.simps(3) nonnested.simps(4) nonnested.simps(5) nonnested.simps(6) nonnested.simps(7) nonnested.simps(8))
  using bbbbs1 apply fastforce
  by (metis bbbbs1 list.set_intros(2) nn1qq)

lemma nn1c:
  assumes "\<forall>r \<in> set rs. nonnested r"
  shows "\<forall>r \<in> set (rflts rs). nonalt r"
  using assms
  apply(induct rs rule: rflts.induct)
        apply(auto)
  using n0 by blast

lemma nn1bb:
  assumes "\<forall>r \<in> set rs. nonalt r"
  shows "nonnested (rsimp_ALTs  rs)"
  using assms
  apply(induct  rs rule: rsimp_ALTs.induct)
    apply(auto)
  using nonalt.simps(1) nonnested.elims(3) apply blast
  using n0 by auto

lemma bsimp_ASEQ0:
  shows "rsimp_SEQ  r1 RZERO = RZERO"
  apply(induct r1)
  apply(auto)
  done

lemma nn1b:
  shows "nonnested (rsimp r)"
  apply(induct r)
       apply(simp_all)
  apply(case_tac "rsimp r1 = RZERO")
    apply(simp)
 apply(case_tac "rsimp r2 = RZERO")
   apply(simp)
    apply(subst bsimp_ASEQ0)
  apply(simp)
  apply(case_tac "\<exists>bs. rsimp r1 = RONE")
    apply(auto)[1]
  using idiot apply fastforce
  apply (simp add: idiot2)
  by (metis (mono_tags, lifting) image_iff list.set_map nn1bb nn1c rdistinct_set_equality)

lemma nonalt_flts_rd:
  shows "\<lbrakk>xa \<in> set (rdistinct (rflts (map rsimp rs)) {})\<rbrakk>
       \<Longrightarrow> nonalt xa"
  by (metis Diff_empty ex_map_conv nn1b nn1c rdistinct_set_equality1)

lemma rsimpalts_implies1:
  shows " rsimp_ALTs (a # rdistinct rs {a}) = RZERO \<Longrightarrow> a = RZERO"
  using rsimp_ALTs.elims by auto

lemma rsimpalts_implies2:
  shows "rsimp_ALTs (a # rdistinct rs rset) = RZERO \<Longrightarrow> rdistinct rs rset = []"
  by (metis append_butlast_last_id rrexp.distinct(7) rsimpalts_conscons)

lemma rsimpalts_implies21:
  shows "rsimp_ALTs (a # rdistinct rs {a}) = RZERO \<Longrightarrow> rdistinct rs {a} = []"
  using rsimpalts_implies2 by blast

lemma bsimp_ASEQ2:
  shows "rsimp_SEQ RONE r2 =  r2"
  apply(induct r2)
  apply(auto)
  done

lemma elem_smaller_than_set:
  shows "xa \<in> set  list \<Longrightarrow> rsize xa < Suc (rsizes list)"
  apply(induct list)
   apply simp
  by (metis image_eqI le_imp_less_Suc list.set_map member_le_sum_list)

lemma rsimp_list_mono:
  shows "rsizes (map rsimp rs) \<le> rsizes rs"
  apply(induct rs)
   apply simp+
  by (simp add: add_mono_thms_linordered_semiring(1) rsimp_mono)

(*says anything coming out of simp+flts+db will be good*)
lemma good2_obv_simplified:
  shows " \<lbrakk>\<forall>y. rsize y < Suc (rsizes rs) \<longrightarrow> good (rsimp y) \<or> rsimp y = RZERO;
           xa \<in> set (rdistinct (rflts (map rsimp rs)) {}); good (rsimp xa) \<or> rsimp xa = RZERO\<rbrakk> \<Longrightarrow> good xa"
  apply(subgoal_tac " \<forall>xa' \<in> set (map rsimp rs). good xa' \<or> xa' = RZERO")
  prefer 2
   apply (simp add: elem_smaller_than_set)
  by (metis Diff_empty flts3 rdistinct_set_equality1)

thm Diff_empty flts3 rdistinct_set_equality1

lemma good1:
  shows "good (rsimp a) \<or> rsimp a = RZERO"
  apply(induct a taking: rsize rule: measure_induct)
  apply(case_tac x)
  apply(simp)
  apply(simp)
  apply(simp)
  prefer 3
    apply(simp)
   prefer 2
   apply(simp only:)
   apply simp
  apply (smt (verit, ccfv_threshold) add_mono_thms_linordered_semiring(1) elem_smaller_than_set good0 good2_obv_simplified le_eq_less_or_eq nonalt_flts_rd order_less_trans plus_1_eq_Suc rdistinct_does_the_job rdistinct_smaller rflts_mono rsimp_ALTs.simps(1) rsimp_list_mono)
  apply simp
  apply(subgoal_tac "good (rsimp x41) \<or> rsimp x41 = RZERO")
   apply(subgoal_tac "good (rsimp x42) \<or> rsimp x42 = RZERO")
    apply(case_tac "rsimp x41 = RZERO")
     apply simp
    apply(case_tac "rsimp x42 = RZERO")
     apply simp
  using bsimp_ASEQ0 apply blast
    apply(subgoal_tac "good (rsimp x41)")
     apply(subgoal_tac "good (rsimp x42)")
      apply simp
  apply (metis bsimp_ASEQ2 good_SEQ idiot2)
  apply blast
  apply fastforce
  using less_add_Suc2 apply blast
  using less_iff_Suc_add apply blast
  using good.simps(45) rsimp.simps(7) by presburger

fun
  RL :: "rrexp \<Rightarrow> string set"
where
  "RL (RZERO) = {}"
| "RL (RONE) = {[]}"
| "RL (RCHAR c) = {[c]}"
| "RL (RSEQ r1 r2) = (RL r1) ;; (RL r2)"
| "RL (RALTS rs) = (\<Union> (set (map RL rs)))"
| "RL (RSTAR r) = (RL r)\<star>"
| "RL (RNTIMES r n) = (RL r) ^^ n"

lemma pow_rempty_iff:
  shows "[] \<in> (RL r) ^^ n \<longleftrightarrow> (if n = 0 then True else [] \<in> (RL r))"
  by (induct n) (auto simp add: Sequ_def)

lemma RL_rnullable:
  shows "rnullable r = ([] \<in> RL r)"
  apply(induct r)
        apply(auto simp add: Sequ_def pow_rempty_iff)
  done

lemma concI_if_Nil1: "[] \<in> A \<Longrightarrow> xs : B \<Longrightarrow> xs \<in> A ;; B"
by (metis append_Nil concI)

lemma empty_pow_add:
  fixes A::"string set"
  assumes "[] \<in> A" "s \<in> A ^^ n"
  shows "s \<in> A ^^ (n + m)"
  using assms
  apply(induct m arbitrary: n)
   apply(auto simp add: Sequ_def)
  done

(*
lemma der_pow:
  shows "Der c (A ^^ n) = (if n = 0 then {} else (Der c A) ;; (A ^^ (n - 1)))"
  apply(induct n arbitrary: A)
   apply(auto)
  by (smt (verit, best) Suc_pred concE concI concI_if_Nil2 conc_pow_comm lang_pow.simps(2))
*)

lemma RL_rder:
  shows "RL (rder c r) = Der c (RL r)"
  apply(induct r)
  apply(auto simp add: Sequ_def Der_def)[5]
        apply (metis append_Cons)
  using RL_rnullable apply blast
  apply (metis append_eq_Cons_conv)
  apply (metis append_Cons)
    apply (metis RL_rnullable append_eq_Cons_conv)
  apply simp
  apply(simp)
  done

lemma RL_rsimp_RSEQ:
  shows "RL (rsimp_SEQ r1 r2) = (RL r1 ;; RL r2)"
  apply(induct r1 r2 rule: rsimp_SEQ.induct)
  apply(simp_all)
  done

lemma RL_rsimp_RALTS:
  shows "RL (rsimp_ALTs rs) = (\<Union> (set (map RL rs)))"
  apply(induct rs rule: rsimp_ALTs.induct)
  apply(simp_all)
  done

lemma RL_rsimp_rdistinct:
  shows "(\<Union> (set (map RL (rdistinct rs {})))) = (\<Union> (set (map RL rs)))"
  apply(auto)
  apply (metis Diff_iff rdistinct_set_equality1)
  by (metis Diff_empty rdistinct_set_equality1)

lemma RL_rsimp_rflts:
  shows "(\<Union> (set (map RL (rflts rs)))) = (\<Union> (set (map RL rs)))"
  apply(induct rs rule: rflts.induct)
  apply(simp_all)
  done

lemma RL_rsimp:
  shows "RL r = RL (rsimp r)"
  apply(induct r rule: rsimp.induct)
       apply(auto simp add: Sequ_def RL_rsimp_RSEQ)
  using RL_rsimp_RALTS RL_rsimp_rdistinct RL_rsimp_rflts apply auto[1]
  by (smt (verit, del_insts) RL_rsimp_RALTS RL_rsimp_rdistinct RL_rsimp_rflts UN_E image_iff list.set_map)

lemma qqq1:
  shows "RZERO \<notin> set (rflts (map rsimp rs))"
  by (metis ex_map_conv flts3 good.simps(1) good1)

fun nonazero :: "rrexp \<Rightarrow> bool"
  where
  "nonazero RZERO = False"
| "nonazero r = True"

lemma flts_single1:
  assumes "nonalt r" "nonazero r"
  shows "rflts [r] = [r]"
  using assms
  apply(induct r)
  apply(auto)
  done

lemma nonalt0_flts_keeps:
  shows "(a \<noteq> RZERO) \<and> (\<forall>rs. a \<noteq> RALTS rs) \<Longrightarrow> rflts (a # xs) = a # rflts xs"
  apply(case_tac a)
       apply simp+
  done

lemma nonalt0_fltseq:
  shows "\<forall>r \<in> set rs. r \<noteq> RZERO \<and> nonalt r \<Longrightarrow> rflts rs = rs"
  apply(induct rs)
   apply simp
  apply(case_tac "a = RZERO")
   apply fastforce
  apply(case_tac "\<exists>rs1. a = RALTS rs1")
   apply(erule exE)
   apply simp+
  using nonalt0_flts_keeps by presburger

lemma goodalts_nonalt:
  shows "good (RALTS rs) \<Longrightarrow> rflts rs = rs"
  apply(induct x == "RALTS rs" arbitrary: rs rule: good.induct)
    apply simp

  using good.simps(5) apply blast
  apply simp
  apply(case_tac "r1 = RZERO")
  using good.simps(1) apply force
  apply(case_tac "r2 = RZERO")
  using good.simps(1) apply force
  apply(subgoal_tac "rflts (r1 # r2 # rs) = r1 # r2 # rflts rs")
  prefer 2
   apply (metis nonalt.simps(1) rflts_def_idiot)
  apply(subgoal_tac "\<forall>r \<in> set rs. r \<noteq> RZERO \<and> nonalt r")
   apply(subgoal_tac "rflts rs = rs")
    apply presburger
  using nonalt0_fltseq apply presburger
  using good.simps(1) by blast

lemma test:
  assumes "good r"
  shows "rsimp r = r"

  using assms
  apply(induct rule: good.induct)
                      apply simp
                      apply simp
                      apply simp
                      apply simp
                      apply simp
                      apply(subgoal_tac "distinct (r1 # r2 # rs)")
  prefer 2
  using good.simps(6) apply blast
  apply(subgoal_tac "rflts (r1 # r2 # rs ) = r1 # r2 # rs")
  prefer 2
  using goodalts_nonalt apply blast

                      apply(subgoal_tac "r1 \<noteq> r2")
  prefer 2
                      apply (meson distinct_length_2_or_more)
                      apply(subgoal_tac "r1 \<notin> set rs")
                      apply(subgoal_tac "r2 \<notin> set rs")
                      apply(subgoal_tac "\<forall>r \<in> set rs. rsimp r = r")
                      apply(subgoal_tac "map rsimp rs = rs")
  apply simp
                      apply(subgoal_tac "\<forall>r \<in>  {r1, r2}. r \<notin> set rs")
  apply (metis distinct_not_exist rdistinct_on_distinct)

                      apply blast
                      apply (meson map_idI)
                      apply (metis good.simps(6) insert_iff list.simps(15))

  apply (meson distinct.simps(2))
                      apply (simp add: distinct_length_2_or_more)
                      apply simp+
  done

lemma rsimp_idem:
  shows "rsimp (rsimp r) = rsimp r"
  using test good1
  by force

corollary rsimp_inner_idem4:
  shows "rsimp r = RALTS rs \<Longrightarrow> rflts rs = rs"
  by (metis good1 goodalts_nonalt rrexp.simps(12))

lemma head_one_more_simp:
  shows "map rsimp (r # rs) = map rsimp (( rsimp r) # rs)"
  by (simp add: rsimp_idem)

lemma der_simp_nullability:
  shows "rnullable r = rnullable (rsimp r)"
  using RL_rnullable RL_rsimp by auto

lemma no_alt_short_list_after_simp:
  shows "RALTS rs = rsimp r \<Longrightarrow> rsimp_ALTs rs = RALTS rs"
  by (metis bbbbs good1 k0a rrexp.simps(12))

lemma no_further_dB_after_simp:
  shows "RALTS rs = rsimp r \<Longrightarrow> rdistinct rs {} = rs"
  apply(subgoal_tac "good (RALTS rs)")
  apply(subgoal_tac "distinct rs")
  using rdistinct_on_distinct apply blast
  apply (metis distinct.simps(1) distinct.simps(2) empty_iff good.simps(6) list.exhaust set_empty2)
  using good1 by fastforce

lemma idem_after_simp1:
  shows "rsimp_ALTs (rdistinct (rflts [rsimp aa]) {}) = rsimp aa"
  apply(case_tac "rsimp aa")
  apply simp+
  apply (metis no_alt_short_list_after_simp no_further_dB_after_simp)
   apply(simp)
  apply(simp)
  done

lemma identity_wwo0:
  shows "rsimp (rsimp_ALTs (RZERO # rs)) = rsimp (rsimp_ALTs rs)"
  apply (metis idem_after_simp1 list.exhaust list.simps(8) list.simps(9) rflts.simps(2) rsimp.simps(2) rsimp.simps(3) rsimp_ALTs.simps(1) rsimp_ALTs.simps(2) rsimp_ALTs.simps(3))
  done

lemma distinct_removes_last:
  shows "\<lbrakk>a \<in> set as\<rbrakk>
    \<Longrightarrow> rdistinct as rset = rdistinct (as @ [a]) rset"
and "rdistinct (ab # as @ [ab]) rset1 = rdistinct (ab # as) rset1"
  apply(induct as arbitrary: rset ab rset1 a)
     apply simp
    apply simp
  apply(case_tac "aa \<in> rset")
   apply(case_tac "a = aa")
  apply (metis append_Cons)
    apply simp
   apply(case_tac "a \<in> set as")
  apply (metis append_Cons rdistinct.simps(2) set_ConsD)
   apply(case_tac "a = aa")
    prefer 2
    apply simp
   apply (metis append_Cons)
  apply(case_tac "ab \<in> rset1")
  prefer 2
   apply(subgoal_tac "rdistinct (ab # (a # as) @ [ab]) rset1 =
               ab # (rdistinct ((a # as) @ [ab]) (insert ab rset1))")
  prefer 2
  apply force
  apply(simp only:)
     apply(subgoal_tac "rdistinct (ab # a # as) rset1 = ab # (rdistinct (a # as) (insert ab rset1))")
    apply(simp only:)
    apply(subgoal_tac "rdistinct ((a # as) @ [ab]) (insert ab rset1) = rdistinct (a # as) (insert ab rset1)")
     apply blast
    apply(case_tac "a \<in> insert ab rset1")
     apply simp
     apply (metis insertI1)
    apply simp
    apply (meson insertI1)
   apply simp
  apply(subgoal_tac "rdistinct ((a # as) @ [ab]) rset1 = rdistinct (a # as) rset1")
   apply simp
  by (metis append_Cons insert_iff insert_is_Un rdistinct.simps(2))

lemma distinct_removes_middle:
  shows  "\<lbrakk>a \<in> set as\<rbrakk>
    \<Longrightarrow> rdistinct (as @ as2) rset = rdistinct (as @ [a] @ as2) rset"
and "rdistinct (ab # as @ [ab] @ as3) rset1 = rdistinct (ab # as @ as3) rset1"
   apply(induct as arbitrary: rset rset1 ab as2 as3 a)
     apply simp
    apply simp
   apply(case_tac "a \<in> rset")
    apply simp
    apply metis
   apply simp
   apply (metis insertI1)
  apply(case_tac "a = ab")
   apply simp
   apply(case_tac "ab \<in> rset")
    apply simp
    apply presburger
   apply (meson insertI1)
  apply(case_tac "a \<in> rset")
  apply (metis (no_types, opaque_lifting) Un_insert_left append_Cons insert_iff rdistinct.simps(2) sup_bot_left)
  apply(case_tac "ab \<in> rset")
  apply simp
   apply (meson insert_iff)
  apply simp
  by (metis insertI1)

lemma distinct_removes_middle3:
  shows  "\<lbrakk>a \<in> set as\<rbrakk>
    \<Longrightarrow> rdistinct (as @ a #as2) rset = rdistinct (as @ as2) rset"
  using distinct_removes_middle(1) by fastforce

lemma distinct_removes_list:
  shows "\<lbrakk> \<forall>r \<in> set rs. r \<in> set as\<rbrakk> \<Longrightarrow> rdistinct (as @ rs) {} = rdistinct as {}"
  apply(induct rs)
   apply simp+
  apply(subgoal_tac "rdistinct (as @ a # rs) {} = rdistinct (as @ rs) {}")
   prefer 2
  apply (metis append_Cons append_Nil distinct_removes_middle(1))
  by presburger

lemma spawn_simp_rsimpalts:
  shows "rsimp (rsimp_ALTs rs) = rsimp (rsimp_ALTs (map rsimp rs))"
  apply(cases rs)
   apply simp
  apply(case_tac list)
   apply simp
   apply(subst rsimp_idem[symmetric])
   apply simp
  apply(subgoal_tac "rsimp_ALTs rs = RALTS rs")
   apply(simp only:)
   apply(subgoal_tac "rsimp_ALTs (map rsimp rs) = RALTS (map rsimp rs)")
    apply(simp only:)
  prefer 2
  apply simp
   prefer 2
  using rsimp_ALTs.simps(3) apply presburger
  apply auto
  apply(subst rsimp_idem)+
  by (metis comp_apply rsimp_idem)

lemma simp_singlealt_flatten:
  shows "rsimp (RALTS [RALTS rsa]) = rsimp (RALTS (rsa @ []))"
  apply(induct rsa)
   apply simp
  apply simp
  by (metis idem_after_simp1 list.simps(9) rsimp.simps(2))

lemma good1_rsimpalts:
  shows "rsimp r = RALTS rs \<Longrightarrow> rsimp_ALTs rs = RALTS rs"
  by (metis no_alt_short_list_after_simp)

lemma good1_flatten:
  shows "\<lbrakk> rsimp r =  (RALTS rs1)\<rbrakk>
       \<Longrightarrow> rflts (rsimp_ALTs rs1 # map rsimp rsb) = rflts (rs1 @ map rsimp rsb)"
  apply(subst good1_rsimpalts)
   apply simp+
  apply(subgoal_tac "rflts (rs1 @ map rsimp rsb) = rs1 @ rflts (map rsimp rsb)")
   apply simp
  using flts_append rsimp_inner_idem4 by presburger

lemma flatten_rsimpalts:
  shows "rflts (rsimp_ALTs (rdistinct (rflts (map rsimp rsa)) {}) # map rsimp rsb) =
         rflts ( (rdistinct (rflts (map rsimp rsa)) {}) @ map rsimp rsb)"
  apply(case_tac "map rsimp rsa")
   apply simp
  apply(case_tac "list")
   apply simp
   apply(case_tac a)
        apply simp+
    apply(rename_tac rs1)
    apply (metis good1_flatten map_eq_Cons_D no_further_dB_after_simp)

  apply simp

  apply(subgoal_tac "\<forall>r \<in> set( rflts (map rsimp rsa)). good r")
   apply(case_tac "rdistinct (rflts (map rsimp rsa)) {}")
     apply simp
  apply auto[1]
  apply simp
  apply(simp)
   apply(case_tac "lista")
  apply simp_all

   apply (metis append_Cons append_Nil good1_flatten rflts.simps(2) rsimp.simps(2) rsimp_ALTs.elims)
   by (metis (no_types, opaque_lifting) append_Cons append_Nil good1_flatten rflts.simps(2) rsimp.simps(2) rsimp_ALTs.elims)

lemma last_elem_out:
  shows "\<lbrakk>x \<notin> set xs; x \<notin> rset \<rbrakk> \<Longrightarrow> rdistinct (xs @ [x]) rset = rdistinct xs rset @ [x]"
  apply(induct xs arbitrary: rset)
  apply simp+
  done

lemma rdistinct_concat_general:
  shows "rdistinct (rs1 @ rs2) {} = (rdistinct rs1 {}) @ (rdistinct rs2 (set rs1))"
  apply(induct rs1 arbitrary: rs2 rule: rev_induct)
   apply simp
  apply(drule_tac x = "x # rs2" in meta_spec)
  apply simp
  apply(case_tac "x \<in> set xs")
   apply simp

   apply (simp add: distinct_removes_middle3 insert_absorb)
  apply simp
  by (simp add: last_elem_out)

lemma distinct_once_enough:
  shows "rdistinct (rs @ rsa) {} = rdistinct (rdistinct rs {} @ rsa) {}"
  apply(subgoal_tac "distinct (rdistinct rs {})")
   apply(subgoal_tac
" rdistinct (rdistinct rs {} @ rsa) {} = rdistinct rs {} @ (rdistinct rsa (set rs))")
  apply(simp only:)
  using rdistinct_concat_general apply blast
  apply (simp add: distinct_rdistinct_append rdistinct_set_equality1)
  by (simp add: rdistinct_does_the_job)

lemma simp_flatten:
  shows "rsimp (RALTS ((RALTS rsa) # rsb)) = rsimp (RALTS (rsa @ rsb))"
  apply simp
  apply(subst flatten_rsimpalts)
  apply(simp add: flts_append)
  by (metis Diff_empty distinct_once_enough flts_append nonalt0_fltseq nonalt_flts_rd qqq1 rdistinct_set_equality1)

lemma basic_rsimp_SEQ_property1:
  shows "rsimp_SEQ RONE r = r"
  by (simp add: idiot)

lemma basic_rsimp_SEQ_property3:
  shows "rsimp_SEQ r RZERO = RZERO"
  using rsimp_SEQ.elims by blast

fun vsuf :: "char list \<Rightarrow> rrexp \<Rightarrow> char list list" where
"vsuf [] _ = []"
|"vsuf (c#cs) r1 = (if (rnullable r1) then  (vsuf cs (rder c r1)) @ [c # cs]
                                      else  (vsuf cs (rder c r1))
                   ) "

fun star_update :: "char \<Rightarrow> rrexp \<Rightarrow> char list list \<Rightarrow> char list list" where
"star_update c r [] = []"
|"star_update c r (s # Ss) = (if (rnullable (rders r s))
                                then (s@[c]) # [c] # (star_update c r Ss)
                               else   (s@[c]) # (star_update c r Ss) )"

fun star_updates :: "char list \<Rightarrow> rrexp \<Rightarrow> char list list \<Rightarrow> char list list"
  where
"star_updates [] r Ss = Ss"
| "star_updates (c # cs) r Ss = star_updates cs r (star_update c r Ss)"

lemma stupdates_append: shows
"star_updates (s @ [c]) r Ss = star_update c r (star_updates s r Ss)"
  apply(induct s arbitrary: Ss)
   apply simp
  apply simp
  done

lemma flts_removes0:
  shows "  rflts (rs @ [RZERO])  =
           rflts rs"
  apply(induct rs)
   apply simp
  by (metis append_Cons rflts.simps(2) rflts.simps(3) rflts_def_idiot)

lemma rflts_spills_last:
  shows "rflts (rs1 @ [RALTS rs]) = rflts rs1 @ rs"
  apply (induct rs1 rule: rflts.induct)
  apply(auto)
  done

lemma flts_keeps1:
  shows "rflts (rs @ [RONE]) = rflts rs @ [RONE]"
  apply (induct rs rule: rflts.induct)
  apply(auto)
  done

lemma flts_keeps_others:
  shows "\<lbrakk>a \<noteq> RZERO; \<nexists>rs1. a = RALTS rs1\<rbrakk> \<Longrightarrow>rflts (rs @ [a]) = rflts rs @ [a]"
  apply(induct rs rule: rflts.induct)
  apply(auto)
  by (meson k0b nonalt.elims(3))

lemma spilled_alts_contained:
  shows "\<lbrakk>a = RALTS rs ; a \<in> set rs1\<rbrakk> \<Longrightarrow> \<forall>r \<in> set rs. r \<in> set (rflts rs1)"
  apply(induct rs1)
   apply simp
  apply(case_tac "a = aa")
   apply simp
  apply(subgoal_tac " a \<in> set rs1")
  prefer 2
   apply (meson set_ConsD)
  apply(case_tac aa)
  using rflts.simps(2) apply presburger
      apply fastforce
  apply fastforce
  apply fastforce
  apply fastforce
  apply fastforce
  by simp

lemma distinct_removes_duplicate_flts:
  shows " a \<in> set rsa
       \<Longrightarrow> rdistinct (rflts (map rsimp rsa @ [rsimp a])) {} =
           rdistinct (rflts (map rsimp rsa)) {}"
  apply(subgoal_tac "rsimp a \<in> set (map rsimp rsa)")
  prefer 2
   apply simp
  apply(induct "rsimp a")
       apply simp
  using flts_removes0 apply presburger
      apply(subgoal_tac " rdistinct (rflts (map rsimp rsa @ [rsimp a])) {} =
                          rdistinct (rflts (map rsimp rsa @ [RONE])) {}")
      apply (simp only:)
        apply(subst flts_keeps1)
  apply (metis distinct_removes_last(1) flts_append in_set_conv_decomp rflts.simps(4))
      apply presburger
        apply(subgoal_tac " rdistinct (rflts (map rsimp rsa @ [rsimp a]))    {} =
                            rdistinct ((rflts (map rsimp rsa)) @ [RCHAR x]) {}")
      apply (simp only:)
       prefer 2
       apply (metis flts_append rflts.simps(1) rflts.simps(5))
  apply (metis distinct_removes_last(1) rflts_def_idiot2 rrexp.distinct(25) rrexp.distinct(3))
  apply (metis distinct_removes_last(1) flts_append rflts.simps(1) rflts.simps(6) rflts_def_idiot2 rrexp.distinct(31) rrexp.distinct(5))
  apply (metis distinct_removes_list rflts_spills_last spilled_alts_contained)
  apply (metis distinct_removes_last(1) flts_append good.simps(1) good.simps(44) rflts.simps(1) rflts.simps(7) rflts_def_idiot2 rrexp.distinct(37))
  by (metis distinct_removes_last(1) flts_append rflts.simps(1) rflts.simps(8) rflts_def_idiot2 rrexp.distinct(11) rrexp.distinct(39))

(*some basic facts about rsimp*)

unused_thms

end


theory tests
  imports labellings correspondence
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=2] (*default settings*)

(******************** Admissible and conflict-free **********************)

(* There always exists an admissible Labelling (label, e.g., all arguments as Undec). *)
lemma exAdmissible: \<open>\<exists>Lab. admissible AF Lab\<close> unfolding Defs by auto
(* See here: *)
lemma fixes AF :: \<open>'a \<A>\<F>\<close> and Lab :: \<open>'a Labelling\<close>
      assumes \<open>\<forall>x. undec Lab x\<close> (* give every argument the label Undec *)
      shows \<open>admissible AF Lab\<close> using assms unfolding Defs by simp

(* every admissible labelling is conflict-free but not the other way round*)
lemma admissibleConflictfree: \<open>admissible AF Lab \<Longrightarrow> conflictfree AF Lab\<close>
  by (simp add: admissible_def conflictfree_def inset_def legallyIn_def legallyOut_def outset_def)
lemma \<open>conflictfree AF Lab \<Longrightarrow> admissible AF Lab\<close> nitpick oops

(*For admissible labellings, legally-undecided implies undecided but not the other way round*)
lemma admissibleLegUndec: \<open>admissible AF Lab \<Longrightarrow> legallyUndec AF Lab x \<longrightarrow> undec Lab x\<close>
  by (meson Label.exhaust admissible_def inset_def legallyUndec_def outset_def undecset_def)
lemma \<open>admissible AF Lab \<Longrightarrow> undec Lab x \<longrightarrow> legallyUndec AF Lab x\<close> nitpick oops

(*OTOH, for admissible labellings, legally-in/out still do not imply in/out*)
lemma \<open>admissible AF Lab \<Longrightarrow> legallyIn AF Lab x \<longrightarrow> in Lab x\<close> nitpick oops
lemma \<open>admissible AF Lab \<Longrightarrow> legallyOut AF Lab x \<longrightarrow> out Lab x\<close> nitpick oops

(********************************** Complete **************************************)

(*in-sets of complete labellings are fixed points of the characteristic function*)
lemma completeInFP: "complete AF Lab \<Longrightarrow> fixpoint (\<F> AF) (in Lab)"
  unfolding fixpoint_def by (metis complete2_def complete_def2 defends_def legallyIn_def legallyOut_def)

lemma \<open>\<exists>Lab. fixpoint (\<F> AF) (in Lab)\<close> unfolding fixpoint_def using complete_def2 exAdmissible oops (*TODO*)

(* complete labellings always exist *)
lemma \<open>\<exists>Lab. complete AF Lab\<close>  using complete_def2 exAdmissible oops (*TODO*)

(* every complete labelling is admissible but not the other way round *)
lemma completeAdmissible: \<open>complete AF Lab \<Longrightarrow> admissible AF Lab\<close> by (simp add: complete_def)
lemma \<open>admissible AF Lab \<Longrightarrow> complete AF Lab\<close> nitpick oops

(* For complete labellings we have that in/out-sets completely determine the labelling*)
lemma completeInLab: \<open>complete AF L1 \<Longrightarrow> complete AF L2 \<Longrightarrow> in(L1) \<approx> in(L2) \<longrightarrow> (\<forall>x. L1(x) = L2(x))\<close>
  by (smt (verit) Label.exhaust admissibleConflictfree complete_def conflictfree_def inset_def legallyOut_def legallyUndec_def outset_def undecset_def)
lemma completeOutLab: \<open>complete AF L1 \<Longrightarrow> complete AF L2 \<Longrightarrow> out(L1) \<approx> out(L2) \<longrightarrow> (\<forall>x. L1(x) = L2(x))\<close>
  by (metis (full_types) Label.exhaust complete2_def complete_def2 inset_def legallyIn_def outset_def)
lemma \<open>complete AF L1 \<Longrightarrow> complete AF L2 \<Longrightarrow> undec(L1) \<approx> undec(L2) \<longrightarrow> (\<forall>x. L1(x) = L2(x))\<close> nitpick oops

(* For complete labellings, every in-set which is minimal is the least in-set.
(this result is key and has somehow to do with the fact that complete extensions are fixed points of a monotonic function)*)
lemma completeMinLeastIn: \<open>minimal (complete AF) Lab in \<longrightarrow> least (complete AF) Lab in\<close> oops (*TODO*)
(*(these two below may hold too, but are less important)*)
lemma \<open>minimal (complete AF) Lab out \<longrightarrow> least (complete AF) Lab out\<close> oops
lemma \<open>maximal (complete AF) Lab undec \<longrightarrow> greatest (complete AF) Lab undec\<close> oops

(*Lemma 1 from [BCG2011] *)
lemma \<open>complete AF Lab1 \<Longrightarrow> complete AF Lab2 \<Longrightarrow> (in(Lab1) \<subseteq> in(Lab2) \<longleftrightarrow> out(Lab1) \<subseteq> out(Lab2))\<close> unfolding Defs
  by (metis (full_types) Label.exhaust)

(*Prop 5 from [BCG2011], only partially proven so far *)
lemma prop5_1iff2: \<open>minimal (complete AF) Lab out = minimal (complete AF) Lab in\<close>
  unfolding minimal_def using complete_def2 complete2_def by (smt (z3) Label.exhaust legallyIn_def legallyOut_def)
(* some of the following still required *)
lemma prop5_1to3: \<open>minimal (complete AF) Lab in \<longrightarrow> maximal (complete AF) Lab undec\<close> oops (*TODO*)
lemma prop5_2to3: \<open>minimal (complete AF) Lab out \<longrightarrow> maximal (complete AF) Lab undec\<close> oops (*TODO*)
lemma prop5_3to1: \<open>maximal (complete AF) Lab undec \<longrightarrow> minimal (complete AF) Lab in\<close> oops (*TODO*)
lemma prop5_3to2: \<open>maximal (complete AF) Lab undec \<longrightarrow> minimal (complete AF) Lab out\<close> oops (*TODO*)

(*However, we can prove weaker variants of some of the above*)
lemma prop5_2to3_weak: \<open>least (complete AF) Lab out \<longrightarrow> greatest (complete AF) Lab undec\<close> unfolding least_def greatest_def
  by (smt (verit, best) Label.exhaust outset_def complete_def2 complete2_def undecset_def legallyIn_def inset_def)
lemma prop5_3to2_weak: \<open>greatest (complete AF) Lab undec \<longrightarrow> minimal (complete AF) Lab out\<close> unfolding minimal_def greatest_def
  by (metis admissibleConflictfree admissibleLegUndec complete_def complete2_def complete_def2 conflictfree_def legallyUndec_def legallyOut_def )

(*********************************** Grounded and Preferred ********************************)

(* the two provided definitions of grounded labellings are equivalent *)
lemma grounded_def2: \<open>grounded AF Lab = grounded2 AF Lab\<close>
 unfolding grounded_def grounded2_def by (smt (verit) complete_LE grounded_LE grounded_def grounded_ext_def2 id_apply least_def minimal_def)

(* grounded labellings always exist *)
lemma \<open>\<exists>Lab. grounded AF Lab\<close> oops (*TODO*)

(* Side comment from [BCG2011] that grounded labellings are unique *)
lemma grounded_unique: \<open>grounded AF Lab1 \<Longrightarrow> grounded AF Lab2 \<Longrightarrow> \<forall>x. Lab1(x) = Lab2(x)\<close>
  unfolding grounded_def2 least_def
  by (metis (full_types) completeInLab grounded2_def least_def)

(* preferred labellings always exist *)
lemma \<open>\<exists>Lab. preferred AF Lab\<close> oops (*TODO*)

(*Prop 8 from [BCG2011]
 For complete labellings, being maximal/greatest wrt In is equivalent to being maximal/greatest wrt Out*)
lemma prop8: \<open>maximal (complete AF) Lab in \<longleftrightarrow> maximal (complete AF) Lab out\<close> unfolding maximal_def
  by (smt (z3) complete_def2 complete2_def legallyIn_def legallyOut_def)

lemma prop8': \<open>greatest (complete AF) Lab in \<longleftrightarrow> greatest (complete AF) Lab out\<close> unfolding greatest_def
  by (metis complete_def2 complete2_def legallyIn_def legallyOut_def)

(* In fact, being greatest wrt In implies being least wrt Undec, but not the other way round*)
lemma \<open>greatest (complete AF) Lab in \<longrightarrow> least (complete AF) Lab undec\<close> unfolding greatest_def least_def
  by (metis admissibleLegUndec complete_def complete2_def complete_def2 legallyOut_def legallyUndec_def)
lemma \<open>least (complete AF) Lab undec \<longrightarrow> greatest (complete AF) Lab in\<close> nitpick oops
(* Moreover, being minimal wrt Undec implies being maximal wrt In, but not the other way round (cf. semi-stable labellings)*)
lemma \<open>minimal (complete AF) Lab undec \<longrightarrow> maximal (complete AF) Lab in\<close> unfolding minimal_def maximal_def
  by (smt (verit, ccfv_SIG) Label.exhaust complete_def2 complete2_def inset_def legallyOut_def outset_def undecset_def)
lemma \<open>maximal (complete AF) Lab in \<longrightarrow> minimal (complete AF) Lab undec\<close> nitpick oops

(* Prop. 10 from [BCG2011]
 If no argument is labelled Undec then the notions of conflict-free, admissible, complete and preferred collapse *)
lemma prop10_1to2: \<open>\<forall>x. Lab(x) \<noteq> Undec \<Longrightarrow> conflictfree AF Lab \<longrightarrow> admissible AF Lab\<close>
  unfolding Defs by (meson Label.exhaust)
lemma prop10_2to3: \<open>\<forall>x. Lab(x) \<noteq> Undec \<Longrightarrow> admissible AF Lab \<longrightarrow> complete AF Lab\<close>
  by (simp add: complete_def undecset_def)
lemma prop10_3to4: \<open>\<forall>x. Lab(x) \<noteq> Undec \<Longrightarrow> complete AF Lab \<longrightarrow>  preferred AF Lab\<close> unfolding preferred_def maximal_def
  by (metis admissibleConflictfree admissibleLegUndec completeLegIn complete_def conflictfree_def legallyOut_def legallyUndec_def undecset_def)
lemma prop10_4to1: \<open>\<forall>x. Lab(x) \<noteq> Undec \<Longrightarrow> preferred AF Lab \<longrightarrow> conflictfree AF Lab\<close>
  by (simp add: preferred_def admissibleConflictfree complete_def maximal_def)

(************************************* Stable and semi-stable ************************)

(* the AF in which every arguments attacks itself does not have a stable labelling *)
lemma stableLem01: \<open>\<forall>Lab. \<not>stable (\<lambda>x y. x = y) Lab\<close>
  unfolding stable_def complete_def by (metis (mono_tags, hide_lams) Label.exhaust admissibleConflictfree conflictfree_def legallyOut_def inset_def outset_def)

(* stable labellings do not exist necessarily *)
corollary \<open>\<exists>AF. \<forall>Lab. \<not>stable AF Lab\<close> using stableLem01 by auto

(*Lemma 14 from Dung. S is a stable extension iff S = {A | A is not attacked by S}.
Adapted to Labelings: It's weaker as we have to deal with Undec as well. *)
lemma lem14Dung: "stable AF Lab \<longrightarrow> (\<forall>a. in(Lab) a \<longleftrightarrow> \<not>(\<exists>b. in(Lab) b \<and> AF b a))" unfolding stable_def complete_def2
  by (metis (full_types) Label.distinct(1) Label.exhaust complete2_def inset_def legallyOut_def outset_def)

(*Lemma 15 from Dung. Every stable extension is a preferred extension, but not vice versa.
Adapted to Labellings *)
lemma lem15Dung: \<open>stable AF Lab \<Longrightarrow> preferred AF Lab\<close>
  by (simp add: prop10_3to4 stable_def)
lemma \<open>preferred AF Lab \<Longrightarrow> stable AF Lab\<close> nitpick oops

(* semistable labellings always exist *)
lemma \<open>\<exists>Lab. semistable AF Lab\<close> oops (*TODO*)

(***************************** Ideal ************************)

(***************************** Stage ************************)

(************************************************************************)
(* Inclusion relations as summary: Figure 12 of [BCG2011]
   All but ONE verified.
   The non-inclusion of the inverse directions has been checked with Nitpick in every case.
 Also, the CF2 stuff is missing, I haven't looked at it so far.
 *)

lemma \<open>stable AF Lab \<Longrightarrow> semistable AF Lab\<close>
  by (simp add: semistable_def stable_def undecset_def minimal_def)

lemma \<open>semistable AF Lab \<Longrightarrow> preferred AF Lab \<close> unfolding semistable_def preferred_def minimal_def maximal_def
  by (smt (verit, ccfv_SIG) Label.exhaust complete2_def complete_def2 inset_def legallyOut_def outset_def undecset_def)

lemma \<open>stable AF Lab \<Longrightarrow> stage AF Lab\<close> sledgehammer
  by (simp add: admissibleConflictfree leastMin least_def stable_def stage_def completeAdmissible undecset_def)

lemma \<open>preferred AF Lab \<Longrightarrow> complete AF Lab\<close>
  by (simp add: preferred_def maximal_def)

lemma \<open>ideal AF Lab \<Longrightarrow> complete AF Lab\<close>
  oops (*TODO*)

lemma \<open>grounded AF Lab \<Longrightarrow> complete AF Lab\<close>
  by (simp add: grounded_def minimal_def)

lemma \<open>complete AF Lab \<Longrightarrow> admissible AF Lab\<close>
  by (simp add: admissible_def complete_def)

lemma \<open>admissible AF Lab \<Longrightarrow> conflictfree AF Lab\<close>
  by (simp add: admissibleConflictfree)

lemma \<open>stage AF Lab \<Longrightarrow> conflictfree AF Lab\<close>
  by (simp add: stage_def minimal_def)

end


(*  Title:      HOL/UNITY/Simple/Mutex.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

Based on "A Family of 2-Process Mutual Exclusion Algorithms" by J Misra.
*)

theory Mutex imports "../UNITY_Main" begin

record state =
  p :: bool
  m :: int
  n :: int
  u :: bool
  v :: bool

type_synonym command = "(state*state) set"

  (** The program for process U **)

definition U0 :: command
  where "U0 = {(s,s'). s' = s (|u:=True, m:=1|) & m s = 0}"

definition  U1 :: command
  where "U1 = {(s,s'). s' = s (|p:= v s, m:=2|) & m s = 1}"

definition  U2 :: command
  where "U2 = {(s,s'). s' = s (|m:=3|) & ~ p s & m s = 2}"

definition  U3 :: command
  where "U3 = {(s,s'). s' = s (|u:=False, m:=4|) & m s = 3}"

definition  U4 :: command
  where "U4 = {(s,s'). s' = s (|p:=True, m:=0|) & m s = 4}"

  (** The program for process V **)

definition  V0 :: command
  where "V0 = {(s,s'). s' = s (|v:=True, n:=1|) & n s = 0}"

definition  V1 :: command
  where "V1 = {(s,s'). s' = s (|p:= ~ u s, n:=2|) & n s = 1}"

definition  V2 :: command
  where "V2 = {(s,s'). s' = s (|n:=3|) & p s & n s = 2}"

definition  V3 :: command
  where "V3 = {(s,s'). s' = s (|v:=False, n:=4|) & n s = 3}"

definition  V4 :: command
  where "V4 = {(s,s'). s' = s (|p:=False, n:=0|) & n s = 4}"

definition  Mutex :: "state program"
  where "Mutex = mk_total_program
                 ({s. ~ u s & ~ v s & m s = 0 & n s = 0},
                  {U0, U1, U2, U3, U4, V0, V1, V2, V3, V4},
                  UNIV)"

  (** The correct invariants **)

definition  IU :: "state set"
  where "IU = {s. (u s = (1 \<le> m s & m s \<le> 3)) & (m s = 3 --> ~ p s)}"

definition  IV :: "state set"
  where "IV = {s. (v s = (1 \<le> n s & n s \<le> 3)) & (n s = 3 --> p s)}"

  (** The faulty invariant (for U alone) **)

definition  bad_IU :: "state set"
  where "bad_IU = {s. (u s = (1 \<le> m s & m s \<le> 3)) &
                   (3 \<le> m s & m s \<le> 4 --> ~ p s)}"

declare Mutex_def [THEN def_prg_Init, simp]

declare U0_def [THEN def_act_simp, simp]
declare U1_def [THEN def_act_simp, simp]
declare U2_def [THEN def_act_simp, simp]
declare U3_def [THEN def_act_simp, simp]
declare U4_def [THEN def_act_simp, simp]
declare V0_def [THEN def_act_simp, simp]
declare V1_def [THEN def_act_simp, simp]
declare V2_def [THEN def_act_simp, simp]
declare V3_def [THEN def_act_simp, simp]
declare V4_def [THEN def_act_simp, simp]

declare IU_def [THEN def_set_simp, simp]
declare IV_def [THEN def_set_simp, simp]
declare bad_IU_def [THEN def_set_simp, simp]

lemma IU: "Mutex \<in> Always IU"
apply (rule AlwaysI, force)
apply (unfold Mutex_def, safety)
done

lemma IV: "Mutex \<in> Always IV"
apply (rule AlwaysI, force)
apply (unfold Mutex_def, safety)
done

(*The safety property: mutual exclusion*)
lemma mutual_exclusion: "Mutex \<in> Always {s. ~ (m s = 3 & n s = 3)}"
apply (rule Always_weaken)
apply (rule Always_Int_I [OF IU IV], auto)
done

(*The bad invariant FAILS in V1*)
lemma "Mutex \<in> Always bad_IU"
apply (rule AlwaysI, force)
apply (unfold Mutex_def, safety, auto)
(*Resulting state: n=1, p=false, m=4, u=false.
  Execution of V1 (the command of process v guarded by n=1) sets p:=true,
  violating the invariant!*)
oops

lemma eq_123: "((1::int) \<le> i & i \<le> 3) = (i = 1 | i = 2 | i = 3)"
by arith

(*** Progress for U ***)

lemma U_F0: "Mutex \<in> {s. m s=2} Unless {s. m s=3}"
by (unfold Unless_def Mutex_def, safety)

lemma U_F1: "Mutex \<in> {s. m s=1} LeadsTo {s. p s = v s & m s = 2}"
by (unfold Mutex_def, ensures_tac U1)

lemma U_F2: "Mutex \<in> {s. ~ p s & m s = 2} LeadsTo {s. m s = 3}"
apply (cut_tac IU)
apply (unfold Mutex_def, ensures_tac U2)
done

lemma U_F3: "Mutex \<in> {s. m s = 3} LeadsTo {s. p s}"
apply (rule_tac B = "{s. m s = 4}" in LeadsTo_Trans)
 apply (unfold Mutex_def)
 apply (ensures_tac U3)
apply (ensures_tac U4)
done

lemma U_lemma2: "Mutex \<in> {s. m s = 2} LeadsTo {s. p s}"
apply (rule LeadsTo_Diff [OF LeadsTo_weaken_L
                             Int_lower2 [THEN subset_imp_LeadsTo]])
apply (rule LeadsTo_Trans [OF U_F2 U_F3], auto)
done

lemma U_lemma1: "Mutex \<in> {s. m s = 1} LeadsTo {s. p s}"
by (rule LeadsTo_Trans [OF U_F1 [THEN LeadsTo_weaken_R] U_lemma2], blast)

lemma U_lemma123: "Mutex \<in> {s. 1 \<le> m s & m s \<le> 3} LeadsTo {s. p s}"
by (simp add: eq_123 Collect_disj_eq LeadsTo_Un_distrib U_lemma1 U_lemma2 U_F3)

(*Misra's F4*)
lemma u_Leadsto_p: "Mutex \<in> {s. u s} LeadsTo {s. p s}"
by (rule Always_LeadsTo_weaken [OF IU U_lemma123], auto)

(*** Progress for V ***)

lemma V_F0: "Mutex \<in> {s. n s=2} Unless {s. n s=3}"
by (unfold Unless_def Mutex_def, safety)

lemma V_F1: "Mutex \<in> {s. n s=1} LeadsTo {s. p s = (~ u s) & n s = 2}"
by (unfold Mutex_def, ensures_tac "V1")

lemma V_F2: "Mutex \<in> {s. p s & n s = 2} LeadsTo {s. n s = 3}"
apply (cut_tac IV)
apply (unfold Mutex_def, ensures_tac "V2")
done

lemma V_F3: "Mutex \<in> {s. n s = 3} LeadsTo {s. ~ p s}"
apply (rule_tac B = "{s. n s = 4}" in LeadsTo_Trans)
 apply (unfold Mutex_def)
 apply (ensures_tac V3)
apply (ensures_tac V4)
done

lemma V_lemma2: "Mutex \<in> {s. n s = 2} LeadsTo {s. ~ p s}"
apply (rule LeadsTo_Diff [OF LeadsTo_weaken_L
                             Int_lower2 [THEN subset_imp_LeadsTo]])
apply (rule LeadsTo_Trans [OF V_F2 V_F3], auto)
done

lemma V_lemma1: "Mutex \<in> {s. n s = 1} LeadsTo {s. ~ p s}"
by (rule LeadsTo_Trans [OF V_F1 [THEN LeadsTo_weaken_R] V_lemma2], blast)

lemma V_lemma123: "Mutex \<in> {s. 1 \<le> n s & n s \<le> 3} LeadsTo {s. ~ p s}"
by (simp add: eq_123 Collect_disj_eq LeadsTo_Un_distrib V_lemma1 V_lemma2 V_F3)

(*Misra's F4*)
lemma v_Leadsto_not_p: "Mutex \<in> {s. v s} LeadsTo {s. ~ p s}"
by (rule Always_LeadsTo_weaken [OF IV V_lemma123], auto)

(** Absence of starvation **)

(*Misra's F6*)
lemma m1_Leadsto_3: "Mutex \<in> {s. m s = 1} LeadsTo {s. m s = 3}"
apply (rule LeadsTo_cancel2 [THEN LeadsTo_Un_duplicate])
apply (rule_tac [2] U_F2)
apply (simp add: Collect_conj_eq)
apply (subst Un_commute)
apply (rule LeadsTo_cancel2 [THEN LeadsTo_Un_duplicate])
 apply (rule_tac [2] PSP_Unless [OF v_Leadsto_not_p U_F0])
apply (rule U_F1 [THEN LeadsTo_weaken_R], auto)
done

(*The same for V*)
lemma n1_Leadsto_3: "Mutex \<in> {s. n s = 1} LeadsTo {s. n s = 3}"
apply (rule LeadsTo_cancel2 [THEN LeadsTo_Un_duplicate])
apply (rule_tac [2] V_F2)
apply (simp add: Collect_conj_eq)
apply (subst Un_commute)
apply (rule LeadsTo_cancel2 [THEN LeadsTo_Un_duplicate])
 apply (rule_tac [2] PSP_Unless [OF u_Leadsto_p V_F0])
apply (rule V_F1 [THEN LeadsTo_weaken_R], auto)
done

end


(*  Title:      HOL/TPTP/THF_Arith.thy
    Author:     Jasmin Blanchette
    Copyright   2011, 2012

Experimental setup for THF arithmetic. This is not connected with the TPTP
parser yet.
*)

theory THF_Arith
imports Complex_Main
begin

consts
  is_int :: "'a \<Rightarrow> bool"
  is_rat :: "'a \<Rightarrow> bool"

overloading rat_is_int \<equiv> "is_int :: rat \<Rightarrow> bool"
begin
  definition "rat_is_int (q::rat) \<longleftrightarrow> (\<exists>n::int. q = of_int n)"
end

overloading real_is_int \<equiv> "is_int :: real \<Rightarrow> bool"
begin
  definition "real_is_int (x::real) \<longleftrightarrow> x \<in> \<int>"
end

overloading real_is_rat \<equiv> "is_rat :: real \<Rightarrow> bool"
begin
  definition "real_is_rat (x::real) \<longleftrightarrow> x \<in> \<rat>"
end

consts
  to_int :: "'a \<Rightarrow> int"
  to_rat :: "'a \<Rightarrow> rat"
  to_real :: "'a \<Rightarrow> real"

overloading rat_to_int \<equiv> "to_int :: rat \<Rightarrow> int"
begin
  definition "rat_to_int (q::rat) = \<lfloor>q\<rfloor>"
end

overloading real_to_int \<equiv> "to_int :: real \<Rightarrow> int"
begin
  definition "real_to_int (x::real) = \<lfloor>x\<rfloor>"
end

overloading int_to_rat \<equiv> "to_rat :: int \<Rightarrow> rat"
begin
  definition "int_to_rat (n::int) = (of_int n::rat)"
end

overloading real_to_rat \<equiv> "to_rat :: real \<Rightarrow> rat"
begin
  definition "real_to_rat (x::real) = (inv of_rat x::rat)"
end

overloading int_to_real \<equiv> "to_real :: int \<Rightarrow> real"
begin
  definition "int_to_real (n::int) = real_of_int n"
end

overloading rat_to_real \<equiv> "to_real :: rat \<Rightarrow> real"
begin
  definition "rat_to_real (x::rat) = (of_rat x::real)"
end

declare
  rat_is_int_def [simp]
  real_is_int_def [simp]
  real_is_rat_def [simp]
  rat_to_int_def [simp]
  real_to_int_def [simp]
  int_to_rat_def [simp]
  real_to_rat_def [simp]
  int_to_real_def [simp]
  rat_to_real_def [simp]

lemma to_rat_is_int [intro, simp]: "is_int (to_rat (n::int))"
by (metis int_to_rat_def rat_is_int_def)

lemma to_real_is_int [intro, simp]: "is_int (to_real (n::int))"
by (metis Ints_of_int int_to_real_def real_is_int_def)

lemma to_real_is_rat [intro, simp]: "is_rat (to_real (q::rat))"
by (metis Rats_of_rat rat_to_real_def real_is_rat_def)

lemma inj_of_rat [intro, simp]: "inj (of_rat::rat\<Rightarrow>real)"
by (metis injI of_rat_eq_iff)

end


(*  Title:      HOL/Fun_Def.thy
    Author:     Alexander Krauss, TU Muenchen
*)

section \<open>Function Definitions and Termination Proofs\<close>

theory Fun_Def
  imports Basic_BNF_LFPs Partial_Function SAT
  keywords
    "function" "termination" :: thy_goal_defn and
    "fun" "fun_cases" :: thy_defn
begin

subsection \<open>Definitions with default value\<close>

definition THE_default :: "'a \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a"
  where "THE_default d P = (if (\<exists>!x. P x) then (THE x. P x) else d)"

lemma THE_defaultI': "\<exists>!x. P x \<Longrightarrow> P (THE_default d P)"
  by (simp add: theI' THE_default_def)

lemma THE_default1_equality: "\<exists>!x. P x \<Longrightarrow> P a \<Longrightarrow> THE_default d P = a"
  by (simp add: the1_equality THE_default_def)

lemma THE_default_none: "\<not> (\<exists>!x. P x) \<Longrightarrow> THE_default d P = d"
  by (simp add: THE_default_def)

lemma fundef_ex1_existence:
  assumes f_def: "f \<equiv> (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
  assumes ex1: "\<exists>!y. G x y"
  shows "G x (f x)"
  apply (simp only: f_def)
  apply (rule THE_defaultI')
  apply (rule ex1)
  done

lemma fundef_ex1_uniqueness:
  assumes f_def: "f \<equiv> (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
  assumes ex1: "\<exists>!y. G x y"
  assumes elm: "G x (h x)"
  shows "h x = f x"
  apply (simp only: f_def)
  apply (rule THE_default1_equality [symmetric])
   apply (rule ex1)
  apply (rule elm)
  done

lemma fundef_ex1_iff:
  assumes f_def: "f \<equiv> (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
  assumes ex1: "\<exists>!y. G x y"
  shows "(G x y) = (f x = y)"
  apply (auto simp:ex1 f_def THE_default1_equality)
  apply (rule THE_defaultI')
  apply (rule ex1)
  done

lemma fundef_default_value:
  assumes f_def: "f \<equiv> (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
  assumes graph: "\<And>x y. G x y \<Longrightarrow> D x"
  assumes "\<not> D x"
  shows "f x = d x"
proof -
  have "\<not>(\<exists>y. G x y)"
  proof
    assume "\<exists>y. G x y"
    then have "D x" using graph ..
    with \<open>\<not> D x\<close> show False ..
  qed
  then have "\<not>(\<exists>!y. G x y)" by blast
  then show ?thesis
    unfolding f_def by (rule THE_default_none)
qed

definition in_rel_def[simp]: "in_rel R x y \<equiv> (x, y) \<in> R"

lemma wf_in_rel: "wf R \<Longrightarrow> wfP (in_rel R)"
  by (simp add: wfP_def)

ML_file \<open>Tools/Function/function_core.ML\<close>
ML_file \<open>Tools/Function/mutual.ML\<close>
ML_file \<open>Tools/Function/pattern_split.ML\<close>
ML_file \<open>Tools/Function/relation.ML\<close>
ML_file \<open>Tools/Function/function_elims.ML\<close>

method_setup relation = \<open>
  Args.term >> (fn t => fn ctxt => SIMPLE_METHOD' (Function_Relation.relation_infer_tac ctxt t))
\<close> "prove termination using a user-specified wellfounded relation"

ML_file \<open>Tools/Function/function.ML\<close>
ML_file \<open>Tools/Function/pat_completeness.ML\<close>

method_setup pat_completeness = \<open>
  Scan.succeed (SIMPLE_METHOD' o Pat_Completeness.pat_completeness_tac)
\<close> "prove completeness of (co)datatype patterns"

ML_file \<open>Tools/Function/fun.ML\<close>
ML_file \<open>Tools/Function/induction_schema.ML\<close>

method_setup induction_schema = \<open>
  Scan.succeed (CONTEXT_TACTIC oo Induction_Schema.induction_schema_tac)
\<close> "prove an induction principle"

subsection \<open>Measure functions\<close>

inductive is_measure :: "('a \<Rightarrow> nat) \<Rightarrow> bool"
  where is_measure_trivial: "is_measure f"

named_theorems measure_function "rules that guide the heuristic generation of measure functions"
ML_file \<open>Tools/Function/measure_functions.ML\<close>

lemma measure_size[measure_function]: "is_measure size"
  by (rule is_measure_trivial)

lemma measure_fst[measure_function]: "is_measure f \<Longrightarrow> is_measure (\<lambda>p. f (fst p))"
  by (rule is_measure_trivial)

lemma measure_snd[measure_function]: "is_measure f \<Longrightarrow> is_measure (\<lambda>p. f (snd p))"
  by (rule is_measure_trivial)

ML_file \<open>Tools/Function/lexicographic_order.ML\<close>

method_setup lexicographic_order = \<open>
  Method.sections clasimp_modifiers >>
  (K (SIMPLE_METHOD o Lexicographic_Order.lexicographic_order_tac false))
\<close> "termination prover for lexicographic orderings"

subsection \<open>Congruence rules\<close>

lemma let_cong [fundef_cong]: "M = N \<Longrightarrow> (\<And>x. x = N \<Longrightarrow> f x = g x) \<Longrightarrow> Let M f = Let N g"
  unfolding Let_def by blast

lemmas [fundef_cong] =
  if_cong image_cong
  bex_cong ball_cong imp_cong map_option_cong Option.bind_cong

lemma split_cong [fundef_cong]:
  "(\<And>x y. (x, y) = q \<Longrightarrow> f x y = g x y) \<Longrightarrow> p = q \<Longrightarrow> case_prod f p = case_prod g q"
  by (auto simp: split_def)

lemma comp_cong [fundef_cong]: "f (g x) = f' (g' x') \<Longrightarrow> (f \<circ> g) x = (f' \<circ> g') x'"
  by (simp only: o_apply)

subsection \<open>Simp rules for termination proofs\<close>

declare
  trans_less_add1[termination_simp]
  trans_less_add2[termination_simp]
  trans_le_add1[termination_simp]
  trans_le_add2[termination_simp]
  less_imp_le_nat[termination_simp]
  le_imp_less_Suc[termination_simp]

lemma size_prod_simp[termination_simp]: "size_prod f g p = f (fst p) + g (snd p) + Suc 0"
  by (induct p) auto

subsection \<open>Decomposition\<close>

lemma less_by_empty: "A = {} \<Longrightarrow> A \<subseteq> B"
  and union_comp_emptyL: "A O C = {} \<Longrightarrow> B O C = {} \<Longrightarrow> (A \<union> B) O C = {}"
  and union_comp_emptyR: "A O B = {} \<Longrightarrow> A O C = {} \<Longrightarrow> A O (B \<union> C) = {}"
  and wf_no_loop: "R O R = {} \<Longrightarrow> wf R"
  by (auto simp add: wf_comp_self [of R])

subsection \<open>Reduction pairs\<close>

definition "reduction_pair P \<longleftrightarrow> wf (fst P) \<and> fst P O snd P \<subseteq> fst P"

lemma reduction_pairI[intro]: "wf R \<Longrightarrow> R O S \<subseteq> R \<Longrightarrow> reduction_pair (R, S)"
  by (auto simp: reduction_pair_def)

lemma reduction_pair_lemma:
  assumes rp: "reduction_pair P"
  assumes "R \<subseteq> fst P"
  assumes "S \<subseteq> snd P"
  assumes "wf S"
  shows "wf (R \<union> S)"
proof -
  from rp \<open>S \<subseteq> snd P\<close> have "wf (fst P)" "fst P O S \<subseteq> fst P"
    unfolding reduction_pair_def by auto
  with \<open>wf S\<close> have "wf (fst P \<union> S)"
    by (auto intro: wf_union_compatible)
  moreover from \<open>R \<subseteq> fst P\<close> have "R \<union> S \<subseteq> fst P \<union> S" by auto
  ultimately show ?thesis by (rule wf_subset)
qed

definition "rp_inv_image = (\<lambda>(R,S) f. (inv_image R f, inv_image S f))"

lemma rp_inv_image_rp: "reduction_pair P \<Longrightarrow> reduction_pair (rp_inv_image P f)"
  unfolding reduction_pair_def rp_inv_image_def split_def by force

subsection \<open>Concrete orders for SCNP termination proofs\<close>

definition "pair_less = less_than <*lex*> less_than"
definition "pair_leq = pair_less\<^sup>="
definition "max_strict = max_ext pair_less"
definition "max_weak = max_ext pair_leq \<union> {({}, {})}"
definition "min_strict = min_ext pair_less"
definition "min_weak = min_ext pair_leq \<union> {({}, {})}"

lemma wf_pair_less[simp]: "wf pair_less"
  by (auto simp: pair_less_def)

lemma total_pair_less [iff]: "total_on A pair_less" and trans_pair_less [iff]: "trans pair_less"
  by (auto simp: total_on_def pair_less_def)

text \<open>Introduction rules for \<open>pair_less\<close>/\<open>pair_leq\<close>\<close>
lemma pair_leqI1: "a < b \<Longrightarrow> ((a, s), (b, t)) \<in> pair_leq"
  and pair_leqI2: "a \<le> b \<Longrightarrow> s \<le> t \<Longrightarrow> ((a, s), (b, t)) \<in> pair_leq"
  and pair_lessI1: "a < b  \<Longrightarrow> ((a, s), (b, t)) \<in> pair_less"
  and pair_lessI2: "a \<le> b \<Longrightarrow> s < t \<Longrightarrow> ((a, s), (b, t)) \<in> pair_less"
  by (auto simp: pair_leq_def pair_less_def)

text \<open>Introduction rules for max\<close>
lemma smax_emptyI: "finite Y \<Longrightarrow> Y \<noteq> {} \<Longrightarrow> ({}, Y) \<in> max_strict"
  and smax_insertI:
    "y \<in> Y \<Longrightarrow> (x, y) \<in> pair_less \<Longrightarrow> (X, Y) \<in> max_strict \<Longrightarrow> (insert x X, Y) \<in> max_strict"
  and wmax_emptyI: "finite X \<Longrightarrow> ({}, X) \<in> max_weak"
  and wmax_insertI:
    "y \<in> YS \<Longrightarrow> (x, y) \<in> pair_leq \<Longrightarrow> (XS, YS) \<in> max_weak \<Longrightarrow> (insert x XS, YS) \<in> max_weak"
  by (auto simp: max_strict_def max_weak_def elim!: max_ext.cases)

text \<open>Introduction rules for min\<close>
lemma smin_emptyI: "X \<noteq> {} \<Longrightarrow> (X, {}) \<in> min_strict"
  and smin_insertI:
    "x \<in> XS \<Longrightarrow> (x, y) \<in> pair_less \<Longrightarrow> (XS, YS) \<in> min_strict \<Longrightarrow> (XS, insert y YS) \<in> min_strict"
  and wmin_emptyI: "(X, {}) \<in> min_weak"
  and wmin_insertI:
    "x \<in> XS \<Longrightarrow> (x, y) \<in> pair_leq \<Longrightarrow> (XS, YS) \<in> min_weak \<Longrightarrow> (XS, insert y YS) \<in> min_weak"
  by (auto simp: min_strict_def min_weak_def min_ext_def)

text \<open>Reduction Pairs.\<close>

lemma max_ext_compat:
  assumes "R O S \<subseteq> R"
  shows "max_ext R O (max_ext S \<union> {({}, {})}) \<subseteq> max_ext R"
  using assms
  apply auto
  apply (elim max_ext.cases)
  apply rule
     apply auto[3]
  apply (drule_tac x=xa in meta_spec)
  apply simp
  apply (erule bexE)
  apply (drule_tac x=xb in meta_spec)
  apply auto
  done

lemma max_rpair_set: "reduction_pair (max_strict, max_weak)"
  unfolding max_strict_def max_weak_def
  apply (intro reduction_pairI max_ext_wf)
   apply simp
  apply (rule max_ext_compat)
  apply (auto simp: pair_less_def pair_leq_def)
  done

lemma min_ext_compat:
  assumes "R O S \<subseteq> R"
  shows "min_ext R O  (min_ext S \<union> {({},{})}) \<subseteq> min_ext R"
  using assms
  apply (auto simp: min_ext_def)
  apply (drule_tac x=ya in bspec, assumption)
  apply (erule bexE)
  apply (drule_tac x=xc in bspec)
   apply assumption
  apply auto
  done

lemma min_rpair_set: "reduction_pair (min_strict, min_weak)"
  unfolding min_strict_def min_weak_def
  apply (intro reduction_pairI min_ext_wf)
   apply simp
  apply (rule min_ext_compat)
  apply (auto simp: pair_less_def pair_leq_def)
  done

subsection \<open>Yet another induction principle on the natural numbers\<close>

lemma nat_descend_induct [case_names base descend]:
  fixes P :: "nat \<Rightarrow> bool"
  assumes H1: "\<And>k. k > n \<Longrightarrow> P k"
  assumes H2: "\<And>k. k \<le> n \<Longrightarrow> (\<And>i. i > k \<Longrightarrow> P i) \<Longrightarrow> P k"
  shows "P m"
  using assms by induction_schema (force intro!: wf_measure [of "\<lambda>k. Suc n - k"])+

subsection \<open>Tool setup\<close>

ML_file \<open>Tools/Function/termination.ML\<close>
ML_file \<open>Tools/Function/scnp_solve.ML\<close>
ML_file \<open>Tools/Function/scnp_reconstruct.ML\<close>
ML_file \<open>Tools/Function/fun_cases.ML\<close>

ML_val \<comment> \<open>setup inactive\<close>
\<open>
  Context.theory_map (Function_Common.set_termination_prover
    (K (ScnpReconstruct.decomp_scnp_tac [ScnpSolve.MAX, ScnpSolve.MIN, ScnpSolve.MS])))
\<close>

end


(* author: wzh*)

theory MyTree
  imports Main
begin

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun mirror :: "'a tree \<Rightarrow> 'a tree" where
"mirror Tip = Tip" |
"mirror (Node l a r) = Node (mirror r) a (mirror l)"

lemma mirr: "mirror (mirror t) = t"
  apply(induction t)
   apply(auto)
  done

end