(*
 * Copyright 201machine_word_bytes, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory factorial
imports "CParser.CTranslation" "$L4V_ARCH/imports/MachineWords"
begin

declare hrs_simps [simp add]
declare sep_conj_ac [simp add]

consts free_pool :: "nat \<Rightarrow> heap_assert"

primrec
  fac :: "nat \<Rightarrow> machine_word"
where
  "fac 0 = 1"
| "fac (Suc n) = of_nat (Suc n) * fac n"

lemma fac_unfold:
  "unat n \<noteq> 0 \<Longrightarrow> fac (unat n) = n * fac (unat (n - 1))"
  apply(case_tac "unat n")
   apply simp
  apply(subst unat_minus_one)
   apply(simp only: unat_simps)
   apply(clarify)
   apply simp
  apply clarsimp
  apply(simp only: unat_simps)
  apply(subst mod_less)
   apply (fold len_of_addr_card)
   apply unat_arith
  apply (clarsimp simp: distrib_right split: unat_splits)
  done

primrec
  fac_list :: "nat \<Rightarrow> machine_word list"
where
  "fac_list 0 = [1]"
| "fac_list (Suc n) = fac (Suc n) # fac_list n"

lemma fac_list_length [simp]:
  "length (fac_list n) = n + 1"
  by (induct n) auto

lemma fac_list_unfold:
  "unat n \<noteq> 0 \<Longrightarrow> fac_list (unat n) = fac (unat n) # fac_list (unat (n - 1))"
  apply(case_tac "unat n")
   apply clarsimp
  apply(subst unat_minus_one)
   apply clarsimp+
  done

primrec
  sep_list :: "machine_word list \<Rightarrow> machine_word ptr \<Rightarrow> heap_assert"
where
  "sep_list [] p = (\<lambda>s. p=NULL \<and> \<box> s)"
| "sep_list (x#xs) p = (\<lambda>s. \<exists>j. ((p \<mapsto> x) \<and>\<^sup>* (p +\<^sub>p 1) \<mapsto> j \<and>\<^sup>*
      sep_list xs (Ptr j)) s)"

lemma sep_list_NULL [simp]:
  "sep_list xs NULL = (\<lambda>s. xs = [] \<and> \<box> s)"
  by (case_tac xs) auto

definition
  sep_fac_list :: "machine_word \<Rightarrow> machine_word ptr \<Rightarrow> heap_assert"
where
  "sep_fac_list n p \<equiv> sep_list (fac_list (unat n)) p"

lemma sep_fac_list_unfold:
  "((\<lambda>s. unat n \<noteq> 0 \<and> (\<exists>q. (p \<mapsto> fac (unat n) \<and>\<^sup>* (p +\<^sub>p 1) \<mapsto> q \<and>\<^sup>*
      sep_fac_list (n - 1) (Ptr q)) s)) \<and>\<^sup>* R) s \<Longrightarrow>
      (sep_fac_list n p \<and>\<^sup>* R) s"
  apply (erule sep_globalise)
  apply (simp add: sep_fac_list_def fac_list_unfold)
  done

lemma sep_fac_list_points:
  "sep_points (sep_fac_list n p) s \<Longrightarrow> (p \<hookrightarrow> fac (unat n)) s"
  apply(unfold sep_points_def)
  apply(subst sep_map'_unfold)
  apply(erule sep_conj_impl)
   apply(unfold sep_fac_list_def)
   apply(case_tac "unat n")
    apply simp
    apply(unfold sep_map'_old)
    apply(erule (1) sep_conj_impl)
    apply simp
   apply clarsimp
   apply(subst (asm) sep_conj_assoc [symmetric])+
   apply(erule sep_conj_impl)
    apply simp+
  done

external_file "factorial.c"
install_C_file  "factorial.c"

thm factorial_global_addresses.factorial_body_def

lemma (in factorial_global_addresses) mem_safe_alloc:
  "mem_safe (\<acute>ret__ptr_to_unsigned_long :== PROC alloc()) \<Gamma>"
  apply(insert alloc_impl)
  apply(unfold alloc_body_def)
  apply(subst mem_safe_restrict)
  apply(rule intra_mem_safe)
   apply(simp_all add: restrict_map_def split: if_split_asm)
  apply(auto simp: whileAnno_def comp_def hrs_comm split_def mono_guard_def)
  done

lemma (in factorial_global_addresses) sep_frame_alloc:
  "\<lbrakk> \<forall>\<sigma>. \<Gamma> \<turnstile> \<lbrace>\<sigma>. (P (f \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace> \<acute>ret__ptr_to_unsigned_long :== PROC alloc() \<lbrace> (Q (g \<sigma> \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>;
      htd_ind f; htd_ind g; \<forall>s. htd_ind (g s) \<rbrakk> \<Longrightarrow>
      \<forall>\<sigma>. \<Gamma> \<turnstile> \<lbrace>\<sigma>. (P (f \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>
              \<acute>ret__ptr_to_unsigned_long :== PROC alloc()
              \<lbrace> (Q (g \<sigma> \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<sigma>))\<^bsup>sep\<^esup> \<rbrace>"
  unfolding sep_app_def
  by (rule sep_frame, auto intro!: mem_safe_alloc)

lemma (in alloc_spec) alloc_spec':
  shows "\<forall>\<sigma> k R f. factorial_global_addresses.\<Gamma> \<turnstile>
    \<lbrace>\<sigma>. ((\<lambda>x. free_pool k) ((\<lambda>x. undefined) \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (f \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>
    \<acute>ret__ptr_to_unsigned_long :== PROC alloc()
    \<lbrace> ((\<lambda>p s. if k > 0 then (\<turnstile>\<^sub>s p \<and>\<^sup>* \<turnstile>\<^sub>s (p +\<^sub>p 1) \<and>\<^sup>*
        free_pool (k - 1)) s else (free_pool k) s \<and> p = NULL) \<acute>ret__ptr_to_unsigned_long
        \<and>\<^sup>* R (f \<sigma>))\<^bsup>sep\<^esup> \<rbrace>"
  apply clarify
  apply(insert alloc_spec)
  apply(rule_tac x=\<sigma> in spec)
  apply(rule sep_frame_alloc)
     apply(clarsimp simp: sep_app_def split: if_split_asm)
    apply simp+
  done

lemma (in factorial_global_addresses) mem_safe_free:
  "mem_safe (PROC free(\<acute>p)) \<Gamma>"
  apply(insert free_impl)
  apply(unfold free_body_def)
  apply(subst mem_safe_restrict)
  apply(auto simp: whileAnno_def)
  apply(rule intra_mem_safe)
   apply(auto simp: restrict_map_def split: if_split_asm)
  done

lemma (in factorial_global_addresses) sep_frame_free:
  "\<lbrakk> \<forall>\<sigma>. \<Gamma> \<turnstile> \<lbrace>\<sigma>. (P (f \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace> PROC free(\<acute>p) \<lbrace> (Q (g \<sigma> \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>;
      htd_ind f; htd_ind g; \<forall>s. htd_ind (g s) \<rbrakk> \<Longrightarrow>
      \<forall>\<sigma>. \<Gamma> \<turnstile> \<lbrace>\<sigma>. (P (f \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>
              PROC free(\<acute>p)
              \<lbrace> (Q (g \<sigma> \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<sigma>))\<^bsup>sep\<^esup> \<rbrace>"
  apply(simp only: sep_app_def)
  apply(rule sep_frame, auto intro!: mem_safe_free)
  done

lemma (in free_spec) free_spec':
  shows "\<forall>\<sigma> k R f. factorial_global_addresses.\<Gamma> \<turnstile>
    \<lbrace>\<sigma>. ((\<lambda>p. sep_cut' (ptr_val p) (2 * size_of TYPE(machine_word)) \<and>\<^sup>* free_pool k) \<acute>p  \<and>\<^sup>* R (f \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>
    PROC free(\<acute>p)
    \<lbrace> ((\<lambda>x. free_pool (k + 1)) ((\<lambda>x. ()) \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (f \<sigma>))\<^bsup>sep\<^esup> \<rbrace>"
  apply clarify
  apply(insert free_spec)
  apply(rule_tac x=\<sigma> in spec)
  apply(rule sep_frame_free)
     apply(clarsimp simp: sep_app_def split: if_split_asm)
    apply simp+
  done

lemma double_word_sep_cut':
  "(p \<mapsto> x \<and>\<^sup>* (p +\<^sub>p 1) \<mapsto> y) s \<Longrightarrow> sep_cut' (ptr_val (p::machine_word ptr)) (2*machine_word_bytes) s"
apply(clarsimp simp: sep_conj_def sep_cut'_def dest!: sep_map_dom)
apply(subgoal_tac "{ptr_val p..+machine_word_bytes} \<subseteq> {ptr_val p..+(2*machine_word_bytes)}")
 apply(subgoal_tac "{ptr_val p+(of_nat machine_word_bytes)..+machine_word_bytes} \<subseteq> {ptr_val p..+(2*machine_word_bytes)}")
  apply rule
   apply (fastforce simp: ptr_add_def)
  apply clarsimp
  apply(drule intvlD)
  apply clarsimp
  apply(case_tac "k < machine_word_bytes")
   apply(erule intvlI)
  apply(erule notE)
  apply(clarsimp simp: intvl_def)
  apply(rule_tac x="k - machine_word_bytes" in exI)
  apply rule
   apply(simp only: unat_simps)
   apply(subst mod_less)
    apply(simp add: addr_card)
   apply (simp add: ptr_add_def addr_card)
  apply simp
 apply(clarsimp simp: intvl_def)
 apply(rule_tac x="machine_word_bytes+k" in exI)
 apply simp
apply(rule intvl_start_le)
apply simp
done

locale specs = factorial_global_addresses + alloc_spec + free_spec

lemma (in specs) factorial_spec:
  shows "factorial_spec"
  apply unfold_locales
  apply(hoare_rule HoarePartial.ProcRec1)
  apply (hoare_rule anno = "factorial_invs_body k" in HoarePartial.annotateI)
   prefer 2
   apply (simp add: whileAnno_def factorial_invs_body_def)
  apply(subst factorial_invs_body_def)
  apply(unfold sep_app_def)
  apply (vcg exspec=alloc_spec' exspec=free_spec')
    apply (fold lift_def)
    apply(clarsimp simp: sep_app_def)
    apply (rule conjI)
     apply clarsimp
     apply(rule_tac x=k in exI)
     apply(rule_tac x="\<lambda>p. \<box>" in exI)
     apply(rule_tac x="\<lambda>s. undefined" in exI)
     apply clarsimp
     apply (rule conjI)
      apply clarsimp
     apply clarsimp
     apply (rename_tac a b ret__ptr_to_unsigned_long)
     apply(subgoal_tac "(\<turnstile>\<^sub>s ret__ptr_to_unsigned_long \<and>\<^sup>* sep_true) (lift_state (a,b))")
      prefer 2
      apply(drule sep_conj_sep_true_right)
      apply simp
     apply(subgoal_tac "(\<turnstile>\<^sub>s (ret__ptr_to_unsigned_long +\<^sub>p 1) \<and>\<^sup>* sep_true) (lift_state (a,b))")
      prefer 2
      apply(drule sep_conj_sep_true_left)
      apply simp
      apply(subst (asm) sep_conj_assoc [symmetric])+
      apply(drule_tac Q="free_pool (k - Suc 0)" in sep_conj_sep_true_right)
      apply simp
     apply(simp add: tagd_ptr_safe tagd_g c_guard_ptr_aligned c_guard_NULL)
     apply(simp add: sep_fac_list_def)
     apply(sep_select_tac "(_ +\<^sub>p _) \<mapsto> _")
     apply(rule sep_heap_update_global')
     apply simp
     apply(rule sep_heap_update_global')
     apply simp
    apply clarsimp
    apply(rule_tac x=k in exI)
    apply clarsimp
    apply(rule_tac x="k - Suc (unat (n - 1))" in exI)
    apply clarsimp
    apply(rule_tac x="\<lambda>(n,p). sep_fac_list (n - 1) p" in exI)
    apply(rule_tac x="\<lambda>s. (n_' s,q_' s)" in exI)
    apply (rule conjI, clarsimp)
    apply clarsimp
    apply (rule conjI)
     apply clarsimp
     apply(simp add: sep_fac_list_def)
     apply(rule_tac x="fac_list (unat (n - 1))" in exI)
     apply clarsimp
    apply clarsimp
    apply(subgoal_tac "(\<turnstile>\<^sub>s ret__ptr_to_unsigned_long \<and>\<^sup>* sep_true) (lift_state (ab,bb))")
     prefer 2
     apply(erule (1) sep_conj_impl)
     apply simp
    apply(subgoal_tac "(\<turnstile>\<^sub>s (ret__ptr_to_unsigned_long +\<^sub>p 1) \<and>\<^sup>* sep_true) (lift_state (ab,bb))")
     prefer 2
     apply(subgoal_tac "(\<turnstile>\<^sub>s ret__ptr_to_unsigned_long \<and>\<^sup>*
                         \<turnstile>\<^sub>s (ret__ptr_to_unsigned_long +\<^sub>p 1) \<and>\<^sup>*
                         sep_fac_list (n - 1) ret__ptr_to_unsigned_longa \<and>\<^sup>*
                         free_pool (k - Suc (unat n))) =
                         (\<turnstile>\<^sub>s (ret__ptr_to_unsigned_long +\<^sub>p 1) \<and>\<^sup>* (\<turnstile>\<^sub>s ret__ptr_to_unsigned_long \<and>\<^sup>*
                         sep_fac_list (n - 1) ret__ptr_to_unsigned_longa \<and>\<^sup>*
                         free_pool (k - Suc (unat n))))")
      prefer 2
      apply simp
     apply (simp only:)
     apply(erule (1) sep_conj_impl)
     apply simp
    apply(sep_point_tac sep_fac_list_points)
    apply(simp add: tagd_ptr_safe tagd_g sep_map'_g c_guard_ptr_aligned c_guard_NULL sep_map'_lift)
    apply(rule sep_fac_list_unfold)
    apply clarsimp
    apply (rule conjI, unat_arith)
    apply sep_exists_tac
    apply(rule_tac x="ptr_val ret__ptr_to_unsigned_longa" in exI)
    apply clarsimp
    apply(subst fac_unfold)
     apply unat_arith
    apply clarsimp
    apply(sep_select_tac "(_ +\<^sub>p _) \<mapsto> _")
    apply(rule sep_heap_update_global')
    apply(sep_select_tac "_ \<mapsto> _")
      apply(rule sep_heap_update_global')
      apply(erule (1) sep_conj_impl)+
      apply clarsimp
   apply clarsimp
   apply(case_tac xs)
    apply simp
   apply clarsimp
   apply sep_exists_tac
   apply clarsimp
   apply sep_point_tac
   apply(simp add: sep_map'_g c_guard_ptr_aligned c_guard_NULL sep_map'_lift)
   apply(rule_tac x="k - Suc (length list)" in exI)
   apply(rule_tac x="\<lambda>p. sep_list list (Ptr j)" in exI)
   apply(rule_tac x="\<lambda>x. ()" in exI)
   apply(clarsimp simp: sep_app_def)
   apply (rule conjI)
    apply(subgoal_tac "(q \<mapsto> aa \<and>\<^sup>* sep_list list (Ptr j) \<and>\<^sup>*
                         (q +\<^sub>p 1) \<mapsto> j \<and>\<^sup>* free_pool (k - Suc (length list))) =
                       (sep_list list (Ptr j) \<and>\<^sup>* (q \<mapsto> aa \<and>\<^sup>*
                         (q +\<^sub>p 1) \<mapsto> j \<and>\<^sup>* free_pool (k - Suc (length list))))")
     apply(simp only:)
     apply(erule (1) sep_conj_impl)
     apply simp
     apply(subst sep_conj_com)
     apply(subst (asm) sep_conj_assoc [symmetric])+
     apply(erule sep_conj_impl)
      apply simp
      apply(erule double_word_sep_cut'[simplified])
     apply assumption
    apply simp
   apply clarsimp
   apply(subgoal_tac "Suc (k - Suc (length list)) = k - length list")
    apply force
   apply arith
  apply clarsimp
  done

declare hrs_simps [simp del]

lemma (in factorial_global_addresses) mem_safe_factorial:
  shows "mem_safe (\<acute>ret__ptr_to_unsigned_long :== PROC factorial(\<acute>n)) \<Gamma>"
  apply(subst mem_safe_restrict)
  apply(rule intra_mem_safe)
   apply (insert factorial_impl free_impl alloc_impl)
   apply(drule_tac t="Some C" in sym)
   apply(simp_all add: restrict_map_def call_def block_def whileAnno_def
                       free_body_def alloc_body_def factorial_body_def creturn_def
                split: if_split_asm option.splits)
  apply((erule disjE)?, simp,
        (thin_tac "C=x" for x, (thin_tac "\<Gamma> x = y" for x y)+,
        force simp: intra_sc)?)+
  done

end


(*  Title:      HOL/Corec_Examples/Tests/Misc_Mono.thy
    Author:     Aymeric Bouzy, Ecole polytechnique
    Author:     Jasmin Blanchette, Inria, LORIA, MPII
    Copyright   2015, 2016

Miscellaneous monomorphic examples.
*)

section \<open>Miscellaneous Monomorphic Examples\<close>

theory Misc_Mono
imports "~~/src/HOL/Library/BNF_Corec"
begin

codatatype T0 =
  C1 (lab: nat) (tl11: T0) (tl12: T0)
| C2 (lab: nat) (tl2: T0)
| C3 (tl3: "T0 list")

codatatype stream =
  S (hd: nat) (tl: stream)

corec (friend) ff where
  "ff x = S 0 (ff (ff x))"

corec test0 where
  "test0 x y = (case (x, y) of
  (S a1 s1, S a2 s2) \<Rightarrow> S (a1 + a2) (test0 s1 s2))"

friend_of_corec test0 where
  "test0 x y = (case (x, y) of
  (S a1 s1, S a2 s2) \<Rightarrow> S (a1 + a2) (test0 s1 s2))"
   apply (rule test0.code)
  apply transfer_prover
  done

corec test01 where
  "test01 x y = C2 (lab x + lab y) (test01 (tl2 x) (tl2 y))"

friend_of_corec test01 where
  "test01 x y = C2 (lab x + lab y) (test01 (tl2 x) (tl2 y))"
   apply (rule test01.code)
  sorry (* not parametric *)

corec test02 where
  "test02 x y = C2 (lab x * lab y) (test01 (test02 x (tl2 y)) (test02 (tl2 x) y))"

friend_of_corec test02 where
  "test02 x y = C2 (lab x * lab y) (test01 (test02 x (tl2 y)) (test02 (tl2 x) y))"
   apply (rule test02.code)
  sorry (* not parametric *)

corec test03 where
  "test03 x = C2 (lab x) (C2 (lab x) (test02 (test03 (tl2 x)) (test03 (tl2 x))))"

friend_of_corec test03 where
  "test03 x = C2 (lab x) (C2 (lab x) (test02 (test03 (tl2 x)) (test03 (tl2 x))))"
   apply (rule test03.code)
  sorry (* not parametric *)

corec (friend) test04a where
  "test04a x = (case x of C1 a t1 t2 \<Rightarrow> C1 (a * a) (test04a t1) (test04a t2) | C2 a t \<Rightarrow> C2 (a * a) (test04a t) | C3 l \<Rightarrow> C3 l)"

corec test04 where
  "test04 x = (case x of C1 a t1 t2 \<Rightarrow> C1 (a * a) (test04 t1) (test04 t2) | C2 a t \<Rightarrow> C2 (a * a) (test04 t) | C3 l \<Rightarrow> C3 l)"

friend_of_corec test04 where
  "test04 x = (case x of C1 a t1 t2 \<Rightarrow> C1 (a * a) (test04 t1) (test04 t2) | C2 a t \<Rightarrow> C2 (a * a) (test04 t) | C3 l \<Rightarrow> C3 l)"
   apply (rule test04.code)
  apply transfer_prover
  done

corec test05 where
  "test05 x y = (case (x, y) of
  (C1 a t11 t12, C1 b t21 t22) \<Rightarrow> C1 (a + b) (test05 t11 t21) (test05 t12 t22)
| (C1 a t11 _, C2 b t2) \<Rightarrow> C2 (a + b) (test05 t11 t2)
| (C2 a t1, C1 b _ t22) \<Rightarrow> C2 (a + b) (test05 t1 t22)
| (C2 a t1, C2 b t2) \<Rightarrow> C2 (a + b) (test05 t1 t2)
| (_, _) \<Rightarrow> C3 [])"

friend_of_corec test05 where
  "test05 x y = (case (x, y) of
  (C1 a t11 t12, C1 b t21 t22) \<Rightarrow> C1 (a + b) (test05 t11 t21) (test05 t12 t22)
| (C1 a t11 _, C2 b t2) \<Rightarrow> C2 (a + b) (test05 t11 t2)
| (C2 a t1, C1 b _ t22) \<Rightarrow> C2 (a + b) (test05 t1 t22)
| (C2 a t1, C2 b t2) \<Rightarrow> C2 (a + b) (test05 t1 t2)
| (_, _) \<Rightarrow> C3 [])"
   apply (rule test05.code)
  apply transfer_prover
  done

corec test06 :: "T0 \<Rightarrow> T0" where
  "test06 x =
  (if \<not> is_C1 x then
    let tail = tl2 x in
    C1 (lab x) (test06 tail) tail
  else
    C2 (lab x) (test06 (tl12 x)))"

friend_of_corec test06 :: "T0 \<Rightarrow> T0" where
  "test06 x =
  (if \<not> is_C1 x then
    let tail = tl2 x in
    C1 (lab x) (test06 tail) tail
  else
    C2 (lab x) (test06 (tl12 x)))"
   apply (rule test06.code)
  sorry (* not parametric *)

corec test07 where
  "test07 xs = C3 (map (\<lambda>x. test07 (tl3 x)) xs)"

friend_of_corec test07 where
  "test07 xs = C3 (map (\<lambda>x. test07 (tl3 x)) xs)"
   apply (rule test07.code)
  sorry (* not parametric *)

corec test08 where
  "test08 xs = (case xs of
    [] \<Rightarrow> C2 0 (test08 [])
  | T # r \<Rightarrow> C1 1 (test08 r) T)"

friend_of_corec test08 where
  "test08 xs = (case xs of
    [] \<Rightarrow> C2 0 (test08 [])
  | T # r \<Rightarrow> C1 1 (test08 r) T)"
   apply (rule test08.code)
  apply transfer_prover
  done

corec test09 where
  "test09 xs = test08 [case xs of
    [] \<Rightarrow> C2 0 (test09 [])
  | (C1 n T1 T2) # r \<Rightarrow> C1 n (test09 (T1 # r)) (test09 (T2 # r))
  | _ # r \<Rightarrow> C3 [test09 r]]"

friend_of_corec test09 where
  "test09 xs = (case xs of
    [] \<Rightarrow> C2 0 (test09 [])
  | (C1 n T1 T2) # r \<Rightarrow> C1 n (test09 (T1 # r)) (test09 (T2 # r))
  | _ # r \<Rightarrow> C3 [test09 r])"
   defer
   apply transfer_prover
  sorry (* not sure the specifications are equal *)

codatatype tree =
  Node (node: int) (branches: "tree list")

consts integerize_tree_list :: "'a list \<Rightarrow> int"

lemma integerize_tree_list_transfer[transfer_rule]:
  "rel_fun (list_all2 R) op = integerize_tree_list integerize_tree_list"
  sorry

corec (friend) f10a where
  "f10a x y = Node
  (integerize_tree_list (branches x) + integerize_tree_list (branches y))
  (map (\<lambda>(x, y). f10a x y) (zip (branches x) (branches y)))"

corec f10 where
  "f10 x y = Node
  (integerize_tree_list (branches x) + integerize_tree_list (branches y))
  (map (\<lambda>(x, y). f10 x y) (zip (branches x) (branches y)))"

friend_of_corec f10 where
  "f10 x y = Node
  (integerize_tree_list (branches x) + integerize_tree_list (branches y))
  (map (\<lambda>(x, y). f10 x y) (zip (branches x) (branches y)))"
     apply (rule f10.code)
    by transfer_prover+

corec f12 where
  "f12 t = Node (node t) (map f12 (branches t))"

friend_of_corec f12 where
  "f12 t = Node (node t) (map f12 (branches t))"
  sorry

corec f13 where
  "f13 n ts = Node n (map (%t. f13 (node t) (branches t)) ts)"

friend_of_corec f13 where
  "f13 n ts = Node n (map (%t. f13 (node t) (branches t)) ts)"
  sorry

corec f14 :: "tree option \<Rightarrow> tree" where
  "f14 t_opt = Node 0
    (case map_option branches t_opt of
      None \<Rightarrow> []
    | Some ts \<Rightarrow> map (f14 o Some) ts)"

friend_of_corec f14 where
  "f14 t_opt = Node 0
    (case map_option branches t_opt of
      None \<Rightarrow> []
    | Some ts \<Rightarrow> map (f14 o Some) ts)"
  sorry

corec f15 :: "tree list option \<Rightarrow> tree" where
  "f15 ts_opt = Node 0
    (case map_option (map branches) ts_opt of
      None \<Rightarrow> []
    | Some tss \<Rightarrow> map (f15 o Some) tss)"

friend_of_corec f15 where
  "f15 ts_opt = Node 0
    (case map_option (map branches) ts_opt of
      None \<Rightarrow> []
    | Some tss \<Rightarrow> map (f15 o Some) tss)"
    sorry

corec f16 :: "tree list option \<Rightarrow> tree" where
  "f16 ts_opt = Node 0
    (case ts_opt of
      None \<Rightarrow> []
    | Some ts \<Rightarrow> map (f16 o Some o branches) ts)"

friend_of_corec f16 where
  "f16 ts_opt = Node 0
    (case ts_opt of
      None \<Rightarrow> []
    | Some ts \<Rightarrow> map (f16 o Some o branches) ts)"
    sorry

corec f17 :: "tree list option \<Rightarrow> tree" where
  "f17 ts_opt = Node 0 (case ts_opt of
    None \<Rightarrow> []
  | Some ts \<Rightarrow> [f17 (Some (map (List.hd o branches) ts))])"

(* not parametric
friend_of_corec f17 where
  "f17 ts_opt = Node 0 (case ts_opt of
    None \<Rightarrow> []
  | Some ts \<Rightarrow> [f17 (Some (map (List.hd o branches) ts))])"
  sorry
*)

corec f18 :: "tree \<Rightarrow> tree" where
  "f18 t = Node (node t) (map (f18 o f12) (branches t))"

friend_of_corec f18 :: "tree \<Rightarrow> tree" where
  "f18 t = Node (node t) (map (f18 o f12) (branches t))"
  sorry

corec f19 :: "tree \<Rightarrow> tree" where
  "f19 t = Node (node t) (map (%f. f [t]) (map f13 [1, 2, 3]))"

friend_of_corec f19 :: "tree \<Rightarrow> tree" where
  "f19 t = Node (node t) (map (%f. f [t]) (map f13 [1, 2, 3]))"
  sorry

datatype ('a, 'b, 'c) h = H1 (h_a: 'a) (h_tail: "('a, 'b, 'c) h") | H2 (h_b: 'b) (h_c: 'c) (h_tail: "('a, 'b, 'c) h") | H3

term "map_h (map_option f12) (%n. n) f12"

corec f20 :: "(tree option, int, tree) h \<Rightarrow> tree \<Rightarrow> tree" where
  "f20 x y = Node (node y) (case (map_h (map_option f12) (%n. n) f12 x) of
    H1 None r \<Rightarrow> (f20 r y) # (branches y)
  | H1 (Some t) r \<Rightarrow> (f20 r t) # (branches y)
  | H2 n t r \<Rightarrow> (f20 r (Node n [])) # (branches y)
  | H3 \<Rightarrow> branches y)"

friend_of_corec f20 where
  "f20 x y = Node (node y) (case (map_h (map_option f12) (%n. n) f12 x) of
    H1 None r \<Rightarrow> (f20 r y) # (branches y)
  | H1 (Some t) r \<Rightarrow> (f20 r t) # (branches y)
  | H2 n t r \<Rightarrow> (f20 r (Node n [])) # (branches y)
  | H3 \<Rightarrow> branches y)"
  sorry

corec f21 where
  "f21 x xh =
  Node (node x) (case xh of
    H1 (Some a) yh \<Rightarrow> (f21 x (map_h (map_option (f20 yh)) id id yh)) # (branches a)
  | H1 None yh \<Rightarrow> [f21 x yh]
  | H2 b c yh \<Rightarrow> (f21 c (map_h id (%n. n + b) id yh)) # (branches x)
  | H3 \<Rightarrow> branches x)"

friend_of_corec f21 where
  "f21 x xh =
  Node (node x) (case xh of
    H1 (Some a) yh \<Rightarrow> (f21 x (map_h (map_option (f20 yh)) (%t. t) (%t. t) yh)) # (branches a)
  | H1 None yh \<Rightarrow> [f21 x yh]
  | H2 b c yh \<Rightarrow> (f21 c (map_h (%t. t) (%n. n + b) (%t. t) yh)) # (branches x)
  | H3 \<Rightarrow> branches x)"
  sorry

corec f22 :: "('a \<Rightarrow> tree) \<Rightarrow> 'a list \<Rightarrow> tree" where
  "f22 f x = Node 0 (map f x)"

friend_of_corec f22:: "(nat \<Rightarrow> tree) \<Rightarrow> nat list \<Rightarrow> tree"  where
  "f22 f x = Node 0 (map f x)"
    sorry

corec f23 where
  "f23 xh = Node 0
    (if is_H1 xh then
      (f23 (h_tail xh)) # (branches (h_a xh))
    else if is_H1 xh then
      (f23 (h_tail xh)) # (h_c xh) # (branches (h_b xh))
    else
      [])"

friend_of_corec f23 where
  "f23 xh = Node 0
    (if is_H1 xh then
      (f23 (h_tail xh)) # (branches (h_a xh))
    else if is_H1 xh then
      (f23 (h_tail xh)) # (h_c xh) # (branches (h_b xh))
    else
      [])"
  sorry

corec f24 where
  "f24 xh =
    (if is_H1 xh then
      Node 0 ((f24 (h_tail xh)) # (h_a xh 0))
    else if is_H2 xh then
      Node (h_b xh) ((f24 (h_tail xh)) # (h_c xh 0))
    else
      Node 0 [])"

friend_of_corec f24 :: "(nat \<Rightarrow> tree list, int, int \<Rightarrow> tree list) h \<Rightarrow> tree" where
  "f24 xh =
    (if is_H1 xh then
      Node 0 ((f24 (h_tail xh)) # (h_a xh 0))
    else if is_H2 xh then
      Node (h_b xh) ((f24 (h_tail xh)) # (h_c xh 0))
    else
      Node 0 [])"
  sorry

corec f25 where
  "f25 x = Node (node x) (map f25 ((id branches) x))"

codatatype ('a, 'b) y_type =
  Y (lab: "'a \<Rightarrow> 'b") (y_tail: "('a, 'b) y_type")

corec f26 :: "(int, tree) y_type \<Rightarrow> tree \<Rightarrow> tree" where
  "f26 y x = (case map_y_type f12 y of
  Y f y' \<Rightarrow> Node (node x) ((f (node x)) # (map (f26 y') (branches x))))"

friend_of_corec f26 where
  "f26 y x = (case map_y_type f12 y of
  Y f y' \<Rightarrow> Node (node x) ((f (node x)) # (map (f26 y') (branches x))))"
  sorry

consts int_of_list :: "'a list \<Rightarrow> int"

corec f27 :: "(int, tree) y_type \<Rightarrow> tree \<Rightarrow> tree" where
  "f27 y x = Node (int_of_list (map (f26 (y_tail y)) (branches x))) [lab y (node x)]"

friend_of_corec f27 :: "(int, tree) y_type \<Rightarrow> tree \<Rightarrow> tree" where
  "f27 y x = Node (int_of_list (map (f26 (y_tail y)) (branches x))) [lab y (node x)]"
  sorry

corec f28 :: "(tree option list, (int \<Rightarrow> int) \<Rightarrow> int list \<Rightarrow> tree, tree) h \<Rightarrow> tree" where
  "f28 xh = (case xh of
    H3 \<Rightarrow> Node 0 []
  | H1 l r \<Rightarrow> Node 0 ((f28 r) # map the (filter (%opt. case opt of None \<Rightarrow> False | Some _ \<Rightarrow> True) l))
  | H2 f t r \<Rightarrow> Node (node t) (map (%t. f id [node t]) (branches t)))"

codatatype llist =
  LNil | LCons (head: nat) (tail: llist)

inductive llist_in where
  "llist_in (LCons x xs) x"
| "llist_in xs y \<Longrightarrow> llist_in (LCons x xs) y"

abbreviation "lset xs \<equiv> {x. llist_in xs x}"

corecursive lfilter where
  "lfilter P xs = (if \<forall> x \<in> lset xs. \<not> P x then
    LNil
    else if P (head xs) then
      LCons (head xs) (lfilter P (tail xs))
    else
      lfilter P (tail xs))"
proof (relation "measure (\<lambda>(P, xs). LEAST n. P (head ((tail ^^ n) xs)))", rule wf_measure, clarsimp)
  fix P xs x
  assume "llist_in xs x" "P x" "\<not> P (head xs)"
  from this(1,2) obtain a where "P (head ((tail ^^ a) xs))"
    by (atomize_elim, induct xs x rule: llist_in.induct) (auto simp: funpow_Suc_right
      simp del: funpow.simps(2) intro: exI[of _ 0] exI[of _ "Suc i" for i])
  with \<open>\<not> P (head xs)\<close>
    have "(LEAST n. P (head ((tail ^^ n) xs))) = Suc (LEAST n. P (head ((tail ^^ Suc n) xs)))"
    by (intro Least_Suc) auto
  then show "(LEAST n. P (head ((tail ^^ n) (tail xs)))) < (LEAST n. P (head ((tail ^^ n) xs)))"
    by (simp add: funpow_swap1[of tail])
qed

codatatype Stream =
  SCons (head: nat) (tail: Stream)

corec map_Stream where
  "map_Stream f s = SCons (f (head s)) (map_Stream f (tail s))"

friend_of_corec map_Stream where
  "map_Stream f s = SCons (f (head s)) (map_Stream f (tail s))"
  sorry

corec f29 where
  "f29 f ll = SCons (head ll) (f29 f (map_Stream f (tail ll)))"

friend_of_corec f29 where
  "f29 f ll = SCons (head ll) (f29 f (map_Stream f (tail ll)))"
  sorry

corec f30 where
  "f30 n m = (if n = 0 then SCons m (f30 m m) else f30 (n - 1) (n * m))"

corec f31 :: "llist \<Rightarrow> llist" where
  "f31 x = (if x = LNil then LCons undefined (f31 undefined) else LCons undefined undefined)"

friend_of_corec f31 where
  "f31 x = (if x = LNil then LCons undefined (f31 undefined) else LCons undefined undefined)"
  sorry

corec f32 :: "tree \<Rightarrow> tree" where
  "f32 t = Node (node t) (map ((\<lambda>t'. f18  t') o f32) (branches t))"

corec f33 :: "tree \<Rightarrow> tree" where
  "f33 t = f18 (f18 (Node (node t) (map (\<lambda>t'. (f18 o f18) (f18 (f18 (f33 t')))) (branches t))))"

corec f34 :: "tree \<Rightarrow> tree" where
  "f34 t = f18 (f18 (Node (node t) (map (f18 o f18 o f34) (branches t))))"

corec f35 :: "tree \<Rightarrow> tree" where
  "f35 t = f18 (f18 (Node (node t) (map (f18 o (f18 o (\<lambda>t'. f18 t')) o f35) (branches t))))"

corec f37 :: "int \<Rightarrow> tree list \<Rightarrow> tree option \<Rightarrow> nat \<Rightarrow> tree"  where
  "f37 a x1 = undefined a x1"

end


theory prop_60
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun null2 :: "Nat list => bool" where
  "null2 (Nil2) = True"
  | "null2 (Cons2 y z) = False"
  fun last :: "Nat list => Nat" where
  "last (Nil2) = Z"
  | "last (Cons2 y (Nil2)) = y"
  | "last (Cons2 y (Cons2 x2 x3)) = last (Cons2 x2 x3)"
  fun append :: "Nat list => Nat list => Nat list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster null last append *)
(*hipster last null2 append*)(*
lemma lemma_a []: "append x2 Nil2 = x2"
by (hipster_induct_schemes last.simps null2.simps append.simps)

lemma lemma_aa []: "append (append x2 y2) z2 = append x2 (append y2 z2)"
by (hipster_induct_schemes last.simps null2.simps append.simps)

lemma lemma_ab []: "null2 (append x2 x2) = null2 x2"
by (hipster_induct_schemes last.simps null2.simps append.simps)

(*hipster null2 append*)
lemma unknown []: "null2 (append x y) = null2 (append y x)"
by (hipster_induct_schemes last.simps null2.simps append.simps list.exhaust)

(*hipster_cond null2 append*)
lemma lemma_ac []: "null2 x2 \<Longrightarrow> append x2 y2 = y2"
by (hipster_induct_schemes null2.simps append.simps)*)

  theorem x0 :
    "(~ (null2 ys)) ==> ((last (append xs ys)) = (last ys))"
    by (hipster_induct_schemes last.simps null2.simps append.simps list.exhaust) (*
    by (tactic {* Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1 *})*)
end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_43
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun takeWhile :: "('a => bool) => 'a list => 'a list" where
  "takeWhile y (nil2) = nil2"
| "takeWhile y (cons2 z2 xs) =
     (if y z2 then cons2 z2 (takeWhile y xs) else nil2)"

fun dropWhile :: "('a => bool) => 'a list => 'a list" where
  "dropWhile y (nil2) = nil2"
| "dropWhile y (cons2 z2 xs) =
     (if y z2 then dropWhile y xs else cons2 z2 xs)"

theorem property0 :
  "((x (takeWhile p xs) (dropWhile p xs)) = xs)"
  oops

end


theory Load_Store
  imports
    Assertion_Tree_Lookup
    Extended_Assertion_Exceptions
begin

context rbt_impl
begin
interpretation rbt_impl_deps .

subsection \<open>Load\<close>

definition "load p \<equiv> do { n \<leftarrow> ll_load p; return rbt_node.val n }"

lemma rbt_ptr_load_correct [vcg_rules]:
  assumes
    "rbt_sorted (rbt_of t)"
  shows
    "
    llvm_htriple
    (rbt_assn_ext t ex ti ** \<up>(ptr_of_key t ti kn = Some p))
    (load p)
    (\<lambda>vi_res.
        rbt_assn_ext t ex ti **
        \<up>(value_of_key t kn = Some vi_res)
    )
    "
  using assms
proof(induction t arbitrary: ti)
  case ATEmpty
  show ?case by (simp add: ptr_of_key.simps)
next
  case (ATBranch c k v ci li ki vi ri al ar)
  note ATBranch(1-2)[vcg_rules]

  show ?case
  proof(cases kn k rule: linorder_cases)
    case less
    moreover from less ATBranch have "kn \<guillemotleft>| rbt_of ar" by (auto intro: rbt_greater_trans)
    moreover from less have "k \<noteq> kn" by blast

    ultimately show ?thesis using ATBranch(3)
      supply ptr_of_key.simps[simp]
      apply vcg
      done
  next
    case equal
    with ATBranch(3) show ?thesis
      unfolding load_def
      supply ptr_of_key.simps[simp]
      unfolding rbt_assn_ext_unfold
      apply vcg
      done
  next
    case greater
    moreover from greater ATBranch have "rbt_of al |\<guillemotleft> kn" by (auto intro: rbt_less_trans)
    moreover from greater have "k \<noteq> kn" by blast
    ultimately show ?thesis using ATBranch(3)
      supply ptr_of_key.simps[simp] order_less_not_sym[simp]
      apply vcg
      done
  qed
qed

subsection \<open>Store\<close>

definition store :: "('ki, 'vi) rbti \<Rightarrow> 'vi \<Rightarrow> unit llM" where
  "store p v = set_value_p v p"

lemma Hx: "(k, v) \<in> graph (value_of_key t) \<Longrightarrow> rbt_of t |\<guillemotleft> k \<Longrightarrow> T"
  apply (induction t)
  unfolding graph_def
  apply auto
  done

lemma Hy: "(k, v) \<in> graph (value_of_key t) \<Longrightarrow> k \<guillemotleft>| rbt_of t \<Longrightarrow> T"
  apply (induction t)
  unfolding graph_def
   apply auto
  done

lemma store_correct:
  assumes
    "ptr_of_key t ti kn = Some p" and
    "kn \<in> ex" and
    "rbt_sorted (rbt_of t)"
  shows
    "
    llvm_htriple
    (rbt_assn_ext t ex ti)
    (store p vni)
    (\<lambda>_. EXS t_res.
      rbt_assn_ext t_res ex ti **
      \<up>(rbt_of t_res = rbt_of t) **
      \<up>(ptr_of_key t_res ti = ptr_of_key t ti) **
      \<up>(value_of_key t_res = (value_of_key t)(kn \<mapsto> vni))
    )
    "
  using assms
proof(induction t arbitrary: ti)
  case ATEmpty thus ?case by (simp add: ptr_of_key.simps)
next
  case (ATBranch c k v ci li ki vi ri l r)
  show ?case
  proof(cases k kn rule: linorder_cases)
    case less
    note ATBranch(2)[vcg_rules]
    from less ATBranch(3) have "ptr_of_key r ri kn = Some p"
      by (simp add: order_less_not_sym ptr_of_key.simps)
    with less ATBranch(3-5) show ?thesis
      apply vcg
      apply vcg_compat
      apply (sepEwith \<open>simp\<close> | find_sep)+
       apply pok_solver

      unfolding fun_upd_apply[symmetric]
      apply vok_solver
      by (fast intro: rbt_less_trans elim: Hx)
  next
    case equal
    with ATBranch(3) have "p = ti" by (simp add: ptr_of_key.simps)
    with ATBranch(3-5) equal show ?thesis
      unfolding store_def
      unfolding rbt_assn_ext_unfold
      apply vcg
      apply vcg_compat
      apply (sepEwith \<open>(solves auto) | solves pok_solver | succeed\<close>)
      unfolding fun_upd_apply[symmetric]
      apply vok_solver
        apply (auto elim: Hx Hy)
      done
  next
    case greater
    note ATBranch(1)[vcg_rules]
    from greater ATBranch(3) have "ptr_of_key l li kn = Some p"
      by (auto simp add: ptr_of_key.simps)
    with greater ATBranch(3-5) show ?thesis
      apply vcg
      apply vcg_compat
      apply (sepEwith simp | find_sep)+
      unfolding fun_upd_apply[symmetric]
       apply pok_solver
      apply vok_solver
      by (fast intro: rbt_greater_trans elim: Hy)
  qed
qed

lemma store_correct_no_ex:
  assumes
    "ptr_of_key t ti kn = Some p" and
    "kn \<notin> ex" and
    "rbt_sorted (rbt_of t)"
  shows
    "
    llvm_htriple
    (rbt_assn_ext t ex ti)
    (store p vni)
    (\<lambda>_. EXS t_res.
      rbt_assn_ext t_res ({kn} \<union> ex) ti ** \<upharpoonleft>value_assn (the (rbt_lookup (rbt_of t) kn)) (the (value_of_key t kn)) **
      \<up>(rbt_of t_res = rbt_of t) **
      \<up>(ptr_of_key t_res ti = ptr_of_key t ti) **
      \<up>(value_of_key t_res = (value_of_key t)(kn \<mapsto> vni))
    )
    "
  using assms
proof(induction t arbitrary: ti)
  case ATEmpty thus ?case by (simp add: ptr_of_key.simps)
next
  case (ATBranch c k v ci li ki vi ri l r)
  show ?case
  proof(cases k kn rule: linorder_cases)
    case less
    note ATBranch(2)[vcg_rules]
    from less ATBranch(3) have "ptr_of_key r ri kn = Some p"
      by (simp add: order_less_not_sym ptr_of_key.simps)

    then show ?thesis using less ATBranch(3-5)
      apply vcg
      apply vcg_compat
      apply (sepEwith simp)
       apply pok_solver
      apply sep
       apply (simp_all only: fun_upd_apply[symmetric])
       apply vok_solver
       apply (fast intro: rbt_less_trans elim: Hx)

      apply (auto simp: less_imp_neq rbt_less_trans )
      apply sep
      done
  next
    case equal
    with ATBranch(3) have "p = ti" by (simp add: ptr_of_key.simps)
    with ATBranch(3-5) equal show ?thesis
      unfolding store_def
      unfolding rbt_assn_ext_unfold
      apply vcg
      apply vcg_compat
      apply (sepEwith simp)
       apply pok_solver
      apply sep
      unfolding fun_upd_apply[symmetric]
       apply vok_solver
      apply (auto elim: Hx Hy)
      done
  next
    case greater
    note ATBranch(1)[vcg_rules]
    from greater ATBranch(3) have "Some p = ptr_of_key l li kn"
      by (auto simp add: ptr_of_key.simps)

    moreover from greater have "k \<noteq> kn" by simp

    ultimately show ?thesis using greater ATBranch(3-5)
      apply vcg
      apply vcg_compat
      apply (sepEwith simp)
       apply pok_solver

      apply sep
      unfolding fun_upd_apply[symmetric]
       apply vok_solver
       apply (fast intro: rbt_greater_trans elim: Hy)
      apply (auto simp: rbt_greater_trans order_less_not_sym)
      done
  qed
qed

lemma store_correct' [vcg_rules]:
    "
    llvm_htriple
    (rbt_assn_ext t ex ti ** \<up>(ptr_of_key t ti kn = Some p) ** \<up>(kn \<in> ex) ** \<up>(rbt_sorted (rbt_of t)))
    (store p vni)
    (\<lambda>_. EXS t_res.
      rbt_assn_ext t_res ex ti **
      \<up>(rbt_of t_res = rbt_of t) **
      \<up>(ptr_of_key t_res ti = ptr_of_key t ti) **
      \<up>(value_of_key t_res = (value_of_key t)(kn \<mapsto> vni))
    )
    "
  supply store_correct[vcg_rules]
  apply vcg
    apply auto
  apply vcg
  done

lemma store_correct_no_ex' [vcg_rules]:
    "
    llvm_htriple
    (rbt_assn_ext t ex ti ** \<up>(ptr_of_key t ti kn = Some p) ** \<up>(kn \<notin> ex) ** \<up>(rbt_sorted (rbt_of t)))
    (store p vni)
    (\<lambda>_. EXS t_res.
      rbt_assn_ext t_res ({kn} \<union> ex) ti ** \<upharpoonleft>value_assn (the (rbt_lookup (rbt_of t) kn)) (the (value_of_key t kn)) **
      \<up>(rbt_of t_res = rbt_of t) **
      \<up>(ptr_of_key t_res ti = ptr_of_key t ti) **
      \<up>(value_of_key t_res = (value_of_key t)(kn \<mapsto> vni))
    )
    "
  supply store_correct_no_ex[vcg_rules]
  apply vcg
    apply auto
  apply vcg
  done

end

end


(*  Title:      HOL/Matrix_LP/LP.thy
    Author:     Steven Obua
*)

theory LP
imports Main "~~/src/HOL/Library/Lattice_Algebras"
begin

lemma le_add_right_mono:
  assumes
  "a <= b + (c::'a::ordered_ab_group_add)"
  "c <= d"
  shows "a <= b + d"
  apply (rule_tac order_trans[where y = "b+c"])
  apply (simp_all add: assms)
  done

lemma linprog_dual_estimate:
  assumes
  "A * x \<le> (b::'a::lattice_ring)"
  "0 \<le> y"
  "\<bar>A - A'\<bar> \<le> \<delta>_A"
  "b \<le> b'"
  "\<bar>c - c'\<bar> \<le> \<delta>_c"
  "\<bar>x\<bar> \<le> r"
  shows
  "c * x \<le> y * b' + (y * \<delta>_A + \<bar>y * A' - c'\<bar> + \<delta>_c) * r"
proof -
  from assms have 1: "y * b <= y * b'" by (simp add: mult_left_mono)
  from assms have 2: "y * (A * x) <= y * b" by (simp add: mult_left_mono)
  have 3: "y * (A * x) = c * x + (y * (A - A') + (y * A' - c') + (c'-c)) * x" by (simp add: algebra_simps)
  from 1 2 3 have 4: "c * x + (y * (A - A') + (y * A' - c') + (c'-c)) * x <= y * b'" by simp
  have 5: "c * x <= y * b' + \<bar>(y * (A - A') + (y * A' - c') + (c'-c)) * x\<bar>"
    by (simp only: 4 estimate_by_abs)
  have 6: "\<bar>(y * (A - A') + (y * A' - c') + (c'-c)) * x\<bar> <= \<bar>y * (A - A') + (y * A' - c') + (c'-c)\<bar> * \<bar>x\<bar>"
    by (simp add: abs_le_mult)
  have 7: "(\<bar>y * (A - A') + (y * A' - c') + (c'-c)\<bar>) * \<bar>x\<bar> <= (\<bar>y * (A-A') + (y*A'-c')\<bar> + \<bar>c' - c\<bar>) * \<bar>x\<bar>"
    by(rule abs_triangle_ineq [THEN mult_right_mono]) simp
  have 8: "(\<bar>y * (A-A') + (y*A'-c')\<bar> + \<bar>c' - c\<bar>) * \<bar>x\<bar> <= (\<bar>y * (A-A')\<bar> + \<bar>y*A'-c'\<bar> + \<bar>c' - c\<bar>) * \<bar>x\<bar>"
    by (simp add: abs_triangle_ineq mult_right_mono)
  have 9: "(\<bar>y * (A-A')\<bar> + \<bar>y*A'-c'\<bar> + \<bar>c'-c\<bar>) * \<bar>x\<bar> <= (\<bar>y\<bar> * \<bar>A-A'\<bar> + \<bar>y*A'-c'\<bar> + \<bar>c'-c\<bar>) * \<bar>x\<bar>"
    by (simp add: abs_le_mult mult_right_mono)
  have 10: "c'-c = -(c-c')" by (simp add: algebra_simps)
  have 11: "\<bar>c'-c\<bar> = \<bar>c-c'\<bar>"
    by (subst 10, subst abs_minus_cancel, simp)
  have 12: "(\<bar>y\<bar> * \<bar>A-A'\<bar> + \<bar>y*A'-c'\<bar> + \<bar>c'-c\<bar>) * \<bar>x\<bar> <= (\<bar>y\<bar> * \<bar>A-A'\<bar> + \<bar>y*A'-c'\<bar> + \<delta>_c) * \<bar>x\<bar>"
    by (simp add: 11 assms mult_right_mono)
  have 13: "(\<bar>y\<bar> * \<bar>A-A'\<bar> + \<bar>y*A'-c'\<bar> + \<delta>_c) * \<bar>x\<bar> <= (\<bar>y\<bar> * \<delta>_A + \<bar>y*A'-c'\<bar> + \<delta>_c) * \<bar>x\<bar>"
    by (simp add: assms mult_right_mono mult_left_mono)
  have r: "(\<bar>y\<bar> * \<delta>_A + \<bar>y*A'-c'\<bar> + \<delta>_c) * \<bar>x\<bar> <= (\<bar>y\<bar> * \<delta>_A + \<bar>y*A'-c'\<bar> + \<delta>_c) * r"
    apply (rule mult_left_mono)
    apply (simp add: assms)
    apply (rule_tac add_mono[of "0::'a" _ "0", simplified])+
    apply (rule mult_left_mono[of "0" "\<delta>_A", simplified])
    apply (simp_all)
    apply (rule order_trans[where y="\<bar>A-A'\<bar>"], simp_all add: assms)
    apply (rule order_trans[where y="\<bar>c-c'\<bar>"], simp_all add: assms)
    done
  from 6 7 8 9 12 13 r have 14: "\<bar>(y * (A - A') + (y * A' - c') + (c'-c)) * x\<bar> <= (\<bar>y\<bar> * \<delta>_A + \<bar>y*A'-c'\<bar> + \<delta>_c) * r"
    by (simp)
  show ?thesis
    apply (rule le_add_right_mono[of _ _ "\<bar>(y * (A - A') + (y * A' - c') + (c'-c)) * x\<bar>"])
    apply (simp_all only: 5 14[simplified abs_of_nonneg[of y, simplified assms]])
    done
qed

lemma le_ge_imp_abs_diff_1:
  assumes
  "A1 <= (A::'a::lattice_ring)"
  "A <= A2"
  shows "\<bar>A-A1\<bar> <= A2-A1"
proof -
  have "0 <= A - A1"
  proof -
    from assms add_right_mono [of A1 A "- A1"] show ?thesis by simp
  qed
  then have "\<bar>A-A1\<bar> = A-A1" by (rule abs_of_nonneg)
  with assms show "\<bar>A-A1\<bar> <= (A2-A1)" by simp
qed

lemma mult_le_prts:
  assumes
  "a1 <= (a::'a::lattice_ring)"
  "a <= a2"
  "b1 <= b"
  "b <= b2"
  shows
  "a * b <= pprt a2 * pprt b2 + pprt a1 * nprt b2 + nprt a2 * pprt b1 + nprt a1 * nprt b1"
proof -
  have "a * b = (pprt a + nprt a) * (pprt b + nprt b)"
    apply (subst prts[symmetric])+
    apply simp
    done
  then have "a * b = pprt a * pprt b + pprt a * nprt b + nprt a * pprt b + nprt a * nprt b"
    by (simp add: algebra_simps)
  moreover have "pprt a * pprt b <= pprt a2 * pprt b2"
    by (simp_all add: assms mult_mono)
  moreover have "pprt a * nprt b <= pprt a1 * nprt b2"
  proof -
    have "pprt a * nprt b <= pprt a * nprt b2"
      by (simp add: mult_left_mono assms)
    moreover have "pprt a * nprt b2 <= pprt a1 * nprt b2"
      by (simp add: mult_right_mono_neg assms)
    ultimately show ?thesis
      by simp
  qed
  moreover have "nprt a * pprt b <= nprt a2 * pprt b1"
  proof -
    have "nprt a * pprt b <= nprt a2 * pprt b"
      by (simp add: mult_right_mono assms)
    moreover have "nprt a2 * pprt b <= nprt a2 * pprt b1"
      by (simp add: mult_left_mono_neg assms)
    ultimately show ?thesis
      by simp
  qed
  moreover have "nprt a * nprt b <= nprt a1 * nprt b1"
  proof -
    have "nprt a * nprt b <= nprt a * nprt b1"
      by (simp add: mult_left_mono_neg assms)
    moreover have "nprt a * nprt b1 <= nprt a1 * nprt b1"
      by (simp add: mult_right_mono_neg assms)
    ultimately show ?thesis
      by simp
  qed
  ultimately show ?thesis
    by - (rule add_mono | simp)+
qed

lemma mult_le_dual_prts:
  assumes
  "A * x \<le> (b::'a::lattice_ring)"
  "0 \<le> y"
  "A1 \<le> A"
  "A \<le> A2"
  "c1 \<le> c"
  "c \<le> c2"
  "r1 \<le> x"
  "x \<le> r2"
  shows
  "c * x \<le> y * b + (let s1 = c1 - y * A2; s2 = c2 - y * A1 in pprt s2 * pprt r2 + pprt s1 * nprt r2 + nprt s2 * pprt r1 + nprt s1 * nprt r1)"
  (is "_ <= _ + ?C")
proof -
  from assms have "y * (A * x) <= y * b" by (simp add: mult_left_mono)
  moreover have "y * (A * x) = c * x + (y * A - c) * x" by (simp add: algebra_simps)
  ultimately have "c * x + (y * A - c) * x <= y * b" by simp
  then have "c * x <= y * b - (y * A - c) * x" by (simp add: le_diff_eq)
  then have cx: "c * x <= y * b + (c - y * A) * x" by (simp add: algebra_simps)
  have s2: "c - y * A <= c2 - y * A1"
    by (simp add: assms add_mono mult_left_mono algebra_simps)
  have s1: "c1 - y * A2 <= c - y * A"
    by (simp add: assms add_mono mult_left_mono algebra_simps)
  have prts: "(c - y * A) * x <= ?C"
    apply (simp add: Let_def)
    apply (rule mult_le_prts)
    apply (simp_all add: assms s1 s2)
    done
  then have "y * b + (c - y * A) * x <= y * b + ?C"
    by simp
  with cx show ?thesis
    by(simp only:)
qed

end


(*  Title:      HOL/BNF_Composition.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2012, 2013, 2014

Composition of bounded natural functors.
*)

section {* Composition of Bounded Natural Functors *}

theory BNF_Composition
imports BNF_Def
begin

lemma empty_natural: "(\<lambda>_. {}) o f = image g o (\<lambda>_. {})"
  by (rule ext) simp

lemma Union_natural: "Union o image (image f) = image f o Union"
  by (rule ext) (auto simp only: comp_apply)

lemma in_Union_o_assoc: "x \<in> (Union o gset o gmap) A \<Longrightarrow> x \<in> (Union o (gset o gmap)) A"
  by (unfold comp_assoc)

lemma comp_single_set_bd:
  assumes fbd_Card_order: "Card_order fbd" and
    fset_bd: "\<And>x. |fset x| \<le>o fbd" and
    gset_bd: "\<And>x. |gset x| \<le>o gbd"
  shows "|\<Union>(fset ` gset x)| \<le>o gbd *c fbd"
  apply simp
  apply (rule ordLeq_transitive)
  apply (rule card_of_UNION_Sigma)
  apply (subst SIGMA_CSUM)
  apply (rule ordLeq_transitive)
  apply (rule card_of_Csum_Times')
  apply (rule fbd_Card_order)
  apply (rule ballI)
  apply (rule fset_bd)
  apply (rule ordLeq_transitive)
  apply (rule cprod_mono1)
  apply (rule gset_bd)
  apply (rule ordIso_imp_ordLeq)
  apply (rule ordIso_refl)
  apply (rule Card_order_cprod)
  done

lemma csum_dup: "cinfinite r \<Longrightarrow> Card_order r \<Longrightarrow> p +c p' =o r +c r \<Longrightarrow> p +c p' =o r"
  apply (erule ordIso_transitive)
  apply (frule csum_absorb2')
  apply (erule ordLeq_refl)
  by simp

lemma cprod_dup: "cinfinite r \<Longrightarrow> Card_order r \<Longrightarrow> p *c p' =o r *c r \<Longrightarrow> p *c p' =o r"
  apply (erule ordIso_transitive)
  apply (rule cprod_infinite)
  by simp

lemma Union_image_insert: "\<Union>(f ` insert a B) = f a \<union> \<Union>(f ` B)"
  by simp

lemma Union_image_empty: "A \<union> \<Union>(f ` {}) = A"
  by simp

lemma image_o_collect: "collect ((\<lambda>f. image g o f) ` F) = image g o collect F"
  by (rule ext) (auto simp add: collect_def)

lemma conj_subset_def: "A \<subseteq> {x. P x \<and> Q x} = (A \<subseteq> {x. P x} \<and> A \<subseteq> {x. Q x})"
  by blast

lemma UN_image_subset: "\<Union>(f ` g x) \<subseteq> X = (g x \<subseteq> {x. f x \<subseteq> X})"
  by blast

lemma comp_set_bd_Union_o_collect: "|\<Union>\<Union>((\<lambda>f. f x) ` X)| \<le>o hbd \<Longrightarrow> |(Union \<circ> collect X) x| \<le>o hbd"
  by (unfold comp_apply collect_def) simp

lemma wpull_cong:
  "\<lbrakk>A' = A; B1' = B1; B2' = B2; wpull A B1 B2 f1 f2 p1 p2\<rbrakk> \<Longrightarrow> wpull A' B1' B2' f1 f2 p1 p2"
  by simp

lemma Grp_fst_snd: "(Grp (Collect (split R)) fst)^--1 OO Grp (Collect (split R)) snd = R"
  unfolding Grp_def fun_eq_iff relcompp.simps by auto

lemma OO_Grp_cong: "A = B \<Longrightarrow> (Grp A f)^--1 OO Grp A g = (Grp B f)^--1 OO Grp B g"
  by (rule arg_cong)

lemma vimage2p_relcompp_mono: "R OO S \<le> T \<Longrightarrow>
  vimage2p f g R OO vimage2p g h S \<le> vimage2p f h T"
  unfolding vimage2p_def by auto

lemma type_copy_map_cong0: "M (g x) = N (h x) \<Longrightarrow> (f o M o g) x = (f o N o h) x"
  by auto

lemma type_copy_set_bd: "(\<And>y. |S y| \<le>o bd) \<Longrightarrow> |(S o Rep) x| \<le>o bd"
  by auto

lemma vimage2p_cong: "R = S \<Longrightarrow> vimage2p f g R = vimage2p f g S"
  by simp

context
  fixes Rep Abs
  assumes type_copy: "type_definition Rep Abs UNIV"
begin

lemma type_copy_map_id0: "M = id \<Longrightarrow> Abs o M o Rep = id"
  using type_definition.Rep_inverse[OF type_copy] by auto

lemma type_copy_map_comp0: "M = M1 o M2 \<Longrightarrow> f o M o g = (f o M1 o Rep) o (Abs o M2 o g)"
  using type_definition.Abs_inverse[OF type_copy UNIV_I] by auto

lemma type_copy_set_map0: "S o M = image f o S' \<Longrightarrow> (S o Rep) o (Abs o M o g) = image f o (S' o g)"
  using type_definition.Abs_inverse[OF type_copy UNIV_I] by (auto simp: o_def fun_eq_iff)

lemma type_copy_wit: "x \<in> (S o Rep) (Abs y) \<Longrightarrow> x \<in> S y"
  using type_definition.Abs_inverse[OF type_copy UNIV_I] by auto

lemma type_copy_vimage2p_Grp_Rep: "vimage2p f Rep (Grp (Collect P) h) =
    Grp (Collect (\<lambda>x. P (f x))) (Abs o h o f)"
  unfolding vimage2p_def Grp_def fun_eq_iff
  by (auto simp: type_definition.Abs_inverse[OF type_copy UNIV_I]
   type_definition.Rep_inverse[OF type_copy] dest: sym)

lemma type_copy_vimage2p_Grp_Abs:
  "\<And>h. vimage2p g Abs (Grp (Collect P) h) = Grp (Collect (\<lambda>x. P (g x))) (Rep o h o g)"
  unfolding vimage2p_def Grp_def fun_eq_iff
  by (auto simp: type_definition.Abs_inverse[OF type_copy UNIV_I]
   type_definition.Rep_inverse[OF type_copy] dest: sym)

lemma type_copy_ex_RepI: "(\<exists>b. F b) = (\<exists>b. F (Rep b))"
proof safe
  fix b assume "F b"
  show "\<exists>b'. F (Rep b')"
  proof (rule exI)
    from `F b` show "F (Rep (Abs b))" using type_definition.Abs_inverse[OF type_copy] by auto
  qed
qed blast

lemma vimage2p_relcompp_converse:
  "vimage2p f g (R^--1 OO S) = (vimage2p Rep f R)^--1 OO vimage2p Rep g S"
  unfolding vimage2p_def relcompp.simps conversep.simps fun_eq_iff image_def
  by (auto simp: type_copy_ex_RepI)

end

bnf DEADID: 'a
  map: "id :: 'a \<Rightarrow> 'a"
  bd: natLeq
  rel: "op = :: 'a \<Rightarrow> 'a \<Rightarrow> bool"
  by (auto simp add: Grp_def natLeq_card_order natLeq_cinfinite)

definition id_bnf :: "'a \<Rightarrow> 'a" where
  "id_bnf \<equiv> (\<lambda>x. x)"

lemma id_bnf_apply: "id_bnf x = x"
  unfolding id_bnf_def by simp

bnf ID: 'a
  map: "id_bnf :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
  sets: "\<lambda>x. {x}"
  bd: natLeq
  rel: "id_bnf :: ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
  unfolding id_bnf_def
  apply (auto simp: Grp_def fun_eq_iff relcompp.simps natLeq_card_order natLeq_cinfinite)
  apply (rule ordLess_imp_ordLeq[OF finite_ordLess_infinite[OF _ natLeq_Well_order]])
  apply (auto simp add: Field_card_of Field_natLeq card_of_well_order_on)[3]
  done

lemma type_definition_id_bnf_UNIV: "type_definition id_bnf id_bnf UNIV"
  unfolding id_bnf_def by unfold_locales auto

ML_file "Tools/BNF/bnf_comp_tactics.ML"
ML_file "Tools/BNF/bnf_comp.ML"

hide_fact
  DEADID.inj_map DEADID.inj_map_strong DEADID.map_comp DEADID.map_cong DEADID.map_cong0
  DEADID.map_cong_simp DEADID.map_id DEADID.map_id0 DEADID.map_ident DEADID.map_transfer
  DEADID.rel_Grp DEADID.rel_compp DEADID.rel_compp_Grp DEADID.rel_conversep DEADID.rel_eq
  DEADID.rel_flip DEADID.rel_map DEADID.rel_mono DEADID.rel_transfer
  ID.inj_map ID.inj_map_strong ID.map_comp ID.map_cong ID.map_cong0 ID.map_cong_simp ID.map_id
  ID.map_id0 ID.map_ident ID.map_transfer ID.rel_Grp ID.rel_compp ID.rel_compp_Grp ID.rel_conversep
  ID.rel_eq ID.rel_flip ID.rel_map ID.rel_mono ID.rel_transfer ID.set_map ID.set_transfer

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_34
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) y = y"
| "t2 (S z) y = S (t2 z y)"

fun t22 :: "Nat => Nat => Nat" where
  "t22 (Z) y = Z"
| "t22 (S z) y = t2 y (t22 z y)"

fun mult :: "Nat => Nat => Nat => Nat" where
  "mult (Z) y z = z"
| "mult (S x2) y z = mult x2 y (t2 y z)"

theorem property0 :
  "((t22 x y) = (mult x y Z))"
  oops

end