theory Scratch3
  imports Main
begin

type_synonym vname = string

datatype aexp = N int | V vname | Plus aexp aexp

type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n"|
"aval (V v) s = s v"|
"aval (Plus a1 a2) s = (aval a1 s) + (aval a2 s)"

value "aval (Plus (N 3) (V ''x'')) ((\<lambda>x.0)(''x'':=7))"

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x.0"
syntax
  "_State" :: "updbinds \<Rightarrow> 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n"|
"asimp_const (V x) = V x"|
"asimp_const (Plus a1 a2) =
  (case (asimp_const a1, asimp_const a2) of
  (N n1, N n2) \<Rightarrow> N (n1 + n2)|
  (b1,b2) \<Rightarrow> Plus b1 b2)"

lemma "aval (asimp_const a) s = aval a s"
  apply (induction a)
    apply (auto split: aexp.split)
  done

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i1) (N i2) = N (i1 + i2)"|
"plus (N i) a = (if i = 0 then a else Plus (N i) a)"|
"plus a (N i) = (if i = 0 then a else Plus a (N i))"|
"plus a1 a2 = Plus a1 a2"

lemma aval_plus: "aval (plus a1 a2) s = aval a1 s + aval a2 s"
  apply (induction a1 rule : plus.induct)
              apply (auto)
  done

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n"|
"asimp (V x) = V x"|
"asimp (Plus a1 a2) = plus (asimp a1) (asimp a2)"

lemma "aval (asimp a) s = aval a s"
  apply (induction a)
    apply (auto)
  apply (simp add : aval_plus)
  done

(* Exercise 3.1 *)
fun optimal:: "aexp \<Rightarrow> bool" where
"optimal (N _) = True"|
"optimal (V _) = True"|
"optimal (Plus (N _) (N _)) = False"|
"optimal (Plus a1 a2) = ((optimal a1) \<and> (optimal a2))"

lemma "optimal (asimp_const a)"
  apply (induction a rule : optimal.induct)
        apply(auto split: aexp.split)
  done

(* Exercise 3.2 *)
fun plus_complete:: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus_complete (N i1) (N i2) = N (i1 + i2)"|
"plus_complete (N i1) (Plus (V v) (N i2)) = Plus (V v) (N (i1 + i2))"|
"plus_complete (N i1) (Plus (N i2) (V v)) = Plus (V v) (N (i1 + i2))"|
"plus_complete (Plus (V v) (N i1)) (N i2) = Plus (V v) (N (i1 + i2))"|
"plus_complete (Plus (N i1) (V v)) (N i2) = Plus (V v) (N (i1 + i2))"|
"plus_complete a1 a2 = Plus a1 a2"

lemma aval_plus_complete: "aval (plus_complete a1 a2) s = aval a1 s + aval a2 s"
  apply (induction a1 rule : plus_complete.induct)
                      apply (auto)
  done

fun full_asimp :: "aexp \<Rightarrow> aexp" where
"full_asimp (N n) = N n"|
"full_asimp (V v) = V v"|
"full_asimp (Plus a1 a2) = plus_complete (full_asimp a1) (full_asimp a2)"

lemma "aval (full_asimp a) s = aval a s"
  apply (induction a)
    apply (auto)
  apply (simp add : aval_plus_complete)
  done

(* Exercise 3.3 *)
fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"subst v a  (N x) = (N x)"|
"subst v1 a (V v2) = (if (v1 = v2) then a else (V v2))"|
"subst v a (Plus e1 e2) = Plus (subst v a e1) (subst v a e2)"

lemma subst_lemma : "aval (subst x a e) s = aval e (s(x := aval a s))"
  apply (induction e)
    apply(auto)
  done

lemma subst_equiv:"aval a\<^sub>1 s = aval a\<^sub>2 s \<Longrightarrow> aval (subst x a\<^sub>1 e) s = aval (subst x a\<^sub>2 e) s"
  apply (induction e)
    apply (auto)
  done

datatype aexp' = N' int | V' vname | Plus' aexp' aexp' | Times' aexp' aexp'

fun aval' :: "aexp' \<Rightarrow> state \<Rightarrow> val" where
"aval' (N' n) _ = n"|
"aval' (V' v) s = s v"|
"aval' (Plus' e1 e2) s = (aval' e1 s) + (aval' e2 s)"|
"aval' (Times' e1 e2) s = (aval' e1 s) * (aval' e2 s)"

fun plus' :: "aexp' \<Rightarrow> aexp' \<Rightarrow> aexp'" where
"plus' (N' n1) (N' n2) = N' (n1 + n2)"|
"plus' (N' n) e = (if (n = 0) then e else (Plus' (N' n) e))"|
"plus' e (N' n) = (if (n = 0) then e else (Plus' e (N' n)))"|
"plus' e1 e2 = Plus' e1 e2"

fun times' :: "aexp' \<Rightarrow> aexp' \<Rightarrow> aexp'" where
"times' (N' n1) (N' n2) = N' (n1 * n2)"|
"times' (N' n) e = (if n = 0
                  then (N' 0)
                  else (if n = 1
                       then e
                       else (Times' (N' n) e)))"|
"times' e (N' n) = (if n = 0
                  then (N' 0)
                  else (if n = 1
                       then e
                       else (Times' e (N' n))))"|
"times' e1 e2 = Times' e1 e2"

fun asimp' :: "aexp' \<Rightarrow> aexp'" where
"asimp' (N' n) = (N' n)"|
"asimp' (V' v) = (V' v)"|
"asimp' (Plus' e1 e2) = plus' e1 e2"|
"asimp' (Times' e1 e2) = times' e1 e2"

lemma aval_plus': "aval' (plus' a1 a2) s = aval' a1 s + aval' a2 s"
  apply (induction a1 rule : plus'.induct)
              apply (auto)
  done

lemma aval_times : "aval' (times' a1 a2) s = aval' a1 s * aval' a2 s"
  apply (induction a1 rule : times'.induct)
                      apply(auto)
  done

lemma "aval' (asimp' a) s = aval' a s"
  apply (induction a)
     apply (auto)
   apply (simp_all add: aval_plus' aval_times)
  done

datatype aexp2 = N2 int |
                 V2 vname |
                 Plus2 aexp2 aexp2 |
                 Times2 aexp2 aexp2 |
                 PostInc vname|
                 Div2 aexp2 aexp2
value "(1::nat, 2::nat)"
value "fst (1::nat, 2::nat)"
value "let x = 2::nat in x"
value "let (a, b) = (1::nat, 2::nat) in a"
value "(1::int) div (2::int)"

(* Argument application order is always first then second *)
fun aval2 :: "aexp2 \<Rightarrow> state \<Rightarrow> (val \<times> state) option" where
"aval2 (PostInc v) s = Some (s v, s(v := (s v) + 1))"|
"aval2 (N2 n) s = Some (n, s)"|
"aval2 (V2 v) s = Some (s v, s)"|
"aval2 (Plus2 a1 a2) s = (case aval2 a1 s of
                         None \<Rightarrow> None |
                         Some (r1, s1) \<Rightarrow>
                            (case aval2 a2 s1 of
                            None \<Rightarrow> None |
                            Some (r2, s2) \<Rightarrow> Some (r1 + r2, s2)))"|
"aval2 (Times2 a1 a2) s = (case aval2 a1 s of
                         None \<Rightarrow> None |
                         Some (r1, s1) \<Rightarrow>
                            (case aval2 a2 s1 of
                            None \<Rightarrow> None |
                            Some (r2, s2) \<Rightarrow> Some (r1 * r2, s2)))"|
"aval2 (Div2 a1 a2) s = (case aval2 a1 s of
                         None \<Rightarrow> None |
                         Some (r1, s1) \<Rightarrow>
                            (case aval2 a2 s1 of
                            None \<Rightarrow> None |
                            Some (r2, s2) \<Rightarrow> (if r2 = 0 then None else Some (r1 div r2, s2))))"

value "(snd (case (aval2 (N2 2) <>) of
        None \<Rightarrow> (0, <>) |
        Some (v, s) \<Rightarrow> (v, s))) ''x''"

value "(snd (case (aval2 (PostInc ''x'') <>) of
        None \<Rightarrow> (0, <>) |
        Some (v, s) \<Rightarrow> (v, s))) ''x''"

value "(snd (case (aval2 (Div2 (PostInc ''x'') (PostInc ''x'')) <''x'':=6>) of
        None \<Rightarrow> (0, <>) |
        Some (v, s) \<Rightarrow> (v, s))) ''x''"
value "(fst (case (aval2 (Div2 (PostInc ''x'') (PostInc ''x'')) <''x'':=6>) of
        None \<Rightarrow> (0, <>) |
        Some (v, s) \<Rightarrow> (v, s)))"

value "aval2 (Div2 (V2 ''x'') (N2 2)) <''x'':=6>"

(* Exercise 3.6 *)
datatype lexp=Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> val" where
"lval (Nl n) _ = n"|
"lval (Vl v) s = s v"|
"lval (Plusl l1 l2) s = (lval l1 s) + (lval l2 s)"|
"lval (LET v l1 l2) s = lval l2 (s(v:=(lval l1 s)))"

fun inline :: "lexp \<Rightarrow> aexp" where
"inline (Nl n) = (N n)"|
"inline (Vl v) = (V v)"|
"inline (Plusl l1 l2) = Plus (inline l1) (inline l2)"|
"inline (LET v l1 l2) = subst v (inline l1) (inline l2)"

lemma inline_correct : "aval (inline l) s = lval l s"
  apply(induction l arbitrary:s)
     apply(auto)
  apply(simp add:subst_lemma)
  done

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc v) s = v"|
"bval (Not b) s = (\<not>bval b s)"|
"bval (And b\<^sub>1 b\<^sub>2) s = (bval b\<^sub>1 s \<and> bval b\<^sub>2 s)"|
"bval (Less a\<^sub>1 a\<^sub>2) s = (aval a\<^sub>1 s < aval a\<^sub>2 s)"

fun not :: "bexp \<Rightarrow> bexp" where
"not (Bc True) = Bc False"|
"not (Bc False) = Bc True"|
"not b = Not b"

fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"and (Bc True) b = b"|
"and b (Bc True) = b"|
"and (Bc False) b = Bc False"|
"and b (Bc False) = Bc False"|
"and b\<^sub>1 b\<^sub>2 = And b\<^sub>1 b\<^sub>2"

fun bsimp :: "bexp \<Rightarrow> bexp" where
"bsimp (Bc v) = Bc v"|
"bsimp (Not b) = not(bsimp b)"|
"bsimp (And b\<^sub>1 b\<^sub>2) = and (bsimp b\<^sub>1) (bsimp b\<^sub>2)"|
"bsimp (Less a\<^sub>1 a\<^sub>2) = Less (asimp a\<^sub>1) (asimp a\<^sub>2)"

(* Exercise 3.7 *)
definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Eq a\<^sub>1 a\<^sub>2 = And (Not (Less a\<^sub>1 a\<^sub>2)) (Not (Less a\<^sub>2 a\<^sub>1))"

value "bval (Eq (N 1) (N 1)) <>"
value "bval (Eq (N 1) (N 2)) <>"
value "bval (Eq (N 2) (N 1)) <>"

definition Or :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"Or b\<^sub>1 b\<^sub>2 = Not (And (Not b\<^sub>1) (Not b\<^sub>2))"

definition Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Le a\<^sub>1 a\<^sub>2 = Or (Eq a\<^sub>1 a\<^sub>2) (Less a\<^sub>1 a\<^sub>2)"

value "bval (Le (N 1) (N 1)) <>"
value "bval (Le (N 1) (N 2)) <>"
value "bval (Le (N 2) (N 1)) <>"

lemma "bval (Eq a\<^sub>1 a\<^sub>2) s = (aval a\<^sub>1 s = aval a\<^sub>2 s)"
  apply (auto simp add: Eq_def)
  done

lemma "bval (Le a\<^sub>1 a\<^sub>2) s = ((aval a\<^sub>1 s) \<le> (aval a\<^sub>2 s))"
  apply (auto simp add: Le_def Or_def Eq_def)
  done

(* Exercise 3.8 *)
datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
"ifval (Bc2 b) _ = b"|
"ifval (Less2 a\<^sub>1 a\<^sub>2) s = ((aval a\<^sub>1 s) < (aval a\<^sub>2 s))"|
"ifval (If i\<^sub>1 i\<^sub>2 i\<^sub>3) s = (if (ifval i\<^sub>1 s) then (ifval i\<^sub>2 s) else (ifval i\<^sub>3 s))"

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
"b2ifexp (Bc v) = Bc2 v"|
"b2ifexp (Not b) = If (b2ifexp b) (Bc2 False) (Bc2 True)"|
"b2ifexp (And b\<^sub>1 b\<^sub>2) = If (b2ifexp b\<^sub>1) (b2ifexp b\<^sub>2) (Bc2 False)"|
"b2ifexp (Less a\<^sub>1 a\<^sub>2) = Less2 a\<^sub>1 a\<^sub>2"

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
"if2bexp (Bc2 v) = Bc v"|
"if2bexp (Less2 a\<^sub>1 a\<^sub>2) = Less a\<^sub>1 a\<^sub>2"|
"if2bexp (If i\<^sub>1 i\<^sub>2 i\<^sub>3) = Or (And (if2bexp i\<^sub>1) (if2bexp i\<^sub>2))
                            (And (Not (if2bexp i\<^sub>1)) (if2bexp i\<^sub>3))"

lemma "ifval (b2ifexp b) s = bval b s"
  apply (induction b)
     apply (auto)
  done
lemma "bval (if2bexp i) s = ifval i s"
  apply (induction i)
    apply (auto simp add : Or_def)
  done

(* Exercise 3.8 *)
datatype pbexp = VAR vname | NOT pbexp | AND pbexp pbexp | OR pbexp pbexp

fun pbval :: "pbexp \<Rightarrow> (vname \<Rightarrow> bool) \<Rightarrow> bool" where
"pbval (VAR x) s = s x"|
"pbval (NOT b) s = (\<not> pbval b s)"|
"pbval (AND b\<^sub>1 b\<^sub>2) s = (pbval b\<^sub>1 s \<and> pbval b\<^sub>2 s)"|
"pbval (OR b\<^sub>1 b\<^sub>2) s = (pbval b\<^sub>1 s \<or> pbval b\<^sub>2 s)"

fun is_nnf :: "pbexp \<Rightarrow> bool" where
"is_nnf (VAR _) = True"|
"is_nnf (NOT (VAR _)) = True"|
"is_nnf (NOT _) = False"|
"is_nnf (AND b\<^sub>1 b\<^sub>2) = (is_nnf b\<^sub>1 \<and> is_nnf b\<^sub>2)"|
"is_nnf (OR b\<^sub>1 b\<^sub>2) = (is_nnf b\<^sub>1 \<or> is_nnf b\<^sub>2)"

fun nnf :: "pbexp \<Rightarrow> pbexp" where
"nnf (VAR v) = VAR v"|
"nnf (NOT (VAR v)) = NOT (VAR v)"|
"nnf (NOT (NOT b)) = nnf b"|
"nnf (AND b\<^sub>1 b\<^sub>2) = AND (nnf b\<^sub>1) (nnf b\<^sub>2)"|
"nnf (NOT (AND b\<^sub>1 b\<^sub>2)) = OR (nnf (NOT b\<^sub>1)) (nnf (NOT b\<^sub>2))"|
"nnf (OR b\<^sub>1 b\<^sub>2) = OR (nnf b\<^sub>1) (nnf b\<^sub>2)"|
"nnf (NOT (OR b\<^sub>1 b\<^sub>2)) = AND (nnf (NOT b\<^sub>1)) (nnf (NOT b\<^sub>2))"

lemma "(pbval (nnf b) s = pbval b s)"
  apply (induction b rule:nnf.induct)
     apply(auto)
  done

datatype instr = LOADI val | LOAD vname | ADD

type_synonym stack = "val list"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec1 (LOADI n) _ stk = n # stk"|
"exec1 (LOAD v) s stk = (s v) # stk"|
"exec1 ADD _ (j # i # stk) = (i + j) # stk"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec [] _ stk = stk"|
"exec (i#is) s stk = exec is s (exec1 i s stk)"

fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]"|
"comp (V x) = [LOAD x]"|
"comp (Plus e\<^sub>1 e\<^sub>2) = comp e\<^sub>1 @ comp e\<^sub>2 @ [ADD]"

lemma instr_app_stack:"exec (is\<^sub>1 @ is\<^sub>2) s stk = exec is\<^sub>2 s (exec is\<^sub>1 s stk)"
  apply (induction is\<^sub>1 arbitrary: stk)
   apply (auto)
  done

lemma "exec (comp a) s stk = aval a s # stk"
  apply (induction a arbitrary: stk)
  apply(auto)
    apply (auto simp add: instr_app_stack)
  done

(* Exercise 3.10 *)
fun exec1' :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec1' (LOADI n) _ stk = Some (n # stk)"|
"exec1' (LOAD v) s stk = Some ((s v) # stk)"|
"exec1' ADD _ (j # i # stk) = Some ((i + j) # stk)"|
"exec1' ADD _ _ = None"

fun exec' :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec' [] _ stk = Some stk"|
"exec' (i#is) s stk = (case (exec1' i s stk) of
                      None \<Rightarrow> None |
                      Some stk' \<Rightarrow> exec' is s stk')"

lemma instr_app_stack':"(exec' is\<^sub>1 s stk) = Some v \<Longrightarrow> exec' (is\<^sub>1 @ is\<^sub>2) s stk = exec' is\<^sub>2 s v"
  apply (induction is\<^sub>1 arbitrary: stk)
   apply (auto split:option.split)
  done

lemma "exec' (comp a) s stk = Some  (aval a s # stk)"
  apply (induction a arbitrary: stk)
    apply(auto simp add: instr_app_stack')
  done

(* Exercise 3.11 *)
type_synonym reg = nat

(* (ADD r\<^sub>1 r\<^sub>2) adds value in r\<^sub>1 and value in r\<^sub>2 and puts result in r\<^sub>1 *)
datatype rinstr = LDI int reg | LD vname reg | ADD reg reg

fun rexec1:: "rinstr \<Rightarrow> state \<Rightarrow> (reg\<Rightarrow>int) \<Rightarrow> reg \<Rightarrow> int" where
"rexec1 (LDI i r) st regs  = regs(r := i)"|
"rexec1 (LD v r) st regs = regs(r := (st v))"|
"rexec1 (ADD r\<^sub>1 r\<^sub>2) st regs = regs(r\<^sub>1 := ((regs r\<^sub>1) + (regs r\<^sub>2)))"

fun rexec:: "rinstr list \<Rightarrow> state \<Rightarrow> (reg \<Rightarrow> int) \<Rightarrow> reg \<Rightarrow> int" where
"rexec [] _ regs = regs"|
"rexec (i#is) st regs = rexec is st (rexec1 i st regs)"

fun rcomp :: "aexp \<Rightarrow> reg \<Rightarrow> rinstr list" where
"rcomp (N n) r = [LDI n r]" |
"rcomp (V x) r = [LD x r]" |
"rcomp (Plus e\<^sub>1 e\<^sub>2) r = (rcomp e\<^sub>1 r) @ (rcomp e\<^sub>2 (r+1)) @ [ADD r (r+1)]"

lemma rinstr_app_reg:"rexec (is\<^sub>1 @ is\<^sub>2) s r = rexec is\<^sub>2 s (rexec is\<^sub>1 s r)"
  apply (induction is\<^sub>1 arbitrary: r)
   apply (auto)
  done

lemma "rexec(rcomp a r) s rs r = aval a s"
  apply (induction a arbitrary: rs r)
  apply (auto)
  apply (auto simp add: rinstr_app_reg )
  done

end


theory ChoiceFunction
  imports Main Common Base
begin

(* A choice function maps a set of presented alternatives to a set of chosen alternatives *)
type_synonym 'a CF = "'a set \<Rightarrow> 'a set"

abbreviation invalid_cf :: "'a CF" where "invalid_cf \<equiv> \<lambda>_. {}"
abbreviation trivial_cf :: "'a CF" where "trivial_cf \<equiv> id"

locale choice_function = choice_setting +
  constrains U :: "'a set"
  fixes S :: "'a CF"
  (* S has to choose some nonempty subset of the given alternatives A *)
  assumes S: "A \<sqsubseteq> U \<Longrightarrow> S A \<sqsubseteq> A"
  assumes S_domain: "(\<not> A \<sqsubseteq> U) = (S A = invalid_cf A)"
begin

lemma S_subset: "S A \<subseteq> A" using S S_domain by (cases "A \<sqsubseteq> U") auto

(* The base relation of S *)
definition R\<^sub>S (infixl "R\<^sub>S" 50) where "x R\<^sub>S y = (x \<in> S {x, y})"
interpretation base_complete: complete_preference U "(R\<^sub>S)" proof
  show "\<And>x y. x \<notin> U \<or> y \<notin> U \<Longrightarrow> \<not> x R\<^sub>S y" unfolding R\<^sub>S_def using S_domain by auto next
  show "\<And>x y. x \<in> U \<Longrightarrow> y \<in> U \<Longrightarrow> x R\<^sub>S y \<or> y R\<^sub>S x" unfolding R\<^sub>S_def by (smt (verit) Diff_eq_empty_iff Diff_insert_absorb S Un_Diff_cancel Un_upper1 insert_Diff insert_commute insert_is_Un insert_not_empty insert_subsetI subset_insert)
qed
lemma base_complete: "complete_preference U (R\<^sub>S)" by (simp add: base_complete.complete_preference_axioms)

lemma eq_base_max: "A \<sqsubseteq> U \<Longrightarrow> x \<in> A \<Longrightarrow> (\<forall>y \<in> A. x \<in> S {x, y}) = (x \<in> general_preference.Max (R\<^sub>S) A)" using base_complete.Max_comp R\<^sub>S_def by auto

lemma trivial_choice: "x \<in> U \<Longrightarrow> S {x} = {x}" using S[of "{x}"] by auto

end

(* Contraction *)
locale sat_\<alpha> = choice_function +
  assumes \<alpha>: "A \<sqsubseteq> U \<Longrightarrow> B \<sqsubseteq> U \<Longrightarrow> x \<in> A \<Longrightarrow> x \<in> B \<Longrightarrow> x \<in> S (A \<union> B) \<Longrightarrow> x \<in> S A \<and> x \<in> S B"

(* Expansion *)
locale sat_\<gamma> = choice_function +
  assumes \<gamma>: "A \<sqsubseteq> U \<Longrightarrow> B \<sqsubseteq> U \<Longrightarrow> x \<in> A \<Longrightarrow> x \<in> B \<Longrightarrow> x \<in> S A \<Longrightarrow> x \<in> S B \<Longrightarrow> x \<in> S (A \<union> B)"

locale sat_\<gamma>_plus = choice_function +
  assumes \<gamma>_plus: "A \<sqsubseteq> U \<Longrightarrow> B \<sqsubseteq> U \<Longrightarrow> S A \<subseteq> S (A \<union> B) \<or> S B \<subseteq> S (A \<union> B)"

(* Strong Expansion *)
locale sat_\<beta>_plus = choice_function +
  assumes \<beta>_plus: "A \<sqsubseteq> U \<Longrightarrow> B \<sqsubseteq> U \<Longrightarrow> B \<subseteq> A \<Longrightarrow> S A \<inter> B \<noteq> {} \<Longrightarrow> S B \<subseteq> S A"

sublocale sat_\<beta>_plus \<subseteq> sat_\<gamma>_plus proof
  fix A B assume au: "A \<sqsubseteq> U" and bu: "B \<sqsubseteq> U"
  hence ab: "A \<union> B \<sqsubseteq> U" by auto

  have "S (A \<union> B) \<noteq> {}" using S[of "A \<union> B"] ab by auto
  then obtain x where x: "x \<in> S (A \<union> B)" using S by auto

  have "S (A \<union> B) \<subseteq> A \<union> B" using ab S[of "A \<union> B"] by auto
  hence "x \<in> A \<or> x \<in> B" using x by auto
  thus "S A \<subseteq> S (A \<union> B) \<or> S B \<subseteq> S (A \<union> B)" using \<beta>_plus[OF ab] ab x by auto
qed

sublocale sat_\<gamma>_plus \<subseteq> sat_\<gamma> proof
  fix A B x assume "A \<sqsubseteq> U" "B \<sqsubseteq> U" "x \<in> A" "x \<in> B" "x \<in> S A" "x \<in> S B"
  thus "x \<in> S (A \<union> B)" using \<gamma>_plus by auto
qed

locale rationalizable_choice_function = choice_function +
  (* A CF is rationalizable iff it is rationalized by its  base relation *)
  assumes rationalized: "A \<sqsubseteq> U \<Longrightarrow> S A = general_preference.Max (R\<^sub>S) A"

locale sat_\<alpha>_\<gamma> = sat_\<alpha> + sat_\<gamma>

(* Sen's theorem rationalizable \<Longleftrightarrow> \<alpha> \<and> \<gamma> *)
(* Direction \<Longleftarrow> *)
sublocale sat_\<alpha>_\<gamma> \<subseteq> rationalizable_choice_function proof
  fix A assume AU: "A \<sqsubseteq> U"

  show "S A = general_preference.Max (R\<^sub>S) A" proof (rule set_eqI; rule iffI)
    fix x assume xsa: "x \<in> S A" hence xa: "x \<in> A" using S_subset by auto
    {
      fix y assume ya: "y \<in> A"
      hence xyu: "{x, y} \<sqsubseteq> U" using AU xa by blast
      have "x \<in> S A \<and> x \<in> S {x, y}" using \<alpha>[OF AU xyu xa] by (simp add: xsa insert_absorb xa ya)
    }
    thus "x \<in> general_preference.Max (R\<^sub>S) A" using eq_base_max[OF AU xa] by auto
  next
    fix x assume xmax: "x \<in> general_preference.Max (R\<^sub>S) A"

    have xa: "x \<in> A" using general_preference.Max_def[of U "(R\<^sub>S)"] xmax AU base_complete complete_preference.Max_comp by blast

    have "finite A" using AU finite_subset finite_universe by auto
    moreover have "A \<subseteq> A" by auto
    ultimately have "A \<sqsubseteq> U \<Longrightarrow> x \<in> S (A \<union> {x})" proof (induction rule: finite_subset_induct)
      case empty thus ?case using AU xa trivial_choice by auto
    next
      case (insert a F)
      moreover have fxu: "F \<union> {x} \<sqsubseteq> U" using AU xa insert.prems by auto
      moreover have "{x, a} \<sqsubseteq> U" using insert fxu insert.prems by auto
      moreover have "x \<in> F \<union> {x}" by auto
      moreover have "x \<in> {x, a}" by auto
      moreover have "x \<in> S (F \<union> {x})" using fxu insert.IH trivial_choice by force
      moreover have "x \<in> S {x, a}" using AU eq_base_max insert.hyps(2) xa xmax by auto
      ultimately show ?case using \<gamma>[of "F \<union> {x}" "{x, a}" x] by (simp add: Un_commute)
    qed
    thus "x \<in> S A" using AU xa by (simp add: insert_absorb)
  qed
qed

(* Sen's theorem rationalizable \<Longleftrightarrow> \<alpha> \<and> \<gamma> *)
(* Direction \<Longrightarrow> *)
sublocale rationalizable_choice_function \<subseteq> sat_\<alpha>_\<gamma> proof
  fix A B x assume AU: "A \<sqsubseteq> U" and BU: "B \<sqsubseteq> U" and xa:  "x \<in> A" and xb: "x \<in> B"

  have g: "general_preference U (R\<^sub>S)" using base_complete complete_preference_def by auto

  show "x \<in> S (A \<union> B) \<Longrightarrow> x \<in> S A \<and> x \<in> S B" proof
    assume "x \<in> S (A \<union> B)"
    hence x: "x \<in> general_preference.Max (R\<^sub>S) (A \<union> B)" by (metis S_domain empty_iff rationalized)

    show "x \<in> S A" using x rationalized[OF AU] xa general_preference.Max_def[OF g] by auto
    show "x \<in> S B" using x rationalized[OF BU] xb general_preference.Max_def[OF g] by auto
  qed

  assume "x \<in> S A"
  hence "x \<in> general_preference.Max (R\<^sub>S) A" by (metis S_domain empty_iff rationalized)
  hence a_max: "y \<in> A \<Longrightarrow> \<not>general_preference.P (R\<^sub>S) y x" for y using general_preference.Max_def[OF g, of A] by auto

  assume "x \<in> S B"
  hence "x \<in> general_preference.Max (R\<^sub>S) B" by (metis S_domain empty_iff rationalized)
  hence b_max: "y \<in> B \<Longrightarrow> \<not>general_preference.P (R\<^sub>S) y x" for y using general_preference.Max_def[OF g, of B] by auto

  have "y \<in> B \<union> A \<Longrightarrow> \<not>general_preference.P (R\<^sub>S) y x" for y using a_max b_max by auto
  hence "x \<in> general_preference.Max (R\<^sub>S) (A \<union> B)" using general_preference.Max_def[OF g] using xb by blast
  thus "x \<in> S (A \<union> B)" by (simp add: AU BU rationalized)
qed

end


theory Lazy_List
  imports Main "$HIPSTER_HOME/IsaHipster"
begin
setup Tactic_Data.set_coinduct_sledgehammer
(*setup Tactic_Data.set_no_proof*) (* For measuring exploration time *)
setup Misc_Data.set_time (* Print out timing info *)
setup Misc_Data.set_noisy (* Verbose output on hipster calls *)

(* Lazy list codatatype *)
codatatype (lset: 'a) Llist =
      lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

(* Appending lazy lists *)
primcorec lappend :: "'a Llist \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist"
where
  "lappend xs ys = (case xs of LNil \<Rightarrow> ys | LCons x xs' \<Rightarrow> LCons x (lappend xs' ys))"

cohipster lappend
(* The lemmas and proofs below are the output of the hipster call above
   lemma_ac is lappend_LNil2 and lemma_ab is lappend_assoc from Coinductive_List *)
lemma lemma_a [thy_expl]: "lappend LNil y = y"
  by(coinduction arbitrary: y rule: Llist.coinduct_strong)
    (simp add: lappend.code)

lemma lemma_aa [thy_expl]: "lappend (LCons y z) x2 = LCons y (lappend z x2)"
  by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    simp

lemma lemma_ab [thy_expl]: "lappend (lappend y z) x2 = lappend y (lappend z x2)"
  by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    (smt Llist.collapse(1) Llist.collapse(2) Llist.simps(4) Llist.simps(5) lappend.code lappend.disc(1) lappend.disc_iff(1) lappend.simps(4) lhd_def)

lemma lemma_ac [thy_expl]: "lappend y LNil = y"
  by(coinduction arbitrary: y rule: Llist.coinduct_strong)
    (smt Llist.collapse(2) Llist.disc_eq_case(1) Llist.simps(4) Llist.simps(5) lappend.code lappend.simps(4) lhd_def lnull_def)

(* Mapping a function over a lazy list *)
primcorec lmap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Llist \<Rightarrow> 'b Llist" where
 "lmap f xs = (case xs of LNil \<Rightarrow> LNil | LCons x xs \<Rightarrow> LCons (f x) (lmap f xs))"

cohipster lmap
(* The lemmas and proofs below are the output of the hipster call above *)

lemma lemma_ad [thy_expl]: "lmap z (LCons x2 LNil) = LCons (z x2) LNil"
  by(coinduction arbitrary: x2 z rule: Llist.coinduct_strong)
simp

lemma lemma_ae [thy_expl]: "LCons (z x2) (lmap z x3) = lmap z (LCons x2 x3)"
  by(coinduction arbitrary: x2 x3 z rule: Llist.coinduct_strong)
    simp

lemma lemma_af [thy_expl]: "LCons (z x2) (LCons (z x3) LNil) = lmap z (LCons x2 (LCons x3 LNil))"
by(coinduction arbitrary: x2 x3 z rule: Llist.coinduct_strong)
  (simp add: lemma_ad)

cohipster lmap lappend
(* The lemmas and proofs below are the output of the hipster call above
   lemma_ag is lmap_lappend_distrib from Coinductive_List *)
lemma lemma_ag [thy_expl]: "lappend (lmap z x2) (lmap z x3) = lmap z (lappend x2 x3)"
  by(coinduction arbitrary: x2 x3 z rule: Llist.coinduct_strong)
    (smt Llist.case_eq_if lappend.disc_iff(1) lappend.simps(3) lappend.simps(4) lmap.disc_iff(2) lmap.simps(3) lmap.simps(4))

(* Converting a standard list to a lazy list *)
primrec llist_of :: "'a list \<Rightarrow> 'a Llist"
where
  "llist_of [] = LNil"
| "llist_of (x#xs) = LCons x (llist_of xs)"

cohipster llist_of lappend append
(* The lemmas and proofs below are the output of the hipster call above
   lemma_ah is lappend_llist_of_llist_of from Coinductive_List *)
lemma lemma_ah [thy_expl]: "lappend (llist_of y) (llist_of z) = llist_of (y @ z)"
  apply (induct y arbitrary: z)
  apply (simp add: lappend.code)
  apply (simp add: lemma_aa)
  done

cohipster llist_of lmap map
(* The lemmas and proofs below are the output of the hipster call above
   lemma_ai is lmap_llist_of from Coinductive_List *)
lemma lemma_ai [thy_expl]: "lmap z (llist_of x2) = llist_of (map z x2)"
  apply (induct x2)
  apply simp
  apply (metis lemma_ae list.simps(9) llist_of.simps(2))
  done

(* Extended natural numbers *)
codatatype ENat = is_zero: EZ | ESuc (epred: ENat)

(* Length of a lazy list *)
primcorec llength :: "'a Llist \<Rightarrow> ENat" where
"llength xs = (case xs of LNil \<Rightarrow> EZ | LCons y ys \<Rightarrow> ESuc (llength ys))"

cohipster llength
(* The lemmas and proofs below are the output of the hipster call above *)
lemma lemma_aj [thy_expl]: "llength (LCons y z) = ESuc (llength z)"
  by(coinduction arbitrary: y z rule: ENat.coinduct_strong)
    simp

cohipster llength lmap
(* The lemmas and proofs below are the output of the hipster call above
   lemma_ak is llength_lmap from Coinductive_List *)
lemma lemma_ak [thy_expl]: "llength (lmap z x2) = llength x2"
  by(coinduction arbitrary: x2 z rule: ENat.coinduct_strong)
    (metis Llist.case_eq_if llength.disc_iff(2) llength.sel lmap.disc_iff(2) lmap.simps(4))

(* Addition on extended natural numbers *)
primcorec eplus :: "ENat \<Rightarrow> ENat \<Rightarrow> ENat" where
"eplus m n = (if is_zero m then n else ESuc (eplus (epred m) n))"

cohipster eplus
(* The lemmas and proofs below are the output of the hipster call above
   lemma_am is iadd_Suc_right and lemma_an and unknown lemma in line 130
   are proved in lines 171-180 of Extended_Nat *)
lemma lemma_al [thy_expl]: "eplus x EZ = x"
  by(coinduction arbitrary: x rule: ENat.coinduct_strong)
simp

lemma lemma_am [thy_expl]: "eplus x (ESuc y) = ESuc (eplus x y)"
 by(coinduction arbitrary: x y rule: ENat.coinduct_strong)
    (metis ENat.disc(2) ENat.sel eplus.code)

lemma lemma_an [thy_expl]: "eplus (eplus x y) z = eplus x (eplus y z)"
  by(coinduction arbitrary: x y z rule: ENat.coinduct_strong)
auto

lemma unknown [thy_expl]: "eplus y x = eplus x y"
  oops

cohipster llength lappend eplus
(* The lemmas and proofs below are the output of the hipster call above
   lemma_aq is llength_lappend from Coinductive_List *)
lemma lemma_ao [thy_expl]: "eplus EZ (llength y) = llength y"
  by(coinduction arbitrary: y rule: ENat.coinduct_strong)
    simp

lemma lemma_ap [thy_expl]: "eplus (ESuc y) (llength z) = ESuc (eplus y (llength z))"
 by(coinduction arbitrary: y z rule: ENat.coinduct_strong)
simp

lemma lemma_aq [thy_expl]: "eplus (llength y) (llength z) = llength (lappend y z)"
  by(coinduction arbitrary: y z rule: ENat.coinduct_strong)
(smt ENat.sel Llist.case_eq_if eplus.disc_iff(1) eplus.sel lappend.ctr(2) lappend.disc_iff(1) lemma_aj llength.disc_iff(2) llength.sel)

lemma lemma_ar [thy_expl]: "llength (lappend z (LCons y x2)) = ESuc (llength (lappend z x2))"
by(coinduction arbitrary: x2 y z rule: ENat.coinduct_strong)
  (metis Lazy_List.lemma_aq lemma_aj lemma_am)

lemma lemma_as [thy_expl]: "llength (lappend z y) = llength (lappend y z)"
by(coinduction arbitrary: y z rule: ENat.coinduct_strong)
  (smt ENat.sel Lazy_List.lemma_aq Llist.case_eq_if eplus.code lappend.disc_iff(1) lemma_am llength.ctr(2) llength.disc_iff(2))

lemma unknown [thy_expl]: "eplus y x = eplus x y"
  oops

(* Taking from a lazy list *)
primcorec ltake :: "ENat \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist" where
"ltake n xs = (case xs of LNil \<Rightarrow> LNil
                  | LCons y ys \<Rightarrow> (case n of EZ \<Rightarrow> LNil | ESuc n \<Rightarrow> LCons y (ltake n ys)
                                  )
               )"

cohipster ltake
(* The lemmas and proofs below are the output of the hipster call above *)
lemma lemma_at [thy_expl]: "ltake z (ltake y x2) = ltake y (ltake z x2)"
  by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
(smt ENat.case_eq_if Llist.case_eq_if ltake.disc(1) ltake.disc(2) ltake.simps(3) ltake.simps(4))

lemma lemma_au [thy_expl]: "ltake y (ltake y z) = ltake y z"
by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
  (smt ENat.collapse(2) ENat.simps(5) Llist.collapse(2) Llist.simps(5) ltake.disc_iff(1) ltake.simps(3) ltake.simps(4))

lemma lemma_av [thy_expl]: "ltake y (ltake (ESuc y) z) = ltake y z"
by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
  (smt ENat.collapse(2) ENat.discI(2) ENat.simps(5) Llist.case_eq_if ltake.disc(1) ltake.disc(2) ltake.simps(3) ltake.simps(4))

lemma lemma_aw [thy_expl]: "ltake (ESuc z) (LCons y x2) = LCons y (ltake z x2)"
  by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    simp

lemma lemma_ax [thy_expl]: "ltake y (LCons z (ltake y x2)) = ltake y (LCons z x2)"
 by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    (metis Lazy_List.lemma_aw lemma_av)

lemma lemma_ay [thy_expl]: "ltake y (ltake (ESuc (ESuc y)) z) = ltake y z"
by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
  (metis lemma_av)

lemma lemma_az [thy_expl]: "ltake (ESuc y) (ltake (ESuc EZ) z) = ltake (ESuc EZ) z"
by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
  (smt ENat.disc(1) Lazy_List.lemma_aw Llist.collapse(2) Llist.disc(1) ltake.ctr(1))

cohipster ltake lmap
(* The lemmas and proofs below are the output of the hipster call above
   lemma_ba is ltake_lmap from Coinductive_List *)
lemma lemma_ba [thy_expl]: "ltake x2 (lmap z x3) = lmap z (ltake x2 x3)"
  by(coinduction arbitrary: x2 x3 z rule: Llist.coinduct_strong)
    (smt ENat.collapse(2) Llist.collapse(2) Llist.sel(1) Llist.sel(3) lemma_ae lemma_aw lmap.disc_iff(2) ltake.disc(1) ltake.disc(2))

lemma lemma_bb [thy_expl]: "lmap x2 (ltake z (LCons x3 LNil)) = ltake z (LCons (x2 x3) LNil)"
  by(coinduction arbitrary: x2 x3 z rule: Llist.coinduct_strong)
    (metis lemma_ad lemma_ba)

(* Iteratively building a lazy list from a function and an element *)
primcorec iterates :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a Llist"
where "iterates f x = LCons x (iterates f (f x))"

cohipster lmap iterates
(* The lemmas and proofs below are the output of the hipster call above
   lemma_bc is ltake_lmap from Coinductive_List *)
lemma lemma_bc [thy_expl]: "lmap y (iterates y z) = iterates y (y z)"
  by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (smt Lazy_List.iterates.simps(2) Llist.case_eq_if Llist.sel(3) iterates.code lemma_ae lmap.disc_iff(2) lmap.simps(3) lnull_def)

lemma lemma_bd [thy_expl]: "lmap z (LCons y (iterates z x2)) = LCons (z y) (iterates z (z x2))"
  by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    (simp add: lemma_bc)

cohipster lappend iterates
(* The lemmas and proofs below are the output of the hipster call above
   lemma_be is lmap_iterates from Coinductive_List *)
lemma lemma_be [thy_expl]: "lappend (iterates z x2) y = iterates z x2"
  by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    (smt Llist.sel(3) Llist.simps(5) iterates.code iterates.disc_iff lappend.disc_iff(2) lemma_aa lhd_def)

end


(* 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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_TSortCount
imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

datatype Tree = TNode "Tree" "Nat" "Tree" | TNil

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

fun le :: "Nat => Nat => bool" where
"le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun flatten :: "Tree => Nat list => Nat list" where
"flatten (TNode q z r) y = flatten q (cons2 z (flatten r y))"
| "flatten (TNil) y = y"

fun count :: "'a => 'a list => Nat" where
"count x (nil2) = Z"
| "count x (cons2 z ys) =
     (if (x = z) then plus (S Z) (count x ys) else count x ys)"

fun add :: "Nat => Tree => Tree" where
"add x (TNode q z r) =
   (if le x z then TNode (add x q) z r else TNode q z (add x r))"
| "add x (TNil) = TNode TNil x TNil"

fun toTree :: "Nat list => Tree" where
"toTree (nil2) = TNil"
| "toTree (cons2 y xs) = add y (toTree xs)"

fun tsort :: "Nat list => Nat list" where
"tsort x = flatten (toTree x) (nil2)"

theorem property0 :
  "((count x (tsort xs)) = (count x xs))"
  oops

end


(*
  File:    Buffons_Needle.thy
  Author:  Manuel Eberl <eberlm@in.tum.de>

  A formal solution of Buffon's needle problem.
*)
section \<open>Buffon's Needle Problem\<close>
theory Buffons_Needle
  imports "HOL-Probability.Probability"
begin

subsection \<open>Auxiliary material\<close>

lemma sin_le_zero': "sin x \<le> 0" if "x \<ge> -pi" "x \<le> 0" for x
  by (metis minus_le_iff neg_0_le_iff_le sin_ge_zero sin_minus that(1) that(2))

subsection \<open>Problem definition\<close>

text \<open>
  Consider a needle of length $l$ whose centre has the $x$-coordinate $x$. The following then
  defines the set of all $x$-coordinates that the needle covers
  (i.e. the projection of the needle onto the $x$-axis.)
\<close>
definition needle :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real set" where
  "needle l x \<phi> = closed_segment (x - l / 2 * sin \<phi>) (x + l / 2 * sin \<phi>)"

text \<open>
  Buffon's Needle problem is then this: Assuming the needle's $x$ position is chosen uniformly
  at random in a strip of width $d$ centred at the origin, what is the probability that the
  needle crosses at least one of the left/right boundaries of that strip (located at
  $x = \pm\frac{1}{2}d$)?
\<close>
definition buffon :: "real \<Rightarrow> real \<Rightarrow> bool measure" where
  "buffon l d =
     do {
       (x, \<phi>) \<leftarrow> uniform_measure lborel ({-d/2..d/2} \<times> {-pi..pi});
       return (count_space UNIV) (needle l x \<phi> \<inter> {-d/2, d/2} \<noteq> {})
     }"

subsection \<open>Derivation of the solution\<close>

text \<open>
  The following form is a bit easier to handle.
\<close>
lemma buffon_altdef:
  "buffon l d =
     do {
       (x, \<phi>) \<leftarrow> uniform_measure lborel ({-d/2..d/2} \<times> {-pi..pi});
       return (count_space UNIV)
         (let a = x - l / 2 * sin \<phi>; b = x + l / 2 * sin \<phi>
          in  min a b + d/2 \<le> 0 \<and> max a b + d/2 \<ge> 0 \<or> min a b - d/2 \<le> 0 \<and> max a b - d/2 \<ge> 0)
     }"
proof -
  note buffon_def[of l d]
  also {
    have "(\<lambda>(x,\<phi>). needle l x \<phi> \<inter> {-d/2, d/2} \<noteq> {}) =
        (\<lambda>(x,\<phi>). let a = x - l / 2 * sin \<phi>; b = x + l / 2 * sin \<phi>
                 in  -d/2 \<ge> min a b \<and> -d/2 \<le> max a b \<or> min a b \<le> d/2 \<and> max a b \<ge> d/2)"
      by (auto simp: needle_def Let_def closed_segment_eq_real_ivl min_def max_def)
    also have "\<dots> =
      (\<lambda>(x,\<phi>). let a = x - l / 2 * sin \<phi>; b = x + l / 2 * sin \<phi>
               in  min a b + d/2 \<le> 0 \<and> max a b + d/2 \<ge> 0 \<or> min a b - d/2 \<le> 0 \<and> max a b - d/2 \<ge> 0)"
      by (auto simp add: algebra_simps Let_def)
    finally have "(\<lambda>(x, \<phi>). return (count_space UNIV) (needle l x \<phi> \<inter> {- d/2, d/2} \<noteq> {})) =
                  (\<lambda>(x,\<phi>). return (count_space UNIV)
                    (let a = x - l / 2 * sin \<phi>; b = x + l / 2 * sin \<phi>
                     in  min a b + d/2 \<le> 0 \<and> max a b + d/2 \<ge> 0 \<or> min a b - d/2 \<le> 0 \<and> max a b - d/2 \<ge> 0))"
      by (simp add: case_prod_unfold fun_eq_iff)
  }
  finally show ?thesis .
qed

text \<open>
  It is obvious that the problem boils down to determining the measure of the following set:
\<close>
definition buffon_set :: "real \<Rightarrow> real \<Rightarrow> (real \<times> real) set" where
  "buffon_set l d = {(x,\<phi>) \<in> {-d/2..d/2} \<times> {-pi..pi}. abs x \<ge> d / 2 - abs (sin \<phi>) * l / 2}"

text \<open>
  By using the symmetry inherent in the problem, we can reduce the problem to the following
  set, which corresponds to one quadrant of the original set:
\<close>
definition buffon_set' :: "real \<Rightarrow> real \<Rightarrow> (real \<times> real) set" where
  "buffon_set' l d = {(x,\<phi>) \<in> {0..d/2} \<times> {0..pi}. x \<ge> d / 2 - sin \<phi> * l / 2}"

lemma closed_buffon_set [simp, intro, measurable]: "closed (buffon_set l d)"
proof -
  have "buffon_set l d = ({-d/2..d/2} \<times> {-pi..pi}) \<inter>
          (\<lambda>z. abs (fst z) + abs (sin (snd z)) * l / 2 - d / 2) -` {0..}"
    (is "_ = ?A") unfolding buffon_set_def by auto
  also have "closed \<dots>"
    by (intro closed_Int closed_vimage closed_Times) (auto intro!: continuous_intros)
  finally show ?thesis by simp
qed

lemma closed_buffon_set' [simp, intro, measurable]: "closed (buffon_set' l d)"
proof -
  have "buffon_set' l d = ({0..d/2} \<times> {0..pi}) \<inter>
          (\<lambda>z. fst z + sin (snd z) * l / 2 - d / 2) -` {0..}"
    (is "_ = ?A") unfolding buffon_set'_def by auto
  also have "closed \<dots>"
    by (intro closed_Int closed_vimage closed_Times) (auto intro!: continuous_intros)
  finally show ?thesis by simp
qed

lemma measurable_buffon_set [measurable]: "buffon_set l d \<in> sets borel"
  by measurable

lemma measurable_buffon_set' [measurable]: "buffon_set' l d \<in> sets borel"
  by measurable

context
  fixes d l :: real
  assumes d: "d > 0" and l: "l > 0"
begin

lemma buffon_altdef':
  "buffon l d = distr (uniform_measure lborel ({-d/2..d/2} \<times> {-pi..pi}))
                  (count_space UNIV) (\<lambda>z. z \<in> buffon_set l d)"
proof -
  let ?P = "\<lambda>(x,\<phi>). let a = x - l / 2 * sin \<phi>; b = x + l / 2 * sin \<phi>
                    in  min a b + d/2 \<le> 0 \<and> max a b + d/2 \<ge> 0 \<or> min a b - d/2 \<le> 0 \<and> max a b - d/2 \<ge> 0"
  have "buffon l d =
          uniform_measure lborel ({- d / 2..d / 2} \<times> {-pi..pi}) \<bind>
          (\<lambda>z. return (count_space UNIV) (?P z))"
    unfolding buffon_altdef case_prod_unfold by simp
  also have "\<dots> = uniform_measure lborel ({- d / 2..d / 2} \<times> {-pi..pi}) \<bind>
          (\<lambda>z. return (count_space UNIV) (z \<in> buffon_set l d))"
  proof (intro bind_cong_AE AE_uniform_measureI AE_I2 impI refl return_measurable, goal_cases)
    show "(\<lambda>z. return (count_space UNIV) (?P z))
             \<in> uniform_measure lborel ({- d / 2..d / 2} \<times> {- pi..pi}) \<rightarrow>\<^sub>M
                 subprob_algebra (count_space UNIV)"
      unfolding Let_def case_prod_unfold lborel_prod [symmetric] by measurable
    show "(\<lambda>z. return (count_space UNIV) (z \<in> buffon_set l d))
            \<in> uniform_measure lborel ({- d / 2..d / 2} \<times> {- pi..pi}) \<rightarrow>\<^sub>M
                subprob_algebra (count_space UNIV)" by simp

    case (4 z)
    hence "?P z \<longleftrightarrow> z \<in> buffon_set l d"
    proof (cases "snd z \<ge> 0")
      case True
      with 4 have "fst z - l / 2 * sin (snd z) \<le> fst z + l / 2 * sin (snd z)" using l
        by (auto simp: sin_ge_zero)
      moreover from True and 4 have "sin (snd z) \<ge> 0" by (auto simp: sin_ge_zero)
      ultimately show ?thesis using 4 True unfolding buffon_set_def
        by (force simp: field_simps Let_def min_def max_def case_prod_unfold abs_if)
    next
      case False
      with 4 have "fst z - l / 2 * sin (snd z) \<ge> fst z + l / 2 * sin (snd z)" using l
        by (auto simp: sin_le_zero' mult_nonneg_nonpos)
      moreover from False and 4 have "sin (snd z) \<le> 0" by (auto simp: sin_le_zero')
      ultimately show ?thesis using 4 and False
        unfolding buffon_set_def using l d
        by (force simp: field_simps Let_def min_def max_def case_prod_unfold abs_if)
    qed
    thus ?case by (simp only: )
  qed (simp_all add: borel_prod [symmetric])
  also have "\<dots> = distr (uniform_measure lborel ({-d/2..d/2} \<times> {-pi..pi}))
                    (count_space UNIV) (\<lambda>z. z \<in> buffon_set l d)"
    by (rule bind_return_distr') simp_all
  finally show ?thesis .
qed

lemma buffon_prob_aux:
  "emeasure (buffon l d) {True} = emeasure lborel (buffon_set l d) / ennreal (2 * d * pi)"
proof -
  have [measurable]: "A \<times> B \<in> sets borel" if "A \<in> sets borel" "B \<in> sets borel"
    for A B :: "real set" using that unfolding borel_prod [symmetric] by simp

  have "emeasure (buffon l d) {True} =
          emeasure (uniform_measure lborel ({- (d / 2)..d / 2} \<times> {-pi..pi}))
          ((\<lambda>z. z \<in> buffon_set l d) -` {True})" (is "_ = emeasure ?M _")
    by (simp add: buffon_altdef' emeasure_distr)
  also have "(\<lambda>z. z \<in> buffon_set l d) -` {True} = buffon_set l d" by auto
  also have "buffon_set l d \<subseteq> {-d/2..d/2} \<times> {-pi..pi}"
    using l d by (auto simp: buffon_set_def)
  hence "emeasure ?M (buffon_set l d) =
           emeasure lborel (buffon_set l d) / emeasure lborel ({- (d / 2)..d / 2} \<times> {-pi..pi})"
    by (subst emeasure_uniform_measure) (simp_all add: Int_absorb1)
  also have "emeasure lborel ({- (d / 2)..d / 2} \<times> {-pi..pi}) = ennreal (2 * pi * d)"
    using d by (simp add: lborel_prod [symmetric] lborel.emeasure_pair_measure_Times
                          ennreal_mult algebra_simps)
  finally show ?thesis by (simp add: mult_ac)
qed

lemma emeasure_buffon_set_conv_buffon_set':
  "emeasure lborel (buffon_set l d) = 4 * emeasure lborel (buffon_set' l d)"
proof -
  have distr_lborel [simp]: "distr M lborel f = distr M borel f" for M and f :: "real \<Rightarrow> real"
    by (rule distr_cong) simp_all

  define A where "A = buffon_set' l d"
  define B C D where "B = (\<lambda>x. (-fst x, snd x)) -` A" and "C = (\<lambda>x. (fst x, -snd x)) -` A" and
      "D = (\<lambda>x. (-fst x, -snd x)) -` A"
  have meas [measurable]:
     "(\<lambda>x::real \<times> real. (-fst x, snd x)) \<in> borel_measurable borel"
     "(\<lambda>x::real \<times> real. (fst x, -snd x)) \<in> borel_measurable borel"
     "(\<lambda>x::real \<times> real. (-fst x, -snd x)) \<in> borel_measurable borel"
    unfolding borel_prod [symmetric] by measurable
  have meas' [measurable]: "A \<in> sets borel" "B \<in> sets borel" "C \<in> sets borel" "D \<in> sets borel"
    unfolding A_def B_def C_def D_def by (rule measurable_buffon_set' measurable_sets_borel meas)+

  have *: "buffon_set l d = A \<union> B \<union> C \<union> D"
  proof (intro equalityI subsetI, goal_cases)
    case (1 z)
    show ?case
    proof (cases "fst z \<ge> 0"; cases "snd z \<ge> 0")
      assume "fst z \<ge> 0" "snd z \<ge> 0"
      with 1 have "z \<in> A"
        by (auto split: prod.splits simp: buffon_set_def buffon_set'_def sin_ge_zero A_def)
      thus ?thesis by blast
    next
      assume "\<not>(fst z \<ge> 0)" "snd z \<ge> 0"
      with 1 have "z \<in> B"
        by (auto split: prod.splits simp: buffon_set_def buffon_set'_def sin_ge_zero A_def B_def)
      thus ?thesis by blast
    next
      assume "fst z \<ge> 0" "\<not>(snd z \<ge> 0)"
      with 1 have "z \<in> C"
        by (auto split: prod.splits simp: buffon_set_def buffon_set'_def sin_le_zero' A_def C_def)
      thus ?thesis by blast
    next
      assume "\<not>(fst z \<ge> 0)" "\<not>(snd z \<ge> 0)"
      with 1 have "z \<in> D"
        by (auto split: prod.splits simp: buffon_set_def buffon_set'_def sin_le_zero' A_def D_def)
      thus ?thesis by blast
    qed
  qed (auto simp: buffon_set_def buffon_set'_def sin_ge_zero sin_le_zero'  A_def B_def C_def D_def)

  have "A \<inter> B = {0} \<times> ({0..pi} \<inter> {\<phi>. sin \<phi> * l - d \<ge> 0})"
    using d l by (auto simp: buffon_set'_def  A_def B_def C_def D_def)
  moreover have "emeasure lborel \<dots> = 0"
    unfolding lborel_prod [symmetric] by (subst lborel.emeasure_pair_measure_Times) simp_all
  ultimately have AB: "(A \<inter> B) \<in> null_sets lborel"
    unfolding lborel_prod [symmetric] by (simp add: null_sets_def)

  have "C \<inter> D = {0} \<times> ({-pi..0} \<inter> {\<phi>. -sin \<phi> * l - d \<ge> 0})"
    using d l by (auto simp: buffon_set'_def  A_def B_def C_def D_def)
  moreover have "emeasure lborel \<dots> = 0"
    unfolding lborel_prod [symmetric] by (subst lborel.emeasure_pair_measure_Times) simp_all
  ultimately have CD: "(C \<inter> D) \<in> null_sets lborel"
    unfolding lborel_prod [symmetric] by (simp add: null_sets_def)

  have "A \<inter> D = {}" "B \<inter> C = {}" using d l
    by (auto simp: buffon_set'_def A_def D_def B_def C_def)
  moreover have "A \<inter> C = {(d/2, 0)}" "B \<inter> D = {(-d/2, 0)}"
    using d l by (auto simp: case_prod_unfold buffon_set'_def A_def B_def C_def D_def)
  ultimately have AD: "A \<inter> D \<in> null_sets lborel" and BC: "B \<inter> C \<in> null_sets lborel" and
    AC: "A \<inter> C \<in> null_sets lborel" and BD: "B \<inter> D \<in> null_sets lborel" by auto

  note *
  also have "emeasure lborel (A \<union> B \<union> C \<union> D) = emeasure lborel (A \<union> B \<union> C) + emeasure lborel D"
    using AB AC AD BC BD CD by (intro emeasure_Un') (auto simp: Int_Un_distrib2)
  also have "emeasure lborel (A \<union> B \<union> C) = emeasure lborel (A \<union> B) + emeasure lborel C"
    using AB AC BC using AB AC AD BC BD CD by (intro emeasure_Un') (auto simp: Int_Un_distrib2)
  also have "emeasure lborel (A \<union> B) = emeasure lborel A + emeasure lborel B"
    using AB using AB AC AD BC BD CD by (intro emeasure_Un') (auto simp: Int_Un_distrib2)
  also have "emeasure lborel B = emeasure (distr lborel lborel (\<lambda>(x,y). (-x, y))) A"
    (is "_ = emeasure ?M _") unfolding B_def
    by (subst emeasure_distr) (simp_all add: case_prod_unfold)
  also have "?M = lborel" unfolding lborel_prod [symmetric]
    by (subst pair_measure_distr [symmetric]) (simp_all add: sigma_finite_lborel lborel_distr_uminus)
  also have "emeasure lborel C = emeasure (distr lborel lborel (\<lambda>(x,y). (x, -y))) A"
    (is "_ = emeasure ?M _") unfolding C_def
    by (subst emeasure_distr) (simp_all add: case_prod_unfold)
  also have "?M = lborel" unfolding lborel_prod [symmetric]
    by (subst pair_measure_distr [symmetric]) (simp_all add: sigma_finite_lborel lborel_distr_uminus)
  also have "emeasure lborel D = emeasure (distr lborel lborel (\<lambda>(x,y). (-x, -y))) A"
    (is "_ = emeasure ?M _") unfolding D_def
    by (subst emeasure_distr) (simp_all add: case_prod_unfold)
  also have "?M = lborel" unfolding lborel_prod [symmetric]
    by (subst pair_measure_distr [symmetric]) (simp_all add: sigma_finite_lborel lborel_distr_uminus)
  finally have "emeasure lborel (buffon_set l d) =
                  of_nat (Suc (Suc (Suc (Suc 0)))) * emeasure lborel A"
    unfolding of_nat_Suc ring_distribs by simp
  also have "of_nat (Suc (Suc (Suc (Suc 0)))) = (4 :: ennreal)" by simp
  finally show ?thesis unfolding A_def .
qed

text \<open>
  It only remains now to compute the measure of @{const buffon_set'}. We first reduce this
  problem to a relatively simple integral:
\<close>
lemma emeasure_buffon_set':
  "emeasure lborel (buffon_set' l d) =
     ennreal (integral {0..pi} (\<lambda>x. min (d / 2) (sin x * l / 2)))"
  (is "emeasure lborel ?A = _")
proof -
  have "emeasure lborel ?A = nn_integral lborel (\<lambda>x. indicator ?A x)"
    by (intro nn_integral_indicator [symmetric]) simp_all
  also have "(lborel :: (real \<times> real) measure) = lborel \<Otimes>\<^sub>M lborel"
    by (simp only: lborel_prod)
  also have "nn_integral \<dots> (indicator ?A) = (\<integral>\<^sup>+\<phi>. \<integral>\<^sup>+x. indicator ?A (x, \<phi>) \<partial>lborel \<partial>lborel)"
    by (subst lborel_pair.nn_integral_snd [symmetric]) (simp_all add: lborel_prod borel_prod)
  also have "\<dots> = (\<integral>\<^sup>+\<phi>. \<integral>\<^sup>+x. indicator {0..pi} \<phi> * indicator {max 0 (d/2 - sin \<phi> * l / 2) .. d/2} x \<partial>lborel \<partial>lborel)"
    using d l by (intro nn_integral_cong) (auto simp: indicator_def field_simps buffon_set'_def)
  also have "\<dots> = \<integral>\<^sup>+ \<phi>. indicator {0..pi} \<phi> * emeasure lborel {max 0 (d / 2 - sin \<phi> * l / 2)..d / 2} \<partial>lborel"
    by (subst nn_integral_cmult) simp_all
  also have "\<dots> = \<integral>\<^sup>+ \<phi>. ennreal (indicator {0..pi} \<phi> * min (d / 2) (sin \<phi> * l / 2)) \<partial>lborel"
    (is "_ = ?I") using d l by (intro nn_integral_cong) (auto simp: indicator_def sin_ge_zero max_def min_def)
  also have "integrable lborel (\<lambda>\<phi>. (d / 2) * indicator {0..pi} \<phi>)" by simp
  hence int: "integrable lborel (\<lambda>\<phi>. indicator {0..pi} \<phi> * min (d / 2) (sin \<phi> * l / 2))"
    by (rule Bochner_Integration.integrable_bound)
       (insert l d, auto intro!: AE_I2 simp: indicator_def min_def sin_ge_zero)
  hence "?I = set_lebesgue_integral lborel {0..pi} (\<lambda>\<phi>. min (d / 2) (sin \<phi> * l / 2))"
    by (subst nn_integral_eq_integral, assumption)
       (insert d l, auto intro!: AE_I2 simp: sin_ge_zero min_def indicator_def set_lebesgue_integral_def)
  also have "\<dots> = ennreal (integral {0..pi} (\<lambda>x. min (d / 2) (sin x * l / 2)))"
    (is "_ = ennreal ?I") using int by (subst set_borel_integral_eq_integral) (simp_all add: set_integrable_def)
  finally show ?thesis by (simp add: lborel_prod)
qed

text \<open>
  We now have to distinguish two cases: The first and easier one is that where the length
  of the needle, $l$, is less than or equal to the strip width, $d$:
\<close>
context
  assumes l_le_d: "l \<le> d"
begin

lemma emeasure_buffon_set'_short: "emeasure lborel (buffon_set' l d) = ennreal l"
proof -
  have "emeasure lborel (buffon_set' l d) =
          ennreal (integral {0..pi} (\<lambda>x. min (d / 2) (sin x * l / 2)))" (is "_ = ennreal ?I")
    by (rule emeasure_buffon_set')
  also have *: "sin \<phi> * l \<le> d" if "\<phi> \<ge> 0" "\<phi> \<le> pi" for \<phi>
    using mult_mono[OF l_le_d sin_le_one _ sin_ge_zero] that d by (simp add: algebra_simps)
  have "?I = integral {0..pi} (\<lambda>x. (l / 2) * sin x)"
    using l d l_le_d
    by (intro integral_cong) (auto dest: * simp: min_def sin_ge_zero)
  also have "\<dots> = l / 2 * integral {0..pi} sin" by simp
  also have "(sin has_integral (-cos pi - (- cos 0))) {0..pi}"
    by (intro fundamental_theorem_of_calculus)
       (auto intro!: derivative_eq_intros simp: has_field_derivative_iff_has_vector_derivative [symmetric])
  hence "integral {0..pi} sin = -cos pi - (-cos 0)"
    by (simp add: has_integral_iff)
  finally show ?thesis by (simp add: lborel_prod)
qed

lemma emeasure_buffon_set_short: "emeasure lborel (buffon_set l d) = 4 * ennreal l"
  by (simp add: emeasure_buffon_set_conv_buffon_set' emeasure_buffon_set'_short l_le_d)

theorem buffon_short: "emeasure (buffon l d) {True} = ennreal (2 * l / (d * pi))"
proof -
  have "emeasure (buffon l d) {True} = ennreal (4 * l) / ennreal (2 * d * pi)"
    using d l by (subst buffon_prob_aux) (simp add: emeasure_buffon_set_short ennreal_mult)
  also have "\<dots> = ennreal (4 * l / (2 * d * pi))"
    using d l by (subst divide_ennreal) simp_all
  also have "4 * l / (2 * d * pi) = 2 * l / (d * pi)" by simp
  finally show ?thesis .
qed

end

text \<open>
  The other case where the needle is at least as long as the strip width is more complicated:
\<close>
context
  assumes l_ge_d: "l \<ge> d"
begin

lemma emeasure_buffon_set'_long:
  "emeasure lborel (buffon_set' l d) =
     ennreal (l * (1 - sqrt (1 - (d / l)\<^sup>2)) + arccos (d / l) * d)"
proof -
  define \<phi>' where "\<phi>' = arcsin (d / l)"
  have \<phi>'_nonneg: "\<phi>' \<ge> 0" unfolding \<phi>'_def using d l l_ge_d arcsin_le_mono[of 0 "d/l"]
    by (simp add: \<phi>'_def)
  have \<phi>'_le: "\<phi>' \<le> pi / 2" unfolding \<phi>'_def using arcsin_bounded[of "d/l"] d l l_ge_d
    by (simp add: field_simps)
  have ge_phi': "sin \<phi> \<ge> d / l" if "\<phi> \<ge> \<phi>'" "\<phi> \<le> pi / 2" for \<phi>
    using arcsin_le_iff[of "d / l" "\<phi>"] d l_ge_d that \<phi>'_nonneg by (auto simp: \<phi>'_def field_simps)
  have le_phi': "sin \<phi> \<le> d / l" if "\<phi> \<le> \<phi>'" "\<phi> \<ge> 0" for \<phi>
    using le_arcsin_iff[of "d / l" "\<phi>"] d l_ge_d that \<phi>'_le by (auto simp: \<phi>'_def field_simps)

  let ?f = "(\<lambda>x. min (d / 2) (sin x * l / 2))"
  have "emeasure lborel (buffon_set' l d) = ennreal (integral {0..pi} ?f)" (is "_ = ennreal ?I")
    by (rule emeasure_buffon_set')
  also have "?I = integral {0..pi/2} ?f + integral {pi/2..pi} ?f"
    by (rule Henstock_Kurzweil_Integration.integral_combine [symmetric]) (auto intro!: integrable_continuous_real continuous_intros)
  also have "integral {pi/2..pi} ?f = integral {-pi/2..0} (?f \<circ> (\<lambda>\<phi>. \<phi> + pi))"
    by (subst integral_shift) (auto intro!: continuous_intros)
  also have "\<dots> = integral {-(pi/2)..-0} (\<lambda>x. min (d / 2) (sin (-x) * l / 2))" by (simp add: o_def)
  also have "\<dots> = integral {0..pi/2} ?f" (is "_ = ?I") by (subst Henstock_Kurzweil_Integration.integral_reflect_real) simp_all
  also have "\<dots> + \<dots> = 2 * \<dots>" by simp
  also have "?I = integral {0..\<phi>'} ?f + integral {\<phi>'..pi/2} ?f"
    using l d l_ge_d \<phi>'_nonneg \<phi>'_le
    by (intro Henstock_Kurzweil_Integration.integral_combine [symmetric]) (auto intro!: integrable_continuous_real continuous_intros)
  also have "integral {0..\<phi>'} ?f = integral {0..\<phi>'} (\<lambda>x. l / 2 * sin x)"
    using l by (intro integral_cong) (auto simp: min_def field_simps dest: le_phi')
  also have "((\<lambda>x. l / 2 * sin x) has_integral (- (l / 2 * cos \<phi>') - (- (l / 2 * cos 0)))) {0..\<phi>'}"
    using \<phi>'_nonneg
    by (intro fundamental_theorem_of_calculus)
       (auto simp: has_field_derivative_iff_has_vector_derivative [symmetric] intro!: derivative_eq_intros)
  hence "integral {0..\<phi>'} (\<lambda>x. l / 2 * sin x) = (1 - cos \<phi>') * l / 2"
    by (simp add: has_integral_iff algebra_simps)
  also have "integral {\<phi>'..pi/2} ?f = integral {\<phi>'..pi/2} (\<lambda>_. d / 2)"
    using l by (intro integral_cong) (auto simp: min_def field_simps dest: ge_phi')
  also have "\<dots> = arccos (d / l) * d / 2" using \<phi>'_le d l l_ge_d
    by (subst arccos_arcsin_eq) (auto simp: field_simps \<phi>'_def)
  also have "cos \<phi>' = sqrt (1 - (d / l)^2)"
    unfolding \<phi>'_def by (rule cos_arcsin) (insert d l l_ge_d, auto simp: field_simps)
  also have "2 * ((1 - sqrt (1 - (d / l)\<^sup>2)) * l / 2 + arccos (d / l) * d / 2) =
               l * (1 - sqrt (1 - (d / l)\<^sup>2)) + arccos (d / l) * d"
    using d l by (simp add: field_simps)
  finally show ?thesis .
qed

lemma emeasure_buffon_set_long: "emeasure lborel (buffon_set l d) =
        4 * ennreal (l * (1 - sqrt (1 - (d / l)\<^sup>2)) + arccos (d / l) * d)"
  by (simp add: emeasure_buffon_set_conv_buffon_set' emeasure_buffon_set'_long l_ge_d)

theorem buffon_long:
  "emeasure (buffon l d) {True} =
     ennreal (2 / pi * ((l / d) - sqrt ((l / d)\<^sup>2 - 1) + arccos (d / l)))"
proof -
  have *: "l * sqrt ((l\<^sup>2 - d\<^sup>2) / l\<^sup>2) + 0 \<le> l + d * arccos (d / l)"
    using d l_ge_d by (intro add_mono mult_nonneg_nonneg arccos_lbound) (auto simp: field_simps)
  have "emeasure (buffon l d) {True} =
          ennreal (4 * (l - l * sqrt (1 - (d / l)\<^sup>2) + arccos (d / l) * d)) / ennreal (2 * d * pi)"
    using d l l_ge_d * unfolding buffon_prob_aux emeasure_buffon_set_long ennreal_numeral [symmetric]
    by (subst ennreal_mult [symmetric])
       (auto intro!: add_nonneg_nonneg mult_nonneg_nonneg simp: field_simps)
  also have "\<dots> = ennreal ((4 * (l - l * sqrt (1 - (d / l)\<^sup>2) + arccos (d / l) * d)) / (2 * d * pi))"
    using d l * by (subst divide_ennreal) (auto simp: field_simps)
  also have "(4 * (l - l * sqrt (1 - (d / l)\<^sup>2) + arccos (d / l) * d)) / (2 * d * pi) =
               2 / pi * (l / d - l / d * sqrt ((d / l)^2 * ((l / d)^2 - 1)) + arccos (d / l))"
    using d l by (simp add: field_simps)
  also have "l / d * sqrt ((d / l)^2 * ((l / d)^2 - 1)) = sqrt ((l / d) ^ 2 - 1)"
    using d l l_ge_d unfolding real_sqrt_mult real_sqrt_abs by simp
  finally show ?thesis .
qed

end
end

end