Up to index of Isabelle/HOL/SizeChange
theory Implementation(* Title: HOL/Library/SCT_Implementation.thy ID: $Id: Implementation.thy,v 1.1 2007/11/06 16:44:54 krauss Exp $ Author: Alexander Krauss, TU Muenchen *) header {* Implemtation of the SCT criterion *} theory Implementation imports Correctness begin fun edges_match :: "('n × 'e × 'n) × ('n × 'e × 'n) => bool" where "edges_match ((n, e, m), (n',e',m')) = (m = n')" fun connect_edges :: "('n × ('e::times) × 'n) × ('n × 'e × 'n) => ('n × 'e × 'n)" where "connect_edges ((n,e,m), (n', e', m')) = (n, e * e', m')" lemma grcomp_code [code]: "grcomp (Graph G) (Graph H) = Graph (connect_edges ` { x ∈ G×H. edges_match x })" by (rule graph_ext) (auto simp:graph_mult_def has_edge_def image_def) lemma mk_tcl_finite_terminates: fixes A :: "'a acg" assumes fA: "finite_acg A" shows "mk_tcl_dom (A, A)" proof - from fA have fin_tcl: "finite_acg (tcl A)" by (simp add:finite_tcl) hence "finite (dest_graph (tcl A))" unfolding finite_acg_def finite_graph_def .. let ?count = "λG. card (dest_graph G)" let ?N = "?count (tcl A)" let ?m = "λX. ?N - (?count X)" let ?P = "λX. mk_tcl_dom (A, X)" { fix X assume "X ≤ tcl A" then have "mk_tcl_dom (A, X)" proof (induct X rule:measure_induct_rule[of ?m]) case (less X) show ?case proof (cases "X * A ≤ X") case True with mk_tcl.domintros show ?thesis by auto next case False then have l: "X < X + X * A" unfolding graph_less_def graph_leq_def graph_plus_def by auto from `X ≤ tcl A` have "X * A ≤ tcl A * A" by (simp add:mult_mono) also have "… ≤ A + tcl A * A" by simp also have "… = tcl A" by (simp add:tcl_unfold_right[symmetric]) finally have "X * A ≤ tcl A" . with `X ≤ tcl A` have "X + X * A ≤ tcl A + tcl A" by (rule add_mono) hence less_tcl: "X + X * A ≤ tcl A" by simp hence "X < tcl A" using l `X ≤ tcl A` by auto from less_tcl fin_tcl have "finite_acg (X + X * A)" by (rule finite_acg_subset) hence "finite (dest_graph (X + X * A))" unfolding finite_acg_def finite_graph_def .. hence X: "?count X < ?count (X + X * A)" using l[simplified graph_less_def graph_leq_def] by (rule psubset_card_mono) have "?count X < ?N" apply (rule psubset_card_mono) by fact (rule `X < tcl A`[simplified graph_less_def]) with X have "?m (X + X * A) < ?m X" by arith from less.hyps this less_tcl have "mk_tcl_dom (A, X + X * A)" . with mk_tcl.domintros show ?thesis . qed qed } from this less_tcl show ?thesis . qed lemma mk_tcl_finite_tcl: fixes A :: "'a acg" assumes fA: "finite_acg A" shows "mk_tcl A A = tcl A" using mk_tcl_finite_terminates[OF fA] by (simp only: tcl_def mk_tcl_correctness star_commute) definition test_SCT :: "nat acg => bool" where "test_SCT \<A> = (let \<T> = mk_tcl \<A> \<A> in (∀(n,G,m)∈dest_graph \<T>. n ≠ m ∨ G * G ≠ G ∨ (∃(p::nat,e,q)∈dest_graph G. p = q ∧ e = LESS)))" lemma SCT'_exec: assumes fin: "finite_acg A" shows "SCT' A = test_SCT A" using mk_tcl_finite_tcl[OF fin] unfolding test_SCT_def Let_def unfolding SCT'_def no_bad_graphs_def has_edge_def by force code_modulename SML Implementation Graphs lemma [code func]: "(G::('a::eq, 'b::eq) graph) ≤ H <-> dest_graph G ⊆ dest_graph H" "(G::('a::eq, 'b::eq) graph) < H <-> dest_graph G ⊂ dest_graph H" unfolding graph_leq_def graph_less_def by rule+ lemma [code func]: "(G::('a::eq, 'b::eq) graph) + H = Graph (dest_graph G ∪ dest_graph H)" unfolding graph_plus_def .. lemma [code func]: "(G::('a::eq, 'b::{eq, times}) graph) * H = grcomp G H" unfolding graph_mult_def .. lemma SCT'_empty: "SCT' (Graph {})" unfolding SCT'_def no_bad_graphs_def graph_zero_def[symmetric] tcl_zero by (simp add:in_grzero) subsection {* Witness checking *} definition test_SCT_witness :: "nat acg => nat acg => bool" where "test_SCT_witness A T = (A ≤ T ∧ A * T ≤ T ∧ (∀(n,G,m)∈dest_graph T. n ≠ m ∨ G * G ≠ G ∨ (∃(p::nat,e,q)∈dest_graph G. p = q ∧ e = LESS)))" lemma no_bad_graphs_ucl: assumes "A ≤ B" assumes "no_bad_graphs B" shows "no_bad_graphs A" using assms unfolding no_bad_graphs_def has_edge_def graph_leq_def by blast lemma SCT'_witness: assumes a: "test_SCT_witness A T" shows "SCT' A" proof - from a have "A ≤ T" "A * T ≤ T" by (auto simp:test_SCT_witness_def) hence "A + A * T ≤ T" by (subst add_idem[of T, symmetric], rule add_mono) with star3' have "tcl A ≤ T" unfolding tcl_def . moreover from a have "no_bad_graphs T" unfolding no_bad_graphs_def test_SCT_witness_def has_edge_def by auto ultimately show ?thesis unfolding SCT'_def by (rule no_bad_graphs_ucl) qed code_modulename SML Graphs SCT Kleene_Algebras SCT Implementation SCT export_code test_SCT in SML end
lemma grcomp_code:
grcomp (Graph G) (Graph H) = Graph (connect_edges ` {x : G × H. edges_match x})
lemma mk_tcl_finite_terminates:
finite_acg A ==> mk_tcl_dom (A, A)
lemma mk_tcl_finite_tcl:
finite_acg A ==> mk_tcl A A = tcl A
lemma SCT'_exec:
finite_acg A ==> SCT' A = test_SCT A
lemma
(G ≤ H) = (dest_graph G ⊆ dest_graph H)
(G < H) = (dest_graph G ⊂ dest_graph H)
lemma
G + H = Graph (dest_graph G ∪ dest_graph H)
lemma
G * H = grcomp G H
lemma SCT'_empty:
SCT' (Graph {})
lemma no_bad_graphs_ucl:
[| A ≤ B; no_bad_graphs B |] ==> no_bad_graphs A
lemma SCT'_witness:
test_SCT_witness A T ==> SCT' A