theory LiveDemo11 imports Main "HOL-Library.Product_Lexorder" (* provides linear order on pairs *) "HOL-Library.Code_Target_Numeral" (* implement int and nat via target-language integers *) Demo09 (* ordered trees *) begin section \Code Generation using Target Language Types\ definition mod_on_int :: "integer \ integer \ integer" where "mod_on_int x y = x mod y" text \In order to guarantee safe implementation, a frontend is used that handles all the potentially corner cases, such that eventually a mod-function of the target language is invoked where both arguments are positive integers.\ (* there is a slight deviation from the slides, since actually a divmod-operation is mapped to a target-language divmod operation *) thm divmod_integer_code[of x y] (* this corresponds to code-equation in slides *) thm Code_Numeral.divmod_abs_def[of x y] (* this corresponds to target_mod in slides *) export_code mod_on_int in Haskell module_name Mod text \Natural numbers are wrapped into their own datatype.\ definition test_on_nat :: "nat \ nat" where "test_on_nat n = (n - 5) + n" export_code test_on_nat in Haskell module_name Nat section \Code Generation with Subtypes\ typedef large_int = "{ n :: integer . n > 1000}" by (intro exI[of _ 1001], auto) setup_lifting type_definition_large_int lift_definition get_int :: "large_int \ integer" is "\ x. x" . lift_definition add_10 :: "large_int \ large_int" is "\ x. x + 10" by simp lemma large: "1000 < get_int x" by transfer auto lemma "1000 < (5 :: integer)" proof - have "1000 < get_int (Abs_large_int 5)" by (rule large) also have "\ = Rep_large_int (Abs_large_int 5)" by (rule get_int.rep_eq) also have "\ = 5" by eval oops (* problem: code equation is usually conditional *) thm Abs_large_int_inverse (* but in generated code the condition is just erased *) code_thms get_int lemma "Rep_large_int (Abs_large_int 5) = 5" by code_simp (* code generator checks that abstraction functions are only applied safely, e.g., via lift_definition where a proof is required at definition time *) (* hiding Abs_large_int in a definition is also detected *) definition foo :: "integer \ large_int" where "foo x = Abs_large_int x" definition bar :: "integer \ large_int" where "bar x = Abs_large_int (x * x + 5000)" value (code) "foo 5" value (code) "bar 5" lift_definition bar' :: "integer \ large_int" is "\ x. x * x + 5000" by (simp add: add_sign_intros(1)) print_theorems thm bar'.abs_eq thm bar'.rep_eq (* bar' ?x) = Abs (?x * ?x + 5000) *) declare [[code drop: bar']] declare bar'.rep_eq[code] value (code) "bar' 5" export_code get_int add_10 bar' in Haskell module_name Subtype_Code (* in the generated code, there is no such safety mechanism, i.e., here it is the users responsibility to not build expressions like "Abs_large_int 5" *) section \Data Refinement\ text \*** copy of Isabelle code of previous Demo10 ***\ definition reach :: "'a rel \ 'a set \ 'a set" where "reach G A = {y. \x\A. (x, y) \ G^*}" lemma [code]: "reach G A = (if A = {} then {} else let A_edges = Set.filter (\ (x,y). x \ A) G; successors = snd ` A_edges in A \ reach (G - A_edges) successors)" unfolding reach_def sorry text \*** end of copy ***\ value (code) "reach {(1,2 :: nat), (3,4), (2,4), (4,1)} {1}" export_code reach in Haskell module_name Reach_List subsection \Implementation of Set-Operations via Ordered Trees\ (* check on empty set *) fun is_empty_t :: "'a tree \ bool" where "is_empty_t Leaf = True" | "is_empty_t _ = False" lemma is_empty_t[simp]: "is_empty_t t = Set.is_empty (set_t t)" by (cases t, auto simp: Set.is_empty_def) (* for image, we convert to list and then do repeated insertion *) fun to_list_t :: "'a tree \ 'a list" where "to_list_t Leaf = []" | "to_list_t (Node l x r) = x # to_list_t l @ to_list_t r" lemma to_list_t[simp]: "set (to_list_t t) = set_t t" by (induct t, auto) fun from_list_t :: "'a :: linorder list \ 'a tree" where "from_list_t [] = Leaf" | "from_list_t (x # xs) = insert_t x (from_list_t xs)" lemma set_from_list_t[simp]: "set_t (from_list_t xs) = set xs" by (induct xs, auto) lemma ordered_from_list_t[simp]: "ordered (from_list_t xs)" by (induct xs, auto simp: ordered_insert_t ordered.intros) definition image_t :: "('a \ 'b :: linorder) \ 'a tree \ 'b tree" where "image_t f t = from_list_t (map f (to_list_t t))" lemma image_t[simp]: "ordered (image_t f t)" "set_t (image_t f t) = f ` set_t t" unfolding image_t_def by auto (* for union and filter we are lazy and do not implement them now, but instead use the next layer; note that our implementation is not tuned on efficiency *) subsection \Implementation of Set-Operations on Ordered Trees\ lift_definition to_list_o :: "'a :: linorder otree \ 'a list" is to_list_t . lift_definition from_list_o :: "'a :: linorder list \ 'a otree" is from_list_t by auto lift_definition image_o :: "('a :: linorder \ 'b :: linorder) \ 'a otree \ 'b otree" is image_t by auto lift_definition is_empty_o :: "'a :: linorder otree \ bool" is is_empty_t . definition "union_o t1 t2 = from_list_o (to_list_o t1 @ to_list_o t2)" definition "filter_o f t = from_list_o (filter f (to_list_o t))" lemma is_empty_o[simp]: "is_empty_o t = Set.is_empty (set_o t)" by transfer auto lemma to_list_o[simp]: "set (to_list_o t) = set_o t" by transfer auto lemma from_list_o[simp]: "set_o (from_list_o xs) = set xs" by transfer auto lemma image_o[simp]: "set_o (image_o f t) = f ` set_o t" by transfer auto lemma union_o[simp]: "set_o (union_o t1 t2) = set_o t1 \ set_o t2" unfolding union_o_def by auto lemma filter_o[simp]: "set_o (filter_o f t) = Set.filter f (set_o t)" unfolding filter_o_def by auto lemmas soundness_o = empty_o image_o member_o is_empty_o union_o filter_o insert_o subsection \Use Ordered Trees to Implement Set-Type\ (* delete existing implementation *) declare [[code drop: Set.insert Set.member Set.union Set.filter Set.empty Set.image Set.is_empty Set.minus_set_inst.minus_set]] (* declare that set_o :: "'a tree \ 'a set" is viewed as constructor for sets, i.e., datatype 'a set = set_o "'a tree" *) code_datatype set_o thm soundness_o thm soundness_o[symmetric] declare soundness_o[symmetric, code] (* only minus is missing: we just invoke filter which is fine *) lemma minus_impl[code]: "X - Y = Set.filter (\ x. x \ Y) X" unfolding Set.filter_def by auto (* now that all required set operations are implemented we can evaluate reach *) value (code) "reach {(1,2 :: nat), (3,4), (2,4), (4,1)} {1}" (* result shows internal structure of tree! *) code_thms reach export_code reach in Haskell module_name Reach_Tree (* side-effect of using ordered trees: sets are only available for types that are linearly ordered *) datatype Test = A | B | C | D value (code) "reach {(A,B), (C,D), (B,D), (D,A)} {A}" end