(*  Title:      HOL/Old_Number_Theory/EulerFermat.thy
    Author:     Thomas M. Rasmussen
    Copyright   2000  University of Cambridge
*)

section {* Fermat's Little Theorem extended to Euler's Totient function *}

theory EulerFermat
imports BijectionRel IntFact
begin

text {*
  Fermat's Little Theorem extended to Euler's Totient function. More
  abstract approach than Boyer-Moore (which seems necessary to achieve
  the extended version).
*}

subsection {* Definitions and lemmas *}

inductive_set RsetR :: "int => int set set" for m :: int
where
  empty [simp]: "{} \<in> RsetR m"
| insert: "A \<in> RsetR m ==> zgcd a m = 1 ==>
    \<forall>a'. a' \<in> A --> \<not> zcong a a' m ==> insert a A \<in> RsetR m"

fun BnorRset :: "int \<Rightarrow> int => int set" where
  "BnorRset a m =
   (if 0 < a then
    let na = BnorRset (a - 1) m
    in (if zgcd a m = 1 then insert a na else na)
    else {})"

definition norRRset :: "int => int set"
  where "norRRset m = BnorRset (m - 1) m"

definition noXRRset :: "int => int => int set"
  where "noXRRset m x = (\<lambda>a. a * x) ` norRRset m"

definition phi :: "int => nat"
  where "phi m = card (norRRset m)"

definition is_RRset :: "int set => int => bool"
  where "is_RRset A m = (A \<in> RsetR m \<and> card A = phi m)"

definition RRset2norRR :: "int set => int => int => int"
  where
    "RRset2norRR A m a =
       (if 1 < m \<and> is_RRset A m \<and> a \<in> A then
          SOME b. zcong a b m \<and> b \<in> norRRset m
        else 0)"

definition zcongm :: "int => int => int => bool"
  where "zcongm m = (\<lambda>a b. zcong a b m)"

lemma abs_eq_1_iff [iff]: "(abs z = (1::int)) = (z = 1 \<or> z = -1)"
  -- {* LCP: not sure why this lemma is needed now *}
  by (auto simp add: abs_if)

text {* \medskip @{text norRRset} *}

declare BnorRset.simps [simp del]

lemma BnorRset_induct:
  assumes "!!a m. P {} a m"
    and "!!a m :: int. 0 < a ==> P (BnorRset (a - 1) m) (a - 1) m
      ==> P (BnorRset a m) a m"
  shows "P (BnorRset u v) u v"
  apply (rule BnorRset.induct)
   apply (case_tac "0 < a")
    apply (rule_tac assms)
     apply simp_all
   apply (simp_all add: BnorRset.simps assms)
  done

lemma Bnor_mem_zle [rule_format]: "b \<in> BnorRset a m \<longrightarrow> b \<le> a"
  apply (induct a m rule: BnorRset_induct)
   apply simp
  apply (subst BnorRset.simps)
   apply (unfold Let_def, auto)
  done

lemma Bnor_mem_zle_swap: "a < b ==> b \<notin> BnorRset a m"
  by (auto dest: Bnor_mem_zle)

lemma Bnor_mem_zg [rule_format]: "b \<in> BnorRset a m --> 0 < b"
  apply (induct a m rule: BnorRset_induct)
   prefer 2
   apply (subst BnorRset.simps)
   apply (unfold Let_def, auto)
  done

lemma Bnor_mem_if [rule_format]:
    "zgcd b m = 1 --> 0 < b --> b \<le> a --> b \<in> BnorRset a m"
  apply (induct a m rule: BnorRset.induct, auto)
   apply (subst BnorRset.simps)
   defer
   apply (subst BnorRset.simps)
   apply (unfold Let_def, auto)
  done

lemma Bnor_in_RsetR [rule_format]: "a < m --> BnorRset a m \<in> RsetR m"
  apply (induct a m rule: BnorRset_induct, simp)
  apply (subst BnorRset.simps)
  apply (unfold Let_def, auto)
  apply (rule RsetR.insert)
    apply (rule_tac [3] allI)
    apply (rule_tac [3] impI)
    apply (rule_tac [3] zcong_not)
       apply (subgoal_tac [6] "a' \<le> a - 1")
        apply (rule_tac [7] Bnor_mem_zle)
        apply (rule_tac [5] Bnor_mem_zg, auto)
  done

lemma Bnor_fin: "finite (BnorRset a m)"
  apply (induct a m rule: BnorRset_induct)
   prefer 2
   apply (subst BnorRset.simps)
   apply (unfold Let_def, auto)
  done

lemma norR_mem_unique_aux: "a \<le> b - 1 ==> a < (b::int)"
  apply auto
  done

lemma norR_mem_unique:
  "1 < m ==>
    zgcd a m = 1 ==> \<exists>!b. [a = b] (mod m) \<and> b \<in> norRRset m"
  apply (unfold norRRset_def)
  apply (cut_tac a = a and m = m in zcong_zless_unique, auto)
   apply (rule_tac [2] m = m in zcong_zless_imp_eq)
       apply (auto intro: Bnor_mem_zle Bnor_mem_zg zcong_trans
         order_less_imp_le norR_mem_unique_aux simp add: zcong_sym)
  apply (rule_tac x = b in exI, safe)
  apply (rule Bnor_mem_if)
    apply (case_tac [2] "b = 0")
     apply (auto intro: order_less_le [THEN iffD2])
   prefer 2
   apply (simp only: zcong_def)
   apply (subgoal_tac "zgcd a m = m")
    prefer 2
    apply (subst zdvd_iff_zgcd [symmetric])
     apply (rule_tac [4] zgcd_zcong_zgcd)
       apply (simp_all (no_asm_use) add: zcong_sym)
  done

text {* \medskip @{term noXRRset} *}

lemma RRset_gcd [rule_format]:
    "is_RRset A m ==> a \<in> A --> zgcd a m = 1"
  apply (unfold is_RRset_def)
  apply (rule RsetR.induct, auto)
  done

lemma RsetR_zmult_mono:
  "A \<in> RsetR m ==>
    0 < m ==> zgcd x m = 1 ==> (\<lambda>a. a * x) ` A \<in> RsetR m"
  apply (erule RsetR.induct, simp_all)
  apply (rule RsetR.insert, auto)
   apply (blast intro: zgcd_zgcd_zmult)
  apply (simp add: zcong_cancel)
  done

lemma card_nor_eq_noX:
  "0 < m ==>
    zgcd x m = 1 ==> card (noXRRset m x) = card (norRRset m)"
  apply (unfold norRRset_def noXRRset_def)
  apply (rule card_image)
   apply (auto simp add: inj_on_def Bnor_fin)
  apply (simp add: BnorRset.simps)
  done

lemma noX_is_RRset:
    "0 < m ==> zgcd x m = 1 ==> is_RRset (noXRRset m x) m"
  apply (unfold is_RRset_def phi_def)
  apply (auto simp add: card_nor_eq_noX)
  apply (unfold noXRRset_def norRRset_def)
  apply (rule RsetR_zmult_mono)
    apply (rule Bnor_in_RsetR, simp_all)
  done

lemma aux_some:
  "1 < m ==> is_RRset A m ==> a \<in> A
    ==> zcong a (SOME b. [a = b] (mod m) \<and> b \<in> norRRset m) m \<and>
      (SOME b. [a = b] (mod m) \<and> b \<in> norRRset m) \<in> norRRset m"
  apply (rule norR_mem_unique [THEN ex1_implies_ex, THEN someI_ex])
   apply (rule_tac [2] RRset_gcd, simp_all)
  done

lemma RRset2norRR_correct:
  "1 < m ==> is_RRset A m ==> a \<in> A ==>
    [a = RRset2norRR A m a] (mod m) \<and> RRset2norRR A m a \<in> norRRset m"
  apply (unfold RRset2norRR_def, simp)
  apply (rule aux_some, simp_all)
  done

lemmas RRset2norRR_correct1 = RRset2norRR_correct [THEN conjunct1]
lemmas RRset2norRR_correct2 = RRset2norRR_correct [THEN conjunct2]

lemma RsetR_fin: "A \<in> RsetR m ==> finite A"
  by (induct set: RsetR) auto

lemma RRset_zcong_eq [rule_format]:
  "1 < m ==>
    is_RRset A m ==> [a = b] (mod m) ==> a \<in> A --> b \<in> A --> a = b"
  apply (unfold is_RRset_def)
  apply (rule RsetR.induct)
    apply (auto simp add: zcong_sym)
  done

lemma aux:
  "P (SOME a. P a) ==> Q (SOME a. Q a) ==>
    (SOME a. P a) = (SOME a. Q a) ==> \<exists>a. P a \<and> Q a"
  apply auto
  done

lemma RRset2norRR_inj:
    "1 < m ==> is_RRset A m ==> inj_on (RRset2norRR A m) A"
  apply (unfold RRset2norRR_def inj_on_def, auto)
  apply (subgoal_tac "\<exists>b. ([x = b] (mod m) \<and> b \<in> norRRset m) \<and>
      ([y = b] (mod m) \<and> b \<in> norRRset m)")
   apply (rule_tac [2] aux)
     apply (rule_tac [3] aux_some)
       apply (rule_tac [2] aux_some)
         apply (rule RRset_zcong_eq, auto)
  apply (rule_tac b = b in zcong_trans)
   apply (simp_all add: zcong_sym)
  done

lemma RRset2norRR_eq_norR:
    "1 < m ==> is_RRset A m ==> RRset2norRR A m ` A = norRRset m"
  apply (rule card_seteq)
    prefer 3
    apply (subst card_image)
      apply (rule_tac RRset2norRR_inj, auto)
     apply (rule_tac [3] RRset2norRR_correct2, auto)
    apply (unfold is_RRset_def phi_def norRRset_def)
    apply (auto simp add: Bnor_fin)
  done

lemma Bnor_prod_power_aux: "a \<notin> A ==> inj f ==> f a \<notin> f ` A"
by (unfold inj_on_def, auto)

lemma Bnor_prod_power [rule_format]:
  "x \<noteq> 0 ==> a < m --> \<Prod>((\<lambda>a. a * x) ` BnorRset a m) =
      \<Prod>(BnorRset a m) * x^card (BnorRset a m)"
  apply (induct a m rule: BnorRset_induct)
   prefer 2
   apply (simplesubst BnorRset.simps)  --{*multiple redexes*}
   apply (unfold Let_def, auto)
  apply (simp add: Bnor_fin Bnor_mem_zle_swap)
  apply (subst setprod.insert)
    apply (rule_tac [2] Bnor_prod_power_aux)
     apply (unfold inj_on_def)
     apply (simp_all add: ac_simps Bnor_fin Bnor_mem_zle_swap)
  done

subsection {* Fermat *}

lemma bijzcong_zcong_prod:
    "(A, B) \<in> bijR (zcongm m) ==> [\<Prod>A = \<Prod>B] (mod m)"
  apply (unfold zcongm_def)
  apply (erule bijR.induct)
   apply (subgoal_tac [2] "a \<notin> A \<and> b \<notin> B \<and> finite A \<and> finite B")
    apply (auto intro: fin_bijRl fin_bijRr zcong_zmult)
  done

lemma Bnor_prod_zgcd [rule_format]:
    "a < m --> zgcd (\<Prod>(BnorRset a m)) m = 1"
  apply (induct a m rule: BnorRset_induct)
   prefer 2
   apply (subst BnorRset.simps)
   apply (unfold Let_def, auto)
  apply (simp add: Bnor_fin Bnor_mem_zle_swap)
  apply (blast intro: zgcd_zgcd_zmult)
  done

theorem Euler_Fermat:
    "0 < m ==> zgcd x m = 1 ==> [x^(phi m) = 1] (mod m)"
  apply (unfold norRRset_def phi_def)
  apply (case_tac "x = 0")
   apply (case_tac [2] "m = 1")
    apply (rule_tac [3] iffD1)
     apply (rule_tac [3] k = "\<Prod>(BnorRset (m - 1) m)"
       in zcong_cancel2)
      prefer 5
      apply (subst Bnor_prod_power [symmetric])
        apply (rule_tac [7] Bnor_prod_zgcd, simp_all)
  apply (rule bijzcong_zcong_prod)
  apply (fold norRRset_def, fold noXRRset_def)
  apply (subst RRset2norRR_eq_norR [symmetric])
    apply (rule_tac [3] inj_func_bijR, auto)
     apply (unfold zcongm_def)
     apply (rule_tac [2] RRset2norRR_correct1)
       apply (rule_tac [5] RRset2norRR_inj)
        apply (auto intro: order_less_le [THEN iffD2]
           simp add: noX_is_RRset)
  apply (unfold noXRRset_def norRRset_def)
  apply (rule finite_imageI)
  apply (rule Bnor_fin)
  done

lemma Bnor_prime:
  "\<lbrakk> zprime p; a < p \<rbrakk> \<Longrightarrow> card (BnorRset a p) = nat a"
  apply (induct a p rule: BnorRset.induct)
  apply (subst BnorRset.simps)
  apply (unfold Let_def, auto simp add:zless_zprime_imp_zrelprime)
  apply (subgoal_tac "finite (BnorRset (a - 1) m)")
   apply (subgoal_tac "a ~: BnorRset (a - 1) m")
    apply (auto simp add: card_insert_disjoint Suc_nat_eq_nat_zadd1)
   apply (frule Bnor_mem_zle, arith)
  apply (frule Bnor_fin)
  done

lemma phi_prime: "zprime p ==> phi p = nat (p - 1)"
  apply (unfold phi_def norRRset_def)
  apply (rule Bnor_prime, auto)
  done

theorem Little_Fermat:
    "zprime p ==> \<not> p dvd x ==> [x^(nat (p - 1)) = 1] (mod p)"
  apply (subst phi_prime [symmetric])
   apply (rule_tac [2] Euler_Fermat)
    apply (erule_tac [3] zprime_imp_zrelprime)
    apply (unfold zprime_def, auto)
  done

end


theory Partially_Filled_Array
  imports
    "Refine_Imperative_HOL.IICF_Array_List"
    Array_SBlit
begin

section "Partially Filled Arrays"

text \<open>An array that is only partially filled.
The number of actual elements contained is kept in a second element.
This represents a weakened version of the array\_list from IICF.\<close>

type_synonym 'a pfarray = "'a array_list"

subsection "Operations on Partly Filled Arrays"

definition is_pfa where
  "is_pfa c l \<equiv> \<lambda>(a,n). \<exists>\<^sub>A l'. a \<mapsto>\<^sub>a l' *  \<up>(c = length l' \<and> n \<le> c \<and> l = (take n l'))"

lemma is_pfa_prec[safe_constraint_rules]: "precise (is_pfa c)"
  unfolding is_pfa_def[abs_def]
  apply(rule preciseI)
  apply(simp split: prod.splits)
  using preciseD snga_prec by fastforce

definition pfa_init where
  "pfa_init cap v n \<equiv> do {
  a \<leftarrow> Array.new cap v;
  return (a,n)
}"

lemma pfa_init_rule[sep_heap_rules]: "n \<le> N \<Longrightarrow> < emp > pfa_init N x n <is_pfa N (replicate n x)>"
  by (sep_auto simp: pfa_init_def is_pfa_def)

definition pfa_empty where
  "pfa_empty cap \<equiv> pfa_init cap default 0"

lemma pfa_empty_rule[sep_heap_rules]: "< emp > pfa_empty N <is_pfa N []>"
  by (sep_auto simp: pfa_empty_def is_pfa_def)

definition "pfa_length \<equiv> arl_length"

lemma pfa_length_rule[sep_heap_rules]: "
  <is_pfa c l a>
    pfa_length a
  <\<lambda>r. is_pfa c l a * \<up>(r=length l)>"
  by (sep_auto simp: pfa_length_def arl_length_def is_pfa_def)

definition "pfa_capacity \<equiv> \<lambda>(a,n). Array.len a
"

lemma pfa_capacity_rule[sep_heap_rules]: "
  <is_pfa c l a>
    pfa_capacity a
  <\<lambda>r. is_pfa c l a * \<up>(c=r)>"
  by (sep_auto simp: pfa_capacity_def arl_length_def is_pfa_def)

definition "pfa_is_empty \<equiv> arl_is_empty"

lemma pfa_is_empty_rule[sep_heap_rules]: "
  <is_pfa c l a>
    pfa_is_empty a
  <\<lambda>r. is_pfa c l a * \<up>(r\<longleftrightarrow>(l=[]))>"
  by (sep_auto simp: pfa_is_empty_def arl_is_empty_def is_pfa_def)

definition "pfa_append \<equiv> \<lambda>(a,n) x. do {
  Array.upd n x a;
  return (a,n+1)
}"

lemma pfa_append_rule[sep_heap_rules]: "
   n < c  \<Longrightarrow>
    < is_pfa c l (a,n) >
      pfa_append (a,n) x
    <\<lambda>(a',n'). is_pfa c (l@[x]) (a',n') * \<up>(a' = a \<and> n' = n+1) >"
  by (sep_auto
      simp: pfa_append_def arl_append_def is_pfa_def take_update_last neq_Nil_conv
      split: prod.splits nat.split)

definition "pfa_last \<equiv> arl_last"

lemma pfa_last_rule[sep_heap_rules]: "
  l\<noteq>[] \<Longrightarrow>
  <is_pfa c l a>
    pfa_last a
  <\<lambda>r. is_pfa c l a * \<up>(r=last l)>"
  by (sep_auto simp: pfa_last_def arl_last_def is_pfa_def last_take_nth_conv)

definition pfa_butlast :: "'a::heap pfarray \<Rightarrow> 'a pfarray Heap" where
  "pfa_butlast \<equiv> \<lambda>(a,n).
    return (a,n-1)
  "

lemma pfa_butlast_rule[sep_heap_rules]: "
  <is_pfa c l (a,n)>
    pfa_butlast (a,n)
  <\<lambda>(a',n'). is_pfa c (butlast l) (a',n') * \<up>(a' = a)>"
  by (sep_auto
      split: prod.splits
      simp: pfa_butlast_def is_pfa_def butlast_take)

definition "pfa_get \<equiv> arl_get"

lemma pfa_get_rule[sep_heap_rules]: "
  i < length l \<Longrightarrow>
  < is_pfa c l a>
    pfa_get a i
  <\<lambda>r. is_pfa c l a * \<up>((l!i) = r)>"
  by (sep_auto simp: is_pfa_def pfa_get_def arl_get_def  split: prod.split)

definition "pfa_set \<equiv> arl_set"

lemma pfa_set_rule[sep_heap_rules]: "
    i<length l \<Longrightarrow>
    <is_pfa c l a>
      pfa_set a i x
    <\<lambda>a'. is_pfa c (l[i:=x]) a' * \<up>(a' = a)>"
  by (sep_auto simp: pfa_set_def arl_set_def is_pfa_def split: prod.split)

definition pfa_shrink :: "nat \<Rightarrow> 'a::heap pfarray \<Rightarrow> 'a pfarray Heap" where
  "pfa_shrink k \<equiv> \<lambda>(a,n).
  return (a,k)
"

lemma pfa_shrink_rule[sep_heap_rules]: "
   k \<le> length xs \<Longrightarrow>
    < is_pfa c xs (a,n) >
      pfa_shrink k (a,n)
    <\<lambda>(a',n'). is_pfa c (take k xs) (a',n') * \<up>(n' = k \<and> a'=a) >"
  by (sep_auto
      simp: pfa_shrink_def is_pfa_def min.absorb1
      split: prod.splits nat.split)

definition pfa_shrink_cap :: "nat \<Rightarrow> 'a::heap pfarray \<Rightarrow> 'a pfarray Heap" where
  "pfa_shrink_cap k \<equiv> \<lambda>(a,n). do {
  a' \<leftarrow> array_shrink a k;
  return (a',min k n)
}
"

lemma pfa_shrink_cap_rule_preserve[sep_heap_rules]: "
   \<lbrakk>n \<le> k; k \<le> c\<rbrakk> \<Longrightarrow>
    < is_pfa c l (a,n) >
      pfa_shrink_cap k (a,n)
    <\<lambda>a'. is_pfa k l a' >\<^sub>t"
  by (sep_auto
      simp: pfa_shrink_cap_def is_pfa_def min.absorb1 min.absorb2
      split: prod.splits nat.split)

lemma pfa_shrink_cap_rule: "
   \<lbrakk>k \<le> c\<rbrakk> \<Longrightarrow>
    < is_pfa c l a >
      pfa_shrink_cap k a
    <\<lambda>a'. is_pfa k (take k l) a' >\<^sub>t"
  by (sep_auto
      simp: pfa_shrink_cap_def is_pfa_def min.absorb1 min.absorb2
      split: prod.splits nat.split dest: mod_starD)

definition "array_ensure a s x \<equiv> do {
    l\<leftarrow>Array.len a;
    if l\<ge>s then
      return a
    else do {
      a'\<leftarrow>Array.new s x;
      blit a 0 a' 0 l;
      return a'
    }
  }"

lemma array_ensure_rule[sep_heap_rules]:
  shows "
      < a\<mapsto>\<^sub>ala >
        array_ensure a s x
      <\<lambda>a'. a'\<mapsto>\<^sub>a (la @ replicate (s-length la) x)>\<^sub>t"
  unfolding array_ensure_def
  by sep_auto

(* Ensure a certain capacity *)
definition pfa_ensure :: "'a::{heap,default} pfarray \<Rightarrow> nat \<Rightarrow> 'a pfarray Heap" where
  "pfa_ensure \<equiv> \<lambda>(a,n) k. do {
  a' \<leftarrow> array_ensure a k default;
  return (a',n)
}
"

lemma pfa_ensure_rule[sep_heap_rules]: "
    < is_pfa c l (a,n) >
      pfa_ensure (a,n) k
    <\<lambda>(a',n'). is_pfa (max c k) l (a',n') * \<up>(n' = n \<and> c \<ge> n)>\<^sub>t"
  by (sep_auto
      simp: pfa_ensure_def is_pfa_def)

definition "pfa_copy \<equiv> arl_copy"

lemma pfa_copy_rule[sep_heap_rules]:
  "< is_pfa c l a >
   pfa_copy a
   <\<lambda>r. is_pfa c l a * is_pfa c l r>\<^sub>t"
  by (sep_auto simp: pfa_copy_def arl_copy_def is_pfa_def)

definition pfa_blit :: "'a::heap pfarray \<Rightarrow> nat \<Rightarrow> 'a::heap pfarray \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "pfa_blit \<equiv> \<lambda>(src,sn) si (dst,dn) di l. blit src si dst di l"

lemma min_nat: "min a (a+b) = (a::nat)"
  by auto

lemma pfa_blit_rule[sep_heap_rules]:
  assumes LEN: "si+len \<le> sn" "di \<le> dn" "di+len \<le> dc"
  shows
    "< is_pfa sc src (srci,sn)
      * is_pfa dc dst (dsti,dn) >
    pfa_blit (srci,sn) si (dsti,dn) di len
    <\<lambda>_. is_pfa sc src (srci,sn)
      * is_pfa dc (take di dst @ take len (drop si src) @ drop (di+len) dst) (dsti,max (di+len) dn)
    >"
  using LEN apply(sep_auto simp add: min_nat is_pfa_def pfa_blit_def min.commute min.absorb1 heap: blit_rule)
   apply (simp add: min.absorb1 take_drop)
  apply (simp add: drop_take max_def)
  done

definition pfa_drop :: "('a::heap) pfarray \<Rightarrow> nat \<Rightarrow> 'a pfarray \<Rightarrow> 'a pfarray Heap" where
  "pfa_drop \<equiv> \<lambda>(src,sn) si (dst,dn). do {
   blit src si dst 0 (sn-si);
   return (dst,(sn-si))
}
"

lemma pfa_drop_rule[sep_heap_rules]:
  assumes LEN: "k \<le> sn" "(sn-k) \<le> dc"
  shows
    "< is_pfa sc src (srci,sn)
      * is_pfa dc dst (dsti,dn) >
    pfa_drop (srci,sn) k (dsti,dn)
    <\<lambda>(dsti',dn'). is_pfa sc src (srci,sn)
      * is_pfa dc (drop k src) (dsti',dn')
      * \<up>(dsti' = dsti)
    >"
  using LEN apply (sep_auto simp add: drop_take is_pfa_def pfa_drop_def dest!: mod_starD heap: pfa_blit_rule)
  done

definition "pfa_append_grow \<equiv> \<lambda>(a,n) x. do {
  l \<leftarrow> pfa_capacity (a,n);
  a' \<leftarrow> if l = n
  then array_grow a (l+1) x
  else Array.upd n x a;
  return (a',n+1)
}"

lemma pfa_append_grow_full_rule[sep_heap_rules]: "n = c \<Longrightarrow>
     <is_pfa c l (a,n)>
  array_grow a (c+1) x
      <\<lambda>a'. is_pfa (c+1) (l@[x]) (a',n+1)>\<^sub>t"
  apply(sep_auto simp add: is_pfa_def
      heap del: array_grow_rule)
  apply(vcg heap del: array_grow_rule heap add: array_grow_rule[of l "(Suc (length l))" a x])
   apply simp
  apply(rule ent_ex_postI[where ?x="l@[x]"])
  apply sep_auto
  done

lemma pfa_append_grow_less_rule: "n < c \<Longrightarrow>
 <is_pfa c l (a,n)>
    Array.upd n x a
<\<lambda>a'. is_pfa c (l@[x]) (a',n+1)>\<^sub>t"
  apply(sep_auto simp add: is_pfa_def take_update_last)
  done

lemma pfa_append_grow_rule[sep_heap_rules]: "
  <is_pfa c l (a,n)>
  pfa_append_grow (a,n) x
  <\<lambda>(a',n'). is_pfa (if c = n then c+1 else c) (l@[x]) (a',n') * \<up>(n'=n+1 \<and> c \<ge> n)>\<^sub>t"
  apply(subst pfa_append_grow_def)
  apply(rule hoare_triple_preI)
  apply (sep_auto
      heap add: pfa_append_grow_full_rule pfa_append_grow_less_rule)
   apply(sep_auto simp add: is_pfa_def)
  apply(sep_auto simp add: is_pfa_def)
  done

(* This definition has only one access to the array length *)
definition "pfa_append_grow' \<equiv> \<lambda>(a,n) x. do {
  a' \<leftarrow> pfa_ensure (a,n) (n+1);
  a'' \<leftarrow> pfa_append a' x;
  return a''
}"

lemma pfa_append_grow'_rule[sep_heap_rules]: "
  <is_pfa c l (a,n)>
  pfa_append_grow' (a,n) x
  <\<lambda>(a',n'). is_pfa (max (n+1) c) (l@[x]) (a',n') * \<up>(n'=n+1 \<and> c \<ge> n)>\<^sub>t"
  unfolding pfa_append_grow'_def
  by (sep_auto simp add: max_def)

definition "pfa_insert \<equiv> \<lambda>(a,n) i x. do {
  a' \<leftarrow> array_shr a i 1;
  a'' \<leftarrow> Array.upd i x a;
  return (a'',n+1)
}"

lemma list_update_last: "length ls = Suc i \<Longrightarrow> ls[i:=x] = (take i ls)@[x]"
  by (metis append_eq_conv_conj length_Suc_rev_conv list_update_length)

lemma pfa_insert_rule[sep_heap_rules]:
  "\<lbrakk>i \<le> n; n < c\<rbrakk> \<Longrightarrow>
  <is_pfa c l (a,n)>
  pfa_insert (a,n) i x
  <\<lambda>(a',n'). is_pfa c (take i l@x#drop i l) (a',n') * \<up>(n' = n+1 \<and> a=a')>"
  unfolding pfa_insert_def is_pfa_def
  by (sep_auto simp add: list_update_append1 list_update_last
      Suc_diff_le drop_take min_def)

definition pfa_insert_grow ::  "'a::{heap,default} pfarray \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a pfarray Heap"
  where "pfa_insert_grow \<equiv> \<lambda>(a,n) i x. do {
  a' \<leftarrow> pfa_ensure (a,n) (n+1);
  a'' \<leftarrow> pfa_insert a' i x;
  return a''
}"

lemma pfa_insert_grow_rule[sep_heap_rules]:
  "i \<le> n \<Longrightarrow>
  <is_pfa c l (a,n)>
  pfa_insert_grow (a,n) i x
  <\<lambda>(a',n'). is_pfa (max c (n+1)) (take i l@x#drop i l) (a',n') * \<up>(n'=n+1 \<and> c \<ge> n)>\<^sub>t"
  unfolding pfa_insert_grow_def
  by (sep_auto heap add: pfa_insert_rule[of i n "max c (Suc n)"])

definition pfa_extend where
  "pfa_extend \<equiv> \<lambda> (a,n) (b,m). do{
  blit b 0 a n m;
  return (a,n+m)
}"

lemma pfa_extend_rule[sep_heap_rules]:
  "n+m \<le> c \<Longrightarrow>
  <is_pfa c l1 (a,n) * is_pfa d l2 (b,m)>
  pfa_extend (a,n) (b,m)
  <\<lambda>(a',n'). is_pfa c (l1@l2) (a',n') * \<up>(a' = a \<and> n'=n+m) * is_pfa d l2 (b,m)>\<^sub>t"
  unfolding pfa_extend_def
  by (sep_auto simp add: is_pfa_def min.absorb1 min.absorb2 heap add: blit_rule)

definition pfa_extend_grow where
  "pfa_extend_grow \<equiv> \<lambda> (a,n) (b,m). do{
  a' \<leftarrow> array_ensure a (n+m) default;
  blit b 0 a' n m;
  return (a',n+m)
}"

lemma pfa_extend_grow_rule[sep_heap_rules]:
  "<is_pfa c l1 (a,n) * is_pfa d l2 (b,m)>
  pfa_extend_grow (a,n) (b,m)
  <\<lambda>(a',n'). is_pfa (max c (n+m)) (l1@l2) (a',n') * \<up>(n'=n+m \<and> c \<ge> n) * is_pfa d l2 (b,m)>\<^sub>t"
  unfolding pfa_extend_grow_def
  by (sep_auto simp add: is_pfa_def min.absorb1 min.absorb2 heap add: blit_rule)

definition pfa_append_extend_grow where
  "pfa_append_extend_grow \<equiv> \<lambda> (a,n) x (b,m). do{
  a' \<leftarrow> array_ensure a (n+m+1) default;
  a'' \<leftarrow> Array.upd n x a';
  blit b 0 a'' (n+1) m;
  return (a'',n+m+1)
}"

lemma pfa_append_extend_grow_rule[sep_heap_rules]:
  "<is_pfa c l1 (a,n) * is_pfa d l2 (b,m)>
  pfa_append_extend_grow (a,n) x (b,m)
  <\<lambda>(a',n'). is_pfa (max c (n+m+1)) (l1@x#l2) (a',n') * \<up>(n'=n+m+1 \<and> c \<ge> n) * is_pfa d l2 (b,m)>\<^sub>t"
  unfolding pfa_append_extend_grow_def
  by (sep_auto simp add: list_update_last is_pfa_def min.absorb1 min.absorb2 heap add: blit_rule)

definition "pfa_delete \<equiv> \<lambda>(a,n) i. do {
  array_shl a (i+1) 1;
  return (a,n-1)
}"

lemma pfa_delete_rule[sep_heap_rules]:
  "i < n \<Longrightarrow>
  <is_pfa c l (a,n)>
  pfa_delete (a,n) i
  <\<lambda>(a',n'). is_pfa c (take i l@drop (i+1) l) (a',n') * \<up>(n' = n-1 \<and> a=a')>"
  unfolding pfa_delete_def is_pfa_def
  apply (sep_auto simp add: drop_take min_def)
  by (metis Suc_diff_Suc diff_zero dual_order.strict_trans2 le_less_Suc_eq zero_le)

end


section \<open>The Circle Example\<close>

theory CircExample
  imports Green SymmetricR2Shapes

begin

locale circle = R2 +
  fixes d::real
  assumes d_gt_0: "0 < d"
begin

definition circle_y where
  "circle_y t = sqrt (1/4 - t * t)"

definition circle_cube where
  "circle_cube = (\<lambda>(x,y). ((x - 1/2) * d, (2 * y - 1) * d * sqrt (1/4 - (x -1/2)*(x -1/2))))"

lemma circle_cube_nice:
  shows "circle_cube = (\<lambda>(x,y). (d * x_coord x, (2 * y - 1) * d * circle_y (x_coord x)))"
  by (auto simp add: circle_cube_def circle_y_def x_coord_def)

definition rot_circle_cube where
  "rot_circle_cube = prod.swap \<circ> (circle_cube) \<circ> prod.swap"

abbreviation "rot_y t1 t2 \<equiv> ((t1-1/2)/(2* circle_y (x_coord (rot_x t1 t2))) +1/2::real)"

definition "x_coord_inv (x::real) = (1/2) + x"

lemma x_coord_inv_1: "x_coord_inv (x_coord (x::real)) = x"
  by (auto simp add: x_coord_inv_def x_coord_def)

lemma x_coord_inv_2: "x_coord (x_coord_inv (x::real)) = x"
  by (auto simp add: x_coord_inv_def x_coord_def)

definition "circle_y_inv = circle_y"

abbreviation "rot_x'' (x::real) (y::real) \<equiv> (x_coord_inv ((2 * y - 1) * circle_y (x_coord x)))"

lemma circle_y_bounds:
  assumes "-1/2 \<le> (x::real) \<and> x \<le> 1/2"
  shows "0 \<le> circle_y x" "circle_y x \<le> 1/2"
  unfolding circle_y_def real_sqrt_ge_0_iff
proof -
  show "0 \<le> 1/4 - x * x"
    using assms by (sos "(((A<0 * R<1) + ((A<=0 * (A<=1 * R<1)) * (R<1 * [1]^2))))")
  show "sqrt (1/4 - x * x) \<le> 1/2"
    apply (rule real_le_lsqrt)
    using assms apply(auto simp add: divide_simps algebra_simps)
    by (sos "(((A<0 * R<1) + ((A<=0 * (A<=1 * R<1)) * (R<1 * [1]^2))))")
qed

lemma circle_y_x_coord_bounds:
  assumes "0 \<le> (x::real)" "x \<le> 1"
  shows "0 \<le> circle_y (x_coord x) \<and> circle_y (x_coord x) \<le> 1/2"
  using circle_y_bounds[OF x_coord_bounds[OF assms]] by auto

lemma rot_x_ivl:
  assumes "(0::real) \<le> x" "x \<le> 1"  "0 \<le> y" "y \<le> 1"
  shows "0 \<le> rot_x'' x y \<and> rot_x'' x y \<le> 1"
proof
  have "\<And>a::real. 0 \<le> a \<and> a \<le> 1/2 \<Longrightarrow> 0 \<le> 1/2 + (2 * y - 1) * a" using assms
    by (sos "(((A<0 * R<1) + (((A<=4 * R<1) * (R<1/2 * [1]^2)) + (((A<=1 * (A<=5 * R<1)) * (R<1 * [1]^2)) + ((A<=0 * (A<=4 * R<1)) * (R<1 * [1]^2))))))")
  then show "0 \<le> rot_x'' x y"
    using assms circle_y_x_coord_bounds by(auto simp add: x_coord_inv_def)
  have "\<And>a::real. 0 \<le> a \<and> a \<le> 1/2 \<Longrightarrow> 1/2 + (2 * y - 1) * a \<le> 1" using assms
    by (sos "(((A<0 * R<1) + (((A<=5 * R<1) * (R<1/2 * [1]^2)) + (((A<=1 * (A<=4 * R<1)) * (R<1 * [1]^2)) + ((A<=0 * (A<=5 * R<1)) * (R<1 * [1]^2))))))")
  then show "rot_x'' x y \<le> 1"
    using assms circle_y_x_coord_bounds by (auto simp add: x_coord_inv_def)
qed

abbreviation "rot_y'' (x::real) (y::real) \<equiv> (x_coord x)/(2* (circle_y (x_coord (rot_x'' x y))))  + 1/2"

lemma rot_y_ivl:
  assumes "(0::real) \<le> x" "x \<le> 1" "0 \<le> y" "y \<le> 1"
  shows "0 \<le> rot_y'' x y \<and> rot_y'' x y \<le> 1"
proof
  show "0 \<le> rot_y'' x y"
  proof(cases "(x_coord x) < 0")
    case True
    have i: "\<And>a b::real. a < 0 \<Longrightarrow> 0 \<le> a + b \<Longrightarrow> (0 \<le> a/(2*(b)) + 1/2)"
      by(auto simp add: algebra_simps divide_simps)
    have *: "(1/2 - x) \<le> sqrt (x * x + (1/4 + (x * (y * 4) + x * (x * (y * (y * 4))))) - (x + (x * (x * (y * 4)) + x * (y * (y * 4)))))"
      apply (rule real_le_rsqrt)
      using assms apply (simp add: algebra_simps power2_eq_square mult_left_le_one_le)
      by (sos "(((A<0 * R<1) + ((A<=0 * (A<=1 * (A<=2 * (A<=3 * R<1)))) * (R<4 * [1]^2))))")
    have rw: "\<bar>x - x * x\<bar> = x - x * x" using assms
      by (sos "(() & (((((A<0 * A<1) * R<1) + ((A<=0 * (A<=1 * (A<1 * R<1))) * (R<1 * [1]^2)))) & ((((A<0 * A<1) * R<1) + ((A<=0 * (A<=1 * (A<1 * R<1))) * (R<1 * [1]^2))))))")
    have "0 \<le> x_coord x + (circle_y (x_coord (rot_x'' x y)))"
      using * apply (auto simp add: x_coord_inv_2)
      by (auto simp add: circle_y_def algebra_simps rw x_coord_def)
    then show ?thesis
      using True i by blast
  next
    case False
    have i: "\<And>a b::real. 0 \<le> a \<Longrightarrow> 0 \<le> b  \<Longrightarrow> (0 \<le> a/(2*b) + 1/2)"
      by(auto simp add: algebra_simps divide_simps)
    have "0 \<le> circle_y (x_coord (x_coord_inv ((2 * y - 1) * circle_y (x_coord x))))"
    proof -
      have rw: "\<bar>x - x * x\<bar> = x - x * x" using assms
        by (sos "(() & (((((A<0 * A<1) * R<1) + ((A<=0 * (A<=1 * (A<1 * R<1))) * (R<1 * [1]^2)))) & ((((A<0 * A<1) * R<1) + ((A<=0 * (A<=1 * (A<1 * R<1))) * (R<1 * [1]^2))))))")
      have "\<And>x. 0 \<le> x \<Longrightarrow> x \<le> 1/2 \<Longrightarrow> -1/2\<le> (2 * y - 1) * x" using assms
        by (sos "(((A<0 * R<1) + (((A<=4 * R<1) * (R<1/2 * [1]^2)) + (((A<=1 * (A<=5 * R<1)) * (R<1 * [1]^2)) + ((A<=0 * (A<=4 * R<1)) * (R<1 * [1]^2))))))")
      then have "- 1/2 \<le> (2 * y - 1) * circle_y (x_coord x)"
        using circle_y_x_coord_bounds assms(1-2) by auto
      moreover
      have "\<And>x. 0 \<le> x \<Longrightarrow> x \<le> 1/2 \<Longrightarrow> (2 * y - 1) * x \<le> 1/2 " using assms
        by (sos "(((A<0 * R<1) + (((A<=5 * R<1) * (R<1/2 * [1]^2)) + (((A<=1 * (A<=4 * R<1)) * (R<1 * [1]^2)) + ((A<=0 * (A<=5 * R<1)) * (R<1 * [1]^2))))))")
      then have "(2 * y - 1) * circle_y (x_coord x) \<le> 1/2"
        using circle_y_x_coord_bounds assms(1-2) by auto
      ultimately show "0 \<le> circle_y (x_coord (x_coord_inv ((2 * y - 1) * circle_y (x_coord x))))"
        by (simp add: circle_y_bounds(1) x_coord_inv_2)
    qed
    then show ?thesis
      using False by auto
  qed
  have i: "\<And>a b::real. a < 0 \<Longrightarrow> 0 \<le> b \<Longrightarrow> (a/(2*(b)) + 1/2) \<le> 1"
    by(auto simp add: algebra_simps divide_simps)
  show "rot_y'' x y \<le> 1"
  proof(cases "(x_coord x) < 0")
    case True
    have i: "\<And>a b::real. a < 0 \<Longrightarrow> 0 \<le> b \<Longrightarrow> (a/(2*(b)) + 1/2) \<le> 1"
      by(auto simp add: algebra_simps divide_simps)
    have "\<And>x. 0 \<le> x \<Longrightarrow> x \<le> 1/2 \<Longrightarrow> -1/2\<le> (2 * y - 1) * x" using assms
      by (sos "(((A<0 * R<1) + (((A<=4 * R<1) * (R<1/2 * [1]^2)) + (((A<=1 * (A<=5 * R<1)) * (R<1 * [1]^2)) + ((A<=0 * (A<=4 * R<1)) * (R<1 * [1]^2))))))")
    then have "- 1/2 \<le> (2 * y - 1) * circle_y (x_coord x)"
      using circle_y_x_coord_bounds assms(1-2) by auto
    moreover have "\<And>x. 0 \<le> x \<Longrightarrow> x \<le> 1/2 \<Longrightarrow> (2 * y - 1) * x \<le> 1/2 " using assms
      by (sos "(((A<0 * R<1) + (((A<=5 * R<1) * (R<1/2 * [1]^2)) + (((A<=1 * (A<=4 * R<1)) * (R<1 * [1]^2)) + ((A<=0 * (A<=5 * R<1)) * (R<1 * [1]^2))))))")
    then have "(2 * y - 1) * circle_y (x_coord x) \<le> 1/2"
      using circle_y_x_coord_bounds assms(1-2) by auto
    ultimately have "0 \<le> circle_y (x_coord (x_coord_inv ((2 * y - 1) * circle_y (x_coord x))))"
      by (simp add: circle_y_bounds(1) x_coord_inv_2)
    then show ?thesis
      by (simp add: True i)
  next
    case False
    have i: "\<And>a b::real. 0 \<le> a \<Longrightarrow> a \<le> b  \<Longrightarrow> (a/(2*b) + 1/2) \<le> 1"
      by(auto simp add: algebra_simps divide_simps)
    have "(x - 1/2) * (x - 1/2) \<le> (x * x + (1/4 + (x * (y * 4) + x * (x * (y * (y * 4))))) - (x + (x * (x * (y * 4)) + x * (y * (y * 4)))))"
      using assms False
      apply(auto simp add: x_coord_def)
      by (sos "(((A<0 * R<1) + (((A<=0 * (A<=1 * (A<=2 * R<1))) * (R<2 * [1]^2)) + ((A<=0 * (A<=1 * (A<=2 * (A<=3 * R<1)))) * (R<2 * [1]^2)))))")
    then have "sqrt ((x - 1/2) * (x - 1/2)) \<le> sqrt (x * x + (1/4 + (x * (y * 4) + x * (x * (y * (y * 4))))) - (x + (x * (x * (y * 4)) + x * (y * (y * 4)))))"
      using real_sqrt_le_mono by blast
    then have *: "(x - 1/2) \<le> sqrt (x * x + (1/4 + (x * (y * 4) + x * (x * (y * (y * 4))))) - (x + (x * (x * (y * 4)) + x * (y * (y * 4)))))"
      using assms False by(auto simp add: x_coord_def)
    have rw: "\<bar>x - x * x\<bar> = x - x * x" using assms
      by (sos "(() & (((((A<0 * A<1) * R<1) + ((A<=0 * (A<=1 * (A<1 * R<1))) * (R<1 * [1]^2)))) & ((((A<0 * A<1) * R<1) + ((A<=0 * (A<=1 * (A<1 * R<1))) * (R<1 * [1]^2))))))")
    have "x_coord x \<le> circle_y (x_coord (x_coord_inv ((2 * y - 1) * circle_y (x_coord x))))"
      using * unfolding x_coord_inv_2
      by (auto simp add: circle_y_def algebra_simps rw x_coord_def)
    then show ?thesis
      using False i by auto
  qed
qed

lemma circle_eq_rot_circle:
  assumes "0 \<le> x" "x \<le> 1" "0 \<le> y" "y \<le> 1"
  shows "(circle_cube (x, y)) = (rot_circle_cube (rot_y'' x y, rot_x'' x y))"
proof
  have rw:  "\<bar>1/4 - x_coord x * x_coord x\<bar> = 1/4 - x_coord x * x_coord x"
    apply(rule abs_of_nonneg)
    using assms mult_left_le by (auto simp add: x_coord_def divide_simps algebra_simps)
  show "fst (circle_cube (x, y)) = fst (rot_circle_cube (rot_y'' x y, rot_x'' x y))"
    using assms d_gt_0
    apply(simp add: circle_cube_nice rot_circle_cube_def x_coord_inv_2 circle_y_def algebra_simps rw)
    apply(auto simp add: x_coord_def algebra_simps)
    by (sos "(((((A<0 * A<1) * ((A<0 * A<1) * R<1)) + (([~4*d^2] * A=0) + (((A<=1 * (A<=2 * (A<=3 * R<1))) * (R<8 * [d]^2)) + ((A<=1 * (A<=2 * (A<=3 * (A<1 * R<1)))) * (R<8 * [d]^2)))))) & ((((A<0 * A<1) * ((A<0 * A<1) * R<1)) + (([~4*d^2] * A=0) + (((A<=0 * (A<=2 * (A<=3 * R<1))) * (R<8 * [d]^2)) + ((A<=0 * (A<=2 * (A<=3 * (A<1 * R<1)))) * (R<8 * [d]^2)))))))") (*Be patient: it takes a bit of time, still better than creeping its proof manually.*)
  show "snd (circle_cube (x, y)) = snd (rot_circle_cube (rot_y'' x y, rot_x'' x y))"
    using assms
    by(auto simp add: circle_cube_def rot_circle_cube_def x_coord_inv_def circle_y_def x_coord_def)
qed

lemma rot_circle_eq_circle:
  assumes "0 \<le> x" "x \<le> 1" "0 \<le> y" "y \<le> 1"
  shows "(rot_circle_cube (x, y)) = (circle_cube (rot_x'' y x, rot_y'' y x))"
proof
  show "fst (rot_circle_cube (x, y)) = fst (circle_cube (rot_x'' y x, rot_y'' y x))"
    using assms
    by(auto simp add: circle_cube_def rot_circle_cube_def x_coord_inv_def circle_y_def x_coord_def)
  have rw:  "\<bar>1/4 - x_coord y * x_coord y\<bar> =  1/4 - x_coord y * x_coord y"
    apply(rule abs_of_nonneg)
    using assms mult_left_le by (auto simp add: x_coord_def divide_simps algebra_simps)
  show "snd (rot_circle_cube (x, y)) = snd (circle_cube (rot_x'' y x, rot_y'' y x))"
    using assms d_gt_0
    apply(simp add: circle_cube_nice rot_circle_cube_def x_coord_inv_2 circle_y_def algebra_simps rw)
    apply(auto simp add: x_coord_def algebra_simps)
    by (sos "(((((A<0 * A<1) * ((A<0 * A<1) * R<1)) + (([~4*d^2] * A=0) + (((A<=0 * (A<=1 * (A<=3 * R<1))) * (R<8 * [d]^2)) + ((A<=0 * (A<=1 * (A<=3 * (A<1 * R<1)))) * (R<8 * [d]^2)))))) & ((((A<0 * A<1) * ((A<0 * A<1) * R<1)) + (([~4*d^2] * A=0) + (((A<=0 * (A<=1 * (A<=2 * R<1))) * (R<8 * [d]^2)) + ((A<=0 * (A<=1 * (A<=2 * (A<1 * R<1)))) * (R<8 * [d]^2)))))))") (*Be patient: it takes a bit of time, still better than creeping its proof manually.*)
qed

lemma rot_img_eq:
  assumes "0 < d"
  shows "(cubeImage (circle_cube )) = (cubeImage (rot_circle_cube))"
  apply(auto simp add: cubeImage_def image_def cbox_def real_pair_basis)
  by (meson rot_y_ivl rot_x_ivl assms circle_eq_rot_circle rot_circle_eq_circle)+

lemma rot_circle_div_circle:
  assumes "0 < (d::real)"
  shows "gen_division (cubeImage circle_cube) (cubeImage ` {rot_circle_cube})"
  using rot_img_eq[OF assms] by(auto simp add: gen_division_def)

lemma circle_cube_boundary_valid:
  assumes "(k,\<gamma>)\<in>boundary circle_cube"
  shows "valid_path \<gamma>"
proof -
  have f01: "finite{0,1}"
    by simp
  show ?thesis
    using assms
    unfolding boundary_def horizontal_boundary_def vertical_boundary_def circle_cube_def valid_path_def piecewise_C1_differentiable_on_def
    by safe (rule derivative_intros continuous_intros f01 exI ballI conjI refl | force simp add: field_simps)+
qed

lemma rot_circle_cube_boundary_valid:
  assumes "(k,\<gamma>)\<in>boundary rot_circle_cube"
  shows "valid_path \<gamma>"
  using assms swap_valid_boundaries circle_cube_boundary_valid
  by (fastforce simp add: rot_circle_cube_def)

lemma diff_divide_cancel:
  fixes z::real shows  "z \<noteq> 0  \<Longrightarrow> (a * z - a * (b * z)) / z = (a - a * b)"
  by (auto simp: field_simps)

lemma circle_cube_is_type_I:
  assumes "0 < d"
  shows "typeI_twoCube circle_cube"
  unfolding typeI_twoCube_def
proof (intro exI conjI ballI)
  have f01: "finite{-d/2,d/2}"
    by simp
  show "-d/2 < d/2"
    using assms by simp
  show "(\<lambda>x. d * sqrt (1/4 - (x/d) * (x/d))) piecewise_C1_differentiable_on {- d/2..d/2}"
    using assms unfolding piecewise_C1_differentiable_on_def
    apply (intro exI conjI)
      apply (rule ballI refl f01 derivative_intros continuous_intros | simp)+
    apply (auto simp: field_simps)
    by sos
   show "(\<lambda>x. -d * sqrt (1/4 - (x/d) * (x/d))) piecewise_C1_differentiable_on {- d/2..d/2}"
    using assms unfolding piecewise_C1_differentiable_on_def
    apply (intro exI conjI)
       apply (rule ballI refl f01 derivative_intros continuous_intros | simp)+
    apply (auto simp: field_simps)
    by sos
  show "- d * sqrt (1/4 - x / d * (x / d)) \<le> d * sqrt (1/4 - x / d * (x / d))"
    if "x \<in> {- d/2..d/2}" for x
  proof -
    have *: "x^2 \<le> (d/2)^2"
      using real_sqrt_le_iff that by fastforce
    show ?thesis
      apply (rule mult_right_mono)
      using assms * apply (simp_all add: divide_simps power2_eq_square)
      done
  qed
qed (auto simp add: circle_cube_def divide_simps algebra_simps diff_divide_cancel)

lemma rot_circle_cube_is_type_II:
  shows "typeII_twoCube rot_circle_cube"
  using d_gt_0 swap_typeI_is_typeII circle_cube_is_type_I
  by (auto simp add: rot_circle_cube_def)

definition circle_bot_edge where
  "circle_bot_edge = (1::int, \<lambda>t. (x_coord t * d, - d * circle_y (x_coord t)))"

definition circle_top_edge where
  "circle_top_edge = (- 1::int, \<lambda>t. (x_coord t * d, d * circle_y (x_coord t)))"

definition circle_right_edge where
  "circle_right_edge = (1::int, \<lambda>y. (d/2, 0))"

definition circle_left_edge where
  "circle_left_edge = (- 1::int, \<lambda>y. (- (d/2), 0))"

lemma circle_cube_boundary_explicit:
    "boundary circle_cube = {circle_left_edge,circle_right_edge,circle_bot_edge,circle_top_edge}"
  by (auto simp add: valid_two_cube_def boundary_def horizontal_boundary_def vertical_boundary_def circle_cube_def
      circle_top_edge_def circle_bot_edge_def circle_cube_nice x_coord_def circle_y_def
      circle_left_edge_def circle_right_edge_def)

definition rot_circle_right_edge where
  "rot_circle_right_edge = (1::int, \<lambda>t. (d * circle_y (x_coord t), x_coord t * d))"

definition rot_circle_left_edge where
  "rot_circle_left_edge = (- 1::int, \<lambda>t. (- d * circle_y (x_coord t), x_coord t * d))"

definition rot_circle_top_edge where
  "rot_circle_top_edge = (- 1::int, \<lambda>y. (0, d/2))"

definition rot_circle_bot_edge where
  "rot_circle_bot_edge = (1::int, \<lambda>y. (0, - (d/2)))"

lemma rot_circle_cube_boundary_explicit:
    "boundary (rot_circle_cube) =
           {rot_circle_top_edge,rot_circle_bot_edge,rot_circle_right_edge,rot_circle_left_edge}"
  by (auto simp add: rot_circle_cube_def valid_two_cube_def boundary_def horizontal_boundary_def vertical_boundary_def circle_cube_def
      rot_circle_right_edge_def rot_circle_left_edge_def x_coord_def circle_y_def rot_circle_top_edge_def rot_circle_bot_edge_def)

lemma rot_circle_cube_vertical_boundary_explicit:
    "vertical_boundary rot_circle_cube = {rot_circle_right_edge,rot_circle_left_edge}"
  by (auto simp add: rot_circle_cube_def valid_two_cube_def vertical_boundary_def circle_cube_def
      rot_circle_right_edge_def rot_circle_left_edge_def x_coord_def circle_y_def)

lemma circ_left_edge_neq_top:
   "(- 1::int, \<lambda>y::real. (- (d/2), 0)) \<noteq> (- 1, \<lambda>x. ((x - 1/2) * d, d * sqrt (1/4 - (x - 1/2) * (x - 1/2))))"
  by (metis (no_types, lifting) add_diff_cancel_right' d_gt_0 mult.commute mult_cancel_left order_less_irrefl prod.inject)

lemma circle_cube_valid_two_cube: "valid_two_cube (circle_cube)"
proof (auto simp add: valid_two_cube_def boundary_def horizontal_boundary_def vertical_boundary_def circle_cube_def)
  have iv: "(- 1::int, \<lambda>y::real. (- (d/2), 0)) \<noteq> (- 1, \<lambda>x. ((x - 1/2) * d, d * sqrt (1/4 - (x - 1/2) * (x - 1/2))))"
    using d_gt_0  apply (auto simp add: algebra_simps)
    by (metis (no_types, hide_lams) add_diff_cancel_right' add_uminus_conv_diff cancel_comm_monoid_add_class.diff_cancel less_eq_real_def linorder_not_le mult.left_neutral prod.simps(1))
  have v: "(1::int, \<lambda>y. (d/2, 0)) \<noteq> (1, \<lambda>x. ((x - 1/2) * d, - (d * sqrt (1/4 - (x - 1/2) * (x - 1/2)))))"
    using d_gt_0  apply (auto simp add: algebra_simps)
    by (metis (no_types, hide_lams) diff_0 equal_neg_zero mult_zero_left nonzero_mult_div_cancel_left order_less_irrefl prod.sel(1) times_divide_eq_right zero_neq_numeral)
  show " card {(- 1::int, \<lambda>y. (- (d/2), 0)), (1, \<lambda>y. (d/2, 0)), (1, \<lambda>x. ((x - 1/2) * d, - (d * sqrt (1/4 - (x - 1/2) * (x - 1/2))))),
                   (- 1, \<lambda>x. ((x - 1/2) * d, d * sqrt (1/4 - (x - 1/2) * (x - 1/2))))} = 4"
    using iv v by auto
qed

lemma rot_circle_cube_valid_two_cube:
  shows "valid_two_cube rot_circle_cube"
  using valid_cube_valid_swap circle_cube_valid_two_cube d_gt_0 rot_circle_cube_def
  by force

definition circle_arc_0 where "circle_arc_0 = (1, \<lambda>t::real. (0,0))"

lemma circle_top_bot_edges_neq' [simp]:
  shows "circle_top_edge \<noteq> circle_bot_edge"
  by (simp add: circle_top_edge_def circle_bot_edge_def)

lemma rot_circle_top_left_edges_neq [simp]: "rot_circle_top_edge \<noteq> rot_circle_left_edge"
  apply (simp add: rot_circle_left_edge_def rot_circle_top_edge_def x_coord_def)
  by (metis (mono_tags, hide_lams) cancel_comm_monoid_add_class.diff_cancel d_gt_0 divide_eq_0_iff mult_zero_left order_less_irrefl prod.sel(2) zero_neq_numeral)

lemma rot_circle_bot_left_edges_neq [simp]: "rot_circle_bot_edge \<noteq> rot_circle_left_edge"
  by (simp add: rot_circle_left_edge_def rot_circle_bot_edge_def x_coord_def)

lemma rot_circle_top_right_edges_neq [simp]: "rot_circle_top_edge \<noteq> rot_circle_right_edge"
  by (simp add: rot_circle_right_edge_def rot_circle_top_edge_def x_coord_def)

lemma rot_circle_bot_right_edges_neq [simp]: "rot_circle_bot_edge \<noteq> rot_circle_right_edge"
  apply (simp add: rot_circle_right_edge_def rot_circle_bot_edge_def x_coord_def)
  by (metis (mono_tags, hide_lams) cancel_comm_monoid_add_class.diff_cancel d_gt_0 divide_eq_0_iff mult_zero_left neg_0_equal_iff_equal order_less_irrefl prod.sel(2) zero_neq_numeral)

lemma rot_circle_right_top_edges_neq' [simp]: "rot_circle_right_edge \<noteq> rot_circle_left_edge"
  by (simp add: rot_circle_left_edge_def rot_circle_right_edge_def)

lemma rot_circle_left_bot_edges_neq [simp]: "rot_circle_left_edge \<noteq> rot_circle_top_edge"
  apply (simp add: rot_circle_top_edge_def rot_circle_left_edge_def)
  by (metis (no_types, hide_lams) cancel_comm_monoid_add_class.diff_cancel d_gt_0 mult.commute mult_zero_right nonzero_mult_div_cancel_left order_less_irrefl prod.sel(2) times_divide_eq_right x_coord_def zero_neq_numeral)

lemma circle_right_top_edges_neq [simp]: "circle_right_edge \<noteq> circle_top_edge"
proof -
  have "circle_right_edge = (1, (\<lambda>r::real. (d / 2, 0::real)))"
    using circle.circle_right_edge_def circle_axioms by blast
  then show ?thesis
    using circle.circle_top_edge_def circle_axioms by auto
qed

lemma circle_left_bot_edges_neq [simp]: "circle_left_edge \<noteq> circle_bot_edge"
proof -
  have "circle_bot_edge = (1, \<lambda>r. (x_coord r * d, - d * circle_y (x_coord r)))"
    using circle.circle_bot_edge_def circle_axioms by blast
  then show ?thesis
    by (simp add: circle_left_edge_def)
qed

lemma circle_left_top_edges_neq [simp]: "circle_left_edge \<noteq> circle_top_edge"
proof -
  have "\<exists>r. ((r - 1 / 2) * d, d * sqrt (1 / 4 - (r - 1 / 2) * (r - 1 / 2))) \<noteq> (- (d / 2), 0)"
    by (metis circ_left_edge_neq_top)
  then have "(\<exists>r. d * r \<noteq> - (d / 2)) \<or> (\<exists>r ra. (x_coord (x_coord_inv r) * d, d * circle_y (x_coord (x_coord_inv r))) = (x_coord ra * d, d * circle_y (x_coord ra)) \<and> d * circle_y r \<noteq> 0)"
    by (metis mult.commute)
  then have "(\<lambda>r. (x_coord r * d, d * circle_y (x_coord r))) \<noteq> (\<lambda>r. (- (d / 2), 0))"
    by (metis mult.commute prod.simps(1) x_coord_inv_2)
  then show ?thesis
    by (simp add: circle_left_edge_def circle_top_edge_def)
qed

lemma circle_right_bot_edges_neq [simp]: "circle_right_edge \<noteq> circle_bot_edge"
  by (smt Pair_inject circle_bot_edge_def d_gt_0 circle.circle_right_edge_def circle_axioms real_mult_le_cancel_iff1 x_coord_def)

definition circle_polar where
  "circle_polar t = ((d/2)  * cos (2 * pi * t), (d/2) * sin (2 * pi * t))"

lemma circle_polar_smooth: "(circle_polar) C1_differentiable_on {0..1}"
proof -
  have "inj ((*) (2 * pi))"
    by (auto simp: inj_on_def)
  then have *: "\<And>x. finite ({0..1} \<inter> (*) (2 * pi) -` {x})"
    by (simp add: finite_vimageI)
  have "(\<lambda>t. ((d/2)  * cos (2 * pi * t), (d/2) * sin (2 * pi * t))) C1_differentiable_on {0..1}"
    by (rule * derivative_intros)+
  then show ?thesis
    apply (rule eq_smooth_gen)
    by(simp add: circle_polar_def)
qed

abbreviation "custom_arccos \<equiv> (\<lambda>x. (if -1 \<le> x \<and> x \<le> 1 then arccos x else (if x < -1 then -x + pi else 1 -x )))"

lemma cont_custom_arccos:
  assumes "S \<subseteq> {-1..1}"
  shows "continuous_on S custom_arccos"
proof -
  have "continuous_on ({-1..1} \<union> {}) custom_arccos"
    by (auto intro!: continuous_on_cases continuous_intros)
  with assms show ?thesis
    using continuous_on_subset by auto
qed

lemma custom_arccos_has_deriv:
  assumes "- 1 < x" "x < 1"
  shows "DERIV custom_arccos x :> inverse (- sqrt (1 - x\<^sup>2))"
proof -
  have x1: "\<bar>x\<bar>\<^sup>2 < 1\<^sup>2"
    by (simp add: abs_less_iff abs_square_less_1 assms)
  show ?thesis
    apply (rule DERIV_inverse_function [where f=cos and a="-1" and b=1])
         apply (rule x1 derivative_eq_intros | simp add: sin_arccos)+
    using assms x1 cont_custom_arccos [of "{-1<..<1}"]
         apply (auto simp: continuous_on_eq_continuous_at greaterThanLessThan_subseteq_atLeastAtMost_iff)
    done
qed

declare
  custom_arccos_has_deriv[THEN DERIV_chain2, derivative_intros]
  custom_arccos_has_deriv[THEN DERIV_chain2, unfolded has_field_derivative_def, derivative_intros]

lemma circle_boundary_reparams:
  shows rot_circ_left_edge_reparam_polar_circ_split:
    "reparam (rec_join [(rot_circle_left_edge)]) (rec_join [(subcube (1/4) (1/2) (1, circle_polar)), (subcube (1/2) (3/4) (1, circle_polar))])"
    (is ?P1)
    and circ_top_edge_reparam_polar_circ_split:
    "reparam (rec_join [(circle_top_edge)]) (rec_join [(subcube 0 (1/4) (1, circle_polar)), (subcube (1/4) (1/2) (1, circle_polar))])"
    (is ?P2)
    and circ_bot_edge_reparam_polar_circ_split:
    "reparam (rec_join [(circle_bot_edge)]) (rec_join [(subcube (1/2) (3/4) (1, circle_polar)), (subcube (3/4) 1 (1, circle_polar))])"
    (is ?P3)
    and rot_circ_right_edge_reparam_polar_circ_split:
    "reparam (rec_join [(rot_circle_right_edge)]) (rec_join [(subcube (3/4) 1 (1, circle_polar)), (subcube 0 (1/4) (1, circle_polar))])"
    (is ?P4)
proof -
  let ?\<phi> = "((*) (1/pi) \<circ> custom_arccos \<circ> (\<lambda>t. 2 * x_coord (1 - t)))"
  let ?LHS1 = "(\<lambda>x. (- (d * sqrt (1/4 - x_coord (1 - x) * x_coord (1 - x))), x_coord (1 - x) * d))"
  let ?RHS1 = "((\<lambda>x. if x * 2 \<le> 1 then (d * cos (2 * pi * (2 * x/4 + 1/4))/2, d * sin (2 * pi * (2 * x/4 + 1/4))/2)
                        else (d * cos (2 * pi * ((2 * x - 1)/4 + 1/2))/2, d * sin (2 * pi * ((2 * x - 1)/4 + 1/2))/2)) \<circ> ?\<phi>)"
  let ?LHS2 = "\<lambda>x. ((x_coord (1 - x) * d, d * sqrt (1/4 - x_coord (1 - x) * x_coord (1 - x))))"
  let ?RHS2 = "((\<lambda>x. if x * 2 \<le> 1 then (d * cos (2 * x * pi/2)/2, d * sin (2 * x * pi/2)/2) else (d * cos (2 * pi * ((2 * x - 1)/4 + 1/4))/2, d * sin (2 * pi * ((2 * x - 1)/4 + 1/4))/2)) \<circ> ?\<phi>)"
  let ?LHS3 = "\<lambda>x. (x_coord x * d, - (d * sqrt (1/4 - x_coord x * x_coord x)))"
  let ?RHS3 = "(\<lambda>x. if x * 2 \<le> 1 then (d * cos (2 * pi * (2 * x/4 + 1/2))/2, d * sin (2 * pi * (2 * x/4 + 1/2))/2)
                  else (d * cos (2 * pi * ((2 * x - 1)/4 + 3/4))/2, d * sin (2 * pi * ((2 * x - 1)/4 + 3/4))/2))"
  let ?LHS4 = "\<lambda>x. (d * sqrt (1/4 - x_coord x * x_coord x), x_coord x * d)"
  let ?RHS4 = "(\<lambda>x. if x * 2 \<le> 1 then (d * cos (2 * pi * (2 * x/4 + 3/4))/2, d * sin (2 * pi * (2 * x/4 + 3/4))/2)
                 else (d * cos ((2 * x - 1) * pi/2)/2, d * sin ((2 * x - 1) * pi/2)/2))"
  have phi_diff: "?\<phi> piecewise_C1_differentiable_on {0..1}"
    unfolding piecewise_C1_differentiable_on_def
  proof
    show "continuous_on {0..1} ?\<phi>"
      unfolding x_coord_def
      by (intro continuous_on_compose cont_custom_arccos continuous_intros) auto
    have "?\<phi> C1_differentiable_on {0..1} - {0,1}"
      unfolding x_coord_def piecewise_C1_differentiable_on_def C1_differentiable_on_def valid_path_def
      by (simp | rule has_vector_derivative_pair_within DERIV_image_chain derivative_eq_intros continuous_intros exI ballI conjI
          | force simp add: field_simps | sos)+
    then show "\<exists>s. finite s \<and> ?\<phi> C1_differentiable_on {0..1} - s"
      by force
  qed
  have inj: "inj ?\<phi>"
    apply (intro comp_inj_on inj_on_cases inj_on_arccos)
          apply (auto simp add: inj_on_def x_coord_def)
    using pi_ge_zero apply auto[1]
     apply (smt arccos)
    by (smt arccos_lbound)
  then have fin: "\<And>x. \<lbrakk>0 \<le> x; x \<le> 1\<rbrakk> \<Longrightarrow> finite (?\<phi> -` {x})"
    by (simp add: finite_vimageI)
  have "?\<phi> ` {0..1} = {0..1}"
  proof
    show "?\<phi> ` {0..1} \<subseteq> {0..1}"
      by (auto simp add: x_coord_def divide_simps arccos_lbound arccos_bounded)
    have "arccos (1 - 2 * ((1 - cos (x * pi))/2)) = x * pi" if "0 \<le> x" "x \<le> 1" for x
      using that by (simp add: field_simps arccos_cos)
    then show "{0..1} \<subseteq> ?\<phi> ` {0..1}"
      apply (auto simp: x_coord_def o_def image_def)
      by (rule_tac x="(1 - cos (x * pi))/2" in bexI) auto
  qed
  then have bij_phi: "bij_betw ?\<phi> {0..1} {0..1}"
    unfolding bij_betw_def using inj inj_on_subset by blast
  have phi01: "?\<phi> -` {0..1} \<subseteq> {0..1}"
    by (auto simp add: subset_iff x_coord_def divide_simps)
  {
    fix x::real assume x: "0 \<le> x" "x \<le> 1"
    then have i: "- 1 \<le> (2 * x - 1)" "(2 * x - 1) \<le> 1"  by auto
    have ii: "cos (pi / 2 + arccos (1 - x * 2)) = -sin (arccos (1 - x * 2))"
      using minus_sin_cos_eq[symmetric, where ?x = "arccos (1 - x * 2)"]
      by (auto simp add: add.commute)
    have "2 * sqrt (x - x * x) = sqrt (4*x - 4*x * x)"
      by (metis mult.assoc real_sqrt_four real_sqrt_mult right_diff_distrib)
    also have "... = sqrt (1  - (2 * x - 1) * (2 * x - 1))"
      by (simp add: algebra_simps)
    finally have iii: "2 * sqrt (x - x * x) = cos (arcsin (2 * x - 1)) \<and> 2 * sqrt (x - x * x) =  sin (arccos (1 - 2 * x))"
      using arccos_minus[OF i]  unfolding minus_diff_eq sin_pi_minus
      by (simp add: cos_arcsin i power2_eq_square sin_arccos)
    then have 1: "?LHS1 x = ?RHS1 x"
      using d_gt_0 i x apply (simp add: x_coord_def field_simps)
      apply (auto simp add: diff_divide_distrib add_divide_distrib right_diff_distrib mult.commute ii)
      using cos_sin_eq[where ?x = "- arccos (1 - x * 2)"]
      by (simp add: cos_sin_eq[where ?x = "- arccos (1 - x * 2)"] right_diff_distrib)
    have 2: "?LHS2 x = ?RHS2 x"
      using x d_gt_0 iii by (auto simp add: x_coord_def diff_divide_distrib algebra_simps)
    have a: "cos (pi / 2 - arccos (x * 2 - 1)) = cos (pi / 2 - arccos (1 - x * 2))"
      by (smt arccos_minus arccos_cos2 arccos_lbound cos_arccos cos_ge_minus_one cos_le_one i(1) i(2) pi_def pi_half)
    have b: "cos (arccos (1 - x * 2) + pi * 3 / 2) = cos ((pi / 2 - arccos (x * 2 - 1)) + 2 * pi)"
      using arccos_minus[OF i]  by(auto simp add: mult.commute add.commute)
    then have c: "... = cos (pi / 2 - arccos (x * 2 - 1))" using cos_periodic by blast
    have "cos (- pi - arccos (1 - x * 2)) = cos (- (pi + arccos (1 - x * 2)))"
      by (auto simp add: minus_add[where b = "pi" and a = "arccos (1 - x * 2)", symmetric])
    moreover have "... = cos ((pi + arccos (1 - x * 2)))"
      using cos_minus by blast
    moreover have "... = cos (2*pi - arccos (x * 2 - 1))"
      using arccos_minus[OF i]  by (auto simp add: mult.commute add.commute)
    moreover have "... = cos (arccos (x * 2 - 1))"
      using cos_2pi_minus by auto
    ultimately have d: "cos (- pi - arccos (1 - x * 2)) = (x * 2 - 1)"
      using cos_arccos[OF i] mult.commute by metis
    have cosm: "\<And>x. cos (x - pi*2) = cos x"
      by (metis cos_periodic eq_diff_eq' mult.commute)
    have 34: "?LHS3 x = (?RHS3  \<circ> ?\<phi>) x"  "?LHS4 x = (?RHS4 \<circ> ?\<phi>) x"
      using d_gt_0 x a b c iii cos_periodic [of "pi / 2 - arccos (x * 2 - 1)"]
       apply (auto simp add: x_coord_def algebra_simps diff_divide_distrib power2_eq_square)
       apply (auto simp add: sin_cos_eq cosm)
      using d apply (auto simp add: right_diff_distrib)
      by (smt cos_minus)
    note 1 2 34
  } note * = this
  show ?P1 ?P2 ?P3 ?P4
       apply (auto simp add: subcube_def circle_bot_edge_def circle_top_edge_def circle_polar_def reversepath_def
               subpath_def joinpaths_def circle_y_def rot_circle_left_edge_def rot_circle_right_edge_def)
    unfolding reparam_def
    by (rule ballI exI conjI impI phi_diff bij_phi phi01 fin * | force simp add: x_coord_def)+
qed

definition circle_cube_boundary_to_polarcircle where
  "circle_cube_boundary_to_polarcircle \<gamma> \<equiv>
     if (\<gamma> = (circle_top_edge)) then
           {subcube 0 (1/4) (1, circle_polar), subcube (1/4) (1/2) (1, circle_polar)}
     else if (\<gamma> = (circle_bot_edge)) then
           {subcube (1/2) (3/4) (1, circle_polar), subcube (3/4) 1 (1, circle_polar)}
     else {}"

definition rot_circle_cube_boundary_to_polarcircle where
  "rot_circle_cube_boundary_to_polarcircle \<gamma> \<equiv>
     if (\<gamma> = (rot_circle_left_edge )) then
           {subcube (1/4)  (1/2) (1, circle_polar), subcube (1/2) (3/4) (1, circle_polar)}
     else if (\<gamma> = (rot_circle_right_edge)) then
           {subcube (3/4) 1 (1, circle_polar), subcube 0 (1/4) (1, circle_polar)}
     else {}"

lemma circle_arcs_neq:
  assumes "0 \<le> k" "k \<le> 1" "0 \<le> n" "n \<le> 1" "n < k" "k + n < 1"
  shows "subcube k m (1, circle_polar) \<noteq> subcube n q (1, circle_polar)"
proof (simp add: subcube_def subpath_def circle_polar_def)
  have "cos (2 * pi * k) \<noteq> cos(2 * pi * n)"
    unfolding cos_eq
  proof safe
    show False if "2 * pi * k = 2 * pi * n + 2 * m * pi" "m \<in> \<int>" for m
    proof -
      have "2 * pi * (k - n ) = 2 * m * pi"
        using distrib_left that by (simp add: left_diff_distrib mult.commute)
      then have a: "m = (k - n)" by auto
      have "\<lfloor>k - n\<rfloor> = 0 "
        using assms by (simp add: floor_eq_iff)
      then have "k - n \<notin> \<int>"
        using assms by (auto simp only: frac_eq_0_iff[symmetric] frac_def)
      then show False using that a by auto
    qed
    show False if "2 * pi * k = - (2 * pi * n) + 2 * m * pi" "m \<in> \<int>" for m
    proof -
      have "2 * pi * (k + n ) = 2 * m * pi"
        using that by (auto simp add: distrib_left)
      then have a: "m = (k + n)" by auto
      have "\<lfloor>k + n\<rfloor> = 0 "
        using assms by (simp add: floor_eq_iff)
      then have "k + n \<notin> \<int>"
        using Ints_def assms by force
      then show False using that a by auto
    qed
  qed
  then have "(\<lambda>x. (d * cos (2 * pi * ((m - k) * x + k))/2, d * sin (2 * pi * ((m - k) * x + k))/2)) 0  \<noteq> (\<lambda>x. (d * cos (2 * pi * ((q - n) * x + n))/2, d * sin (2 * pi * ((q - n) * x + n))/2)) 0"
    using d_gt_0 by auto
  then show "(\<lambda>x. (d * cos (2 * pi * ((m - k) * x + k))/2, d * sin (2 * pi * ((m - k) * x + k))/2)) \<noteq> (\<lambda>x. (d * cos (2 * pi * ((q - n) * x + n))/2, d * sin (2 * pi * ((q - n) * x + n))/2))"
    by metis
qed

lemma circle_arcs_neq_2:
  assumes "0 \<le> k" "k \<le> 1" "0 \<le> n" "n \<le> 1" "n < k" "0 < n" and kn12: "1/2 < k + n" and "k + n < 3/2"
  shows "subcube k m (1, circle_polar) \<noteq> subcube n q (1, circle_polar)"
proof (simp add: subcube_def subpath_def circle_polar_def)
  have "sin (2 * pi * k) \<noteq> sin(2 * pi * n)"
    unfolding sin_eq
  proof safe
    show False if "m \<in> \<int>" "2 * pi * k = 2 * pi * n + 2 * m * pi" for m
    proof -
      have "2 * pi * (k - n) = 2 * m * pi"
        using that by (simp add: left_diff_distrib mult.commute)
      then have a: "m = (k - n)" by auto
      have "\<lfloor>k - n\<rfloor> = 0 "
        using assms by (simp add: floor_eq_iff)
      then have "k - n \<notin>  \<int>"
        using assms by (auto simp only: frac_eq_0_iff[symmetric] frac_def )
      then show False using that a by auto
    qed
    show False if "2 * pi * k = - (2 * pi * n) + (2 * m + 1) * pi" "m \<in> \<int>" for m
    proof -
      have i: "\<And>pi. 0 < pi \<Longrightarrow> 2 * pi * (k + n ) = 2 * m * pi + pi \<Longrightarrow> m = (k + n) - 1/2"
        by (sos "(((((A<0 * A<1) * R<1) + ([1/2] * A=0))) & ((((A<0 * A<1) * R<1) + ([~1/2] * A=0))))")
      have "2 * pi * (k + n) = 2 * m * pi + pi"
        using that by (simp add: algebra_simps)
      then have a: "m = (k + n) - 1/2" using i[OF pi_gt_zero] by fastforce
      have "\<lfloor>k + n - 1/2\<rfloor> = 0 "
        using assms by (auto simp add: floor_eq_iff)
      then have "k + n - 1/2 \<notin> \<int>"
        by (metis Ints_cases add.commute add.left_neutral add_diff_cancel_left' add_diff_eq kn12 floor_of_int of_int_0 order_less_irrefl)
      then show False using that a by auto
    qed
  qed
  then have "(\<lambda>x. (d * cos (2 * pi * ((m - k) * x + k))/2, d * sin (2 * pi * ((m - k) * x + k))/2)) 0  \<noteq> (\<lambda>x. (d * cos (2 * pi * ((q - n) * x + n))/2, d * sin (2 * pi * ((q - n) * x + n))/2)) 0"
    using d_gt_0 by auto
  then show "(\<lambda>x. (d * cos (2 * pi * ((m - k) * x + k))/2, d * sin (2 * pi * ((m - k) * x + k))/2)) \<noteq> (\<lambda>x. (d * cos (2 * pi * ((q - n) * x + n))/2, d * sin (2 * pi * ((q - n) * x + n))/2))"
    by metis
qed

lemma circle_cube_is_only_horizontal_div_of_rot:
  shows "only_horizontal_division (boundary (circle_cube)) {rot_circle_cube}"
  unfolding only_horizontal_division_def
proof (rule exI [of _ "{}"], simp, intro conjI ballI)
  show "finite (boundary circle_cube)"
    using circle.circle_cube_boundary_explicit circle_axioms by auto
  show "boundary_chain (boundary circle_cube)"
    by (simp add: two_cube_boundary_is_boundary)
  show "\<And>x. x \<in> boundary circle_cube \<Longrightarrow> case x of (k, x) \<Rightarrow> valid_path x"
    using circle_cube_boundary_valid by blast
  let ?\<V> = "(boundary (circle_cube))"
  let ?pi = "{circle_left_edge, circle_right_edge}"
  let ?pj = "{rot_circle_top_edge, rot_circle_bot_edge}"
  let ?f = "circle_cube_boundary_to_polarcircle"
  let ?one_chaini = "boundary (circle_cube) - ?pi"
  have c: "common_reparam_exists ?\<V> (two_chain_vertical_boundary {rot_circle_cube})"
    unfolding common_reparam_exists_def
  proof (intro exI conjI)
    let ?subdiv = "{(subcube 0 (1/4) (1, circle_polar)),
                    (subcube (1/4) (1/2) (1, circle_polar)),
                    (subcube (1/2) (3/4) (1, circle_polar)),
                    (subcube (3/4) 1 (1, circle_polar))}"
    show "(\<forall>(k, \<gamma>)\<in>?subdiv. \<gamma> C1_differentiable_on {0..1})"
      using subpath_smooth[OF circle_polar_smooth] by (auto simp add: subcube_def)
    have 1: "finite ?subdiv" by auto
    show "boundary_chain ?subdiv"
      by (simp add: boundary_chain_def subcube_def)
    show "chain_reparam_chain' (boundary (circle_cube) - ?pi) ?subdiv"
      unfolding chain_reparam_chain'_def
    proof (intro exI conjI impI)
      show "\<Union> (?f ` ?one_chaini) = ?subdiv"
        apply (simp add: circle_cube_boundary_to_polarcircle_def circle_cube_boundary_explicit)
        using circle_top_bot_edges_neq' by metis
        let ?l = "[subcube 0 (1/4) (1, circle_polar), subcube (1/4) (1/2) (1, circle_polar)]"
      have "chain_reparam_weak_path (coeff_cube_to_path (circle_top_edge)) {subcube 0 (1/4) (1, circle_polar), subcube (1/4) (1/2) (1, circle_polar)}"
        unfolding chain_reparam_weak_path_def
      proof (intro exI conjI)
        show "valid_chain_list ?l"
          by (auto simp add: subcube_def circle_top_edge_def  x_coord_def circle_y_def pathfinish_def pathstart_def
              reversepath_def subpath_def joinpaths_def)
        show "reparam (coeff_cube_to_path circle_top_edge) (rec_join ?l)"
          using circ_top_edge_reparam_polar_circ_split by auto
        show "distinct ?l"
            apply simp
            apply (subst neq_commute)
            apply (simp add: circle_arcs_neq)
            done
      qed auto
      moreover have "chain_reparam_weak_path (coeff_cube_to_path (circle_bot_edge)) {subcube (1/2) (3/4) (1, circle_polar), subcube (3/4) 1 (1, circle_polar)}"
        unfolding chain_reparam_weak_path_def
      proof
        let ?l = "[subcube (1/2) (3/4) (1, circle_polar), subcube (3/4) 1 (1, circle_polar)]"
        have a: "valid_chain_list ?l"
          by (auto simp add: subcube_def circle_top_edge_def  x_coord_def circle_y_def pathfinish_def pathstart_def
              reversepath_def subpath_def joinpaths_def)
        have b: "reparam (rec_join [circle_bot_edge]) (rec_join ?l)"
          using circ_bot_edge_reparam_polar_circ_split by auto
        have c: "subcube (3/4) 1 (1, circle_polar) \<noteq> subcube (1/2) (3/4) (1, circle_polar)"
          apply(rule circle_arcs_neq_2) using d_gt_0(1) by auto
        show "set ?l = {subcube (1/2) (3/4) (1, circle_polar), subcube (3/4) 1 (1, circle_polar)} \<and>
                            distinct ?l \<and> reparam (coeff_cube_to_path (circle_bot_edge)) (rec_join ?l) \<and> valid_chain_list ?l \<and> ?l \<noteq> []" using a b c by auto
      qed
      ultimately
      show "(\<forall>cube\<in>?one_chaini. chain_reparam_weak_path (rec_join [cube]) (?f cube))"
        by (auto simp add:  circle_cube_boundary_to_polarcircle_def UNION_eq circle_cube_boundary_explicit)
      show "(\<forall>p\<in>?one_chaini. \<forall>p'\<in>?one_chaini. p \<noteq> p' \<longrightarrow> ?f p \<inter> ?f p' = {})"
        using circle_arcs_neq circle_arcs_neq_2
        apply (auto simp add: circle_cube_boundary_to_polarcircle_def UNION_eq circle_cube_boundary_explicit neq_commute d_gt_0)
        using circle_top_bot_edges_neq' d_gt_0 apply auto[1]
          apply (smt atLeastAtMost_iff divide_less_eq_1_pos zero_less_divide_1_iff)
         apply (smt atLeastAtMost_iff divide_less_eq_1_pos zero_less_divide_iff)
        apply (smt atLeastAtMost_iff divide_cancel_left divide_less_eq_1_pos field_sum_of_halves zero_less_divide_1_iff)
        done
      show "(\<forall>x\<in>?one_chaini. finite (?f x))"
        by (auto simp add: circle_cube_boundary_to_polarcircle_def circle_cube_boundary_explicit)
    qed
    show "(\<forall>(k, \<gamma>)\<in>?pi. point_path \<gamma>)"
      using d_gt_0 by (auto simp add: point_path_def circle_left_edge_def circle_right_edge_def)
    let ?f = "rot_circle_cube_boundary_to_polarcircle"
    let ?one_chain2.0 = "two_chain_vertical_boundary {rot_circle_cube} - ?pj"
    show "chain_reparam_chain' (two_chain_vertical_boundary {rot_circle_cube} - ?pj) ?subdiv"
      unfolding chain_reparam_chain'_def
    proof (intro exI conjI)
      have rw: "?one_chain2.0 = {rot_circle_left_edge, rot_circle_right_edge}"
        by(auto simp add: rot_circle_cube_vertical_boundary_explicit two_chain_vertical_boundary_def)
      show "\<Union> (?f ` ?one_chain2.0) = ?subdiv"
        using rot_circle_right_top_edges_neq'
        by (auto simp add: rot_circle_cube_boundary_to_polarcircle_def rw)
      show "(\<forall>cube\<in>?one_chain2.0. chain_reparam_weak_path (rec_join [cube]) (?f cube))"
      proof (clarsimp simp add: rot_circle_cube_boundary_to_polarcircle_def rw, intro conjI)
        let ?l = "[subcube (1/4) (1/2) (1, circle_polar), subcube (1/2) (3/4) (1, circle_polar)]"
        show "chain_reparam_weak_path (coeff_cube_to_path (rot_circle_left_edge)) {subcube (1/4) (1/2) (1, circle_polar), subcube (1/2) (3/4) (1, circle_polar)}"
          unfolding chain_reparam_weak_path_def
        proof (intro exI conjI)
          show "valid_chain_list ?l"
            by (auto simp add: subcube_def pathfinish_def pathstart_def reversepath_def subpath_def joinpaths_def)
          show "reparam (coeff_cube_to_path rot_circle_left_edge) (rec_join ?l)"
            using rot_circ_left_edge_reparam_polar_circ_split by auto
          show "distinct ?l"
            apply simp
            apply (subst neq_commute)
            apply (simp add: circle_arcs_neq)
            done
        qed auto
        show "chain_reparam_weak_path (coeff_cube_to_path (rot_circle_right_edge)) {subcube (3/4) 1 (1, circle_polar), subcube 0 (1/4) (1, circle_polar)}"
          unfolding chain_reparam_weak_path_def
        proof (intro exI conjI)
          let ?l = "[subcube (3/4) 1 (1, circle_polar), subcube 0 (1/4) (1, circle_polar)]"
          show "valid_chain_list ?l"
            by  (auto simp add: circle_polar_def subcube_def pathfinish_def pathstart_def
                reversepath_def subpath_def joinpaths_def)
          show "reparam (coeff_cube_to_path rot_circle_right_edge) (rec_join ?l)"
            using rot_circ_right_edge_reparam_polar_circ_split by auto
          show "distinct ?l"
            by (simp add: circle_arcs_neq)
        qed auto
      qed
      show "(\<forall>p\<in>?one_chain2.0. \<forall>p'\<in>?one_chain2.0. p \<noteq> p' \<longrightarrow> ?f p \<inter> ?f p' = {})"
        using circle_arcs_neq circle_arcs_neq_2
        apply (auto simp add: rot_circle_cube_boundary_to_polarcircle_def neq_commute)
         apply (metis add.right_neutral divide_less_eq_1_pos dual_order.order_iff_strict num.distinct(1) one_less_numeral_iff prod.sel(1) prod.sel(2) semiring_norm(68) subcube_def zero_less_divide_1_iff zero_less_numeral)
        apply (smt field_sum_of_halves)
        done
      show "(\<forall>x\<in>?one_chain2.0. finite (?f x))"
        by (auto simp add: rot_circle_cube_boundary_to_polarcircle_def UNION_eq rw)
    qed
    show "(\<forall>(k, \<gamma>)\<in>?pj. point_path \<gamma>)"
      using d_gt_0 by (auto simp add: point_path_def rot_circle_top_edge_def rot_circle_bot_edge_def)
  qed
  then show "common_sudiv_exists (two_chain_vertical_boundary {rot_circle_cube}) (boundary circle_cube) \<or>
             common_reparam_exists (boundary circle_cube) (two_chain_vertical_boundary {rot_circle_cube})"
    by blast
qed

lemma GreenThm_cirlce:
  assumes "\<forall>twoC\<in>{circle_cube}. analytically_valid (cubeImage twoC) (\<lambda>x. F x \<bullet> i) j"
    "\<forall>twoC\<in>{rot_circle_cube}. analytically_valid (cubeImage twoC) (\<lambda>x. F x \<bullet> j) i"
  shows "integral (cubeImage (circle_cube)) (\<lambda>x. partial_vector_derivative (\<lambda>x. F x \<bullet> j) i x - partial_vector_derivative (\<lambda>x. F x \<bullet> i) j x) =
                     one_chain_line_integral F {i, j} (boundary (circle_cube))"
proof(rule green_typeI_typeII_chain.GreenThm_typeI_typeII_divisible_region_finite_holes[of "(cubeImage (circle_cube))" i j F "{circle_cube}" "{rot_circle_cube}",
                            OF _ _ _ circle_cube_is_only_horizontal_div_of_rot _], auto)
  show "\<And> a b. (a, b) \<in> boundary circle_cube \<Longrightarrow> valid_path b" using circle_cube_boundary_valid by auto
  show "green_typeI_typeII_chain (cubeImage circle_cube) i j F {circle_cube} {rot_circle_cube}"
    using assms
    proof(auto simp add: green_typeI_typeII_chain_def green_typeI_chain_def green_typeII_chain_def green_typeI_chain_axioms_def green_typeII_chain_axioms_def
               intro!: circle_cube_is_type_I rot_circle_cube_is_type_II d_gt_0 R2_axioms)
      show "gen_division (cubeImage circle_cube) {cubeImage circle_cube}" by (simp add: gen_division_def)
      show "gen_division (cubeImage (circle_cube)) ({cubeImage rot_circle_cube})"
        using rot_circle_div_circle d_gt_0 by auto
      show "valid_two_chain {rot_circle_cube}" "valid_two_chain {circle_cube}"
        apply (auto simp add: valid_two_chain_def)
        using rot_circle_cube_valid_two_cube circle_cube_valid_two_cube assms(1) by auto
    qed
  show "only_vertical_division (boundary (circle_cube)) {circle_cube}"
    using twoChainVertDiv_of_itself[of "{circle_cube}"]
    apply(simp add: two_chain_boundary_def)
    using circle_cube_boundary_valid
    by auto
qed
end
end


section \<open> Example of probabilistic relation programming: parallel composition \<close>

theory utp_prob_rel_lattice_parallel_examples
  imports
    "UTP_prob_relations.utp_prob_rel"
begin

unbundle UTP_Syntax

declare [[show_types]]

alphabet state1 =
  b :: \<bool>

lemma if_div_distrib: "(if a then (bb::\<real>) else c) / d = (if a then (bb / d) else (c /d))"
  by presburger

lemma if_div_distrib': "n * (if a then (bb::\<real>) else c) / d = (if a then (n * bb / d) else (n * c /d))"
  by presburger

text \<open>This example is from Hehner's paper "a Probability Perspective"
\cite[Sect.~Probabilistic programming]{Hehner2011} \<close>

lemma b_assign_rel: "((b := e)::state1 hrel) = (b\<^sup>> = e\<^sup><)\<^sub>e"
  apply (simp add: expr_defs assigns_r_def)
  by (pred_auto)

lemma r1_3: "(real_of_ereal (ureal2ereal (ereal2ureal' (min ((1::ereal) / ereal (3::\<real>)) (1::ereal))))) = 1/3"
  using ereal_1_div real2uereal_min_inverse' by auto

lemma "(((if\<^sub>p 1/3 then b := False else b := True) \<parallel> (if\<^sub>p 1/3 then b := (\<not> b) else II))::state1 prhfun) =
  prfun_of_rvfun ((5 - 3 * \<lbrakk>b\<^sup><\<rbrakk>\<^sub>\<I>\<^sub>e + 6 * \<lbrakk>b\<^sup>< \<and> b\<^sup>>\<rbrakk>\<^sub>\<I>\<^sub>e) / 10)\<^sub>e "
  apply (simp add: pparallel_pp_def)
  apply (simp add: prfun_skip[where x = "b"])
  apply (subst prfun_pchoice_assigns_inverse_c')
  apply (subst prfun_pchoice_assigns_inverse_c')
  apply (simp only: b_assign_rel)
  apply (simp only: pparallel_def)
  apply (simp add: expr_defs rel lens_defs prod.case_eq_if alpha_splits dist_defs)
  apply (rule HOL.arg_cong[where f="prfun_of_rvfun"])
  apply (simp add: ureal_defs r1_3)
  apply (subst fun_eq_iff, rule allI)
proof -
  fix x::"state1 \<times> state1"
  let ?sum = "(\<Sum>\<^sub>\<infinity>v\<^sub>0::state1.
          ((if \<not> b\<^sub>v v\<^sub>0 then 1::\<real> else (0::\<real>)) / (3::\<real>) +
           (2::\<real>) * (if b\<^sub>v v\<^sub>0 then 1::\<real> else (0::\<real>)) / (3::\<real>)) *
          ((if b\<^sub>v v\<^sub>0 = (\<not> b\<^sub>v (fst x)) then 1::\<real> else (0::\<real>)) / (3::\<real>) +
           (2::\<real>) * (if b\<^sub>v v\<^sub>0 = b\<^sub>v (fst x) then 1::\<real> else (0::\<real>)) / (3::\<real>)))"
  have card_1: "(card {s::state1. \<not> b\<^sub>v s \<and> b\<^sub>v s = (\<not> b\<^sub>v (fst x))})
    = (if b\<^sub>v (fst x) then 1 else 0)"
    apply (simp)
    by (smt (verit, ccfv_threshold) card_1_singleton state1.cases state1.select_convs(1))
  have card_2: "(card {s::state1. \<not> b\<^sub>v s \<and> b\<^sub>v s = b\<^sub>v (fst x)})
    = (if \<not>b\<^sub>v (fst x) then 1 else 0)"
    apply (auto)
    by (smt (verit) card_1_singleton state1.cases state1.select_convs(1) state1.update_convs(1))

  have card_3: "(card {s::state1. b\<^sub>v s \<and> b\<^sub>v s = (\<not> b\<^sub>v (fst x))})
    = (if \<not>b\<^sub>v (fst x) then 1 else 0)"
    apply (auto)
    by (smt (verit) card_1_singleton state1.cases state1.select_convs(1) state1.update_convs(1))

  have card_4: "(card {s::state1. b\<^sub>v s \<and> b\<^sub>v s = b\<^sub>v (fst x)})
    = (if b\<^sub>v (fst x) then 1 else 0)"
    apply (auto)
    by (smt (verit) card_1_singleton state1.cases state1.select_convs(1) state1.update_convs(1))

  have sum_1: "?sum = (\<Sum>\<^sub>\<infinity>v\<^sub>0::state1.
       (if \<not> b\<^sub>v v\<^sub>0 then 1::\<real> else (0::\<real>)) / (3::\<real>) *
       ((if b\<^sub>v v\<^sub>0 = (\<not> b\<^sub>v (fst x)) then 1::\<real> else (0::\<real>)) / (3::\<real>)) +
       (if \<not> b\<^sub>v v\<^sub>0 then 1::\<real> else (0::\<real>)) / (3::\<real>) *
       ((2::\<real>) * (if b\<^sub>v v\<^sub>0 = b\<^sub>v (fst x) then 1::\<real> else (0::\<real>)) / (3::\<real>)) +
       ((2::\<real>) * (if b\<^sub>v v\<^sub>0 then 1::\<real> else (0::\<real>)) / (3::\<real>) *
        ((if b\<^sub>v v\<^sub>0 = (\<not> b\<^sub>v (fst x)) then 1::\<real> else (0::\<real>)) / (3::\<real>)) +
        (2::\<real>) * (if b\<^sub>v v\<^sub>0 then 1::\<real> else (0::\<real>)) / (3::\<real>) *
        ((2::\<real>) * (if b\<^sub>v v\<^sub>0 = b\<^sub>v (fst x) then 1::\<real> else (0::\<real>)) / (3::\<real>))))"
    apply (simp only: ring_distribs(2))
    by (simp only: ring_distribs(1))
   also have sum_2: "... = (\<Sum>\<^sub>\<infinity>v\<^sub>0::state1.
          (if \<not> b\<^sub>v v\<^sub>0 then 1::\<real> else (0::\<real>)) *
             (if b\<^sub>v v\<^sub>0 = (\<not> b\<^sub>v (fst x)) then 1::\<real> else (0::\<real>)) / (9::\<real>) +
       (if \<not> b\<^sub>v v\<^sub>0 then 1::\<real> else (0::\<real>)) *
         (if b\<^sub>v v\<^sub>0 = b\<^sub>v (fst x) then 1::\<real> else (0::\<real>)) * ((2::\<real>) / (9::\<real>)) +
       ((if b\<^sub>v v\<^sub>0 then 1::\<real> else (0::\<real>)) *
         (if b\<^sub>v v\<^sub>0 = (\<not> b\<^sub>v (fst x)) then 1::\<real> else (0::\<real>)) * ((2::\<real>) / (9::\<real>))) +
       ((if b\<^sub>v v\<^sub>0 then 1::\<real> else (0::\<real>)) *
         (if b\<^sub>v v\<^sub>0 = b\<^sub>v (fst x) then 1::\<real> else (0::\<real>)) * (4 / (9::\<real>))))"
    apply (rule infsum_cong)
     by (simp)
   also have sum_3: "... = (if b\<^sub>v (fst x) then 5 else 4) / 9"
     apply (subst conditional_conds_conj)+
     apply (simp only: divide_inverse)
     apply (subst infsum_constant_finite_states_4)
     using card_1 not_finite_existsD apply force
     using card_2 not_finite_existsD apply force
     using card_3 not_finite_existsD apply force
     using card_4 not_finite_existsD apply force
     by (simp add: card_1 card_2 card_3 card_4)

  show "((if \<not> b\<^sub>v (snd x) then 1::\<real> else (0::\<real>)) / (3::\<real>) +
        (2::\<real>) * (if b\<^sub>v (snd x) then 1::\<real> else (0::\<real>)) / (3::\<real>)) *
       ((if b\<^sub>v (snd x) = (\<not> b\<^sub>v (fst x)) then 1::\<real> else (0::\<real>)) / (3::\<real>) +
        (2::\<real>) * (if b\<^sub>v (snd x) = b\<^sub>v (fst x) then 1::\<real> else (0::\<real>)) / (3::\<real>)) /
       ?sum =
       ((5::\<real>) - (3::\<real>) * (if b\<^sub>v (fst x) then 1::\<real> else (0::\<real>)) +
        (6::\<real>) * (if b\<^sub>v (fst x) \<and> b\<^sub>v (snd x) then 1::\<real> else (0::\<real>))) /
       (10::\<real>)"
    apply (simp only: sum_1 sum_2 sum_3)
    by (auto)
qed

end


(*  Title:      HOL/HOLCF/FOCUS/Fstreams.thy
    Author:     Borislav Gajanovic

FOCUS flat streams (with lifted elements).

TODO: integrate this with Fstream.
*)

theory Fstreams
imports "~~/src/HOL/HOLCF/Library/Stream"
begin

default_sort type

type_synonym 'a fstream = "('a lift) stream"

definition
  fsingleton    :: "'a => 'a fstream"  ("<_>" [1000] 999) where
  fsingleton_def2: "fsingleton = (%a. Def a && UU)"

definition
  fsfilter      :: "'a set \<Rightarrow> 'a fstream \<rightarrow> 'a fstream" where
  "fsfilter A = sfilter\<cdot>(flift2 (\<lambda>x. x\<in>A))"

definition
  fsmap         :: "('a => 'b) => 'a fstream -> 'b fstream" where
  "fsmap f = smap\<cdot>(flift2 f)"

definition
  jth           :: "nat => 'a fstream => 'a" where
  "jth = (%n s. if enat n < #s then THE a. i_th n s = Def a else undefined)"

definition
  first         :: "'a fstream => 'a" where
  "first = (%s. jth 0 s)"

definition
  last          :: "'a fstream => 'a" where
  "last = (%s. case #s of enat n => (if n~=0 then jth (THE k. Suc k = n) s else undefined))"

abbreviation
  emptystream :: "'a fstream"  ("<>") where
  "<> == \<bottom>"

abbreviation
  fsfilter' :: "'a set \<Rightarrow> 'a fstream \<Rightarrow> 'a fstream"       ("(_\<copyright>_)" [64,63] 63) where
  "A\<copyright>s == fsfilter A\<cdot>s"

notation (ASCII)
  fsfilter'  ("(_'(C')_)" [64,63] 63)

lemma ft_fsingleton[simp]: "ft\<cdot>(<a>) = Def a"
by (simp add: fsingleton_def2)

lemma slen_fsingleton[simp]: "#(<a>) = enat 1"
by (simp add: fsingleton_def2 enat_defs)

lemma slen_fstreams[simp]: "#(<a> ooo s) = eSuc (#s)"
by (simp add: fsingleton_def2)

lemma slen_fstreams2[simp]: "#(s ooo <a>) = eSuc (#s)"
apply (cases "#s")
apply (auto simp add: eSuc_enat)
apply (insert slen_sconc [of _ s "Suc 0" "<a>"], auto)
apply (simp add: sconc_def)
done

lemma j_th_0_fsingleton[simp]:"jth 0 (<a>) = a"
apply (simp add: fsingleton_def2 jth_def)
apply (simp add: i_th_def enat_0)
done

lemma jth_0[simp]: "jth 0 (<a> ooo s) = a"
apply (simp add: fsingleton_def2 jth_def)
apply (simp add: i_th_def enat_0)
done

lemma first_sconc[simp]: "first (<a> ooo s) = a"
by (simp add: first_def)

lemma first_fsingleton[simp]: "first (<a>) = a"
by (simp add: first_def)

lemma jth_n[simp]: "enat n = #s ==> jth n (s ooo <a>) = a"
apply (simp add: jth_def, auto)
apply (simp add: i_th_def rt_sconc1)
apply (simp add: enat_defs split: enat.splits)
done

lemma last_sconc[simp]: "enat n = #s ==> last (s ooo <a>) = a"
apply (simp add: last_def)
apply (simp add: enat_defs split:enat.splits)
apply (drule sym, auto)
done

lemma last_fsingleton[simp]: "last (<a>) = a"
by (simp add: last_def)

lemma first_UU[simp]: "first UU = undefined"
by (simp add: first_def jth_def)

lemma last_UU[simp]:"last UU = undefined"
by (simp add: last_def jth_def enat_defs)

lemma last_infinite[simp]:"#s = \<infinity> \<Longrightarrow> last s = undefined"
by (simp add: last_def)

lemma jth_slen_lemma1:"n \<le> k \<and> enat n = #s \<Longrightarrow> jth k s = undefined"
by (simp add: jth_def enat_defs split:enat.splits, auto)

lemma jth_UU[simp]:"jth n UU = undefined"
by (simp add: jth_def)

lemma ext_last:"\<lbrakk>s \<noteq> UU; enat (Suc n) = #s\<rbrakk> \<Longrightarrow> (stream_take n\<cdot>s) ooo <(last s)> = s"
apply (simp add: last_def)
apply (case_tac "#s", auto)
apply (simp add: fsingleton_def2)
apply (subgoal_tac "Def (jth n s) = i_th n s")
apply (auto simp add: i_th_last)
apply (drule slen_take_lemma1, auto)
apply (simp add: jth_def)
apply (case_tac "i_th n s = UU")
apply auto
apply (simp add: i_th_def)
apply (case_tac "i_rt n s = UU", auto)
apply (drule i_rt_slen [THEN iffD1])
apply (drule slen_take_eq_rev [rule_format, THEN iffD2],auto)
apply (drule not_Undef_is_Def [THEN iffD1], auto)
done

lemma fsingleton_lemma1[simp]: "(<a> = <b>) = (a=b)"
by (simp add: fsingleton_def2)

lemma fsingleton_lemma2[simp]: "<a> ~= <>"
by (simp add: fsingleton_def2)

lemma fsingleton_sconc:"<a> ooo s = Def a && s"
by (simp add: fsingleton_def2)

lemma fstreams_ind:
  "[| adm P; P <>; !!a s. P s ==> P (<a> ooo s) |] ==> P x"
apply (simp add: fsingleton_def2)
apply (rule stream.induct, auto)
apply (drule not_Undef_is_Def [THEN iffD1], auto)
done

lemma fstreams_ind2:
  "[| adm P; P <>; !!a. P (<a>); !!a b s. P s ==> P (<a> ooo <b> ooo s) |] ==> P x"
apply (simp add: fsingleton_def2)
apply (rule stream_ind2, auto)
apply (drule not_Undef_is_Def [THEN iffD1], auto)+
done

lemma fstreams_take_Suc[simp]: "stream_take (Suc n)\<cdot>(<a> ooo s) = <a> ooo stream_take n\<cdot>s"
by (simp add: fsingleton_def2)

lemma fstreams_not_empty[simp]: "<a> ooo s \<noteq> <>"
by (simp add: fsingleton_def2)

lemma fstreams_not_empty2[simp]: "s ooo <a> \<noteq> <>"
by (case_tac "s=UU", auto)

lemma fstreams_exhaust: "x = UU \<or> (\<exists>a s. x = <a> ooo s)"
apply (simp add: fsingleton_def2, auto)
apply (erule contrapos_pp, auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
apply (drule not_Undef_is_Def [THEN iffD1], auto)
done

lemma fstreams_cases: "\<lbrakk>x = UU \<Longrightarrow> P; \<And>a y. x = <a> ooo y \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
by (insert fstreams_exhaust [of x], auto)

lemma fstreams_exhaust_eq: "x \<noteq> UU \<longleftrightarrow> (\<exists>a y. x = <a> ooo y)"
apply (simp add: fsingleton_def2, auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
apply (drule not_Undef_is_Def [THEN iffD1], auto)
done

lemma fstreams_inject: "<a> ooo s = <b> ooo t \<longleftrightarrow> a = b \<and> s = t"
by (simp add: fsingleton_def2)

lemma fstreams_prefix: "<a> ooo s << t \<Longrightarrow> \<exists>tt. t = <a> ooo tt \<and> s << tt"
apply (simp add: fsingleton_def2)
apply (insert stream_prefix [of "Def a" s t], auto)
done

lemma fstreams_prefix': "x << <a> ooo z \<longleftrightarrow> x = <> \<or> (\<exists>y. x = <a> ooo y \<and> y << z)"
apply (auto, case_tac "x=UU", auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
apply (simp add: fsingleton_def2, auto)
apply (drule ax_flat, simp)
apply (erule sconc_mono)
done

lemma ft_fstreams[simp]: "ft\<cdot>(<a> ooo s) = Def a"
by (simp add: fsingleton_def2)

lemma rt_fstreams[simp]: "rt\<cdot>(<a> ooo s) = s"
by (simp add: fsingleton_def2)

lemma ft_eq[simp]: "ft\<cdot>s = Def a \<longleftrightarrow> (\<exists>t. s = <a> ooo t)"
apply (cases s, auto)
apply (auto simp add: fsingleton_def2)
done

lemma surjective_fstreams: "<d> ooo y = x \<longleftrightarrow> (ft\<cdot>x = Def d \<and> rt\<cdot>x = y)"
by auto

lemma fstreams_mono: "<a> ooo b << <a> ooo c \<Longrightarrow> b << c"
by (simp add: fsingleton_def2)

lemma fsmap_UU[simp]: "fsmap f\<cdot>UU = UU"
by (simp add: fsmap_def)

lemma fsmap_fsingleton_sconc: "fsmap f\<cdot>(<x> ooo xs) = <(f x)> ooo (fsmap f\<cdot>xs)"
by (simp add: fsmap_def fsingleton_def2 flift2_def)

lemma fsmap_fsingleton[simp]: "fsmap f\<cdot>(<x>) = <(f x)>"
by (simp add: fsmap_def fsingleton_def2 flift2_def)

lemma fstreams_chain_lemma[rule_format]:
  "\<forall>s x y. stream_take n\<cdot>(s::'a fstream) << x \<and> x << y \<and> y << s \<and> x \<noteq> y \<longrightarrow> stream_take (Suc n)\<cdot>s << y"
apply (induct_tac n, auto)
apply (case_tac "s=UU", auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
apply (case_tac "y=UU", auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
apply (simp add: flat_below_iff)
apply (case_tac "s=UU", auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
apply (erule_tac x="ya" in allE)
apply (drule stream_prefix, auto)
apply (case_tac "y=UU",auto)
apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
apply auto
apply (simp add: flat_below_iff)
apply (erule_tac x="tt" in allE)
apply (erule_tac x="yb" in allE, auto)
apply (simp add: flat_below_iff)
apply (simp add: flat_below_iff)
done

lemma fstreams_lub_lemma1: "\<lbrakk>chain Y; (LUB i. Y i) = <a> ooo s\<rbrakk> \<Longrightarrow> \<exists>j t. Y j = <a> ooo t"
apply (subgoal_tac "(LUB i. Y i) ~= UU")
apply (frule lub_eq_bottom_iff, auto)
apply (drule_tac x="i" in is_ub_thelub, auto)
apply (drule fstreams_prefix' [THEN iffD1], auto)
done

lemma fstreams_lub1:
 "\<lbrakk>chain Y; (LUB i. Y i) = <a> ooo s\<rbrakk>
     \<Longrightarrow> (\<exists>j t. Y j = <a> ooo t) \<and> (\<exists>X. chain X \<and> (\<forall>i. \<exists>j. <a> ooo X i << Y j) \<and> (LUB i. X i) = s)"
apply (auto simp add: fstreams_lub_lemma1)
apply (rule_tac x="\<lambda>n. stream_take n\<cdot>s" in exI, auto)
apply (induct_tac i, auto)
apply (drule fstreams_lub_lemma1, auto)
apply (rule_tac x="j" in exI, auto)
apply (case_tac "max_in_chain j Y")
apply (frule lub_finch1 [THEN lub_eqI], auto)
apply (rule_tac x="j" in exI)
apply (erule subst) back back
apply (simp add: below_prod_def sconc_mono)
apply (simp add: max_in_chain_def, auto)
apply (rule_tac x="ja" in exI)
apply (subgoal_tac "Y j << Y ja")
apply (drule fstreams_prefix, auto)+
apply (rule sconc_mono)
apply (rule fstreams_chain_lemma, auto)
apply (subgoal_tac "Y ja << (LUB i. (Y i))", clarsimp)
apply (drule fstreams_mono, simp)
apply (rule is_ub_thelub, simp)
apply (blast intro: chain_mono)
by (rule stream_reach2)

lemma lub_Pair_not_UU_lemma:
  "\<lbrakk>chain Y; (LUB i. Y i) = ((a::'a::flat), b); a \<noteq> UU; b \<noteq> UU\<rbrakk>
      \<Longrightarrow> \<exists>j c d. Y j = (c, d) \<and> c \<noteq> UU \<and> d \<noteq> UU"
apply (frule lub_prod, clarsimp)
apply (clarsimp simp add: lub_eq_bottom_iff [where Y="\<lambda>i. fst (Y i)"])
apply (case_tac "Y i", clarsimp)
apply (case_tac "max_in_chain i Y")
apply (drule maxinch_is_thelub, auto)
apply (rule_tac x="i" in exI, auto)
apply (simp add: max_in_chain_def, auto)
apply (subgoal_tac "Y i << Y j",auto)
apply (simp add: below_prod_def, clarsimp)
apply (drule ax_flat, auto)
apply (case_tac "snd (Y j) = UU",auto)
apply (case_tac "Y j", auto)
apply (rule_tac x="j" in exI)
apply (case_tac "Y j",auto)
apply (drule chain_mono, auto)
done

lemma fstreams_lub_lemma2:
  "\<lbrakk>chain Y; (LUB i. Y i) = (a, <m> ooo ms); (a::'a::flat) \<noteq> UU\<rbrakk> \<Longrightarrow> \<exists>j t. Y j = (a, <m> ooo t)"
apply (frule lub_Pair_not_UU_lemma, auto)
apply (drule_tac x="j" in is_ub_thelub, auto)
apply (drule ax_flat, clarsimp)
apply (drule fstreams_prefix' [THEN iffD1], auto)
done

lemma fstreams_lub2:
  "\<lbrakk>chain Y; (LUB i. Y i) = (a, <m> ooo ms); (a::'a::flat) \<noteq> UU\<rbrakk>
      \<Longrightarrow> (\<exists>j t. Y j = (a, <m> ooo t)) \<and> (\<exists>X. chain X \<and> (\<forall>i. \<exists>j. (a, <m> ooo X i) << Y j) \<and> (LUB i. X i) = ms)"
apply (auto simp add: fstreams_lub_lemma2)
apply (rule_tac x="\<lambda>n. stream_take n\<cdot>ms" in exI, auto)
apply (induct_tac i, auto)
apply (drule fstreams_lub_lemma2, auto)
apply (rule_tac x="j" in exI, auto)
apply (case_tac "max_in_chain j Y")
apply (frule lub_finch1 [THEN lub_eqI], auto)
apply (rule_tac x="j" in exI)
apply (erule subst) back back
apply (simp add: sconc_mono)
apply (simp add: max_in_chain_def, auto)
apply (rule_tac x="ja" in exI)
apply (subgoal_tac "Y j << Y ja")
apply (simp add: below_prod_def, auto)
apply (drule below_trans)
apply (simp add: ax_flat, auto)
apply (drule fstreams_prefix, auto)+
apply (rule sconc_mono)
apply (subgoal_tac "tt \<noteq> tta" "tta << ms")
apply (blast intro: fstreams_chain_lemma)
apply (frule lub_prod, auto)
apply (subgoal_tac "snd (Y ja) << (LUB i. snd (Y i))", clarsimp)
apply (drule fstreams_mono, simp)
apply (rule is_ub_thelub chainI)
apply (simp add: chain_def below_prod_def)
apply (subgoal_tac "fst (Y j) \<noteq> fst (Y ja) \<or> snd (Y j) \<noteq> snd (Y ja)", simp)
apply (drule ax_flat, simp)+
apply (drule prod_eqI, auto)
apply (simp add: chain_mono)
apply (rule stream_reach2)
done

lemma cpo_cont_lemma:
  "\<lbrakk>monofun (f::'a::cpo \<Rightarrow> 'b::cpo); (\<forall>Y. chain Y \<longrightarrow> f (lub(range Y)) << (LUB i. f (Y i)))\<rbrakk> \<Longrightarrow> cont f"
apply (erule contI2)
apply simp
done

end


theory SeprefUF
imports Refine_Imperative_HOL.Sepref "Separation_Logic_Imperative_HOL.Union_Find"
begin

  type_synonym 'a per = "('a\<times>'a) set"

  definition "per_init D \<equiv> {(i,i) | i. i\<in>D}"
  definition [simp]: "per_compare R a b \<equiv> (a,b)\<in>R"

  definition per_init' :: "nat \<Rightarrow> nat per" where "per_init' n \<equiv> {(i,i) |i. i<n}"

  lemma per_init_of_nat_range: "per_init {i. i<N} = per_init' N"
    by (auto simp: per_init_def per_init'_def)

  lemma per_init_per[simp, intro!]:
    "part_equiv (per_init D)"
    unfolding per_init_def
    by (auto simp: part_equiv_def sym_def trans_def)

  lemma per_init_self: "(a,b)\<in>per_init D \<Longrightarrow> a=b"
    unfolding per_init_def by simp

  lemma per_union_impl: "(i,j)\<in>R \<Longrightarrow> (i,j)\<in>per_union R a b"
    by (auto simp: per_union_def)

  lemma per_union_related:
    "part_equiv R \<Longrightarrow> a\<in>Domain R \<Longrightarrow> b\<in>Domain  R \<Longrightarrow> (a,b)\<in>per_union R a b"
    unfolding per_union_def
    by (auto simp: part_equiv_refl)

  lemma part_equiv_refl':
    "part_equiv R \<Longrightarrow> x\<in>Domain R \<Longrightarrow> (x,x)\<in>R"
    using part_equiv_refl[of R x] by blast

  definition per_supset_rel :: "('a per \<times> 'a per) set" where
    "per_supset_rel
      \<equiv> {(p1,p2). p1 \<inter> Domain p2 \<times> Domain p2 = p2 \<and> p1 - (Domain p2 \<times> Domain p2) \<subseteq> Id}"

  lemma per_supset_rel_dom: "(p1, p2) \<in> per_supset_rel \<Longrightarrow> Domain p1 \<supseteq> Domain p2"
    by (auto simp: per_supset_rel_def)

  lemma per_supset_compare:
    "(p1, p2) \<in> per_supset_rel \<Longrightarrow> x1\<in>Domain p2 \<Longrightarrow> x2\<in>Domain p2 \<Longrightarrow> per_compare p1 x1 x2 \<longleftrightarrow> per_compare p2 x1 x2"
    by (auto simp: per_supset_rel_def)

  lemma per_supset_union: "(p1, p2) \<in> per_supset_rel \<Longrightarrow> x1\<in>Domain p2 \<Longrightarrow> x2\<in>Domain p2 \<Longrightarrow>
    (per_union p1 x1 x2, per_union p2 x1 x2) \<in> per_supset_rel"
    apply (clarsimp simp: per_supset_rel_def per_union_def Domain_unfold )
    apply (intro subsetI conjI)
    apply blast
    apply force
    done

  sepref_register per_init per_init' per_compare per_union

  lemma per_init_Domain[simp]: "Domain (per_init D) = D"
    by (auto simp: per_init_def)

  lemma per_init'_Domain[simp]: "Domain (per_init' N) = {i. i<N}"
    by (auto simp: per_init'_def)

  lemma per_init'_sepref_rule[sepref_fr_rules]: "(uf_init,RETURN o per_init') \<in> nat_assn\<^sup>k \<rightarrow>\<^sub>a is_uf"
    unfolding per_init'_def
    apply sepref_to_hoare
    by sep_auto

  lemma per_compare_sepref_rule[sepref_fr_rules]: "(uncurry2 uf_cmp, uncurry2 (RETURN ooo per_compare)) \<in>
    is_uf\<^sup>k *\<^sub>a nat_assn\<^sup>k *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn"
    unfolding per_compare_def
    apply sepref_to_hoare
    by sep_auto

  definition "abs_test \<equiv> do {
    let u = per_init' (5::nat);
    let u = per_union u 1 2;
    let u = per_union u 2 3;
    RETURN (per_compare u 1 3)
  }"

  sepref_definition abs_test_impl is "uncurry0 abs_test" :: "unit_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn"
    unfolding abs_test_def
    by sepref

end