theory LiveDemo10
  imports 
    Main
    "HOL-Library.Char_ord"             (* linear order on characters *)
    "HOL-Library.Code_Target_Numeral"  (* implement types nat and int via target language unbounded integers *)
begin

section \<open>Code Generation and Code Equations\<close>

value (code) "sort [7, 4, 8 :: nat]"

lemma "sort [7, 4 :: nat] = [4, 7]" by code_simp
lemma "sort [7, 4 :: nat] = [4, 7]" by eval

lemma "sorted [x,y :: nat]" quickcheck
  oops

hide_const List.rev

fun rev :: "'a list \<Rightarrow> 'a list" where
  "rev [] = []"
| "rev (x # xs) = rev xs @ [x]"

code_thms rev
export_code rev in Haskell module_name Rev1

fun itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where 
  "itrev [] acc = acc"
| "itrev (x # xs) acc = itrev xs (x # acc)"

lemma itrev_rev [simp]: "itrev xs ys = rev xs @ ys" 
  by (induct xs arbitrary: ys, auto)

declare [[code drop: rev]]
lemma rev_code [code]: "rev xs = itrev xs []" by simp

code_thms rev
export_code rev in OCaml

section \<open>Code Unfold - Detect Patterns and Rewrite\<close>

definition test0 :: "bool" where
  "test0 = (\<forall> x :: nat. even x)" 

definition test1 :: "nat list \<Rightarrow> bool" where
  "test1 xs = (Ball (set xs) even)" 

lemma [code_unfold]: "Ball (set xs) p = list_all p xs" by (rule Ball_set)
lemma [code_unfold]: "(x \<in> set xs) = List.member xs x" by (rule in_set_member) 

export_code test0 in Haskell
code_thms test1

value (code) "test1 [3,7,6,1]"
export_code test1 in Haskell module_name Test1


definition test2 :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
  "test2 p = (\<exists> x. p x)" 
code_thms test2

definition "test2_nat = test2 (\<lambda> x :: nat. x > 5)" 
definition "test2_char = test2 (\<lambda> x :: char. x > CHR ''a'')" 

value (code) "test2_nat" 
value (code) "test2_char" 

code_thms test2_char




section \<open>Code Equations beyond Defining Equations\<close>

definition complex_predicate :: "nat \<Rightarrow> bool" where
  "complex_predicate x = (x > 894105890)"

definition unknown_problem where
  "unknown_problem = (\<exists> x. complex_predicate x)" 

value (code) "unknown_problem" 

lemma [code]: "unknown_problem = (if 
  (\<exists> x \<in> set [0..<10000]. complex_predicate x)
  then True else unknown_problem)" 
  unfolding unknown_problem_def by auto

(* value (code) unknown_problem *)

declare [[code drop: unknown_problem]]

lemma [code]: "unknown_problem = (if 
  (\<exists> x \<in> set [0..<10000]. complex_predicate x)
  then True else Code.abort (STR ''giving up'') (\<lambda> _. unknown_problem))" 
  unfolding unknown_problem_def by auto

value (code) unknown_problem


definition approx_problem :: "nat \<Rightarrow> bool" where
  "approx_problem n = unknown_problem" 

lemma [code]: "approx_problem n = (if complex_predicate n then True
    else approx_problem (n + 1))" 
  unfolding approx_problem_def unknown_problem_def by auto

declare [[code drop: unknown_problem]]

lemma [code]: "unknown_problem = approx_problem 0" 
  unfolding approx_problem_def by simp

lemma unknown_problem by eval 


typedecl real (* just assume there are real numbers *)
typedecl rat  (* and rational numbers *)

consts approx :: "nat \<Rightarrow> real \<Rightarrow> rat \<times> rat" 
  (* and a parametrized approximation function that delivers lower and upper bounds
     on a real number, where the natural number determines the precision *)

(* assume there is some partial algorithm which can sometimes via an 
   approximated real number determine whether the real number has some property *)
consts approx_alg :: "rat \<times> rat \<Rightarrow> bool option" 
consts property :: "real \<Rightarrow> bool" 
axiomatization where approx_alg: 
  "approx n r = lu \<Longrightarrow> approx_alg lu = Some b \<Longrightarrow> b = property r" 

(* now let us define an algorithm which correctly computes the property *)
definition check_property :: "nat \<Rightarrow> real \<Rightarrow> bool" where
  "check_property n r = property r" 

lemma [code]: "check_property n r = 
  (case approx_alg (approx n r) of 
     Some b \<Rightarrow> b
   | None \<Rightarrow> check_property (n+2) r)" 
  using approx_alg[of n r] unfolding check_property_def 
  by (auto split: option.splits)

lemma [code]: "property r = check_property 10 r" 
  unfolding check_property_def by auto

(* obtain sound executable code without any termination proof!
   if you can know that eventually the approximation algorithm 
   will be able to decide the property, e.g., if the precision becomes high
   enough, then no such formal proof is required! *)



section \<open>Reachability\<close>

subsection \<open>Getting @{const finite} executable\<close>

text \<open>This part is not covered during the lecture\<close>

text \<open>Problem: finite is not executable on sets of natural numbers\<close>
value (code) "finite {1 :: nat}"
code_thms finite 

text \<open>Observe that type-constraint @{typ "'a :: finite"} is added in implementation.\<close>

text \<open>We now get rid of this constraint by providing a partial implementation of finiteness 
  which does not require the type-class @{class finite}.\<close>

declare [[code drop: finite]]

(* add new implementation *)
lemma [code]: "finite (set xs) = True" by auto
lemma [code]: "finite (List.coset xs) = 
  Code.abort (STR ''finite not available on cosets'') (\<lambda> _. finite (List.coset xs))" 
  by auto
code_thms finite

value (code) "finite {1 :: nat}"



subsection \<open>Definition of Algorithm\<close>


(* fix graph G and assumption in context;
   one important consequence: 
   termination proof can use such a fixed graph to define measure *)
context
  fixes G :: "'a rel" 
  assumes fG: "finite G" 
begin

function reach_main :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "reach_main todo reached = (if todo = {} then reached
     else let successors = snd ` (Set.filter (\<lambda> (x,y). x \<in> todo) G);
           new = successors - reached
           in reach_main new (reached \<union> successors))" 
  by pat_completeness auto

termination
proof (relation "measures 
  [\<lambda> (t,r). if t = {} then 0 else 1, 
   \<lambda> (t,r). card (snd ` G - r)]", 
    force, goal_cases)
  case (1 todo reached succs new)
  show ?case
  proof (cases "succs \<subseteq> reached")
    case True
    hence "new = {}" using 1 by auto
    thus ?thesis using 1 by auto
  next
    case False
    hence "snd ` G - (reached \<union> succs) \<subset> snd ` G - reached" using 1(2)
      by (smt (verit) Diff_iff imageE image_eqI member_filter psubsetI subset_eq sup_ge1 sup_ge2)
    from finite_imageI[OF fG, of snd] psubset_card_mono[OF _ this]
    have "card (snd ` G - (reached \<union> succs)) < card (snd ` G - reached)" by auto
    thus ?thesis using 1 by auto
  qed
qed

definition reach :: "'a set \<Rightarrow> 'a set" where
  "reach A = reach_main A A" 

lemma reach: "reach A = {y. \<exists> x \<in> A. (x,y) \<in> G^*}" sorry 
    (* main soundness proof is of no further interest here *)
end

(* thms outside context: G is no longer fixed, finiteness becomes assumption *)
thm reach
thm reach_main.simps
thm reach_main.induct
 
value (code) "reach {(1,2 :: nat), (3,4), (2,4), (4,1)} {1}" 

(* problem: code-equations must be unconditional! *)
thm reach_def reach_main.simps 

subsection \<open>Solution 1 - Move Condition into Code\<close>

definition "err = STR ''reach invoked on infinite graph''" 

lemma [code]: "reach_main G todo reached = (if finite G then 
     if todo = {} then reached
     else let successors = snd ` (Set.filter (\<lambda> (x,y). x \<in> todo) G);
           new = successors - reached
           in reach_main G new (reached \<union> successors)
     else Code.abort err (\<lambda> _. reach_main G todo reached))" 
  using reach_main.simps[of G todo reached] by auto

lemma [code]: "reach G A = (if finite G then reach_main G A A
     else Code.abort err (\<lambda> _. reach G A))" 
  using reach_def[of G A] by auto


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

text \<open>Disadvantage: condition finiteness is checked in every iteration\<close>


subsection \<open>Solution 2 - Ensure Condition via Dedicated Type\<close>

typedef 'a fset = "{ A :: 'a set. finite A}" by auto

setup_lifting type_definition_fset

lift_definition get_set :: "'a fset \<Rightarrow> 'a set" is "\<lambda> A. A" .

lemma finite_get_set: "finite (get_set A)" 
  by (transfer, auto)

definition "reach_main_2 fG = reach_main (get_set fG)" 

thm reach_main.simps
thm reach_main.simps[OF finite_get_set]
lemmas reach_main_2_simps = reach_main.simps[OF finite_get_set, folded reach_main_2_def]

declare reach_main_2_simps[code]

definition "reach_2 fG = reach (get_set fG)" 

lemmas reach_2_simps = reach_def[OF finite_get_set, folded reach_2_def reach_main_2_def]

declare reach_2_simps[code]

(* code_dt is required to obtain get_fset in executable version; 
   since lifted type is wrapped within other type, i.e., here "option" *)
lift_definition (code_dt) get_fset :: "'a set \<Rightarrow> 'a fset option" is 
  "\<lambda> G. if finite G then Some G else None"
  by auto

declare [[code drop: reach]]

lemma [code]: "reach G A = (case get_fset G of Some fG \<Rightarrow> reach_2 fG A 
  | None \<Rightarrow> Code.abort err (\<lambda> _. reach G A))" 
proof (cases "finite G")
  case False
  hence "get_fset G = None" by transfer auto
  thus ?thesis by auto
next
  case True
  hence "\<exists> fG. get_fset G = Some fG \<and> get_set fG = G"
    by (transfer, auto)
  thus ?thesis unfolding reach_2_def by auto
qed

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


subsection \<open>Solution 3 - Use @{command partial_function} for tail-recursive functions\<close>

partial_function (tailrec) reach_main_3 :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  [code]: "reach_main_3 G todo reached = (if todo = {} then reached
     else let successors = snd ` (Set.filter (\<lambda> (x,y). x \<in> todo) G);
           new = successors - reached
           in reach_main_3 G new (reached \<union> successors))" 

thm reach_main_3.simps (* unconditional, i.e., code-equation! *)

definition reach_3 :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "reach_3 G A = reach_main_3 G A A" 

lemma reach_main_3: assumes G: "finite G" 
  shows "reach_main_3 G todo reached = reach_main G todo reached" 
proof (induction todo reached rule: reach_main.induct[OF G])
  case (1 todo reached)
  thus ?case using G 
    unfolding reach_main.simps[OF G, of todo reached]
    unfolding reach_main_3.simps[of G todo reached] 
    unfolding Let_def by auto
qed

lemma reach_3: "finite G \<Longrightarrow> reach_3 G A = reach G A" 
  unfolding reach_3_def using reach_def[of G] reach_main_3[of G] by auto

declare [[code drop: reach]]

lemma [code]: "reach G A = (if finite G then reach_3 G A else 
  Code.abort err (\<lambda> _. reach G A))" 
  using reach_3[of G A] by auto

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


subsection \<open>Solution 4 -- Just provide code-equation\<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

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

end