(*  Title:      ZF/AC/AC17_AC1.thy
    Author:     Krzysztof Grabczewski

The equivalence of AC0, AC1 and AC17

Also, the proofs needed to show that each of AC2, AC3, ..., AC6 is equivalent
to AC0 and AC1.
*)

theory AC17_AC1
imports HH
begin

(** AC0 is equivalent to AC1.
    AC0 comes from Suppes, AC1 from Rubin & Rubin **)

lemma AC0_AC1_lemma: "[| f:(\<Pi> X \<in> A. X); D \<subseteq> A |] ==> \<exists>g. g:(\<Pi> X \<in> D. X)"
by (fast intro!: lam_type apply_type)

lemma AC0_AC1: "AC0 ==> AC1"
apply (unfold AC0_def AC1_def)
apply (blast intro: AC0_AC1_lemma)
done

lemma AC1_AC0: "AC1 ==> AC0"
by (unfold AC0_def AC1_def, blast)

(**** The proof of AC1 ==> AC17 ****)

lemma AC1_AC17_lemma: "f \<in> (\<Pi> X \<in> Pow(A) - {0}. X) ==> f \<in> (Pow(A) - {0} -> A)"
apply (rule Pi_type, assumption)
apply (drule apply_type, assumption, fast)
done

lemma AC1_AC17: "AC1 ==> AC17"
apply (unfold AC1_def AC17_def)
apply (rule allI)
apply (rule ballI)
apply (erule_tac x = "Pow (A) -{0}" in allE)
apply (erule impE, fast)
apply (erule exE)
apply (rule bexI)
apply (erule_tac [2] AC1_AC17_lemma)
apply (rule apply_type, assumption)
apply (fast dest!: AC1_AC17_lemma elim!: apply_type)
done

(**** The proof of AC17 ==> AC1 ****)

(* *********************************************************************** *)
(* more properties of HH                                                   *)
(* *********************************************************************** *)

lemma UN_eq_imp_well_ord:
     "[| x - (\<Union>j \<in> LEAST i. HH(\<lambda>X \<in> Pow(x)-{0}. {f`X}, x, i) = {x}.
        HH(\<lambda>X \<in> Pow(x)-{0}. {f`X}, x, j)) = 0;
        f \<in> Pow(x)-{0} -> x |]
        ==> \<exists>r. well_ord(x,r)"
apply (rule exI)
apply (erule well_ord_rvimage
        [OF bij_Least_HH_x [THEN bij_converse_bij, THEN bij_is_inj]
            Ord_Least [THEN well_ord_Memrel]], assumption)
done

(* *********************************************************************** *)
(* theorems closer to the proof                                            *)
(* *********************************************************************** *)

lemma not_AC1_imp_ex:
     "~AC1 ==> \<exists>A. \<forall>f \<in> Pow(A)-{0} -> A. \<exists>u \<in> Pow(A)-{0}. f`u \<notin> u"
apply (unfold AC1_def)
apply (erule swap)
apply (rule allI)
apply (erule swap)
apply (rule_tac x = "\<Union>(A)" in exI)
apply (blast intro: lam_type)
done

lemma AC17_AC1_aux1:
     "[| \<forall>f \<in> Pow(x) - {0} -> x. \<exists>u \<in> Pow(x) - {0}. f`u\<notin>u;
         \<exists>f \<in> Pow(x)-{0}->x.
            x - (\<Union>a \<in> (LEAST i. HH(\<lambda>X \<in> Pow(x)-{0}. {f`X},x,i)={x}).
            HH(\<lambda>X \<in> Pow(x)-{0}. {f`X},x,a)) = 0 |]
        ==> P"
apply (erule bexE)
apply (erule UN_eq_imp_well_ord [THEN exE], assumption)
apply (erule ex_choice_fun_Pow [THEN exE])
apply (erule ballE)
apply (fast intro: apply_type del: DiffE)
apply (erule notE)
apply (rule Pi_type, assumption)
apply (blast dest: apply_type)
done

lemma AC17_AC1_aux2:
      "~ (\<exists>f \<in> Pow(x)-{0}->x. x - F(f) = 0)
       ==> (\<lambda>f \<in> Pow(x)-{0}->x . x - F(f))
           \<in> (Pow(x) -{0} -> x) -> Pow(x) - {0}"
by (fast intro!: lam_type dest!: Diff_eq_0_iff [THEN iffD1])

lemma AC17_AC1_aux3:
     "[| f`Z \<in> Z; Z \<in> Pow(x)-{0} |]
      ==> (\<lambda>X \<in> Pow(x)-{0}. {f`X})`Z \<in> Pow(Z)-{0}"
by auto

lemma AC17_AC1_aux4:
     "\<exists>f \<in> F. f`((\<lambda>f \<in> F. Q(f))`f) \<in> (\<lambda>f \<in> F. Q(f))`f
      ==> \<exists>f \<in> F. f`Q(f) \<in> Q(f)"
by simp

lemma AC17_AC1: "AC17 ==> AC1"
apply (unfold AC17_def)
apply (rule classical)
apply (erule not_AC1_imp_ex [THEN exE])
apply (case_tac
       "\<exists>f \<in> Pow(x)-{0} -> x.
        x - (\<Union>a \<in> (LEAST i. HH (\<lambda>X \<in> Pow (x) -{0}. {f`X},x,i) ={x}) . HH (\<lambda>X \<in> Pow (x) -{0}. {f`X},x,a)) = 0")
apply (erule AC17_AC1_aux1, assumption)
apply (drule AC17_AC1_aux2)
apply (erule allE)
apply (drule bspec, assumption)
apply (drule AC17_AC1_aux4)
apply (erule bexE)
apply (drule apply_type, assumption)
apply (simp add: HH_Least_eq_x del: Diff_iff )
apply (drule AC17_AC1_aux3, assumption)
apply (fast dest!: subst_elem [OF _ HH_Least_eq_x [symmetric]]
                   f_subset_imp_HH_subset elim!: mem_irrefl)
done

(* **********************************************************************
    AC1 ==> AC2 ==> AC1
    AC1 ==> AC4 ==> AC3 ==> AC1
    AC4 ==> AC5 ==> AC4
    AC1 \<longleftrightarrow> AC6
************************************************************************* *)

(* ********************************************************************** *)
(* AC1 ==> AC2                                                            *)
(* ********************************************************************** *)

lemma AC1_AC2_aux1:
     "[| f:(\<Pi> X \<in> A. X);  B \<in> A;  0\<notin>A |] ==> {f`B} \<subseteq> B \<inter> {f`C. C \<in> A}"
by (fast elim!: apply_type)

lemma AC1_AC2_aux2:
        "[| pairwise_disjoint(A); B \<in> A; C \<in> A; D \<in> B; D \<in> C |] ==> f`B = f`C"
by (unfold pairwise_disjoint_def, fast)

lemma AC1_AC2: "AC1 ==> AC2"
apply (unfold AC1_def AC2_def)
apply (rule allI)
apply (rule impI)
apply (elim asm_rl conjE allE exE impE, assumption)
apply (intro exI ballI equalityI)
prefer 2 apply (rule AC1_AC2_aux1, assumption+)
apply (fast elim!: AC1_AC2_aux2 elim: apply_type)
done

(* ********************************************************************** *)
(* AC2 ==> AC1                                                            *)
(* ********************************************************************** *)

lemma AC2_AC1_aux1: "0\<notin>A ==> 0 \<notin> {B*{B}. B \<in> A}"
by (fast dest!: sym [THEN Sigma_empty_iff [THEN iffD1]])

lemma AC2_AC1_aux2: "[| X*{X} \<inter> C = {y}; X \<in> A |]
               ==> (THE y. X*{X} \<inter> C = {y}): X*A"
apply (rule subst_elem [of y])
apply (blast elim!: equalityE)
apply (auto simp add: singleton_eq_iff)
done

lemma AC2_AC1_aux3:
     "\<forall>D \<in> {E*{E}. E \<in> A}. \<exists>y. D \<inter> C = {y}
      ==> (\<lambda>x \<in> A. fst(THE z. (x*{x} \<inter> C = {z}))) \<in> (\<Pi> X \<in> A. X)"
apply (rule lam_type)
apply (drule bspec, blast)
apply (blast intro: AC2_AC1_aux2 fst_type)
done

lemma AC2_AC1: "AC2 ==> AC1"
apply (unfold AC1_def AC2_def pairwise_disjoint_def)
apply (intro allI impI)
apply (elim allE impE)
prefer 2 apply (fast elim!: AC2_AC1_aux3)
apply (blast intro!: AC2_AC1_aux1)
done

(* ********************************************************************** *)
(* AC1 ==> AC4                                                            *)
(* ********************************************************************** *)

lemma empty_notin_images: "0 \<notin> {R``{x}. x \<in> domain(R)}"
by blast

lemma AC1_AC4: "AC1 ==> AC4"
apply (unfold AC1_def AC4_def)
apply (intro allI impI)
apply (drule spec, drule mp [OF _ empty_notin_images])
apply (best intro!: lam_type elim!: apply_type)
done

(* ********************************************************************** *)
(* AC4 ==> AC3                                                            *)
(* ********************************************************************** *)

lemma AC4_AC3_aux1: "f \<in> A->B ==> (\<Union>z \<in> A. {z}*f`z) \<subseteq> A*\<Union>(B)"
by (fast dest!: apply_type)

lemma AC4_AC3_aux2: "domain(\<Union>z \<in> A. {z}*f(z)) = {a \<in> A. f(a)\<noteq>0}"
by blast

lemma AC4_AC3_aux3: "x \<in> A ==> (\<Union>z \<in> A. {z}*f(z))``{x} = f(x)"
by fast

lemma AC4_AC3: "AC4 ==> AC3"
apply (unfold AC3_def AC4_def)
apply (intro allI ballI)
apply (elim allE impE)
apply (erule AC4_AC3_aux1)
apply (simp add: AC4_AC3_aux2 AC4_AC3_aux3 cong add: Pi_cong)
done

(* ********************************************************************** *)
(* AC3 ==> AC1                                                            *)
(* ********************************************************************** *)

lemma AC3_AC1_lemma:
     "b\<notin>A ==> (\<Pi> x \<in> {a \<in> A. id(A)`a\<noteq>b}. id(A)`x) = (\<Pi> x \<in> A. x)"
apply (simp add: id_def cong add: Pi_cong)
apply (rule_tac b = A in subst_context, fast)
done

lemma AC3_AC1: "AC3 ==> AC1"
apply (unfold AC1_def AC3_def)
apply (fast intro!: id_type elim: AC3_AC1_lemma [THEN subst])
done

(* ********************************************************************** *)
(* AC4 ==> AC5                                                            *)
(* ********************************************************************** *)

lemma AC4_AC5: "AC4 ==> AC5"
apply (unfold range_def AC4_def AC5_def)
apply (intro allI ballI)
apply (elim allE impE)
apply (erule fun_is_rel [THEN converse_type])
apply (erule exE)
apply (rename_tac g)
apply (rule_tac x=g in bexI)
apply (blast dest: apply_equality range_type)
apply (blast intro: Pi_type dest: apply_type fun_is_rel)
done

(* ********************************************************************** *)
(* AC5 ==> AC4, Rubin & Rubin, p. 11                                      *)
(* ********************************************************************** *)

lemma AC5_AC4_aux1: "R \<subseteq> A*B ==> (\<lambda>x \<in> R. fst(x)) \<in> R -> A"
by (fast intro!: lam_type fst_type)

lemma AC5_AC4_aux2: "R \<subseteq> A*B ==> range(\<lambda>x \<in> R. fst(x)) = domain(R)"
by (unfold lam_def, force)

lemma AC5_AC4_aux3: "[| \<exists>f \<in> A->C. P(f,domain(f)); A=B |] ==>  \<exists>f \<in> B->C. P(f,B)"
apply (erule bexE)
apply (frule domain_of_fun, fast)
done

lemma AC5_AC4_aux4: "[| R \<subseteq> A*B; g \<in> C->R; \<forall>x \<in> C. (\<lambda>z \<in> R. fst(z))` (g`x) = x |]
                ==> (\<lambda>x \<in> C. snd(g`x)): (\<Pi> x \<in> C. R``{x})"
apply (rule lam_type)
apply (force dest: apply_type)
done

lemma AC5_AC4: "AC5 ==> AC4"
apply (unfold AC4_def AC5_def, clarify)
apply (elim allE ballE)
apply (drule AC5_AC4_aux3 [OF _ AC5_AC4_aux2], assumption)
apply (fast elim!: AC5_AC4_aux4)
apply (blast intro: AC5_AC4_aux1)
done

(* ********************************************************************** *)
(* AC1 \<longleftrightarrow> AC6                                                            *)
(* ********************************************************************** *)

lemma AC1_iff_AC6: "AC1 \<longleftrightarrow> AC6"
by (unfold AC1_def AC6_def, blast)

end


theory Chapter12_4_Evaluation
imports Chapter12_3_Typechecking
begin

fun is_val :: "expr => bool"
where "is_val (Var v) = False"
    | "is_val Zero = True"
    | "is_val (Suc e) = is_val e"
    | "is_val (Rec et e0 es) = False"
    | "is_val (Lam t e) = True"
    | "is_val (Appl e1 e2) = False"
    | "is_val Triv = True"
    | "is_val (Pair e1 e2) = (is_val e1 & is_val e2)"
    | "is_val (ProjL e) = False"
    | "is_val (ProjR e) = False"
    | "is_val (Abort t e) = False"
    | "is_val (Case et el er) = False"
    | "is_val (InL t1 t2 e) = is_val e"
    | "is_val (InR t1 t2 e) = is_val e"
    | "is_val (Match e rs) = False"

inductive eval :: "expr => expr => bool"
      and eval_rules :: "expr => rule list => expr => bool"
      and eval_rule :: "expr => rule => expr option => bool"
where eval_suc [simp]: "eval e e' ==> eval (Suc e) (Suc e')"
    | eval_rec_1 [simp]: "eval et et' ==> eval (Rec et e0 es) (Rec et' e0 es)"
    | eval_rec_2 [simp]: "eval (Rec Zero e0 es) e0"
    | eval_rec_3 [simp]: "is_val et ==>
            eval (Rec (Suc et) e0 es) (subst (Rec et e0 es) first (subst et first es))"
    | eval_appl_1 [simp]: "eval e1 e1' ==> eval (Appl e1 e2) (Appl e1' e2)"
    | eval_appl_2 [simp]: "is_val e1 ==> eval e2 e2' ==> eval (Appl e1 e2) (Appl e1 e2')"
    | eval_appl_3 [simp]: "is_val e2 ==> eval (Appl (Lam t2 e1) e2) (subst e2 first e1)"
    | eval_pair_1 [simp]: "eval e1 e1' ==> eval (Pair e1 e2) (Pair e1' e2)"
    | eval_pair_2 [simp]: "is_val e1 ==> eval e2 e2' ==> eval (Pair e1 e2) (Pair e1 e2')"
    | eval_projl_1 [simp]: "eval e e' ==> eval (ProjL e) (ProjL e')"
    | eval_projl_2 [simp]: "eval (ProjL (Pair e1 e2)) e1"
    | eval_projr_1 [simp]: "eval e e' ==> eval (ProjR e) (ProjR e')"
    | eval_projr_2 [simp]: "eval (ProjR (Pair e1 e2)) e2"
    | eval_abort [simp]: "eval e e' ==> eval (Abort t e) (Abort t e')"
    | eval_case_1 [simp]: "eval et et' ==> eval (Case et el er) (Case et' el er)"
    | eval_case_2 [simp]: "is_val e ==> eval (Case (InL t1 t2 e) el er) (subst e first el)"
    | eval_case_3 [simp]: "is_val e ==> eval (Case (InR t1 t2 e) el er) (subst e first er)"
    | eval_inl [simp]: "eval e e' ==> eval (InL t1 t2 e) (InL t1 t2 e')"
    | eval_inr [simp]: "eval e e' ==> eval (InR t1 t2 e) (InR t1 t2 e')"
    | eval_match_1 [simp]: "eval e e' ==> eval (Match e rs) (Match e' rs)"
    | eval_match_2 [simp]: "is_val e ==> eval_rules e rs e' ==> eval (Match e rs) e'"
    | eval_rules_1 [simp]: "is_val e ==> eval_rule e r (Some e') ==> eval_rules e (r # rs) e'"
    | eval_rules_2 [simp]: "is_val e ==> eval_rule e r None ==> eval_rules e rs e' ==>
            eval_rules e (r # rs) e'"
    | eval_rule_1 [simp]: "is_val e ==> matches p e s ==>
            eval_rule e (Rule p e') (Some (apply_subst s e'))"
    | eval_rule_2 [simp]: "is_val e ==> no_match p e ==> eval_rule e (Rule p e2) None"

lemma canonical_nat: "is_val e ==> typecheck gam e Nat ==>
          e = Zero | (EX e'. e = Suc e' & typecheck gam e' Nat)"
by (induction e, auto)

lemma canonical_nat_no_vars: "is_val e ==> typecheck gam e Nat ==> typecheck gam' e Nat"
by (induction e, auto)

lemma canonical_arrow: "is_val e ==> typecheck gam e (Arrow t1 t2) ==>
              EX e'. e = Lam t1 e' & typecheck (extend gam t1) e' t2"
by (induction e, auto)

lemma canonical_unit: "is_val e ==> typecheck gam e Unit ==> e = Triv"
by (induction e, auto)

lemma canonical_prod: "is_val e ==> typecheck gam e (Prod t1 t2) ==>
              EX e1 e2. e = Pair e1 e2 & typecheck gam e1 t1 & typecheck gam e2 t2"
by (induction e, auto)

lemma canonical_void: "is_val e ==> typecheck gam e Void ==> False"
by (induction e, auto)

lemma canonical_sum: "is_val e ==> typecheck gam e (Sum t1 t2) ==>
          (EX e'. e = InL t1 t2 e' & typecheck gam e' t1) |
          (EX e'. e = InR t1 t2 e' & typecheck gam e' t2)"
by (induction e, auto)

lemma "typecheck_patn p t sig ==> typecheck gam e t ==> is_val e ==>
          (EX s. matches p e s & typecheck_subst gam s sig) | no_match p e"
proof (induction p t sig arbitrary: e gam rule: typecheck_patn.induct)
case tc_vpat
  thus ?case by (metis matches.intros(1) typecheck_subst.intros(1) typecheck_subst.intros(2))
next case tc_wpat
  thus ?case by (metis matches.intros(2) typecheck_subst.intros(1))
next case tc_tpat
  thus ?case by (metis canonical_unit matches.intros(3) typecheck_subst.intros(1))
next case (tc_ppat p1 t1 s1 p2 t2 s2)
  then obtain e1 e2 where E1E2: "e = Pair e1 e2 & typecheck gam e1 t1 & typecheck gam e2 t2" by (metis canonical_prod)
  thus ?case proof (cases "no_match p1 e1")
  case True
    with E1E2 show ?thesis by (metis no_match.intros(2))
  next case False
    with tc_ppat E1E2 obtain s where SDEF: "matches p1 e1 s \<and> typecheck_subst gam s s1" by fastforce
    thus ?thesis proof (cases "no_match p2 e2")
    case True
      with E1E2 show ?thesis by (metis no_match.intros(3))
    next case False
      with tc_ppat E1E2 obtain s' where "matches p2 e2 s' \<and> typecheck_subst gam s' s2" by fastforce
      with SDEF have "matches (PairPat p1 p2) (Pair e1 e2) (s @ s') & typecheck_subst gam (s @ s') (s1 +++ s2)" by simp
      with E1E2 show ?thesis by metis
    qed
  qed
next case tc_lpat
  thus ?case by (metis canonical_sum expr.distinct(206) expr.inject(11) is_val.simps(13)
                 matches.intros(5) no_match.intros(5) no_match.intros(6))
next case tc_rpat
  thus ?case by (metis canonical_sum expr.distinct(206) expr.inject(12) is_val.simps(14)
                 matches.intros(6) no_match.intros(7) no_match.intros(8))
qed

theorem preservation: "eval e e' ==> typecheck gam e t ==> typecheck gam e' t"
    and "eval_rules e rs e' ==> typecheck gam e tt ==> typecheck_rules gam tt rs t ==>
            typecheck gam e' t"
    and "eval_rule e r oe' ==> oe' = Some e' ==> typecheck gam e tt ==> typecheck_rule gam tt r t ==>
            typecheck gam e' t"
proof (induction e e' and e rs e' and e r oe' arbitrary: t and tt t and tt t e'
       rule: eval_eval_rules_eval_rule.inducts)
case eval_suc
  thus ?case by fastforce
next case eval_rec_1
  thus ?case by fastforce
next case eval_rec_2
  thus ?case by fastforce
next case (eval_rec_3 et e0 es)
  from eval_rec_3 canonical_nat_no_vars have "typecheck (extend gam t) (subst et first es) t" by auto
  with eval_rec_3 show ?case by fastforce
next case eval_appl_1
  thus ?case by fastforce
next case eval_appl_2
  thus ?case by fastforce
next case eval_appl_3
  thus ?case by fastforce
next case eval_pair_1
  thus ?case by fastforce
next case eval_pair_2
  thus ?case by fastforce
next case eval_projl_1
  thus ?case by fastforce
next case eval_projl_2
  thus ?case by fastforce
next case eval_projr_1
  thus ?case by fastforce
next case eval_projr_2
  thus ?case by fastforce
next case eval_abort
  thus ?case by fastforce
next case eval_case_1
  thus ?case by fastforce
next case eval_case_2
  thus ?case by fastforce
next case eval_case_3
  thus ?case by fastforce
next case eval_inl
  thus ?case by fastforce
next case eval_inr
  thus ?case by fastforce
next case eval_match_1
  thus ?case by fastforce
next case eval_match_2
  thus ?case by fastforce
next case eval_rules_1
  thus ?case by fastforce
next case eval_rules_2
  thus ?case by fastforce
next case (eval_rule_1 e p s e'' tt)
  then obtain sig where SIG: "typecheck_patn p tt sig & typecheck (sig +++ gam) e'' t" by fast
  from eval_rule_1 SIG have "typecheck_subst gam s sig" by simp
  with SIG have "typecheck gam (apply_subst s e'') t" by simp
  with eval_rule_1 show ?case by simp
next case eval_rule_2
  thus ?case by fastforce
qed

theorem progress: "typecheck gam e t ==> gam = empty_env ==> is_val e | (EX e'. eval e e')"
    and "typecheck_rules gam tt rs t ==> is_val e ==> satisfies e (rules_constraint rs) ==>
            typecheck gam e tt ==> gam = empty_env ==> EX e'. eval_rules e rs e'"
    and "typecheck_rule gam tt r t ==> is_val e ==> typecheck gam e tt ==> gam = empty_env ==>
              (satisfies e (rule_constraint r) --> (EX e'. eval_rule e r (Some e'))) &
              (~ satisfies e (rule_constraint r) --> eval_rule e r None)"
proof (induction gam e t and gam tt rs t and gam tt r t arbitrary: and e and e rs
       rule: typecheck_typecheck_rules_typecheck_rule.inducts)
case tc_var
  thus ?case by simp
next case tc_zero
  thus ?case by simp
next case tc_suc
  thus ?case by (metis eval_suc is_val.simps(3))
next case tc_rec
  thus ?case by (metis eval_rec_1 eval_rec_2 eval_rec_3 is_val.simps(3) canonical_nat)
next case tc_lam
  thus ?case by simp
next case tc_appl
  thus ?case by (metis eval_appl_1 eval_appl_2 eval_appl_3 canonical_arrow)
next case tc_triv
  thus ?case by simp
next case tc_pair
  thus ?case by (metis eval_pair_1 eval_pair_2 is_val.simps(8))
next case tc_projl
  thus ?case by (metis eval_projl_1 eval_projl_2 canonical_prod)
next case tc_projr
  thus ?case by (metis eval_projr_1 eval_projr_2 canonical_prod)
next case tc_abort
  thus ?case by (metis eval_abort canonical_void)
next case tc_case
  thus ?case
  by (metis eval_case_1 eval_case_2 eval_case_3 is_val.simps(13) is_val.simps(14) canonical_sum)
next case tc_inl
  thus ?case by (metis eval_inl is_val.simps(13))
next case tc_inr
  thus ?case by (metis eval_inr is_val.simps(14))
next case (tc_match gam e t1 rs t)
  thus ?case
  proof (cases "is_val e")
  case False
    with tc_match show ?thesis by (metis eval_match_1)
  next case True
    with tc_match have "EX a. eval_rules e rs a" by simp
    with True show ?thesis by (metis eval_match_2)
  qed
next case tc_rules_nil
  thus ?case by auto
next case (tc_rules_cons gam t1 r t rs)
  thus ?case
  proof (cases "satisfies e (rule_constraint r)")
  case True
    with tc_rules_cons show ?thesis by (metis eval_rules_1)
  next case False
    from tc_rules_cons have "satisfies e (rules_constraint (r # rs))" by simp
    with False have "satisfies e (rules_constraint rs)" by force
    with tc_rules_cons False show ?thesis by (metis eval_rules_2)
  qed
next case (tc_rule p t1 sig gam e' t)
  thus ?case
  proof auto
    assume V: "is_val e" and "satisfies e (patn_constraint p)"
    hence "EX s. matches p e s" by simp
    with V show "EX a. eval_rule e (Rule p e') (Some a)" by (metis eval_rule_1)
  qed
qed

end


(* Title:      N-Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>N-Algebras\<close>

theory N_Algebras

imports Stone_Kleene_Relation_Algebras.Iterings Base Lattice_Ordered_Semirings

begin

class C_left_n_algebra = bounded_idempotent_left_semiring + bounded_distrib_lattice + n + L
begin

abbreviation C :: "'a \<Rightarrow> 'a" where "C x \<equiv> n(L) * top \<sqinter> x"

text \<open>AACP Theorem 3.38\<close>

lemma C_isotone:
  "x \<le> y \<longrightarrow> C x \<le> C y"
  using inf.sup_right_isotone by auto

text \<open>AACP Theorem 3.40\<close>

lemma C_decreasing:
  "C x \<le> x"
  by simp

end

class left_n_algebra = C_left_n_algebra +
  assumes n_dist_n_add            : "n(x) \<squnion> n(y) = n(n(x) * top \<squnion> y)"
  assumes n_export                : "n(x) * n(y) = n(n(x) * y)"
  assumes n_left_upper_bound      : "n(x) \<le> n(x \<squnion> y)"
  assumes n_nL_meet_L_nL0         : "n(L) * x = (x \<sqinter> L) \<squnion> n(L * bot) * x"
  assumes n_n_L_split_n_n_L_L     : "x * n(y) * L = x * bot \<squnion> n(x * n(y) * L) * L"
  assumes n_sub_nL                : "n(x) \<le> n(L)"
  assumes n_L_decreasing          : "n(x) * L \<le> x"
  assumes n_L_T_meet_mult_combined: "C (x * y) * z \<le> C x * y * C z"
  assumes n_n_top_split_n_top     : "x * n(y) * top \<le> x * bot \<squnion> n(x * y) * top"
  assumes n_top_meet_L_below_L    : "x * top * y \<sqinter> L \<le> x * L * y"
begin

subclass lattice_ordered_pre_left_semiring ..

lemma n_L_T_meet_mult_below:
  "C (x * y) \<le> C x * y"
proof -
  have "C (x * y) \<le> C x * y * C 1"
    by (meson order.trans mult_sub_right_one n_L_T_meet_mult_combined)
  also have "... \<le> C x * y"
    by (metis mult_1_right mult_left_sub_dist_inf_right)
  finally show ?thesis
    .
qed

text \<open>AACP Theorem 3.41\<close>

lemma n_L_T_meet_mult_propagate:
  "C x * y \<le> x * C y"
proof -
  have "C x * y \<le> C x * 1 * C y"
    by (metis mult_1_right mult_assoc n_L_T_meet_mult_combined mult_1_right)
  also have "... \<le> x * C y"
    by (simp add: mult_right_sub_dist_inf_right)
  finally show ?thesis
    .
qed

text \<open>AACP Theorem 3.43\<close>

lemma C_n_mult_closed:
  "C (n(x) * y) = n(x) * y"
  by (simp add: inf.absorb2 mult_isotone n_sub_nL)

text \<open>AACP Theorem 3.40\<close>

lemma meet_L_below_C:
  "x \<sqinter> L \<le> C x"
  by (simp add: le_supI1 n_nL_meet_L_nL0)

text \<open>AACP Theorem 3.42\<close>

lemma n_L_T_meet_mult:
  "C (x * y) = C x * y"
  apply (rule order.antisym)
  apply (rule n_L_T_meet_mult_below)
  by (smt (z3) C_n_mult_closed inf.boundedE inf.sup_monoid.add_assoc inf.sup_monoid.add_commute mult_right_sub_dist_inf mult_assoc)

text \<open>AACP Theorem 3.42\<close>

lemma C_mult_propagate:
  "C x * y = C x * C y"
  by (smt (z3) C_n_mult_closed order.eq_iff inf.left_commute inf.sup_monoid.add_commute mult_left_sub_dist_inf_right n_L_T_meet_mult_propagate)

text \<open>AACP Theorem 3.32\<close>

lemma meet_L_below_n_L:
  "x \<sqinter> L \<le> n(L) * x"
  by (simp add: n_nL_meet_L_nL0)

text \<open>AACP Theorem 3.27\<close>

lemma n_vector_meet_L:
  "x * top \<sqinter> L \<le> x * L"
  by (metis mult_1_right n_top_meet_L_below_L)

lemma n_right_upper_bound:
  "n(x) \<le> n(y \<squnion> x)"
  by (simp add: n_left_upper_bound sup_commute)

text \<open>AACP Theorem 3.1\<close>

lemma n_isotone:
  "x \<le> y \<Longrightarrow> n(x) \<le> n(y)"
  by (metis le_iff_sup n_left_upper_bound)

lemma n_add_left_zero:
  "n(bot) \<squnion> n(x) = n(x)"
  using le_iff_sup sup_bot_right sup_right_divisibility n_isotone by auto

text \<open>AACP Theorem 3.13\<close>

lemma n_mult_right_zero_L:
  "n(x) * bot \<le> L"
  by (meson bot_least mult_isotone n_L_decreasing n_sub_nL order_trans)

lemma n_add_left_top:
  "n(top) \<squnion> n(x) = n(top)"
  by (simp add: sup_absorb1 n_isotone)

text \<open>AACP Theorem 3.18\<close>

lemma n_n_L:
  "n(n(x) * L) = n(x)"
  by (metis order.antisym n_dist_n_add n_export n_sub_nL sup_bot_right sup_commute sup_top_left n_add_left_zero n_right_upper_bound)

lemma n_mult_transitive:
  "n(x) * n(x) \<le> n(x)"
  by (metis mult_right_isotone n_export n_sub_nL n_n_L)

lemma n_mult_left_absorb_add_sub:
  "n(x) * (n(x) \<squnion> n(y)) \<le> n(x)"
  by (metis mult_right_isotone n_dist_n_add n_export n_sub_nL n_n_L)

text \<open>AACP Theorem 3.21\<close>

lemma n_mult_left_lower_bound:
  "n(x) * n(y) \<le> n(x)"
  by (metis mult_right_isotone n_export n_sub_nL n_n_L)

text \<open>AACP Theorem 3.20\<close>

lemma n_mult_left_zero:
  "n(bot) * n(x) = n(bot)"
  by (metis n_export sup_absorb1 n_add_left_zero n_mult_left_lower_bound)

lemma n_mult_right_one:
  "n(x) * n(top) = n(x)"
  using n_dist_n_add n_export sup_commute n_add_left_zero by fastforce

lemma n_L_increasing:
  "n(x) \<le> n(n(x) * L)"
  by (simp add: n_n_L)

text \<open>AACP Theorem 3.2\<close>

lemma n_galois:
  "n(x) \<le> n(y) \<longleftrightarrow> n(x) * L \<le> y"
  by (metis mult_left_isotone n_L_decreasing n_L_increasing n_isotone order_trans)

lemma n_add_n_top:
  "n(x \<squnion> n(x) * top) = n(x)"
  by (metis n_dist_n_add sup.idem sup_commute)

text \<open>AACP Theorem 3.6\<close>

lemma n_L_below_nL_top:
  "L \<le> n(L) * top"
  by (metis inf_top.left_neutral meet_L_below_n_L)

text \<open>AACP Theorem 3.4\<close>

lemma n_less_eq_char_n:
  "x \<le> y \<longleftrightarrow> x \<le> y \<squnion> L \<and> C x \<le> y \<squnion> n(y) * top"
proof
  assume "x \<le> y"
  thus "x \<le> y \<squnion> L \<and> C x \<le> y \<squnion> n(y) * top"
    by (simp add: inf.coboundedI2 le_supI1)
next
  assume 1: "x \<le> y \<squnion> L \<and> C x \<le> y \<squnion> n(y) * top"
  hence "x \<le> y \<squnion> (x \<sqinter> L)"
    using sup_commute sup_inf_distrib2 by force
  also have "... \<le> y \<squnion> C x"
    using sup_right_isotone meet_L_below_C by blast
  also have "... \<le> y \<squnion> n(y) * top"
    using 1 by simp
  finally have "x \<le> y \<squnion> (L \<sqinter> n(y) * top)"
    using 1 by (simp add: sup_inf_distrib1)
  thus "x \<le> y"
    by (metis inf_commute n_L_decreasing order_trans sup_absorb1 n_vector_meet_L)
qed

text \<open>AACP Theorem 3.31\<close>

lemma n_L_decreasing_meet_L:
  "n(x) * L \<le> x \<sqinter> L"
  using n_sub_nL n_galois by auto

text \<open>AACP Theorem 3.5\<close>

lemma n_zero_L_zero:
  "n(bot) * L = bot"
  by (simp add: le_bot n_L_decreasing)

lemma n_L_top_below_L:
  "L * top \<le> L"
proof -
  have "n(L * bot) * L * top \<le> L * bot"
    by (metis dense_top_closed mult_isotone n_L_decreasing zero_vector mult_assoc)
  hence "n(L * bot) * L * top \<le> L"
    using order_lesseq_imp zero_right_mult_decreasing by blast
  hence "n(L) * L * top \<le> L"
    by (metis inf.absorb2 n_nL_meet_L_nL0 order.refl sup.absorb_iff1 top_right_mult_increasing mult_assoc)
  thus "L * top \<le> L"
    by (metis inf.absorb2 inf.sup_monoid.add_commute n_L_decreasing n_L_below_nL_top n_vector_meet_L)
qed

text \<open>AACP Theorem 3.9\<close>

lemma n_L_top_L:
  "L * top = L"
  by (simp add: order.antisym top_right_mult_increasing n_L_top_below_L)

text \<open>AACP Theorem 3.10\<close>

lemma n_L_below_L:
  "L * x \<le> L"
  by (metis mult_right_isotone top.extremum n_L_top_L)

text \<open>AACP Theorem 3.7\<close>

lemma n_nL_nT:
  "n(L) = n(top)"
  using order.eq_iff n_sub_nL n_add_left_top by auto

text \<open>AACP Theorem 3.8\<close>

lemma n_L_L:
  "n(L) * L = L"
  using order.antisym meet_L_below_n_L n_L_decreasing_meet_L by fastforce

lemma n_top_L:
  "n(top) * L = L"
  using n_L_L n_nL_nT by auto

text \<open>AACP Theorem 3.23\<close>

lemma n_n_L_split_n_L:
  "x * n(y) * L \<le> x * bot \<squnion> n(x * y) * L"
  by (metis n_n_L_split_n_n_L_L n_L_decreasing mult_assoc mult_left_isotone mult_right_isotone n_isotone sup_right_isotone)

text \<open>AACP Theorem 3.12\<close>

lemma n_L_split_n_L_L:
  "x * L = x * bot \<squnion> n(x * L) * L"
  apply (rule order.antisym)
  apply (metis mult_assoc n_n_L_split_n_L n_L_L)
  by (simp add: mult_right_isotone n_L_decreasing)

text \<open>AACP Theorem 3.11\<close>

lemma n_L_split_L:
  "x * L \<le> x * bot \<squnion> L"
  by (metis n_n_L_split_n_n_L_L n_sub_nL sup_right_isotone mult_assoc n_L_L n_galois)

text \<open>AACP Theorem 3.24\<close>

lemma n_split_top:
  "x * n(y) * top \<le> x * y \<squnion> n(x * y) * top"
proof -
  have "x * bot \<squnion> n(x * y) * top \<le> x * y \<squnion> n(x * y) * top"
    by (meson bot_least mult_isotone order.refl sup_left_isotone)
  thus ?thesis
    using order.trans n_n_top_split_n_top by blast
qed

text \<open>AACP Theorem 3.9\<close>

lemma n_L_L_L:
  "L * L = L"
  by (metis inf.sup_monoid.add_commute inf_absorb1 n_L_below_L n_L_top_L n_vector_meet_L)

text \<open>AACP Theorem 3.9\<close>

lemma n_L_top_L_L:
  "L * top * L = L"
  by (simp add: n_L_L_L n_L_top_L)

text \<open>AACP Theorem 3.19\<close>

lemma n_n_nL:
  "n(x) = n(x) * n(L)"
  by (simp add: n_export n_n_L)

lemma n_L_mult_idempotent:
  "n(L) * n(L) = n(L)"
  using n_n_nL by auto

text \<open>AACP Theorem 3.22\<close>

lemma n_n_L_n:
  "n(x * n(y) * L) \<le> n(x * y)"
  by (simp add: mult_right_isotone n_L_decreasing mult_assoc n_isotone)

text \<open>AACP Theorem 3.3\<close>

lemma n_less_eq_char:
  "x \<le> y \<longleftrightarrow> x \<le> y \<squnion> L \<and> x \<le> y \<squnion> n(y) * top"
  by (meson inf.coboundedI2 le_supI1 n_less_eq_char_n)

text \<open>AACP Theorem 3.28\<close>

lemma n_top_meet_L_split_L:
  "x * top * y \<sqinter> L \<le> x * bot \<squnion> L * y"
proof -
  have "x * top * y \<sqinter> L \<le> x * bot \<squnion> n(x * L) * L * y"
    by (smt n_top_meet_L_below_L mult_assoc n_L_L_L n_L_split_n_L_L mult_right_dist_sup mult_left_zero)
  also have "... \<le> x * bot \<squnion> x * L * y"
    using mult_left_isotone n_L_decreasing sup_right_isotone by force
  also have "... \<le> x * bot \<squnion> (x * bot \<squnion> L) * y"
    using mult_left_isotone sup_right_isotone n_L_split_L by blast
  also have "... = x * bot \<squnion> x * bot * y \<squnion> L * y"
    by (simp add: mult_right_dist_sup sup_assoc)
  also have "... = x * bot \<squnion> L * y"
    by (simp add: mult_assoc)
  finally show ?thesis
    .
qed

text \<open>AACP Theorem 3.29\<close>

lemma n_top_meet_L_L_meet_L:
  "x * top * y \<sqinter> L = x * L * y \<sqinter> L"
  apply (rule order.antisym)
  apply (simp add: n_top_meet_L_below_L)
  by (metis inf.sup_monoid.add_commute inf.sup_right_isotone mult_isotone order.refl top.extremum)

lemma n_n_top_below_n_L:
  "n(x * top) \<le> n(x * L)"
  by (meson order.trans n_L_decreasing_meet_L n_galois n_vector_meet_L)

text \<open>AACP Theorem 3.14\<close>

lemma n_n_top_n_L:
  "n(x * top) = n(x * L)"
  by (metis order.antisym mult_right_isotone n_isotone n_n_top_below_n_L top_greatest)

text \<open>AACP Theorem 3.30\<close>

lemma n_meet_L_0_below_0_meet_L:
  "(x \<sqinter> L) * bot \<le> x * bot \<sqinter> L"
  by (meson inf.boundedE inf.boundedI mult_right_sub_dist_inf_left zero_right_mult_decreasing)

text \<open>AACP Theorem 3.15\<close>

lemma n_n_L_below_L:
  "n(x) * L \<le> x * L"
  by (metis mult_assoc mult_left_isotone n_L_L_L n_L_decreasing)

lemma n_n_L_below_n_L_L:
  "n(x) * L \<le> n(x * L) * L"
  by (simp add: mult_left_isotone n_galois n_n_L_below_L)

text \<open>AACP Theorem 3.16\<close>

lemma n_below_n_L:
  "n(x) \<le> n(x * L)"
  by (simp add: n_galois n_n_L_below_L)

text \<open>AACP Theorem 3.17\<close>

lemma n_below_n_L_mult:
  "n(x) \<le> n(L) * n(x)"
  by (metis n_export order_trans meet_L_below_n_L n_L_decreasing_meet_L n_isotone n_n_L)

text \<open>AACP Theorem 3.33\<close>

lemma n_meet_L_below:
  "n(x) \<sqinter> L \<le> x"
  by (meson inf.coboundedI1 inf.coboundedI2 le_supI2 sup.cobounded1 top_right_mult_increasing n_less_eq_char)

text \<open>AACP Theorem 3.35\<close>

lemma n_meet_L_top_below_n_L:
  "(n(x) \<sqinter> L) * top \<le> n(x) * L"
proof -
  have "(n(x) \<sqinter> L) * top \<le> n(x) * top \<sqinter> L * top"
    by (meson mult_right_sub_dist_inf)
  thus ?thesis
    by (metis n_L_top_L n_vector_meet_L order_trans)
qed

text \<open>AACP Theorem 3.34\<close>

lemma n_meet_L_top_below:
  "(n(x) \<sqinter> L) * top \<le> x"
  using order.trans n_L_decreasing n_meet_L_top_below_n_L by blast

text \<open>AACP Theorem 3.36\<close>

lemma n_n_meet_L:
  "n(x) = n(x \<sqinter> L)"
  by (meson order.antisym inf.cobounded1 n_L_decreasing_meet_L n_galois n_isotone)

lemma n_T_below_n_meet:
  "n(x) * top = n(C x) * top"
  by (metis inf.absorb2 inf.sup_monoid.add_assoc meet_L_below_C n_n_meet_L)

text \<open>AACP Theorem 3.44\<close>

lemma n_C:
  "n(C x) = n(x)"
  by (metis n_T_below_n_meet n_export n_mult_right_one)

text \<open>AACP Theorem 3.37\<close>

lemma n_T_meet_L:
  "n(x) * top \<sqinter> L = n(x) * L"
  by (metis antisym_conv n_L_decreasing_meet_L n_n_L n_n_top_n_L n_vector_meet_L)

text \<open>AACP Theorem 3.39\<close>

lemma n_L_top_meet_L:
  "C L = L"
  by (simp add: n_L_L n_T_meet_L)

end

class n_algebra = left_n_algebra + idempotent_left_zero_semiring
begin

(* independence of axioms, checked in n_algebra without the respective axiom: *)
proposition n_dist_n_add            : "n(x) \<squnion> n(y) = n(n(x) * top \<squnion> y)" (* nitpick [expect=genuine,card=5] *) oops
proposition n_export                : "n(x) * n(y) = n(n(x) * y)" (* nitpick [expect=genuine,card=4] *) oops
proposition n_left_upper_bound      : "n(x) \<le> n(x \<squnion> y)" (* nitpick [expect=genuine,card=5] *) oops
proposition n_nL_meet_L_nL0         : "n(L) * x = (x \<sqinter> L) \<squnion> n(L * bot) * x" (* nitpick [expect=genuine,card=2] *) oops
proposition n_n_L_split_n_n_L_L     : "x * n(y) * L = x * bot \<squnion> n(x * n(y) * L) * L" (* nitpick [expect=genuine,card=6] *) oops
proposition n_sub_nL                : "n(x) \<le> n(L)" (* nitpick [expect=genuine,card=2] *) oops
proposition n_L_decreasing          : "n(x) * L \<le> x" (* nitpick [expect=genuine,card=3] *) oops
proposition n_L_T_meet_mult_combined: "C (x * y) * z \<le> C x * y * C z" (* nitpick [expect=genuine,card=4] *) oops
proposition n_n_top_split_n_top     : "x * n(y) * top \<le> x * bot \<squnion> n(x * y) * top" (* nitpick [expect=genuine,card=4] *) oops
proposition n_top_meet_L_below_L    : "x * top * y \<sqinter> L \<le> x * L * y" (* nitpick [expect=genuine,card=5] *) oops

text \<open>AACP Theorem 3.25\<close>

lemma n_top_split_0:
  "n(x) * top * y \<le> x * y \<squnion> n(x * bot) * top"
proof -
  have 1: "n(x) * top * y \<sqinter> L \<le> x * y"
    using inf.coboundedI1 mult_left_isotone n_L_decreasing_meet_L n_top_meet_L_L_meet_L by force
  have "n(x) * top * y = n(x) * n(L) * top * y"
    using n_n_nL by auto
  also have "... = n(x) * ((top * y \<sqinter> L) \<squnion> n(L * bot) * top * y)"
    by (metis mult_assoc n_nL_meet_L_nL0)
  also have "... \<le> n(x) * (top * y \<sqinter> L) \<squnion> n(x) * n(L * bot) * top"
    by (metis sup_right_isotone mult_assoc mult_left_dist_sup mult_right_isotone top_greatest)
  also have "... \<le> (n(x) * top * y \<sqinter> L) \<squnion> n(n(x) * L * bot) * top"
    by (smt sup_left_isotone order.trans inf_greatest mult_assoc mult_left_sub_dist_inf_left mult_left_sub_dist_inf_right n_export n_galois n_sub_nL)
  also have "... \<le> x * y \<squnion> n(n(x) * L * bot) * top"
    using 1 sup_left_isotone by blast
  also have "... \<le> x * y \<squnion> n(x * bot) * top"
    using mult_left_isotone n_galois n_isotone order.refl sup_right_isotone by auto
  finally show ?thesis
    .
qed

text \<open>AACP Theorem 3.26\<close>

lemma n_top_split:
  "n(x) * top * y \<le> x * y \<squnion> n(x * y) * top"
  by (metis order.trans sup_bot_right mult_assoc sup_right_isotone mult_left_isotone mult_left_sub_dist_sup_right n_isotone n_top_split_0)

proposition n_zero: "n(bot) = bot" nitpick [expect=genuine,card=2] oops
proposition n_one: "n(1) = bot" nitpick [expect=genuine,card=2] oops
proposition n_nL_one: "n(L) = 1" nitpick [expect=genuine,card=2] oops
proposition n_nT_one: "n(top) = 1" nitpick [expect=genuine,card=2] oops
proposition n_n_zero: "n(x) = n(x * bot)" nitpick [expect=genuine,card=2] oops
proposition n_dist_add: "n(x) \<squnion> n(y) = n(x \<squnion> y)" nitpick [expect=genuine,card=4] oops
proposition n_L_split: "x * n(y) * L = x * bot \<squnion> n(x * y) * L" nitpick [expect=genuine,card=3] oops
proposition n_split: "x \<le> x * bot \<squnion> n(x * L) * top" nitpick [expect=genuine,card=2] oops
proposition n_mult_top_1: "n(x * y) \<le> n(x * n(y) * top)" nitpick [expect=genuine,card=3] oops
proposition l91_1: "n(L) * x \<le> n(x * top) * top" nitpick [expect=genuine,card=3] oops
proposition meet_domain_top: "x \<sqinter> n(y) * top = n(y) * x" nitpick [expect=genuine,card=3] oops
proposition meet_domain_2: "x \<sqinter> n(y) * top \<le> n(L) * x" nitpick [expect=genuine,card=4] oops
proposition n_nL_top_n_top_meet_L_top_2: "n(L) * x * top \<le> n(x * top \<sqinter> L) * top" nitpick [expect=genuine,card=3] oops
proposition n_nL_top_n_top_meet_L_top_1: "n(x * top \<sqinter> L) * top \<le> n(L) * x * top" nitpick [expect=genuine,card=2] oops
proposition l9: "x * bot \<sqinter> L \<le> n(x * L) * L" nitpick [expect=genuine,card=4] oops
proposition l18_2: "n(x * L) * L \<le> n(x) * L" nitpick [expect=genuine,card=3] oops
proposition l51_1: "n(x) * L \<le> (x \<sqinter> L) * bot" nitpick [expect=genuine,card=2] oops
proposition l51_2: "(x \<sqinter> L) * bot \<le> n(x) * L" nitpick [expect=genuine,card=4] oops

proposition n_split_equal: "x \<squnion> n(x * L) * top = x * bot \<squnion> n(x * L) * top" nitpick [expect=genuine,card=2] oops
proposition n_split_top: "x * top \<le> x * bot \<squnion> n(x * L) * top" nitpick [expect=genuine,card=2] oops
proposition n_mult: "n(x * n(y) * L) = n(x * y)" nitpick [expect=genuine,card=3] oops
proposition n_mult_1: "n(x * y) \<le> n(x * n(y) * L)" nitpick [expect=genuine,card=3] oops
proposition n_mult_top: "n(x * n(y) * top) = n(x * y)" nitpick [expect=genuine,card=3] oops
proposition n_mult_right_upper_bound: "n(x * y) \<le> n(z) \<longleftrightarrow> n(x) \<le> n(z) \<and> x * n(y) * L \<le> x * bot \<squnion> n(z) * L" nitpick [expect=genuine,card=2] oops
proposition meet_domain: "x \<sqinter> n(y) * z = n(y) * (x \<sqinter> z)" nitpick [expect=genuine,card=3] oops
proposition meet_domain_1: "x \<sqinter> n(y) * z \<le> n(y) * x" nitpick [expect=genuine,card=3] oops
proposition meet_domain_top_3: "x \<sqinter> n(y) * top \<le> n(y) * x" nitpick [expect=genuine,card=3] oops
proposition n_n_top_n_top_split_n_n_top_top: "n(x) * top \<squnion> x * n(y) * top = x * bot \<squnion> n(x * n(y) * top) * top" nitpick [expect=genuine,card=2] oops
proposition n_n_top_n_top_split_n_n_top_top_1: "x * bot \<squnion> n(x * n(y) * top) * top \<le> n(x) * top \<squnion> x * n(y) * top" nitpick [expect=genuine,card=5] oops
proposition n_n_top_n_top_split_n_n_top_top_2: "n(x) * top \<squnion> x * n(y) * top \<le> x * bot \<squnion> n(x * n(y) * top) * top" nitpick [expect=genuine,card=2] oops
proposition n_nL_top_n_top_meet_L_top: "n(L) * x * top = n(x * top \<sqinter> L) * top" nitpick [expect=genuine,card=2] oops
proposition l18: "n(x) * L = n(x * L) * L" nitpick [expect=genuine,card=3] oops
proposition l22: "x * bot \<sqinter> L = n(x) * L" nitpick [expect=genuine,card=2] oops
proposition l22_1: "x * bot \<sqinter> L = n(x * L) * L" nitpick [expect=genuine,card=2] oops
proposition l22_2: "x \<sqinter> L = n(x) * L" nitpick [expect=genuine,card=3] oops
proposition l22_3: "x \<sqinter> L = n(x * L) * L" nitpick [expect=genuine,card=3] oops
proposition l22_4: "x \<sqinter> L \<le> n(x) * L" nitpick [expect=genuine,card=3] oops
proposition l22_5: "x * bot \<sqinter> L \<le> n(x) * L" nitpick [expect=genuine,card=4] oops
proposition l23: "x * top \<sqinter> L = n(x) * L" nitpick [expect=genuine,card=3] oops
proposition l51: "n(x) * L = (x \<sqinter> L) * bot" nitpick [expect=genuine,card=2] oops
proposition l91: "x = x * top \<longrightarrow> n(L) * x \<le> n(x) * top" nitpick [expect=genuine,card=3] oops
proposition l92: "x = x * top \<longrightarrow> n(L) * x \<le> n(x \<sqinter> L) * top" nitpick [expect=genuine,card=3] oops
proposition "x \<sqinter> L \<le> n(x) * top" nitpick [expect=genuine,card=3] oops
proposition n_meet_comp: "n(x) \<sqinter> n(y) \<le> n(x) * n(y)" nitpick [expect=genuine,card=3] oops

proposition n_n_meet_L_n_zero: "n(x) = (n(x) \<sqinter> L) \<squnion> n(x * bot)" oops
proposition n_below_n_zero: "n(x) \<le> x \<squnion> n(x * bot)" oops
proposition n_n_top_split_n_L_n_zero_top: "n(x) * top = n(x) * L \<squnion> n(x * bot) * top" oops
proposition n_meet_L_0_0_meet_L: "(x \<sqinter> L) * bot = x * bot \<sqinter> L" oops

end

end


(* Title:      Regular Algebras
   Author:     Simon Foster, Georg Struth
   Maintainer: Simon Foster <s.foster at york.ac.uk>
               Georg Struth <g.struth at sheffield.ac.uk>
*)

header {* Pratt's Counterexamples *}

theory Pratts_Counterexamples
  imports Regular_Algebras
begin

text {* We create two regular algebra models due to Pratt~\cite{Pratt} which are used to
        distinguish K1 algebras from K1l and K1r algebras. *}

datatype pratt1 =
  P1Bot ("\<bottom>\<^sub>1") |
  P1Nat nat ("[_]\<^sub>1") |
  P1Infty ("\<infinity>\<^sub>1") |
  P1Top ("\<top>\<^sub>1")

datatype pratt2 =
  P2Bot ("\<bottom>\<^sub>2") |
  P2Nat nat ("[_]\<^sub>2") |
  P2Infty ("\<infinity>\<^sub>2") |
  P2Top ("\<top>\<^sub>2")

fun pratt1_max where
  "pratt1_max [x]\<^sub>1 [y]\<^sub>1 = [max x y]\<^sub>1" |
  "pratt1_max x \<bottom>\<^sub>1 = x" |
  "pratt1_max \<bottom>\<^sub>1 y = y" |
  "pratt1_max \<infinity>\<^sub>1 [y]\<^sub>1 = \<infinity>\<^sub>1" |
  "pratt1_max [y]\<^sub>1 \<infinity>\<^sub>1 = \<infinity>\<^sub>1" |
  "pratt1_max \<infinity>\<^sub>1 \<infinity>\<^sub>1 = \<infinity>\<^sub>1" |
  "pratt1_max \<top>\<^sub>1 x = \<top>\<^sub>1" |
  "pratt1_max x \<top>\<^sub>1 = \<top>\<^sub>1"

fun pratt1_plus :: "pratt1 \<Rightarrow> pratt1 \<Rightarrow> pratt1" (infixl "+\<^sub>1" 65) where
  "[x]\<^sub>1 +\<^sub>1 [y]\<^sub>1 = [x + y]\<^sub>1" |
  "\<bottom>\<^sub>1 +\<^sub>1 x = \<bottom>\<^sub>1" |
  "x +\<^sub>1 \<bottom>\<^sub>1 = \<bottom>\<^sub>1" |
  "\<infinity>\<^sub>1 +\<^sub>1 [0]\<^sub>1 = \<infinity>\<^sub>1" |
  "[0]\<^sub>1 +\<^sub>1 \<infinity>\<^sub>1 = \<infinity>\<^sub>1" |
  "\<infinity>\<^sub>1 +\<^sub>1 \<infinity>\<^sub>1 = \<top>\<^sub>1" | (* Can be adjusted to PInfty *)
  "\<top>\<^sub>1 +\<^sub>1 x = \<top>\<^sub>1" |
  "x +\<^sub>1 \<top>\<^sub>1 = \<top>\<^sub>1" |
  "[x]\<^sub>1 +\<^sub>1 \<infinity>\<^sub>1 = \<infinity>\<^sub>1" |
  "\<infinity>\<^sub>1 +\<^sub>1 x = \<top>\<^sub>1"

lemma plusl_top_infty: "\<top>\<^sub>1 +\<^sub>1 \<infinity>\<^sub>1 = \<top>\<^sub>1"
  by (simp)

lemma plusl_infty_top: "\<infinity>\<^sub>1 +\<^sub>1 \<top>\<^sub>1  = \<top>\<^sub>1"
  by (simp)

lemma plusl_bot_infty: "\<bottom>\<^sub>1 +\<^sub>1 \<infinity>\<^sub>1 = \<bottom>\<^sub>1"
  by (simp)

lemma plusl_infty_bot: "\<infinity>\<^sub>1 +\<^sub>1 \<bottom>\<^sub>1  = \<bottom>\<^sub>1"
  by (simp)

lemma plusl_zero_infty: "[0]\<^sub>1 +\<^sub>1 \<infinity>\<^sub>1 = \<infinity>\<^sub>1"
  by (simp)

lemma plusl_infty_zero: "\<infinity>\<^sub>1 +\<^sub>1 [0]\<^sub>1 = \<infinity>\<^sub>1"
  by (simp)

lemma plusl_infty_num [simp]: "x > 0 \<Longrightarrow> \<infinity>\<^sub>1 +\<^sub>1 [x]\<^sub>1 = \<top>\<^sub>1"
  by (case_tac x, simp_all)

lemma plusl_num_infty [simp]: "x > 0 \<Longrightarrow> [x]\<^sub>1 +\<^sub>1 \<infinity>\<^sub>1 = \<infinity>\<^sub>1"
  by (case_tac x, simp_all)

fun pratt2_max where
  "pratt2_max [x]\<^sub>2 [y]\<^sub>2 = [max x y]\<^sub>2" |
  "pratt2_max x \<bottom>\<^sub>2 = x" |
  "pratt2_max \<bottom>\<^sub>2 y = y" |
  "pratt2_max \<infinity>\<^sub>2 [y]\<^sub>2 = \<infinity>\<^sub>2" |
  "pratt2_max [y]\<^sub>2 \<infinity>\<^sub>2 = \<infinity>\<^sub>2" |
  "pratt2_max \<infinity>\<^sub>2 \<infinity>\<^sub>2 = \<infinity>\<^sub>2" |
  "pratt2_max \<top>\<^sub>2 x = \<top>\<^sub>2" |
  "pratt2_max x \<top>\<^sub>2 = \<top>\<^sub>2"

fun pratt2_plus :: "pratt2 \<Rightarrow> pratt2 \<Rightarrow> pratt2" (infixl "+\<^sub>2" 65) where
  "[x]\<^sub>2 +\<^sub>2 [y]\<^sub>2 = [x + y]\<^sub>2" |
  "\<bottom>\<^sub>2 +\<^sub>2 x = \<bottom>\<^sub>2" |
  "x +\<^sub>2 \<bottom>\<^sub>2 = \<bottom>\<^sub>2" |
  "\<infinity>\<^sub>2 +\<^sub>2 [0]\<^sub>2 = \<infinity>\<^sub>2" |
  "[0]\<^sub>2 +\<^sub>2 \<infinity>\<^sub>2 = \<infinity>\<^sub>2" |
  "\<infinity>\<^sub>2 +\<^sub>2 \<infinity>\<^sub>2 = \<top>\<^sub>2" | (* Can be adjusted to PInfty *)
  "\<top>\<^sub>2 +\<^sub>2 x = \<top>\<^sub>2" |
  "x +\<^sub>2 \<top>\<^sub>2 = \<top>\<^sub>2" |
  "x +\<^sub>2 \<infinity>\<^sub>2 = \<top>\<^sub>2" |
  "\<infinity>\<^sub>2 +\<^sub>2 [x]\<^sub>2 = \<infinity>\<^sub>2"

instantiation pratt1 :: selective_semiring
begin

  definition zero_pratt1_def:
    "0 \<equiv> \<bottom>\<^sub>1"

  definition one_pratt1_def:
    "1 \<equiv> [0]\<^sub>1"

  definition plus_pratt1_def:
    "x + y \<equiv> pratt1_max x y"

  definition times_pratt1_def:
    "x * y \<equiv> x +\<^sub>1 y"

  definition less_eq_pratt1_def:
    "(x::pratt1) \<le> y \<equiv> x + y = y"

  definition less_pratt1_def:
    "(x::pratt1) < y \<equiv> x \<le> y \<and> x \<noteq> y"

  instance
  proof
    fix x y z :: pratt1
    show "x + y + z = x + (y + z)"
      by (case_tac x, case_tac[!] y, case_tac[!] z, simp_all add: plus_pratt1_def)
    show "x + y = y + x"
      by (cases x, case_tac[!] y, simp_all add: plus_pratt1_def)
    show "x * y * z = x * (y * z)"
      apply (cases x, case_tac[!] y, case_tac[!] z, simp_all add: plus_pratt1_def times_pratt1_def)
      apply (rename_tac[!] n, case_tac[!] n, auto)
      apply (metis nat.exhaust plusl_zero_infty pratt1_plus.simps(14))
      apply (metis not0_implies_Suc plusl_infty_zero plusl_zero_infty pratt1_plus.simps(14))
      apply (metis neq0_conv plusl_num_infty plusl_zero_infty pratt1_plus.simps(15))
      apply (metis not0_implies_Suc plusl_infty_zero pratt1_plus.simps(15) pratt1_plus.simps(9))
      apply (metis not0_implies_Suc plusl_infty_zero pratt1_plus.simps(15) pratt1_plus.simps(9))
    done
    show "(x + y) * z = x * z + y * z"
      apply (cases x, case_tac[!] y, case_tac[!] z, simp_all add: plus_pratt1_def times_pratt1_def)
      apply (rename_tac[!] n, case_tac[!] n, auto)
      apply (metis neq0_conv plusl_num_infty plusl_zero_infty pratt1_max.simps(8))+
    done
    show "1 * x = x"
      by (cases x, simp_all add: one_pratt1_def times_pratt1_def)
    show "x * 1 = x"
      by (cases x, simp_all add: one_pratt1_def times_pratt1_def)
    show "0 + x = x"
      by (cases x, simp_all add: plus_pratt1_def zero_pratt1_def)
    show "0 * x = 0"
      by (cases x, simp_all add: times_pratt1_def zero_pratt1_def)
    show "x * 0 = 0"
      by (cases x, simp_all add: times_pratt1_def zero_pratt1_def)
    show "x \<le> y \<longleftrightarrow> x + y = y"
      by (metis less_eq_pratt1_def)
    show "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"
      by (metis less_pratt1_def)
    show "x + y = x \<or> x + y = y"
      by (cases x, case_tac[!] y, simp_all add: plus_pratt1_def max_def)
    show "x * (y + z) = x * y + x * z"
      apply (cases x, case_tac[!] y, case_tac[!] z, simp_all add: plus_pratt1_def times_pratt1_def)
      apply (rename_tac[!] n, case_tac[!] n, auto)
      apply (metis nat.exhaust plusl_zero_infty pratt1_max.simps(7) pratt1_plus.simps(14))
      apply (metis neq0_conv plusl_num_infty plusl_zero_infty pratt1_max.simps(7))
      apply (metis nat.exhaust plusl_zero_infty pratt1_max.simps(6) pratt1_plus.simps(14))
      apply (metis neq0_conv plusl_num_infty plusl_zero_infty pratt1_max.simps(6))
      apply (metis neq0_conv plusl_infty_num plusl_infty_zero pratt1_max.simps(10) pratt1_max.simps(8))
      apply (metis not0_implies_Suc plusl_infty_zero pratt1_max.simps(11) pratt1_max.simps(13) pratt1_plus.simps(15))
    done
  qed
end

instance pratt1 :: dioid_one_zero ..

instantiation pratt2 :: selective_semiring
begin

  definition zero_pratt2_def:
    "0 \<equiv> \<bottom>\<^sub>2"

  definition one_pratt2_def:
    "1 \<equiv> [0]\<^sub>2"

  definition times_pratt2_def:
    "x * y \<equiv> x +\<^sub>2 y"

  definition plus_pratt2 :: "pratt2 \<Rightarrow> pratt2 \<Rightarrow> pratt2" where
    "plus_pratt2 x y \<equiv> pratt2_max x y"

  definition less_eq_pratt2_def:
    "(x::pratt2) \<le> y \<equiv> x + y = y"

  definition less_pratt2_def:
    "(x::pratt2) < y \<equiv> x \<le> y \<and> x \<noteq> y"

  instance
  proof
    fix x y z :: pratt2
    show "x + y + z = x + (y + z)"
      by (case_tac x, case_tac[!] y, case_tac[!] z, simp_all add: plus_pratt2_def)
    show "x + y = y + x"
      by (cases x, case_tac[!] y, simp_all add: plus_pratt2_def)
    show "x * y * z = x * (y * z)"
      apply (cases x, case_tac[!] y, case_tac[!] z, auto simp add: times_pratt2_def)
      apply (rename_tac[!] n, case_tac[!] n, auto)
      apply (metis not0_implies_Suc pratt2_plus.simps(14) pratt2_plus.simps(6) pratt2_plus.simps(7) pratt2_plus.simps(9))
      apply (metis not0_implies_Suc pratt2_plus.simps(14) pratt2_plus.simps(15) pratt2_plus.simps(7) pratt2_plus.simps(9))
      apply (metis not0_implies_Suc pratt2_plus.simps(15) pratt2_plus.simps(6))
      apply (metis not0_implies_Suc pratt2_plus.simps(15) pratt2_plus.simps(6))
    done
    show "(x + y) * z = x * z + y * z"
      apply (cases x, case_tac[!] y, case_tac[!] z, simp_all add: plus_pratt2_def times_pratt2_def)
      apply (rename_tac[!] n, case_tac[!] n, auto)
      apply (metis not0_implies_Suc pratt2_max.simps(10) pratt2_max.simps(8) pratt2_plus.simps(14) pratt2_plus.simps(7))
      apply (metis max_0L max_0R max.left_idem nat.exhaust pratt2_max.simps(11)
                   pratt2_max.simps(13) pratt2_plus.simps(14) pratt2_plus.simps(7))
    done
    show "1 * x = x"
      by (cases x, simp_all add: one_pratt2_def times_pratt2_def)
    show "x * 1 = x"
      by (cases x, simp_all add: one_pratt2_def times_pratt2_def)
    show "0 + x = x"
      by (cases x, simp_all add: plus_pratt2_def zero_pratt2_def)
    show "0 * x = 0"
      by (cases x, simp_all add: times_pratt2_def zero_pratt2_def)
    show "x * 0 = 0"
      by (cases x, simp_all add: times_pratt2_def zero_pratt2_def)
    show "x \<le> y \<longleftrightarrow> x + y = y"
      by (metis less_eq_pratt2_def)
    show "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"
      by (metis less_pratt2_def)
    show "x + y = x \<or> x + y = y"
      by (cases x, case_tac[!] y, simp_all add: plus_pratt2_def max_def)
    show "x * (y + z) = x * y + x * z"
      apply (cases x, case_tac[!] y, case_tac[!] z, simp_all add: plus_pratt2_def times_pratt2_def)
      apply (rename_tac[!] n, case_tac[!] n, auto)
      apply (metis not0_implies_Suc pratt2_max.simps(12) pratt2_max.simps(7) pratt2_plus.simps(14) pratt2_plus.simps(7))
      apply (metis nat.exhaust pratt2_max.simps(12) pratt2_max.simps(7) pratt2_plus.simps(14) pratt2_plus.simps(7))
      apply (metis not0_implies_Suc pratt2_max.simps(6) pratt2_max.simps(9) pratt2_plus.simps(14) pratt2_plus.simps(7))
      apply (metis nat.exhaust pratt2_max.simps(6) pratt2_max.simps(9) pratt2_plus.simps(14) pratt2_plus.simps(7))
      apply (metis not0_implies_Suc pratt2_max.simps(8) pratt2_plus.simps(15) pratt2_plus.simps(6))
      apply (metis not0_implies_Suc pratt2_max.simps(8) pratt2_plus.simps(15) pratt2_plus.simps(6))
    done
  qed
end

lemma top_greatest: "x \<le> \<top>\<^sub>1"
  by (case_tac x, auto simp add: less_eq_pratt1_def plus_pratt1_def)

instantiation pratt1 :: star_op
begin

  definition star_pratt1 where
    "x\<^sup>\<star> \<equiv> if (x = \<bottom>\<^sub>1 \<or> x = [0]\<^sub>1) then [0]\<^sub>1 else \<top>\<^sub>1"
  instance ..
end

instantiation pratt2 :: star_op
begin
  definition star_pratt2 where
    "x\<^sup>\<star> \<equiv> if (x = \<bottom>\<^sub>2 \<or> x = [0]\<^sub>2) then [0]\<^sub>2 else \<top>\<^sub>2"
  instance ..
end

instance pratt1 :: K1r_algebra
proof
  fix x :: pratt1
  show "1 + x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
    by  (case_tac x, auto simp add: star_pratt1_def one_pratt1_def times_pratt1_def less_eq_pratt1_def plus_pratt1_def)
next
  fix x y :: pratt1
  show "y \<cdot> x \<le> y \<Longrightarrow> y \<cdot> x\<^sup>\<star> \<le> y"
    apply (case_tac x, case_tac[!] y)
    apply (auto simp add:star_pratt1_def one_pratt1_def times_pratt1_def less_eq_pratt1_def plus_pratt1_def)
    apply (rename_tac n, case_tac n)
    apply (simp_all)
    apply (metis nat.exhaust plusl_zero_infty pratt1.distinct(7) pratt1_max.simps(7) pratt1_plus.simps(14))
  done
qed

instance pratt2 :: K1l_algebra
proof
  fix x :: pratt2
  show "1 + x\<cdot>x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (case_tac x, auto simp add: star_pratt2_def one_pratt2_def times_pratt2_def less_eq_pratt2_def plus_pratt2_def)
next
  fix x y :: pratt2
  show "x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> y \<le> y"
    apply (case_tac x, case_tac[!] y)
    apply (auto simp add:star_pratt2_def one_pratt2_def times_pratt2_def less_eq_pratt2_def plus_pratt2_def)
    apply (rename_tac n, case_tac n)
    apply (simp_all)
    apply (rename_tac n, case_tac n)
    apply (auto simp add:star_pratt2_def one_pratt2_def times_pratt2_def less_eq_pratt2_def plus_pratt2_def)
  done
qed

lemma one_star_top: "[1]\<^sub>1\<^sup>\<star> = \<top>\<^sub>1"
  by (simp add:star_pratt1_def one_pratt1_def)

lemma pratt1_kozen_1l_counterexample:
  "\<exists> x y :: pratt1. \<not> (x \<cdot> y \<le> y \<and> x\<^sup>\<star> \<cdot> y \<le> y)"
proof -
  have "\<not> ([1]\<^sub>1 \<cdot> \<infinity>\<^sub>1 \<le> \<infinity>\<^sub>1 \<and> [1]\<^sub>1\<^sup>\<star> \<cdot> \<infinity>\<^sub>1 \<le> \<infinity>\<^sub>1)"
    by (auto simp add: star_pratt1_def times_pratt1_def less_eq_pratt1_def plus_pratt1_def)
  thus ?thesis
    by auto
qed

lemma pratt2_kozen_1r_counterexample:
  "\<exists> x y :: pratt2. \<not> (y \<cdot> x \<le> y \<and> y \<cdot> x\<^sup>\<star> \<le> y)"
proof -
  have "\<not> (\<infinity>\<^sub>2 \<cdot> [1]\<^sub>2 \<le> \<infinity>\<^sub>2 \<and> \<infinity>\<^sub>2 \<cdot> [1]\<^sub>2\<^sup>\<star> \<le> \<infinity>\<^sub>2)"
    by (auto simp add: star_pratt2_def times_pratt2_def less_eq_pratt2_def plus_pratt2_def)
  thus ?thesis
    by auto
qed

end


theory T92
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


theory Functions_1
imports "$HETS_LIB/Isabelle/MainHC"
uses "$HETS_LIB/Isabelle/prelude"
begin

consts
"id" :: "'a => 'a option"
"o_X" :: "(('b => 'c option) * ('a => 'b option)) => ('a => 'c option)"

axioms
o_def: "apt (Some o_X) (pair (Some f) (Some g)) = (Some (% x . app (Some f) (app (Some g) (Some x))))"
id_def: "(Some id) = (Some (% x . (Some x)))"

lemmas o_def' = o_def [simplified]
lemmas id_def' = id_def [simplified]

declare o_def' [simp]
declare o_def [simp]
declare id_def' [simp]
declare id_def [simp]

theorem o_assoc: "apt (Some o_X) (pair (Some f) (apt (Some o_X) (pair (Some g) (Some h)))) = apt (Some o_X) (pair (apt (Some o_X) (pair (Some f) (Some g))) (Some h))"
apply (simp)
apply (rule ext)
apply (case_tac "h x")
apply (simp_all)
done

theorem id_neut: "apt (Some o_X) (pair (Some f') (Some id)) = (Some f')"
apply (simp)
done
theorem inj: "apt (Some o_X) (pair (Some f') (Some f')) = (Some id) ==> (! x :: 'a . ! y :: 'a . app (Some f') (Some x) = app (Some f') (Some y) --> (Some x) = (Some y))"
apply (auto)
apply (subgoal_tac "option_case None f' (f' y) = Some y")
apply (drule_tac x = "x" in fun_cong)
apply (case_tac "f' x")
apply (drule_tac[3] x = "y" in fun_cong)
apply (simp)
apply (case_tac "f' y")
apply (auto)
done

theorem surj: "apt (Some o_X) (pair (Some f') (Some f')) = (Some id) --> (! x :: 'a . ? y :: 'a . app (Some f') (Some y) = (Some x))"
apply (auto)
apply (rule_tac x = "the (f' x)" in exI)
apply (drule_tac x = "x" in fun_cong)
apply (case_tac "f' x")
apply (auto)
done

end


theory FSA_Semantics
  imports FSA_Metamodel
begin

inductive rtrancl_path :: "'a rel \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool"
  for r :: "'a rel"
where
  base: "rtrancl_path r x [] x"
| step: "(x, y) \<in> r \<Longrightarrow> rtrancl_path r y ys z \<Longrightarrow> rtrancl_path r x (y # ys) z"

lemma rtranclp_eq_rtrancl_path: "(x, y) \<in> r\<^sup>* \<longleftrightarrow> (\<exists>xs. rtrancl_path r x xs y)"
proof
  show "\<exists>xs. rtrancl_path r x xs y" if "(x, y) \<in> r\<^sup>*"
    using that
  proof (induct rule: converse_rtrancl_induct)
    case base
    have "rtrancl_path r y [] y" by (rule rtrancl_path.base)
    then show ?case ..
  next
    case (step x z)
    from \<open>\<exists>xs. rtrancl_path r z xs y\<close>
    obtain xs where "rtrancl_path r z xs y" ..
    with \<open>(x, z) \<in> r\<close> have "rtrancl_path r x (z # xs) y"
      by (rule rtrancl_path.step)
    then show ?case ..
  qed
  show "(x, y) \<in> r\<^sup>*" if "\<exists>xs. rtrancl_path r x xs y"
  proof -
    from that obtain xs where "rtrancl_path r x xs y" ..
    then show ?thesis
    proof induct
      case (base x)
      show ?case
        by (rule rtrancl.rtrancl_refl)
    next
      case (step x y ys z)
      from \<open>(x, y) \<in> r\<close> \<open>(y, z) \<in> r\<^sup>*\<close> show ?case
        by (rule converse_rtrancl_into_rtrancl)
    qed
  qed
qed

definition fsa_trans_sem :: "Automaton \<Rightarrow> string rel" ("\<lbrakk>_\<rbrakk>\<^sub>T")
  where "fsa_trans_sem A = {(s\<^sub>1, s\<^sub>2). \<exists> t\<in>set (transitions A). from t = s\<^sub>1 \<and> to t = s\<^sub>2}"

definition fsa_init_sem :: "Automaton \<Rightarrow> string set" ("\<lbrakk>_\<rbrakk>\<^sub>I")
  where "\<lbrakk>A\<rbrakk>\<^sub>I = {State.name s |s. s \<in> set (states A) \<and> initial s}"

definition fsa_sem :: "Automaton \<Rightarrow> string rel" ("\<lbrakk>_\<rbrakk>\<^sub>\<A>")
  where "\<lbrakk>A\<rbrakk>\<^sub>\<A> = {(sa, s). s \<in> \<lbrakk>A\<rbrakk>\<^sub>I} O \<lbrakk>A\<rbrakk>\<^sub>T\<^sup>*"

definition reachable :: "Automaton \<Rightarrow> State \<Rightarrow> bool" where
"reachable A s' = (\<exists> s p. s \<in> \<lbrakk>A\<rbrakk>\<^sub>I \<and> rtrancl_path \<lbrakk>A\<rbrakk>\<^sub>T s p (State.name s'))"

lemma invariant_rtrancl_path:
  assumes "\<lbrakk>A\<rbrakk>\<^sub>I \<subseteq> I" "\<lbrakk>A\<rbrakk>\<^sub>T `` I \<subseteq> I" "s \<in> \<lbrakk>A\<rbrakk>\<^sub>I" "rtrancl_path \<lbrakk>A\<rbrakk>\<^sub>T s p s'"
  shows "s' \<in> I"
  using assms(3-4)
proof (induct p arbitrary: s s')
  case Nil
  then show ?case
    by (metis assms(1) list.distinct(1) rtrancl_path.cases subset_eq)
next
  case (Cons s\<^sub>0 p)
  have "(s, s\<^sub>0) \<in> \<lbrakk>A\<rbrakk>\<^sub>T"
    using Cons.prems(2) rtrancl_path.cases by fastforce
  hence "s\<^sub>0 \<in> I"
    using Cons.prems(1) assms(1) assms(2) by blast
  then show ?case
    by (metis Cons.prems(1) Cons.prems(2) Image_closed_trancl Image_iff assms(1) assms(2) rtranclp_eq_rtrancl_path subset_iff)
qed

lemma unreachable_by_invariant:
  assumes "\<lbrakk>A\<rbrakk>\<^sub>I \<subseteq> I" "\<lbrakk>A\<rbrakk>\<^sub>T `` I \<subseteq> I" "State.name s' \<notin> I"
  shows "\<not> (reachable A s')"
  by (meson assms(1) assms(2) assms(3) invariant_rtrancl_path reachable_def)

end


theory sort_StoogeSortPermutes'
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype ('a, 'b) Pair2 = Pair "'a" "'b"

fun ztake :: "int => 'a list => 'a list" where
"ztake x y =
   (if x = 0 then Nil2 else
      case y of
        | Nil2 => y
        | Cons2 z xs => Cons2 z (ztake (x - 1) xs)
      end)"

fun zlength :: "'a list => int" where
"zlength (Nil2) = 0"
| "zlength (Cons2 y xs) = 1 + (zlength xs)"

fun zdrop :: "int => 'a list => 'a list" where
"zdrop x y =
   (if x = 0 then y else
      case y of
        | Nil2 => y
        | Cons2 z xs => zdrop (x - 1) xs
      end)"

fun zsplitAt :: "int => 'a list =>
                 (('a list), ('a list)) Pair2" where
"zsplitAt x y = Pair (ztake x y) (zdrop x y)"

fun sort2 :: "int => int => int list" where
"sort2 x y =
   (if x <= y then Cons2 x (Cons2 y (Nil2)) else
      Cons2 y (Cons2 x (Nil2)))"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun null :: "'t list => bool" where
"null (Nil2) = True"
| "null (Cons2 y z) = False"

fun elem :: "int => int list => bool" where
"elem x (Nil2) = False"
| "elem x (Cons2 z ys) = or2 (x = z) (elem x ys)"

fun delete :: "int => int list => int list" where
"delete x (Nil2) = Nil2"
| "delete x (Cons2 z ys) =
     (if x = z then ys else Cons2 z (delete x ys))"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

fun reverse :: "'t list => 't list" where
"reverse (Nil2) = Nil2"
| "reverse (Cons2 y xs) = append (reverse xs) (Cons2 y (Nil2))"

function stooge1sort2 :: "int list => int list"
         and stoogesort :: "int list => int list"
         and stooge1sort1 :: "int list => int list" where
"stooge1sort2 x =
   case zsplitAt (div (zlength x) 3) (reverse x) of
     | Pair ys zs =>
         case zsplitAt (div (zlength x) 3) (reverse x) of
           | Pair xs zs2 => append (stoogesort zs) (reverse xs)
         end
   end"
| "stoogesort (Nil2) = Nil2"
| "stoogesort (Cons2 y (Nil2)) = Cons2 y (Nil2)"
| "stoogesort (Cons2 y (Cons2 y2 (Nil2))) = sort2 y y2"
| "stoogesort (Cons2 y (Cons2 y2 (Cons2 x3 x4))) =
     stooge1sort2
       (stooge1sort1 (stooge1sort2 (Cons2 y (Cons2 y2 (Cons2 x3 x4)))))"
| "stooge1sort1 x =
     case zsplitAt (div (zlength x) 3) x of
       | Pair ys zs =>
           case zsplitAt (div (zlength x) 3) x of
             | Pair xs zs2 => append ys (stoogesort zs2)
           end
     end"
by pat_completeness auto

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun isPermutation :: "int list => int list => bool" where
"isPermutation (Nil2) y = null y"
| "isPermutation (Cons2 z xs) y =
     and2 (elem z y) (isPermutation xs (delete z y))"

(*hipster ztake
          zlength
          zdrop
          zsplitAt
          sort2
          or2
          null
          elem
          delete
          append
          reverse
          stooge1sort2
          stoogesort
          stooge1sort1
          and2
          isPermutation *)

theorem x0 :
  "!! (x :: int list) . isPermutation (stoogesort x) x"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end