theory Demo11
  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 \<open>Code Generation using Target Language Types\<close>

definition mod_on_int :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
  "mod_on_int x y = x mod y" 

text \<open>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.\<close>

(* 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 \<open>Natural numbers are wrapped into their own datatype.\<close>

definition test_on_nat :: "nat \<Rightarrow> nat" where
  "test_on_nat n = (n - 5) + n" 

export_code test_on_nat in Haskell module_name Nat



section \<open>Code Generation with Subtypes\<close>

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 \<Rightarrow> integer" is "\<lambda> x. x" .
lift_definition add_10 :: "large_int \<Rightarrow> large_int" is "\<lambda> 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 "\<dots> = Rep_large_int (Abs_large_int 5)" by (rule get_int.rep_eq)
  also have "\<dots> = 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 \<Rightarrow> large_int" where
  "foo x = Abs_large_int x" 
definition bar :: "integer \<Rightarrow> large_int" where
  "bar x = Abs_large_int (x * x + 5000)" 

value (code) "foo 5"
value (code) "bar 5" 

lift_definition bar' :: "integer \<Rightarrow> large_int" is "\<lambda> x. x * x + 5000"
  by (simp add: add_sign_intros(1))

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 \<open>Data Refinement\<close>

text \<open>*** copy of Isabelle code of previous Demo10 ***\<close>

definition reach :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "reach G A = {y. \<exists>x\<in>A. (x, y) \<in> G^*}" 

lemma [code]: "reach G A = (if A = {} then {} else
   let A_edges = Set.filter (\<lambda> (x,y). x \<in> A) G;
       successors = snd ` A_edges
       in A \<union> reach (G - A_edges) successors)"
  unfolding reach_def sorry

text \<open>*** end of copy ***\<close>

value (code) "reach {(1,2 :: nat), (3,4), (2,4), (4,1)} {1}"

export_code reach in Haskell module_name Reach_List



subsection \<open>Implementation of Set-Operations via Ordered Trees\<close>

(* check on empty set *)

fun is_empty_t :: "'a tree \<Rightarrow> 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 \<Rightarrow> '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 \<Rightarrow> '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 \<Rightarrow> 'b :: linorder) \<Rightarrow> 'a tree \<Rightarrow> '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 \<open>Implementation of Set-Operations on Ordered Trees\<close>


lift_definition to_list_o :: "'a :: linorder otree \<Rightarrow> 'a list" is to_list_t .

lift_definition from_list_o :: "'a :: linorder list \<Rightarrow> 'a otree" is from_list_t by auto

lift_definition image_o :: "('a :: linorder \<Rightarrow> 'b :: linorder) \<Rightarrow> 'a otree \<Rightarrow> 'b otree" is image_t by auto

lift_definition is_empty_o :: "'a :: linorder otree \<Rightarrow> 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 \<union> 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 \<open>Use Ordered Trees to Implement Set-Type\<close>

(* 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 \<Rightarrow> '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 (\<lambda> x. x \<notin> 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