theory Univ_RCF_Reification imports
  Complex_Main
  "HOL-Library.Reflection"
  Preprocess_Polys
begin

lemma list_Cons_induct[case_names Nil Cons CCons]:
  "\<lbrakk>P [];\<And>x. P [x];\<And>x1 x2 xs. P (x2#xs) \<Longrightarrow> P (x1 #x2 # xs)\<rbrakk> \<Longrightarrow> P xs"
apply (induct xs,simp)
by (case_tac xs,auto)

section \<open>strict_sorted\<close>

fun strict_sorted :: "'a::linorder list \<Rightarrow> bool" where
  "strict_sorted [] = True" |
  "strict_sorted [x] = True" |
  "strict_sorted (x1#x2#xs) = (x1<x2 \<and> strict_sorted (x2#xs))"

lemma strict_sorted_sorted:"strict_sorted xs \<Longrightarrow> sorted xs"
  by (induct rule:strict_sorted.induct,auto)

lemma strict_sorted_bot:"strict_sorted (x#xs) \<Longrightarrow> \<forall>y\<in>set xs. x<y"
  by (induct xs rule:strict_sorted.induct,auto)

lemma strict_sorted_imp_distinct:"strict_sorted xs \<Longrightarrow> distinct xs"
  apply (induct xs rule:strict_sorted.induct)
  apply auto
by (metis not_less_iff_gr_or_eq strict_sorted_bot)

lemma strict_sorted_Cons: "strict_sorted (x#xs) = (strict_sorted xs \<and> (\<forall> y\<in>set xs. x < y))"
  using strict_sorted_bot
  by (cases xs,auto,fastforce)

lemma strict_sorted_append:"strict_sorted (xs@ys) \<Longrightarrow> strict_sorted xs \<and> strict_sorted ys
    \<and> (\<forall>x\<in>set xs. \<forall>y\<in>set ys. x < y)"
apply (induct xs rule:strict_sorted.induct,auto)
apply (cases ys)
by (auto simp add:strict_sorted_bot)

lemma strict_sorted_append':"strict_sorted (xs@ys@zs) \<Longrightarrow> strict_sorted (xs@zs)"
  apply (induct xs)
  by (auto simp add:strict_sorted_Cons dest:strict_sorted_append)

section \<open>Parse formulas (stratification)\<close>

datatype num = C real | Add num num | Minus num | Mul num num | Var nat | Power num nat

datatype form = Lt num num  | Eq num num | Ge num num | NEq num num |
    Conj form form | Disj form form | Neg form | T | F  | ExQ form | AllQ form

primrec num_interp:: "num \<Rightarrow> real list \<Rightarrow> real"
where
  num_interp_C  : "num_interp (C i) vs = i"
| num_interp_Var: "num_interp (Var v) vs = vs!v"
| num_interp_Add: "num_interp (Add num1 num2) vs = num_interp num1 vs + num_interp num2 vs "
| num_interp_Minus: "num_interp (Minus num) vs = - num_interp num vs "
| num_interp_Mul: "num_interp (Mul num1 num2) vs = num_interp num1 vs * num_interp num2 vs "
| num_interp_Power: "num_interp (Power num n) vs = (num_interp num vs)^n"

lemma num_interp_diff:"num_interp (Add num1 (Minus num2)) vs
    = (num_interp num1 vs) - (num_interp num2 vs)"
  unfolding num_interp.simps by simp

lemma num_interp_number: "num_interp (C (numeral t)) vs = numeral t" by simp
lemma num_interp_rat:
  "num_interp (C (numeral t1/numeral t2)) vs = numeral t1 / numeral t2"
  "num_interp (Mul num (C (1/numeral c))) vs = num_interp num vs / numeral c"
  by simp_all
lemma num_interp_01: "num_interp (C 0) vs = 0" "num_interp (C 1) vs = 1"
    "num_interp (C 0) vs = 0/n" "num_interp (C 0) vs = n/0"
    "num_interp (C (1/numeral t2)) vs = 1/numeral t2"
    "num_interp (C (numeral t1)) vs = numeral t1/1"
  by simp_all
lemmas num_interp_eqs =
  num_interp_Var num_interp_Add num_interp_Mul num_interp_Minus num_interp_number num_interp_01
  num_interp_rat num_interp_diff num_interp_Power

primrec form_interp :: "form \<Rightarrow> real list \<Rightarrow> bool"
where
 "form_interp T vs = True"
| "form_interp F vs = False"
| "form_interp (Lt a b) vs = (num_interp a vs < num_interp b vs)"
| "form_interp (Eq a b) vs = (num_interp a vs = num_interp b vs)"
| "form_interp (Ge a b) vs = (num_interp a vs \<ge> num_interp b vs)"
| "form_interp (NEq a b) vs = (num_interp a vs \<noteq> num_interp b vs)"
| "form_interp (Neg p) vs = (\<not> (form_interp p vs))"
| "form_interp (Conj p q) vs = (form_interp p vs \<and> form_interp q vs)"
| "form_interp (Disj p q) vs = (form_interp p vs \<or> form_interp q vs)"
| "form_interp (ExQ f) vs \<longleftrightarrow> (\<exists>v. form_interp f (v # vs))"
| "form_interp (AllQ f) vs \<longleftrightarrow> (\<forall>v. form_interp f (v # vs))"

datatype norm_num = Pol "real poly" nat | Const real | Abnorm num

fun cancel_normalize_num:: "norm_num \<Rightarrow> num"  where
 "cancel_normalize_num (Pol p v) = fold_coeffs (\<lambda>a f x. Add (C a) (Mul x (f x))) p (\<lambda>_.C 0) (Var v)"|
 "cancel_normalize_num (Const c) = C c"|
 "cancel_normalize_num (Abnorm num) = num"

fun add_norm_num:: "norm_num \<Rightarrow> norm_num \<Rightarrow> norm_num" where
 "add_norm_num (Const c1) (Const c2) = Const (c1+c2)"|
 "add_norm_num (Pol p v) (Const c) = Pol (p+[:c:]) v"|
 "add_norm_num (Const c) (Pol p v)  = Pol (p+[:c:]) v"|
 "add_norm_num (Pol p1 v1) (Pol p2 v2) =
    (if v1=v2 then Pol (p1+p2) v1
    else (Abnorm (Add (cancel_normalize_num (Pol p1 v1)) (cancel_normalize_num (Pol p2 v2)))))" |
 "add_norm_num norm1 norm2 =(Abnorm (Add (cancel_normalize_num norm1) (cancel_normalize_num norm2)))"

fun mult_norm_num:: "norm_num \<Rightarrow> norm_num \<Rightarrow> norm_num" where
 "mult_norm_num (Const c1) (Const c2) = Const (c1*c2)"|
 "mult_norm_num (Pol p v) (Const c) = Pol (smult c p) v"|
 "mult_norm_num (Const c) (Pol p v)  = Pol (smult c p) v"|
 "mult_norm_num (Pol p1 v1) (Pol p2 v2) =
    (if v1=v2 then Pol (p1*p2) v1
    else (Abnorm (Mul (cancel_normalize_num (Pol p1 v1)) (cancel_normalize_num (Pol p2 v2)))))" |
 "mult_norm_num norm1 norm2 =(Abnorm (Mul (cancel_normalize_num norm1) (cancel_normalize_num norm2)))"

fun minus_norm_num:: "norm_num  \<Rightarrow> norm_num" where
 "minus_norm_num (Const c)= Const (- c)"|
 "minus_norm_num (Pol p v)  = Pol (- p) v"|
 "minus_norm_num (Abnorm ab) =(Abnorm (Minus ab))"

fun power_norm_num:: "norm_num \<Rightarrow> nat \<Rightarrow> norm_num" where
  "power_norm_num (Const c) n = Const ( c ^ n)"|
  "power_norm_num (Pol p v) n = Pol (p ^ n) v" |
  "power_norm_num (Abnorm ab) n = (Abnorm (Power ab n))"

fun normalize_num:: "num \<Rightarrow> norm_num" where
  "normalize_num (C c) = Const c"|
  "normalize_num (Var v) = Pol [:0,1:] v"|
  "normalize_num (Minus n1) = minus_norm_num (normalize_num n1)"|
  "normalize_num (Add n1 n2) = add_norm_num (normalize_num n1) (normalize_num n2)"|
  "normalize_num (Mul n1 n2) = mult_norm_num (normalize_num n1) (normalize_num n2)"|
  "normalize_num (Power n1 n) = power_norm_num (normalize_num n1) n"

fun norm_num_interp :: "norm_num \<Rightarrow> real list \<Rightarrow> real" where
  "norm_num_interp (Pol p v) vs = poly p (vs!v)"|
  "norm_num_interp (Const c) vs = c"|
  "norm_num_interp (Abnorm num) vs = num_interp num vs"

lemma cancel_norm:"num_interp (cancel_normalize_num norm_num) = norm_num_interp norm_num"
proof (cases norm_num)
  case (Const c)
  thus ?thesis by auto
next
  case (Abnorm num)
  thus ?thesis by auto
next
  case (Pol p v)
  show ?thesis unfolding Pol
    by (induct_tac p,auto)
qed

lemma norm_add:
  "norm_num_interp (add_norm_num n1 n2) vs = norm_num_interp n1 vs + norm_num_interp n2 vs"
  apply (induct n1 n2 rule:add_norm_num.induct)
  by (simp_all add:cancel_norm del:cancel_normalize_num.simps )

lemma norm_mul:
  "norm_num_interp (mult_norm_num n1 n2) vs = norm_num_interp n1 vs * norm_num_interp n2 vs"
  apply (induct n1 n2 rule:mult_norm_num.induct)
  by (simp_all add:cancel_norm del:cancel_normalize_num.simps )

lemma norm_minus:
  "norm_num_interp (minus_norm_num n1) vs = - norm_num_interp n1 vs"
  apply (induct n1 rule:minus_norm_num.induct)
  by (simp_all add:cancel_norm del:cancel_normalize_num.simps )

lemma norm_power:
  "norm_num_interp (power_norm_num n1 n) vs = (norm_num_interp n1 vs) ^ n"
  apply (induct n1)
  by (simp_all add:cancel_norm del:cancel_normalize_num.simps )

lemma normalize_num_correct:"norm_num_interp (normalize_num num) vs = num_interp num vs"
  apply (induct num rule:normalize_num.induct)
  by (simp_all add:norm_add norm_mul norm_minus norm_power)

datatype qf_form =  Pos norm_num | Zero norm_num | Neg qf_form
    | Conj qf_form qf_form | Disj qf_form qf_form | T | F

datatype norm_form = QF qf_form | ExQ norm_form | AllQ norm_form

fun rename_num:: "nat \<Rightarrow> num \<Rightarrow> num" where
  "rename_num n (Var v) = (if v\<ge>n then Var (v+1) else Var v)"|
  "rename_num _ (C c) = (C c)" |
  "rename_num n (Add n1 n2) = Add (rename_num n n1) (rename_num n n2)"|
  "rename_num n (Minus n1) = Minus (rename_num n n1)"|
  "rename_num n (Mul n1 n2) = Mul (rename_num n n1) (rename_num n n2)"|
  "rename_num n (Power n1 n') = Power (rename_num n n1) n'"

fun rename_norm_num:: "nat \<Rightarrow> norm_num \<Rightarrow> norm_num" where
  "rename_norm_num n (Pol p v) = (if v \<ge> n then Pol p (v+1) else Pol p v)"|
  "rename_norm_num _ (Const c) = Const c" |
  "rename_norm_num n (Abnorm abn) = Abnorm (rename_num n abn)"

fun rename_qf_form:: "nat \<Rightarrow> qf_form \<Rightarrow> qf_form" where
  "rename_qf_form n (Pos nn) = Pos (rename_norm_num n nn)" |
  "rename_qf_form n (Zero nn) = Zero (rename_norm_num n nn)"  |
  "rename_qf_form n (Neg qf) = Neg (rename_qf_form n qf)" |
  "rename_qf_form n (Conj qf1 qf2) = Conj (rename_qf_form n qf1) (rename_qf_form n qf2)" |
  "rename_qf_form n (Disj qf1 qf2) = Disj (rename_qf_form n qf1) (rename_qf_form n qf2)" |
  "rename_qf_form _ T = T" |
  "rename_qf_form _ F = F"

fun rename::"nat \<Rightarrow> norm_form \<Rightarrow> norm_form" where
  "rename n (AllQ nf) = AllQ (rename (n+1) nf)"|
  "rename n (ExQ nf) = ExQ (rename (n+1) nf)" |
  "rename n (QF qf) = QF (rename_qf_form n qf)"

primrec qf_size :: "qf_form\<Rightarrow> nat"
where
  "qf_size (Pos norm_num) = 1"
| "qf_size (Zero norm_num) = 1 "
| "qf_size (Neg qf) = 1 + qf_size qf"
| "qf_size (Conj p q) = 1 + qf_size p + qf_size q"
| "qf_size (Disj p q) = 1 + qf_size p + qf_size q"
| "qf_size T = 0"
| "qf_size F = 0"

primrec nf_size :: "norm_form \<Rightarrow> nat"
where
  "nf_size (QF qf) = 1"
| "nf_size (ExQ nf) = 1 + nf_size nf"
| "nf_size (AllQ nf) = 1 + nf_size nf"

primrec nf_prod_size:: "norm_form \<times> norm_form \<Rightarrow> nat" where
  "nf_prod_size (p1,p2) = (nf_size (p1)) + (nf_size (p2)) "

lemma [measure_function]: "is_measure nf_prod_size" ..

fun combine_conj::"norm_form \<Rightarrow> norm_form \<Rightarrow> norm_form" where
  "combine_conj (QF qf1) (QF qf2) = QF (Conj qf1 qf2)"|
  "combine_conj (AllQ nf1) (AllQ nf2) = AllQ (combine_conj nf1 nf2)"|
  "combine_conj (AllQ nf1) nf2 = AllQ (combine_conj nf1 (rename 0 nf2))"|
  "combine_conj nf1 (AllQ nf2) = AllQ (combine_conj (rename 0 nf1) nf2)"|
  "combine_conj (ExQ nf1) nf2 = ExQ (combine_conj nf1 (rename 0 nf2))"|
  "combine_conj nf1 (ExQ nf2) = ExQ (combine_conj (rename 0 nf1) nf2)"

fun combine_disj::"norm_form \<Rightarrow> norm_form \<Rightarrow> norm_form" where
  "combine_disj (QF qf1) (QF qf2) = QF (Disj qf1 qf2)"|
  "combine_disj (ExQ nf1) (ExQ nf2) = ExQ (combine_disj nf1 nf2)"|
  "combine_disj (AllQ nf1) nf2 = AllQ (combine_disj nf1 (rename 0 nf2))"|
  "combine_disj nf1 (AllQ nf2) = AllQ (combine_disj (rename 0 nf1) nf2)"|
  "combine_disj (ExQ nf1) nf2 = ExQ (combine_disj nf1 (rename 0 nf2))"|
  "combine_disj nf1 (ExQ nf2) = ExQ (combine_disj (rename 0 nf1) nf2)"

fun neg_nf:: "norm_form \<Rightarrow> norm_form " where
  "neg_nf (QF qf) = QF (Neg qf)"|
  "neg_nf (AllQ nf) = ExQ (neg_nf nf)"|
  "neg_nf (ExQ nf) = AllQ (neg_nf nf)"

fun normalize:: "form \<Rightarrow> norm_form" where
  "normalize (Lt num1 num2)
    =  (QF o Pos) (add_norm_num  (normalize_num num2) (minus_norm_num (normalize_num num1)))"|
  "normalize (Eq num1 num2)
    =  (QF o Zero) (add_norm_num  (normalize_num num1) (minus_norm_num(normalize_num num2)))"|
  "normalize (Ge num1 num2)
    = (QF o Neg o Pos) ((add_norm_num  (normalize_num num2) (minus_norm_num (normalize_num num1))))" |
  "normalize (NEq num1 num2)
    = (QF o Neg o Zero) ((add_norm_num  (normalize_num num1) (minus_norm_num (normalize_num num2))))"|
  "normalize (form.Conj f1 f2) = (combine_conj (normalize f1) (normalize f2))" |
  "normalize (form.Disj f1 f2) = combine_disj (normalize f1) (normalize f2)"|
  "normalize (form.Neg form) = neg_nf (normalize form)"|
  "normalize form.T = QF T"|
  "normalize form.F = QF F"|
  "normalize (form.ExQ form) = ExQ (normalize form)"|
  "normalize (form.AllQ form) = AllQ (normalize form)"

fun qf_form_interp:: "qf_form \<Rightarrow> real list \<Rightarrow> bool" where
  "qf_form_interp (Pos norm_num) vs = (norm_num_interp norm_num vs > 0)"|
  "qf_form_interp (Zero norm_num) vs = (norm_num_interp norm_num vs = 0)"|
  "qf_form_interp (Neg qf_form) vs = (\<not> qf_form_interp qf_form vs)" |
  "qf_form_interp (Conj qf_form1 norm_form2) vs = (qf_form_interp qf_form1 vs
   \<and> qf_form_interp norm_form2 vs)"|
  "qf_form_interp (Disj qf_form1 qf_form2) vs = (qf_form_interp qf_form1 vs
   \<or> qf_form_interp qf_form2 vs)"|
  "qf_form_interp T vs = True"|
  "qf_form_interp F vs = False"

fun norm_form_interp:: "norm_form \<Rightarrow>real list \<Rightarrow> bool" where
  "norm_form_interp (QF qf) vs = qf_form_interp qf vs"|
  "norm_form_interp (ExQ norm_form) vs = (\<exists>x. norm_form_interp norm_form (x#vs))"|
  "norm_form_interp (AllQ norm_form) vs = (\<forall>x. norm_form_interp norm_form (x#vs))"

lemma rename_num:
  "length vs'=n \<Longrightarrow> num_interp (rename_num n num) (vs'@v#vs) = num_interp num (vs'@vs)"
by (induct num arbitrary: n vs vs' v ,auto simp add:nth_append)

lemma rename_norm_num:
   "length vs'=n \<Longrightarrow>
   norm_num_interp (rename_norm_num n norm_num) (vs'@ v # vs) = norm_num_interp norm_num (vs'@vs)"
by (induct norm_num arbitrary:n vs vs' v,auto simp add:rename_num nth_append)

lemma rename_qf_form:
  "length vs' = n \<Longrightarrow> qf_form_interp (rename_qf_form n qf) (vs'@v # vs) = qf_form_interp qf (vs'@vs)"
apply (induct qf)
by (auto simp add:rename_norm_num)

lemma rename:
  "length vs'=n \<Longrightarrow> norm_form_interp (rename n nf) (vs'@v # vs) = norm_form_interp nf (vs'@vs)"
apply (induct nf arbitrary:n vs' vs v)
apply (auto simp add:rename_qf_form  )
by (metis append_Cons length_Cons)+

lemma rename_inst:
  " norm_form_interp (rename (Suc 0) nf) (x # v # vs) = norm_form_interp nf (x # vs)"
using rename[of "[x]" 1,simplified] .

lemma combine_conj_correct:
  "norm_form_interp (combine_conj nf1 nf2) vs \<longleftrightarrow> norm_form_interp nf1 vs \<and> norm_form_interp nf2 vs"
apply (induct arbitrary:vs rule:combine_conj.induct )
by (auto simp add:rename_qf_form[of Nil 0,simplified] rename_inst HOL.all_conj_distrib[symmetric])

lemma combine_disj_correct:
  "norm_form_interp (combine_disj nf1 nf2) vs \<longleftrightarrow> norm_form_interp nf1 vs \<or> norm_form_interp nf2 vs"
apply (induct arbitrary:vs rule:combine_disj.induct)
by (auto simp add:rename_inst rename_qf_form[of Nil 0,simplified] rename[of Nil 0,simplified]
  ex_disj_distrib[symmetric])

lemma neg_nf_correct:
  "norm_form_interp (neg_nf nf) vs \<longleftrightarrow> \<not> norm_form_interp nf vs"
apply (induct arbitrary:vs rule:neg_nf.induct)
by auto

lemma norm_form_correct:" norm_form_interp (normalize form) vs = form_interp form vs"
apply (induct form arbitrary:vs rule:normalize.induct)
apply (auto simp add:norm_minus norm_add normalize_num_correct combine_conj_correct
  combine_disj_correct neg_nf_correct)
done

datatype norm_num2 = Pol "int poly" nat | Const real | Abnorm num
datatype qf_form2 =  Pos norm_num2 | Zero norm_num2 | Neg qf_form2
    | Conj qf_form2 qf_form2 | Disj qf_form2 qf_form2 | T | F
datatype norm_form2 = QF qf_form2 | ExQ norm_form2 | AllQ norm_form2

definition int_poly::"real poly \<Rightarrow> int poly" where
  "int_poly p = undefined"

fun normalize_num2:: "norm_num \<Rightarrow> norm_num2" where
  "normalize_num2 (norm_num.Pol p v) =
    (if all_coeffs_rat p then Pol (clear_de_real p) v
    else Abnorm (cancel_normalize_num(norm_num.Pol p v)))" |
  "normalize_num2 (norm_num.Const c) = Const c" |
  "normalize_num2 (norm_num.Abnorm num) = Abnorm num"

fun normalize_qf_form2:: "qf_form \<Rightarrow> qf_form2" where
  "normalize_qf_form2 (qf_form.Pos norm_num) = Pos (normalize_num2 norm_num)"|
  "normalize_qf_form2 (qf_form.Zero norm_num) = Zero (normalize_num2 norm_num)"|
  "normalize_qf_form2 (qf_form.Neg qf_form) = Neg (normalize_qf_form2 qf_form)"|
  "normalize_qf_form2 (qf_form.Conj qf_form qf_form')
      = Conj (normalize_qf_form2 qf_form) (normalize_qf_form2 qf_form')"|
  "normalize_qf_form2 (qf_form.Disj qf_form qf_form')
      = Disj (normalize_qf_form2 qf_form) (normalize_qf_form2 qf_form')"|
  "normalize_qf_form2 qf_form.T = T"|
  "normalize_qf_form2 qf_form.F = F"

fun normalize2 :: "norm_form \<Rightarrow> norm_form2" where
  "normalize2 (norm_form.QF qf_form) = QF (normalize_qf_form2 qf_form)"|
  "normalize2 (norm_form.ExQ norm_form) = ExQ (normalize2 norm_form)"|
  "normalize2 (norm_form.AllQ norm_form) = AllQ (normalize2 norm_form)"

fun norm_num2_interp :: "norm_num2 \<Rightarrow> real list \<Rightarrow> real" where
  "norm_num2_interp (Pol p v) vs = poly (of_int_poly p) (vs!v)"|
  "norm_num2_interp (Const c) vs = c"|
  "norm_num2_interp (Abnorm num) vs = num_interp num vs"

fun qf_form2_interp:: "qf_form2 \<Rightarrow> real list \<Rightarrow> bool" where
  "qf_form2_interp (Pos norm_num) vs = (norm_num2_interp norm_num vs > 0)"|
  "qf_form2_interp (Zero norm_num) vs = (norm_num2_interp norm_num vs = 0)"|
  "qf_form2_interp (Neg qf_form) vs = (\<not> qf_form2_interp qf_form vs)" |
  "qf_form2_interp (Conj qf_form1 norm_form2) vs = (qf_form2_interp qf_form1 vs
   \<and> qf_form2_interp norm_form2 vs)"|
  "qf_form2_interp (Disj qf_form1 qf_form2) vs = (qf_form2_interp qf_form1 vs
   \<or> qf_form2_interp qf_form2 vs)"|
  "qf_form2_interp T vs = True"|
  "qf_form2_interp F vs = False"

fun norm_form2_interp:: "norm_form2 \<Rightarrow>real list \<Rightarrow> bool" where
  "norm_form2_interp (QF qf) vs = qf_form2_interp qf vs"|
  "norm_form2_interp (ExQ norm_form) vs = (\<exists>x. norm_form2_interp norm_form (x#vs))"|
  "norm_form2_interp (AllQ norm_form) vs = (\<forall>x. norm_form2_interp norm_form (x#vs))"

declare [[code drop:norm_form2_interp]]

lemma normalize_qf_form2_correct:
    "qf_form2_interp (normalize_qf_form2 norm_form) vs = qf_form_interp norm_form vs"
proof -
  have "(0 < norm_num2_interp (normalize_num2 norm_num) vs) = (0 < norm_num_interp norm_num vs)"
      for norm_num
    apply (induct norm_num rule:normalize_num2.induct)
    apply (auto simp del:cancel_normalize_num.simps simp add:cancel_norm clear_de_real)
    by (meson de_lcm_pos of_int_0_less_iff zero_less_mult_pos)
  moreover have "(0 = norm_num2_interp (normalize_num2 norm_num) vs) = (0 = norm_num_interp norm_num vs)"
      for norm_num
    apply (induct norm_num rule:normalize_num2.induct)
    apply (auto simp del:cancel_normalize_num.simps simp add:cancel_norm clear_de_real)
    using de_lcm_pos by (metis less_irrefl)
  ultimately show ?thesis
    apply (induct norm_form rule:normalize_qf_form2.induct)
    by auto
qed

lemma norm_form2_correct:" norm_form2_interp (normalize2 (normalize form)) vs = form_interp form vs"
proof -
  have "norm_form2_interp (normalize2 norm_form) vs = norm_form_interp norm_form vs"
    for norm_form
    apply (induct norm_form arbitrary:vs rule:normalize2.induct)
    by (auto simp add:normalize_qf_form2_correct)
  thus ?thesis using norm_form_correct by auto
qed

section \<open>Efficient normalisation\<close>

ML \<open>

fun raw_normalize2 (ctxt, ct,t) = Thm.mk_binop \<^cterm>\<open>Pure.eq :: norm_form2 \<Rightarrow> norm_form2 \<Rightarrow> prop\<close>
  ct (Thm.cterm_of ctxt t);

val (_, normalize2_oracle) = Context.>>> (Context.map_theory_result
  (Thm.add_oracle (\<^binding>\<open>normalize2\<close>, raw_normalize2)));
\<close>

definition "coeffs_int = (coeffs :: _ \<Rightarrow> int list)"
definition "coeffs_real = (coeffs :: _ \<Rightarrow> real list)"

ML \<open>
fun mk_rat a b = @{const "Rat.Fract"} $ (HOLogic.mk_number @{typ int} a)
                  $ (HOLogic.mk_number @{typ int} b);
fun rat_of_rat x = (case @{code quotient_of} x of (x1,x2)
        => mk_rat (@{code integer_of_int} x1) (@{code integer_of_int} x2)
      );
fun real_of_real (@{code Ratreal} x) = @{const "Ratreal"} $ (rat_of_rat x)

fun nat_of_nat x = @{code integer_of_nat} x |> HOLogic.mk_nat

(*TODO: more efficient while avoiding 'poly_of_list'?*)
fun poly_of_poly_int x =
        @{term "poly_of_list :: int list \<Rightarrow> _"} $ (
          (map (fn y => HOLogic.mk_number @{typ int} (@{code integer_of_int} y))
             (@{code coeffs_int} x))
        |> HOLogic.mk_list @{typ "int"}
        )

fun poly_of_poly_real x =
        @{term "poly_of_list :: real list \<Rightarrow> _"} $ (
          (map real_of_real (@{code coeffs_real} x))
        |> HOLogic.mk_list @{typ "real"}
        )

fun num_of_num (@{code C} x) = @{term C} $ real_of_real x
  | num_of_num (@{code Add} (nm1,nm2))
      = @{const Add} $ num_of_num nm1 $ num_of_num nm2
  | num_of_num (@{code Minus} nm1)
      = @{const Minus} $ num_of_num nm1
  | num_of_num (@{code Mul} (nm1,nm2))
      = @{const Mul} $ num_of_num nm1 $ num_of_num nm2
  | num_of_num (@{code Var} n)
      = @{const Var} $ nat_of_nat n
  | num_of_num (@{code Power} (nm1,n))
      = @{const Power} $ num_of_num nm1 $ nat_of_nat n

fun norm_num_of_norm_num (@{code norm_num.Pol} (p, n)) =
        @{const norm_num.Pol} $ (poly_of_poly_real p) $ (nat_of_nat n)
  | norm_num_of_norm_num (@{code norm_num.Const} x) =
        @{const norm_num.Const} $ (real_of_real x)
  | norm_num_of_norm_num (@{code norm_num.Abnorm} x) =
        @{const norm_num.Abnorm} $ (num_of_num x)

fun norm_num2_of_norm_num2 (@{code norm_num2.Pol} (p, n)) =
        @{const norm_num2.Pol} $ (poly_of_poly_int p) $ (nat_of_nat n)
  | norm_num2_of_norm_num2 (@{code norm_num2.Const} x) =
        @{const norm_num2.Const} $ (real_of_real x)
  | norm_num2_of_norm_num2 (@{code norm_num2.Abnorm} x) =
        @{const norm_num2.Abnorm} $ (num_of_num x)

fun qf_form2_of_qf_form2 (@{code Pos} nm) =
        @{const Pos} $ (norm_num2_of_norm_num2 nm)
  | qf_form2_of_qf_form2 (@{code Zero} nm) =
        @{const Zero} $ (norm_num2_of_norm_num2 nm)
  | qf_form2_of_qf_form2 (@{code Neg} qf) =
        @{const Neg} $ (qf_form2_of_qf_form2 qf)
  | qf_form2_of_qf_form2 (@{code Conj} (qf1,qf2)) =
        @{const Conj} $ (qf_form2_of_qf_form2 qf1) $ (qf_form2_of_qf_form2 qf2)
  | qf_form2_of_qf_form2 (@{code Disj} (qf1,qf2)) =
        @{const Disj} $ (qf_form2_of_qf_form2 qf1) $ (qf_form2_of_qf_form2 qf2)
  | qf_form2_of_qf_form2 (@{code T}) = @{const T}
  | qf_form2_of_qf_form2 (@{code F}) = @{const F}

fun norm_form2_of_norm_form2 (@{code QF} qf) =
        @{const QF} $ (qf_form2_of_qf_form2 qf)
  | norm_form2_of_norm_form2 (@{code ExQ} nf) =
        @{const ExQ} $ (norm_form2_of_norm_form2 nf)
  | norm_form2_of_norm_form2 (@{code AllQ} nf) =
        @{const AllQ} $ (norm_form2_of_norm_form2 nf)

val comp_norm_conv = @{computation_conv norm_form2
    terms:
      normalize_num2
      normalize2
      normalize

      Ratreal

      "Rat.Fract :: int \<Rightarrow> int \<Rightarrow> rat"

      (*int*)
      "0::int"
      "1::int"
      rat_of_int

      (*nat*)
      "0::nat"
      "1::nat"
      "Suc"
      nat_of_num

      (*real*)
      "0::real"
      "1::real"
      "(/) :: _ \<Rightarrow> _ \<Rightarrow> real"

      (*poly*)
    "times::int poly \<Rightarrow> _"
    "pCons :: int \<Rightarrow> _"
    "pCons :: real \<Rightarrow> _"
    "smult::int \<Rightarrow> _"
    "HOL.equal ::int poly \<Rightarrow> _"
    "0 :: int poly"
    "0 :: real poly"
    "poly_of_list :: _ \<Rightarrow> int poly"

    datatypes: norm_form2 qf_form2 qf_form form norm_form norm_num norm_num2
      Univ_RCF_Reification.num nat rat int
      Num.num "int list"
    } (fn ctxt => fn p => fn ct => normalize2_oracle (ctxt, ct, (norm_form2_of_norm_form2 p)))
\<close>

ML \<open>
fun check_shape ctrm = (case Thm.term_of ctrm of
        \<^term>\<open>HOL.Trueprop\<close> $
          (Const (\<^const_name>\<open>norm_form2_interp\<close>, _) $ t $ _)
           => true
        |_ => false)

val efficient_norm_tac' =
      Subgoal.FOCUS (fn {context = ctxt, concl = goal, ...}
         => let val _ = @{assert} (check_shape goal);
                val trm_to_norm = goal |> Thm.dest_arg |> Thm.dest_arg1;
                val rw_conv = Conv.rewr_conv (comp_norm_conv ctxt trm_to_norm)
            in
                HEADGOAL (CONVERSION (Conv.arg_conv (Conv.arg1_conv rw_conv)))

            end )

fun efficient_norm_tac ctxt =
        efficient_norm_tac' ctxt
      THEN'
        simp_tac (Raw_Simplifier.clear_simpset ctxt
          addsimps @{thms poly_of_list_def Poly.simps})
\<close>

end


theory hw2
imports Main
  "HOL-Hoare.Hoare_Logic"
 "HOL-Library.Permutation"

begin

(*1*)
lemma DownFact: "VARS (z :: nat) (y :: nat)
{True}
z:=x;
y:=1;
WHILE z>0
INV { fact x  = y * fact z }
DO
y := y * z;
z := z-1
OD
{y = fact x}"
  apply vcg_simp
  by (auto simp add: fact_reduce)

(*2*)

function sum :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where "sum i N = (if i > N then 0 else i + sum (Suc i) N)"
  by pat_completeness auto
termination sum
  apply (relation "measure (\<lambda>(i,N). N + 1 - i)")
  apply auto
  done

value "sum 1 4"

lemma SumLemma: "VARS (s :: nat) (i :: nat)
{b\<ge>0}
s:=0;
i:=a;
WHILE i \<le> b
INV { sum a b = s + sum i b }
DO
s := s + i;
i := i + 1
OD
{s = sum a b   }"
  apply vcg_simp
  done

lemma "VARS (s :: nat) (i :: nat)
{n \<ge> 1}
  s := 0;
  i := 0;
WHILE i \<le> n
  INV {2 * s = ((i - 1) * i) \<and> (i \<le> n + 1)}
DO
  s := s + i;
  i := i + 1
OD
{2 * s = (n * (n + 1))}"
  apply vcg_simp
   apply (auto simp add: algebra_simps le_Suc_eq)
  done

(*fun sum_upto :: "nat \<Rightarrow> nat"
  where "sum_upto 0 = 0" |
"sum_upto (Suc a) = Suc a + (sum_upto (a))"

lemma eq_sum[simp]:"sum 0 n =sum_upto n"
  apply(induct n)
  oops

lemma nsum[simp]:  "(sum 0 (Suc(n))) = ((sum 0 n) + (sum (Suc(n)) (Suc(n))))"
  apply(induct n)
   apply (simp)
  oops*)
lemma   "(sum 0 n) = (n*(n+1))div 2"
proof(induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then show ?case sorry
qed

lemma qsum: "(sum 0 n) = (n*(n+1))div 2"
  apply(induct n)
   apply (simp)
  quickcheck
                                                                                oops

(*3*)
lemma ll[simp]: "length (removeAll x xs) < Suc (length xs)"
  apply(induct xs)
   apply(auto)
  done

function perm::"nat list \<Rightarrow> nat list \<Rightarrow> bool"
  where "perm [] [] = True" |
"perm [] (y#ys) = False" |
"perm (x#xs) ys = perm (removeAll x xs) (removeAll x ys)"
  apply (metis list.exhaust subset_eq_mset_impl.cases)
  by (auto)
termination perm
 apply (relation "measure (\<lambda>(xs,xy). length(xs) )")
   apply auto
  done

(*4*)

datatype tree0 = Node tree0 tree0 | Nil

fun nodes :: "tree0 \<Rightarrow> nat" where
"nodes Nil = 0" |
"nodes (Node l r) = Suc(nodes l + nodes r)"

fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
"explode 0 t = t"|
"explode (Suc n) t = explode n (Node t t)"

value "nodes(explode 12 (Node Nil Nil))"
value "2^(12)*(Suc(nodes (Node Nil Nil)))-1"

lemma "nodes(explode n t) = 2^(n)*(Suc(nodes t)) - 1 "
  apply(induction n arbitrary: t)
  apply (auto)
  by (smt add.assoc  mult.assoc  mult.commute  mult_2_right)

(*5*)
fun itadd::"nat \<Rightarrow> nat \<Rightarrow> nat"  where
 "itadd 0 n = n" |
 "itadd (Suc m) n = itadd m (n + 1) "

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where "add 0 n = n " |
  "add (Suc m) n = Suc (add m n)"

value "itadd 14 17"
value "add 14 17"

lemma cum_add[simp]: "add m (Suc n) = Suc (add m n)"
  apply (induction m)
   apply auto
  done

lemma addEquals : "itadd m n = add m n"
apply (induction m  arbitrary: n)
  apply (auto)
  done

end


(*
Author:  Akihisa Yamada (2018-2019)
License: LGPL (see file COPYING.LESSER)
*)
section \<open> Completeness of Relations \<close>

text \<open>Here we formalize various order-theoretic completeness conditions.\<close>

theory Complete_Relations
  imports HOL.Real Binary_Relations
begin

subsection \<open>Completeness Conditions\<close>

text \<open>Order-theoretic completeness demands certain subsets of elements to admit suprema or infima.

A related set $\tp{A,\SLE}$ is called \emph{bounded} if there is a ``top'' element $\top \in A$,
a greatest element in $A$.
Note that there might be multiple tops if $(\SLE)$ is not antisymmetric.\<close>

locale bounded = less_eq_syntax + assumes bounded: "\<exists>t. \<forall>x. x \<sqsubseteq> t"
begin

lemma ex_bound[intro!]: "Ex (bound (\<sqsubseteq>) X)" using bounded by auto

lemma ex_extreme_UNIV[intro!]: "Ex (extreme (\<sqsubseteq>) UNIV)" using bounded by auto

lemma UNIV_complete[intro!]: "Ex (extreme_bound (\<sqsubseteq>) UNIV)" using bounded by blast

lemma dual_empty_complete[intro!]: "Ex (extreme_bound (\<sqsubseteq>)\<^sup>- {})" by (auto simp: bound_empty)

end

context
  fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
begin

lemma bounded_iff_extreme_UNIV: "bounded (\<sqsubseteq>) \<longleftrightarrow> Ex (extreme (\<sqsubseteq>) UNIV)"
  by (auto simp:bounded_def)

text\<open>Boundedness can be also seen as a completeness condition,
since it is equivalent to saying that the universe has a supremum.\<close>

lemma bounded_iff_UNIV_complete: "bounded (\<sqsubseteq>) \<longleftrightarrow> Ex (extreme_bound (\<sqsubseteq>) UNIV)"
  by (unfold bounded_def, blast)

text \<open>The dual notion of bounded is called ``pointed'', equivalently ensuring a supremum
of the empty set.\<close>

lemma pointed_iff_empty_complete: "bounded (\<sqsubseteq>) \<longleftrightarrow> Ex (extreme_bound (\<sqsubseteq>)\<^sup>- {})"
  by (auto simp:bounded_def)

end

text \<open>One of the most well-studied notion of completeness would be the semilattice condition:
every pair of elements $x$ and $y$ has a supremum $x \sqcup y$
(not necessarily unique if the underlying relation is not antisymmetric).\<close>

locale pair_complete = less_eq_syntax +
  assumes pair_complete: "Ex (extreme_bound (\<sqsubseteq>) {x,y})"
begin

lemma directed_UNIV[intro!]: "directed (\<sqsubseteq>) UNIV"
proof
  fix x y :: 'a
  from pair_complete[of x y] show "\<exists>z \<in> UNIV. x \<sqsubseteq> z \<and> y \<sqsubseteq> z" by auto
qed

end

sublocale total_reflexive \<subseteq> pair_complete
proof (unfold_locales)
  fix x y
  show "Ex (extreme_bound (\<sqsubseteq>) {x, y})" by (cases x y rule:comparable_cases, auto)
qed

text \<open>The next one assumes that every nonempty finite set has a supremum.\<close>

locale finite_complete = less_eq_syntax +
  assumes finite_nonempty_complete: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Ex (extreme_bound (\<sqsubseteq>) X)"

sublocale finite_complete \<subseteq> pair_complete
  by (unfold_locales, intro finite_nonempty_complete, auto)

text \<open>The next one assumes that every nonempty bounded set has a supremum.
It is also called the Dedekind completeness.\<close>

locale conditionally_complete = less_eq_syntax +
  assumes bounded_nonempty_complete:
  "Ex (bound (\<sqsubseteq>) X) \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Ex (extreme_bound (\<sqsubseteq>) X)"
begin

lemma bounded_nonemptyE[elim!]:
  assumes "Ex (bound (\<sqsubseteq>) X)" and "X \<noteq> {}"
    and "Ex (extreme_bound (\<sqsubseteq>) X) \<Longrightarrow> X \<noteq> {} \<Longrightarrow> thesis"
  shows thesis
  using assms bounded_nonempty_complete by auto

lemma nonempty_imp_complete_iff_bounded:
  assumes "X \<noteq> {}" shows "Ex (extreme_bound (\<sqsubseteq>) X) \<longleftrightarrow> Ex (bound (\<sqsubseteq>) X)"
  using assms by (auto intro: bounded_nonempty_complete)

end

text \<open>The $\omega$-completeness condition demands a supremum for an $\omega$-chain,
  $a_1 \sqsubseteq a_2 \sqsubseteq \dots$.
  We model $\omega$-chain as the range of a monotone map $f : i \mapsto a_i$.\<close>

locale omega_complete = less_eq_syntax +
  assumes monotone_seq_complete:
    "\<And>f :: nat \<Rightarrow> 'a. monotone (\<le>) (\<sqsubseteq>) f \<Longrightarrow> Ex (extreme_bound (\<sqsubseteq>) (range f))"

locale chain_complete = less_eq_syntax +
  assumes chain_nonempty_complete: "chain (\<sqsubseteq>) X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Ex (extreme_bound (\<sqsubseteq>) X)"
begin

lemma monotone_chain_complete:
  assumes C0: "C \<noteq> {}" and chain: "chain r C" and mono: "monotone r (\<sqsubseteq>) f"
  shows "Ex (extreme_bound (\<sqsubseteq>) (f ` C))"
  apply (rule chain_nonempty_complete[OF monotone_chain_image[OF mono chain]])
  using C0 by auto

end

sublocale chain_complete \<subseteq> omega_complete
  by (unfold_locales, rule monotone_chain_complete, auto intro:chainI)

text\<open>\emph{Directed completeness} is an important notion in domain theory~\cite{abramski94},
asserting that every nonempty directed set has a supremum.
Here, a set $X$ is \emph{directed} if any pair of two elements in $X$ has a bound in $X$.\<close>

locale directed_complete = less_eq_syntax +
  assumes directed_nonempty_complete: "directed (\<sqsubseteq>) X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Ex (extreme_bound (\<sqsubseteq>) X)"
begin

lemma monotone_directed_complete:
  assumes dir: "directed r C" and c0: "C \<noteq> {}" and mono: "monotone r (\<sqsubseteq>) f"
  shows "Ex (extreme_bound (\<sqsubseteq>) (f ` C))"
  apply (rule directed_nonempty_complete[OF monotone_directed_image[OF mono dir]])
  using c0 by auto

end

sublocale directed_complete \<subseteq> chain_complete
  by (unfold_locales, intro directed_nonempty_complete, auto dest: chain_imp_directed)

text \<open>The next one is quite complete, only the empty set may fail to have a supremum.
The terminology follows \cite{Bergman2015},
although there it is defined more generally depending on a cardinal $\alpha$
such that a nonempty set $X$ of cardinality below $\alpha$ has a supremum.\<close>

locale semicomplete = less_eq_syntax +
  assumes nonempty_complete: "X \<noteq> {} \<Longrightarrow> Ex (extreme_bound (\<sqsubseteq>) X)"

sublocale semicomplete \<subseteq> conditionally_complete + finite_complete + directed_complete
  by (unfold_locales, auto intro!: nonempty_complete)

sublocale semicomplete \<subseteq> bounded
  unfolding bounded_iff_UNIV_complete using nonempty_complete[of UNIV] by auto

subsection \<open>Pointed Ones\<close>

text \<open>The term `pointed' refers to the dual notion of boundedness, i.e., there is a global least element.
  This serves as the supremum of the empty set.\<close>

locale pointed_chain_complete = chain_complete + dual: bounded "(\<sqsubseteq>)\<^sup>-"
begin

lemma chain_complete: "chain (\<sqsubseteq>) X \<Longrightarrow> Ex (extreme_bound (\<sqsubseteq>) X)"
  by (cases "X = {}", auto intro:chain_nonempty_complete)

end

lemma pointed_chain_complete_def':
  fixes less_eq (infix "\<sqsubseteq>" 50)
  shows "pointed_chain_complete (\<sqsubseteq>) \<equiv> \<forall>X. chain (\<sqsubseteq>) X \<longrightarrow> Ex (extreme_bound (\<sqsubseteq>) X)" (is "?l \<equiv> ?r")
  apply (unfold atomize_eq, intro iffI)
  apply (force intro: pointed_chain_complete.chain_complete)
  by (unfold_locales, auto intro!: chain_empty simp: pointed_iff_empty_complete[unfolded bounded_def])

locale pointed_directed_complete = directed_complete + dual: bounded "(\<sqsubseteq>)\<^sup>-"
begin

lemma directed_complete: "directed (\<sqsubseteq>) X \<Longrightarrow> Ex (extreme_bound (\<sqsubseteq>) X)"
  by (cases "X = {}", auto intro: directed_nonempty_complete)

sublocale pointed_chain_complete ..

end

lemma pointed_directed_complete_def':
  fixes less_eq (infix "\<sqsubseteq>" 50)
  shows "pointed_directed_complete (\<sqsubseteq>) \<equiv> \<forall>X. directed (\<sqsubseteq>) X \<longrightarrow> Ex (extreme_bound (\<sqsubseteq>) X)"
  apply (unfold atomize_eq, intro iffI)
  apply (force intro: pointed_directed_complete.directed_complete)
  by (unfold_locales, auto simp: pointed_iff_empty_complete[unfolded bounded_def])

text \<open>``Bounded complete'' refers to pointed conditional complete,
but this notion is just the dual of semicompleteness. We prove this later.

Following is the strongest completeness that requires any subset of elements to have suprema
and infima.\<close>

locale complete = less_eq_syntax + assumes complete: "Ex (extreme_bound (\<sqsubseteq>) X)"
begin

sublocale semicomplete + pointed_directed_complete
  by (auto simp: pointed_directed_complete_def' intro: semicomplete.intro complete)

end

subsection \<open>Relations between Completeness Conditions\<close>

context
  fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
begin

interpretation less_eq_dualize.

text \<open>Pair-completeness implies that the universe is directed. Thus, with directed completeness
implies boundedness.\<close>

proposition directed_complete_pair_complete_imp_bounded:
  assumes "directed_complete (\<sqsubseteq>)" and "pair_complete (\<sqsubseteq>)"
  shows "bounded (\<sqsubseteq>)"
proof-
  from assms interpret directed_complete + pair_complete by auto
  have "Ex (extreme_bound (\<sqsubseteq>) UNIV)" by (rule directed_nonempty_complete, auto)
  then obtain t where "extreme_bound (\<sqsubseteq>) UNIV t" by auto
  then have "\<forall>x. x \<sqsubseteq> t" by auto
  then show ?thesis by (unfold_locales, auto)
qed

text \<open>Semicomplete is conditional complete and bounded.\<close>

proposition semicomplete_iff_conditionally_complete_bounded:
  "semicomplete (\<sqsubseteq>) \<longleftrightarrow> conditionally_complete (\<sqsubseteq>) \<and> bounded (\<sqsubseteq>)" (is "?l \<longleftrightarrow> ?r")
proof
  assume ?r
  then interpret conditionally_complete "(\<sqsubseteq>)" + bounded "(\<sqsubseteq>)" by auto
  show ?l by (unfold_locales, rule bounded_nonempty_complete, auto)
next
  assume ?l
  then interpret semicomplete.
  show ?r by (intro conjI, unfold_locales)
qed

proposition complete_iff_pointed_semicomplete:
  "complete (\<sqsubseteq>) \<longleftrightarrow> semicomplete (\<sqsubseteq>) \<and> bounded (\<sqsupseteq>)" (is "?l \<longleftrightarrow> ?r")
proof
  assume "complete (\<sqsubseteq>)"
  then interpret complete.
  show ?r by (intro conjI, unfold_locales)
next
  assume ?r
  then interpret semicomplete + bounded "(\<sqsupseteq>)" by auto
  show ?l
  proof
    fix X show "Ex (extreme_bound (\<sqsubseteq>) X)" by (cases "X = {}", auto intro:nonempty_complete)
  qed
qed

text \<open>Conditional completeness only lacks top and bottom to be complete.\<close>

proposition complete_iff_conditionally_complete_bounded_pointed:
  "complete (\<sqsubseteq>) \<longleftrightarrow> conditionally_complete (\<sqsubseteq>) \<and> bounded (\<sqsubseteq>) \<and> bounded (\<sqsupseteq>)"
  unfolding complete_iff_pointed_semicomplete
    semicomplete_iff_conditionally_complete_bounded by auto

end

text \<open>If the universe is directed, then every pair is bounded, and thus has a supremum.
  On the other hand, supremum gives an upper bound, witnessing directedness.\<close>

proposition (in conditionally_complete) pair_complete_iff_directed:
  "pair_complete (\<sqsubseteq>) \<longleftrightarrow> directed (\<sqsubseteq>) UNIV"
proof(intro iffI)
  assume "directed (\<sqsubseteq>) UNIV"
  then show "pair_complete (\<sqsubseteq>)"
    by (unfold_locales, intro bounded_nonempty_complete, auto elim: directedE)
next
  assume "pair_complete (\<sqsubseteq>)"
  then interpret pair_complete.
  show "directed (\<sqsubseteq>) UNIV"
  proof (intro directedI)
    fix x y
    from pair_complete obtain z where "extreme_bound (\<sqsubseteq>) {x,y} z" by auto
    then show "\<exists>z\<in>UNIV. x \<sqsubseteq> z \<and> y \<sqsubseteq> z" by auto
  qed
qed

subsection \<open>Completeness Results Requiring Order-Like Properties\<close>

text \<open>Above results hold without any assumption on the relation.
This part demands some order-like properties.\<close>

text \<open>It is well known that in a semilattice, i.e., a pair-complete partial order,
every finite nonempty subset of elements has a supremum.
We prove the result assuming transitivity, but only that.\<close>

locale trans_semilattice = transitive + pair_complete

sublocale trans_semilattice \<subseteq> finite_complete
  apply (unfold_locales)
  subgoal for X
  proof (induct X rule:finite_induct)
    case empty
    then show ?case by auto
  next
    case (insert x X)
    show ?case
    proof (cases "X = {}")
      case True
      obtain x' where "extreme_bound (\<sqsubseteq>) {x,x} x'" using pair_complete[of x x] by auto
      with True show ?thesis by (auto intro!: exI[of _ x'])
    next
      case False
      with insert obtain b where b: "extreme_bound (\<sqsubseteq>) X b" by auto
      from pair_complete obtain c where c: "extreme_bound (\<sqsubseteq>) {x,b} c" by auto
      show ?thesis
      proof (intro exI extreme_boundI)
        from c have "x \<sqsubseteq> c" and "b \<sqsubseteq> c" by auto
        with b show "xb \<in> insert x X \<Longrightarrow> xb \<sqsubseteq> c" for xb by (auto dest: trans)
        fix d assume "bound (\<sqsubseteq>) (insert x X) d"
        with b have "bound (\<sqsubseteq>) {x,b} d" by auto
        with c show "c \<sqsubseteq> d" by auto
      qed
    qed
  qed
done

text \<open>Gierz et al.~\cite{gierz03} showed that a directed complete partial order is semicomplete
if and only if it is also a semilattice.
We generalize the claim so that the underlying relation is only transitive.\<close>

proposition(in transitive) semicomplete_iff_directed_complete_pair_complete:
  "semicomplete (\<sqsubseteq>) \<longleftrightarrow> directed_complete (\<sqsubseteq>) \<and> pair_complete (\<sqsubseteq>)" (is "?l \<longleftrightarrow> ?r")
proof (intro iffI semicomplete.intro)
  assume ?l
  then interpret semicomplete.
  show ?r by (intro conjI, unfold_locales)
next
  assume ?r
  then interpret directed_complete + pair_complete by auto
  interpret trans_semilattice ..
  fix X :: "'a set"
  have 1: "directed (\<sqsubseteq>) {x. \<exists>Y \<subseteq> X. finite Y \<and> Y \<noteq> {} \<and> extreme_bound (\<sqsubseteq>) Y x}" (is "directed _ ?B")
  proof (intro directedI)
    fix a b assume a: "a \<in> ?B" and b: "b \<in> ?B"
    from a obtain A where A: "extreme_bound (\<sqsubseteq>) A a" "finite A" "A \<noteq> {}" "A \<subseteq> X" by auto
    from b obtain B where B: "extreme_bound (\<sqsubseteq>) B b" "finite B" "B \<noteq> {}" "B \<subseteq> X" by auto
    from A B have AB: "finite (A \<union> B)" "A \<union> B \<noteq> {}" "A \<union> B \<subseteq> X" by auto
    with finite_nonempty_complete have "Ex (extreme_bound (\<sqsubseteq>) (A \<union> B))" by auto
    then obtain c where c: "extreme_bound (\<sqsubseteq>) (A \<union> B) c" by auto
    show "\<exists>c \<in> ?B. a \<sqsubseteq> c \<and> b \<sqsubseteq> c"
    proof (intro bexI conjI)
      from A B c show "a \<sqsubseteq> c" and "b \<sqsubseteq> c" by (auto simp: extreme_bound_iff)
      from AB c show "c \<in> ?B" by (auto intro!: exI[of _ "A \<union> B"])
    qed
  qed
  assume "X \<noteq> {}"
  then obtain x where xX: "x \<in> X" by auto
  from finite_nonempty_complete[of "{x}"]
  obtain x' where "extreme_bound (\<sqsubseteq>) {x} x'" by auto
  with xX have x'B: "x' \<in> ?B" by (auto intro!: exI[of _ "{x}"] extreme_boundI)
  then have 2: "?B \<noteq> {}" by auto
  from directed_nonempty_complete[OF 1 2]
  obtain b where b: "extreme_bound (\<sqsubseteq>) ?B b" by auto
  show "Ex (extreme_bound (\<sqsubseteq>) X)"
  proof (intro exI extreme_boundI UNIV_I)
    fix x
    assume xX: "x \<in> X"
    from finite_nonempty_complete[of "{x}"]
    obtain c where c: "extreme_bound (\<sqsubseteq>) {x} c" by auto
    then have xc: "x \<sqsubseteq> c" by auto
    from c xX have cB: "c \<in> ?B" by (auto intro!: exI[of _ "{x}"] extreme_boundI)
    with b have cb: "c \<sqsubseteq> b" by auto
    from xc cb show "x \<sqsubseteq> b" by (rule trans) text\<open> Here transitivity is needed. \<close>
  next
    fix x
    assume Xx: "bound (\<sqsubseteq>) X x"
    have "bound (\<sqsubseteq>) ?B x"
    proof (intro boundI UNIV_I, clarify)
      fix c Y
      assume "finite Y" and YX: "Y \<subseteq> X" and "Y \<noteq> {}" and c: "extreme_bound (\<sqsubseteq>) Y c"
      from YX Xx have "bound (\<sqsubseteq>) Y x" by auto
      with c show "c \<sqsubseteq> x" by auto
    qed
    with b show "b \<sqsubseteq> x" by auto
  qed
qed

text\<open>The last argument in the above proof requires transitivity,
but if we had reflexivity then $x$ itself is a supremum of $\set{x}$
(see @{thm reflexive.extreme_bound_singleton}) and so $x \SLE s$ would be immediate.
Thus we can replace transitivity by reflexivity,
but then pair-completeness does not imply finite completeness.
We obtain the following result.\<close>

proposition (in reflexive) semicomplete_iff_directed_complete_finite_complete:
  "semicomplete (\<sqsubseteq>) \<longleftrightarrow> directed_complete (\<sqsubseteq>) \<and> finite_complete (\<sqsubseteq>)" (is "?l \<longleftrightarrow> ?r")
proof (intro iffI semicomplete.intro)
  assume ?l
  then interpret semicomplete.
  show ?r by (safe, unfold_locales)
next
  assume ?r
  then interpret directed_complete + finite_complete by auto
  fix X :: "'a set"
  have 1: "directed (\<sqsubseteq>) {x. \<exists>Y \<subseteq> X. finite Y \<and> Y \<noteq> {} \<and> extreme_bound (\<sqsubseteq>) Y x}" (is "directed _ ?B")
  proof (intro directedI)
    fix a b assume a: "a \<in> ?B" and b: "b \<in> ?B"
    from a obtain A where A: "extreme_bound (\<sqsubseteq>) A a" "finite A" "A \<noteq> {}" "A \<subseteq> X" by auto
    from b obtain B where B: "extreme_bound (\<sqsubseteq>) B b" "finite B" "B \<noteq> {}" "B \<subseteq> X" by auto
    from A B have AB: "finite (A \<union> B)" "A \<union> B \<noteq> {}" "A \<union> B \<subseteq> X" by auto
    with finite_nonempty_complete have "Ex (extreme_bound (\<sqsubseteq>) (A \<union> B))" by auto
    then obtain c where c: "extreme_bound (\<sqsubseteq>) (A \<union> B) c" by auto
    show "\<exists>c \<in> ?B. a \<sqsubseteq> c \<and> b \<sqsubseteq> c"
    proof (intro bexI conjI)
      from A B c show "a \<sqsubseteq> c" and "b \<sqsubseteq> c" by (auto simp: extreme_bound_iff)
      from AB c show "c \<in> ?B" by (auto intro!: exI[of _ "A \<union> B"])
    qed
  qed
  assume "X \<noteq> {}"
  then obtain x where xX: "x \<in> X" by auto
  then have "extreme_bound (\<sqsubseteq>) {x} x" by auto
  with xX have xB: "x \<in> ?B" by (auto intro!: exI[of _ "{x}"])
  then have 2: "?B \<noteq> {}" by auto
  from directed_nonempty_complete[OF 1 2]
  obtain b where b: "extreme_bound (\<sqsubseteq>) ?B b" by auto
  show "Ex (extreme_bound (\<sqsubseteq>) X)"
  proof (intro exI extreme_boundI UNIV_I)
    fix x
    assume xX: "x \<in> X"
    have x: "extreme_bound (\<sqsubseteq>) {x} x" by auto
    from x xX have cB: "x \<in> ?B" by (auto intro!: exI[of _ "{x}"])
    with b show "x \<sqsubseteq> b" by auto
  next
    fix x
    assume Xx: "bound (\<sqsubseteq>) X x"
    have "bound (\<sqsubseteq>) ?B x"
    proof (intro boundI UNIV_I, clarify)
      fix c Y
      assume "finite Y" and YX: "Y \<subseteq> X" and "Y \<noteq> {}" and c: "extreme_bound (\<sqsubseteq>) Y c"
      from YX Xx have "bound (\<sqsubseteq>) Y x" by auto
      with c show "c \<sqsubseteq> x" by auto
    qed
    with b show "b \<sqsubseteq> x" by auto
  qed
qed

locale complete_attractive = complete + attractive

locale complete_antisymmetric = complete + antisymmetric

sublocale complete_antisymmetric \<subseteq> complete_attractive ..

text \<open>Complete pseudo orders are called complete trellises~\cite{trellis},
but let us reserve the name for introducing classes (in the future).\<close>

locale complete_pseudo_order = complete + pseudo_order

sublocale complete_pseudo_order \<subseteq> complete_antisymmetric ..

text \<open>Finally, we (re)define complete lattices as a complete partial order.\<close>

locale complete_partial_order = complete + partial_order

sublocale complete_partial_order \<subseteq> trans_semilattice + complete_pseudo_order ..

subsection \<open>Relating to Classes\<close>

class ccomplete = ord + assumes "conditionally_complete (\<le>)"
begin

sublocale order: conditionally_complete using ccomplete_axioms unfolding class.ccomplete_def.

end

class complete_ord = ord + assumes "complete (\<le>)"
begin

interpretation order: complete using complete_ord_axioms unfolding class.complete_ord_def.

subclass ccomplete ..

sublocale order: complete ..

end

text \<open>Isabelle's class @{class conditionally_complete_lattice} is @{class ccomplete}.
The other direction does not hold, since for the former,
@{term "Sup {}"} and @{term "Inf {}"} are arbitrary even if there are top or bottom elements.\<close>

subclass (in conditionally_complete_lattice) ccomplete
proof
  fix X
  assume "Ex (upper_bound X)" and X0: "X \<noteq> {}"
  from this(1) have "bdd_above X" by auto
  from cSup_upper[OF _ this] cSup_least[OF X0]
  have "supremum X (Sup X)" by (intro extremeI boundI, auto)
  then show "Ex (supremum X)" by auto
qed

text \<open>Isabelle's class @{class complete_lattice} is precisely @{locale complete_partial_order}.\<close>

context complete_lattice begin

interpretation order: complete_partial_order
  by (unfold_locales, auto intro!: Sup_upper Sup_least Inf_lower Inf_greatest)

subclass complete_ord ..

sublocale order: complete_partial_order ..

end

subsection \<open>Duality of Completeness Conditions\<close>

text \<open>Conditional completeness is symmetric.\<close>

sublocale conditionally_complete \<subseteq> dual: conditionally_complete "(\<sqsubseteq>)\<^sup>-"
proof
  interpret less_eq_dualize.
  fix X :: "'a set"
  assume bound: "Ex (bound (\<sqsupseteq>) X)" and nonemp: "X \<noteq> {}"
  then have "Ex (bound (\<sqsubseteq>) {b. bound (\<sqsupseteq>) X b})" and "{b. bound (\<sqsupseteq>) X b} \<noteq> {}" by auto
  from bounded_nonempty_complete[OF this]
  obtain s where "extreme_bound (\<sqsubseteq>) {b. bound (\<sqsupseteq>) X b} s" by auto
  then show "Ex (extreme_bound (\<sqsupseteq>) X)" by (intro exI[of _ s] extremeI, auto)
qed

text \<open>Full completeness is symmetric.\<close>

sublocale complete \<subseteq> dual: complete "(\<sqsubseteq>)\<^sup>-"
proof
  fix X :: "'a set"
  obtain s where "extreme_bound (\<sqsubseteq>) {b. bound (\<sqsubseteq>)\<^sup>- X b} s" using complete by auto
  then show "Ex (extreme_bound (\<sqsubseteq>)\<^sup>- X)" by (intro exI[of _ s] extreme_boundI, auto)
qed

sublocale complete_attractive \<subseteq> dual: complete_attractive "(\<sqsubseteq>)\<^sup>-" ..

sublocale complete_antisymmetric \<subseteq> dual: complete_antisymmetric "(\<sqsubseteq>)\<^sup>-" ..

sublocale complete_pseudo_order \<subseteq> dual: complete_pseudo_order "(\<sqsubseteq>)\<^sup>-" ..

sublocale complete_partial_order \<subseteq> dual: complete_partial_order "(\<sqsubseteq>)\<^sup>-" ..

text \<open>Now we show that bounded completeness is the dual of semicompleteness.\<close>

context fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
begin

interpretation less_eq_dualize.

definition "bounded_complete \<equiv> \<forall>X. Ex (bound (\<sqsubseteq>) X) \<longrightarrow> Ex (extreme_bound (\<sqsubseteq>) X)"

lemma pointed_conditionally_complete_iff_bounded_complete:
  "conditionally_complete (\<sqsubseteq>) \<and> bounded (\<sqsupseteq>) \<longleftrightarrow> bounded_complete"
proof safe
  assume "bounded_complete"
  note * = this[unfolded bounded_complete_def, rule_format]
  from * show "conditionally_complete (\<sqsubseteq>)" by (unfold_locales, auto)
  from *[of "{}"] show "bounded (\<sqsupseteq>)" by (unfold_locales, auto simp:bound_empty)
next
  assume "conditionally_complete (\<sqsubseteq>)" and "bounded (\<sqsupseteq>)"
  then interpret conditionally_complete "(\<sqsubseteq>)" + dual: bounded "(\<sqsupseteq>)".
  show "bounded_complete" unfolding bounded_complete_def
  proof (intro allI impI)
    fix X
    assume X: "Ex (bound (\<sqsubseteq>) X)"
    show "Ex (extreme_bound (\<sqsubseteq>) X)"
    proof (cases "X = {}")
    case True
    then show ?thesis by auto
    next
      case False
      with bounded_nonempty_complete X show ?thesis by auto
    qed
  qed
qed

proposition bounded_complete_iff_dual_semicomplete:
  "bounded_complete \<longleftrightarrow> semicomplete (\<sqsupseteq>)"
proof (fold pointed_conditionally_complete_iff_bounded_complete, safe)
  assume "conditionally_complete (\<sqsubseteq>)" and "bounded (\<sqsupseteq>)"
  then interpret conditionally_complete + bounded "(\<sqsupseteq>)".
  from dual.conditionally_complete_axioms bounded_axioms
    semicomplete_iff_conditionally_complete_bounded
  show "semicomplete (\<sqsupseteq>)" by auto
next
  assume "semicomplete (\<sqsupseteq>)"
  then interpret semicomplete "(\<sqsupseteq>)".
  show "conditionally_complete (\<sqsubseteq>)" ..
  show "bounded (\<sqsupseteq>)" ..
qed

end

subsection \<open>Completeness in Function Spaces\<close>

text \<open>Here we lift completeness to functions. As we do not assume an operator to choose suprema,
we need the axiom of choice for most of the following results. In antisymmetric cases we do not
need the axiom but we do not formalize this fact.\<close>

lemma (in bounded) bounded_fun[intro!]: "bounded (fun_ord (\<sqsubseteq>))"
proof-
  from bounded obtain t where "\<forall>x. x \<sqsubseteq> t" by auto
  then have "\<forall>f. fun_ord (\<sqsubseteq>) f (\<lambda>x. t)" by (auto intro: fun_ordI)
  then show ?thesis by (auto intro: bounded.intro)
qed

lemma (in pair_complete) pair_complete_fun[intro!]:
  "pair_complete (fun_ord (\<sqsubseteq>) :: ('i \<Rightarrow> _) \<Rightarrow> _)"
proof
  fix f g :: "'i \<Rightarrow> _"
  from pair_complete have "\<forall>x. \<exists>sx. extreme_bound (\<sqsubseteq>) {f x, g x} sx" by auto
  from choice[OF this]
  obtain s where "\<forall>x. extreme_bound (\<sqsubseteq>) {f x, g x} (s x)" by auto
  then show "Ex (extreme_bound (fun_ord (\<sqsubseteq>)) {f, g})"
    by (unfold fun_extreme_bound_iff, intro exI[of _ s], auto 1 4)
qed

lemma (in finite_complete) finite_complete_fun[intro!]:
  "finite_complete (fun_ord (\<sqsubseteq>) :: ('i \<Rightarrow> 'a) \<Rightarrow> _)"
proof
  fix F :: "('i \<Rightarrow> 'a) set"
  assume "finite F" and "F \<noteq> {}"
  with finite_nonempty_complete
  have "\<forall>x. \<exists>sx. extreme_bound (\<sqsubseteq>) {f x |. f \<in> F} sx" by auto
  from choice[OF this]
  show "Ex (extreme_bound (fun_ord (\<sqsubseteq>)) F)" by (unfold fun_extreme_bound_iff, auto)
qed

lemma (in omega_complete) omega_complete_fun[intro!]:
  "omega_complete (fun_ord (\<sqsubseteq>) :: ('i \<Rightarrow> 'a) \<Rightarrow> _)"
proof
  fix ff :: "nat \<Rightarrow> 'i \<Rightarrow> 'a"
  assume ff: "monotone (\<le>) (fun_ord (\<sqsubseteq>)) ff"
  then have "\<forall>i. Ex (extreme_bound (\<sqsubseteq>) {ff n i |. n})"
    by (intro allI monotone_seq_complete, auto simp: monotone_def fun_ord_def)
  from choice[OF this]
  obtain s where "\<forall>i. extreme_bound (\<sqsubseteq>) {ff n i |. n} (s i)" by auto
  then have "extreme_bound (fun_ord (\<sqsubseteq>)) (range ff) s"
    by (auto simp: fun_extreme_bound_iff image_image)
  then show "Ex (extreme_bound (fun_ord (\<sqsubseteq>)) (range ff))" by auto
qed

lemma (in chain_complete) chain_complete_fun[intro!]:
  "chain_complete (fun_ord (\<sqsubseteq>) :: ('i \<Rightarrow> 'a) \<Rightarrow> _)"
proof
  fix F :: "('i \<Rightarrow> 'a) set"
  assume F: "chain (fun_ord (\<sqsubseteq>)) F" and "F \<noteq> {}"
  then have "\<forall>i. Ex (extreme_bound (\<sqsubseteq>) {f i |. f \<in> F})"
    by (intro allI chain_nonempty_complete, auto simp: chain_def fun_ord_def)
  from choice[OF this]
  obtain s where "\<forall>i. extreme_bound (\<sqsubseteq>) {f i |. f \<in> F} (s i)" by auto
  then show "Ex (extreme_bound (fun_ord (\<sqsubseteq>)) F)" by (auto simp: fun_extreme_bound_iff)
qed

lemma (in directed_complete) directed_complete_fun[intro!]:
  "directed_complete (fun_ord (\<sqsubseteq>) :: ('i \<Rightarrow> 'a) \<Rightarrow> _)"
proof
  fix F :: "('i \<Rightarrow> 'a) set"
  assume dir: "directed (fun_ord (\<sqsubseteq>)) F" and F0: "F \<noteq> {}"
  have "\<forall>i. Ex (extreme_bound (\<sqsubseteq>) {f i |. f \<in> F})"
  proof (intro allI directed_nonempty_complete directedI, safe)
    fix i f g assume "f \<in> F" "g \<in> F"
    with dir obtain h
      where h: "h \<in> F" and "fun_ord (\<sqsubseteq>) f h" and "fun_ord (\<sqsubseteq>) g h" by (auto elim:directedE)
    then have "f i \<sqsubseteq> h i" and "g i \<sqsubseteq> h i" by (auto dest: fun_ordD)
    with h show "\<exists>hi\<in>{f i |. f \<in> F}. f i \<sqsubseteq> hi \<and> g i \<sqsubseteq> hi" by (intro bexI[of _ "h i"], auto)
  qed (insert F0, auto)
  from choice[OF this]
  obtain s where "\<forall>i. extreme_bound (\<sqsubseteq>) {f i |. f \<in> F} (s i)" by auto
  then show "Ex (extreme_bound (fun_ord (\<sqsubseteq>)) F)" by (auto simp: fun_extreme_bound_iff)
qed

lemma (in conditionally_complete) conditionally_complete_fun[intro!]:
  "conditionally_complete (fun_ord (\<sqsubseteq>) :: ('i \<Rightarrow> 'a) \<Rightarrow> _)"
proof
  fix F :: "('i \<Rightarrow> 'a) set"
  assume bF: "Ex (bound (fun_ord (\<sqsubseteq>)) F)" and F: "F \<noteq> {}"
  from bF obtain b where b: "bound (fun_ord (\<sqsubseteq>)) F b" by auto
  have "\<forall>x. \<exists>sx. extreme_bound (\<sqsubseteq>) {f x |. f \<in> F} sx"
  proof
    fix x
    from b have "bound (\<sqsubseteq>) {f x |. f \<in> F} (b x)" by (auto simp: fun_ord_def)
    with bounded_nonempty_complete F
    show "Ex (extreme_bound (\<sqsubseteq>) {f x |. f \<in> F})" by auto
  qed
  from choice[OF this]
  show "Ex (extreme_bound (fun_ord (\<sqsubseteq>)) F)" by (unfold fun_extreme_bound_iff, auto)
qed

lemma (in semicomplete) semicomplete_fun[intro!]: "semicomplete (fun_ord (\<sqsubseteq>))"
  by (auto simp: semicomplete_iff_conditionally_complete_bounded)

lemma (in pointed_chain_complete) pointed_chain_complete_fun[intro!]:
  "pointed_chain_complete (fun_ord (\<sqsubseteq>))"
  by (auto intro!: pointed_chain_complete.intro simp: dual_fun_ord)

lemma (in pointed_directed_complete) pointed_directed_complete_fun[intro!]:
  "pointed_directed_complete (fun_ord (\<sqsubseteq>))"
  by (auto intro!: pointed_directed_complete.intro simp: dual_fun_ord)

lemma (in complete) complete_fun[intro!]: "complete (fun_ord (\<sqsubseteq>))"
  by (auto simp: complete_iff_pointed_semicomplete dual_fun_ord)

subsection \<open>Interpretations\<close>

context complete_lattice begin

lemma Sup_eq_The_supremum: "Sup X = The (supremum X)"
  using order.complete[unfolded order.dual.ex_extreme_iff_ex1]
  by (rule the1_equality[symmetric], auto intro!: Sup_upper Sup_least)

lemma Inf_eq_The_infimum: "Inf X = The (infimum X)"
  using order.dual.complete[unfolded order.ex_extreme_iff_ex1]
  by (rule the1_equality[symmetric], auto intro!: Inf_lower Inf_greatest)

end

instance real :: ccomplete by (intro_classes, unfold_locales)

instance "fun" :: (type, ccomplete) ccomplete by (intro_classes, fold fun_ord_le, auto)

instance "fun" :: (type, complete_ord) complete_ord by (intro_classes, fold fun_ord_le, auto)

end


(* From Isabelle exercsises http://isabelle.in.tum.de/exercises/ *)
theory TreeTraversal
imports "$HIPSTER_HOME/IsaHipster"

begin

datatype 'a Tree =
  Tip 'a
  | Node 'a  "'a Tree" "'a Tree"

fun preOrder :: "'a Tree \<Rightarrow> 'a list" where
  "preOrder (Tip a)      = [a]"
| "preOrder (Node a l r) = a#((preOrder l)@(preOrder r))"

fun postOrder :: "'a Tree  \<Rightarrow>  'a list" where
  "postOrder (Tip a)      = [a]"
| "postOrder (Node a l r) = (postOrder l)@(postOrder r)@[a]"

fun inOrder :: "'a Tree  \<Rightarrow> 'a list" where
  "inOrder (Tip a)      = [a]"
| "inOrder (Node a l r) = (inOrder l)@[a]@(inOrder r)"

fun mirror :: "'a Tree => 'a Tree"
where
  "mirror (Tip x) = Tip x"
| "mirror (Node a l r) = Node a (mirror r) (mirror l)"

hipster mirror rev preOrder postOrder inOrder
lemma lemma_a [thy_expl]: "mirror (mirror y) = y"
  apply (induct y)
  apply simp
  apply simp
  done

lemma lemma_aa [thy_expl]: "rev (inOrder y) = inOrder (mirror y)"
  apply (induct y)
  apply simp
  apply simp
  done

lemma lemma_ab [thy_expl]: "rev (postOrder y) = preOrder (mirror y)"
  apply (induct y)
  apply simp
  apply simp
  done

fun root :: "'a Tree \<Rightarrow> 'a" where
  "root (Tip a)      = a"
| "root (Node f x y) = f"

fun leftmost :: "'a Tree \<Rightarrow> 'a" where
  "leftmost (Tip a)      = a"
| "leftmost (Node f x y) = (leftmost x)"

fun rightmost :: "'a Tree \<Rightarrow> 'a" where
  "rightmost (Tip a)      = a"
| "rightmost (Node f x y) = (rightmost y)"

  setup Tactic_Data.set_induct_sledgehammer
hipster root hd last leftmost rightmost inOrder
lemma lemma_ac [thy_expl]: "last (inOrder y) = rightmost y"
  apply (induct y)
  apply simp
  apply simp
  apply (metis append_is_Nil_conv inOrder.simps(1) inOrder.simps(2) rightmost.elims snoc_eq_iff_butlast)
  done

lemma lemma_ad [thy_expl]: "hd (inOrder z @ y) = leftmost z"
  apply (induct z arbitrary: y)
  apply simp
  apply simp
  done

lemma lemma_ae [thy_expl]: "last (y @ inOrder z) = rightmost z"
  apply (induct y arbitrary: z)
  apply simp
  apply (simp add: TreeTraversal.lemma_ac)
  apply simp
  apply (metis append_is_Nil_conv inOrder.simps(1) inOrder.simps(2) list.simps(3) rightmost.elims)
  done
(*

(*
With this tactic, we don't use Sledgehammer in the "Easy tactic", so we get more results.
*)
setup Tactic_Data.set_sledge_induct_sledge
hipster root hd last leftmost rightmost inOrder

lemma lemma_ac [thy_expl]: "hd (inOrder y) = leftmost y"
  apply (induct y)
apply simp
apply simp
apply (metis append_is_Nil_conv hd_append2 inOrder.simps(1) inOrder.simps(2) leftmost.elims self_append_conv2 snoc_eq_iff_butlast)
done

lemma lemma_ad [thy_expl]: "last (inOrder y) = rightmost y"
apply (induct y)
  apply simp
  apply simp
apply (metis append_is_Nil_conv inOrder.simps(1) inOrder.simps(2) rightmost.elims snoc_eq_iff_butlast)
done

lemma lemma_ae [thy_expl]: "hd (inOrder z @ y) = leftmost z"
apply (metis (no_types, lifting) TreeTraversal.lemma_ac append_is_Nil_conv hd_append2 inOrder.simps(1) inOrder.simps(2) leftmost.elims snoc_eq_iff_butlast)
done

lemma lemma_af [thy_expl]: "last (y @ inOrder z) = rightmost z"
apply (induct y arbitrary: z)
apply simp
apply (simp add: lemma_ad)
apply simp
apply (metis append_is_Nil_conv inOrder.simps(1) inOrder.simps(2) list.simps(3) rightmost.elims)
done
*)


theory More_Lattices_Big
  imports Main
begin

lemma ex_max_if_finite:
  "\<lbrakk> finite S; S \<noteq> {} \<rbrakk> \<Longrightarrow> \<exists>m\<in>S. \<not>(\<exists>x\<in>S. (m::'a::order) < x)"
  by (induction rule: finite.induct)
     (auto intro: order.strict_trans)

lemma ex_is_arg_max_if_finite: fixes f :: "'a \<Rightarrow> 'b :: order"
  shows "\<lbrakk> finite S; S \<noteq> {} \<rbrakk> \<Longrightarrow> \<exists>x. is_arg_max f (\<lambda>x. x \<in> S) x"
  unfolding is_arg_max_def
  using ex_max_if_finite[of "f ` S"]
  by auto

lemma arg_max_SOME_Max:
  "finite S \<Longrightarrow> arg_max_on f S = (SOME y. y \<in> S \<and> f y = Max (f ` S))"
  unfolding arg_max_on_def arg_max_def is_arg_max_linorder
  by (auto intro!: arg_cong[where f = Eps] Max_eqI[symmetric] simp: fun_eq_iff)

lemma arg_max_if_finite: fixes f :: "'a \<Rightarrow> 'b :: order"
  assumes "finite S" "S \<noteq> {}"
  shows "arg_max_on f S \<in> S" and "\<not>(\<exists>x\<in>S. f (arg_max_on f S) < f x)"
  using ex_is_arg_max_if_finite[OF assms, of f]
  unfolding arg_max_on_def arg_max_def is_arg_max_def
  by (auto dest!: someI_ex)

lemma arg_max_greatest: fixes f :: "'a \<Rightarrow> 'b :: linorder"
  shows "\<lbrakk> finite S; y \<in> S \<rbrakk> \<Longrightarrow> f y \<le> f (arg_max_on f S)"
proof -
  assume "finite S" "y \<in> S"
  then have "S \<noteq> {}"
    by blast

  from \<open>y \<in> S\<close> show ?thesis
    using arg_max_if_finite[OF \<open>finite S\<close> \<open>S \<noteq> {}\<close>]
    by (auto intro: leI)
qed

end


(*  Title:      HOL/ex/BT.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1995  University of Cambridge

Binary trees
*)

section {* Binary trees *}

theory BT imports Main begin

datatype 'a bt =
    Lf
  | Br 'a  "'a bt"  "'a bt"

primrec n_nodes :: "'a bt => nat" where
  "n_nodes Lf = 0"
| "n_nodes (Br a t1 t2) = Suc (n_nodes t1 + n_nodes t2)"

primrec n_leaves :: "'a bt => nat" where
  "n_leaves Lf = Suc 0"
| "n_leaves (Br a t1 t2) = n_leaves t1 + n_leaves t2"

primrec depth :: "'a bt => nat" where
  "depth Lf = 0"
| "depth (Br a t1 t2) = Suc (max (depth t1) (depth t2))"

primrec reflect :: "'a bt => 'a bt" where
  "reflect Lf = Lf"
| "reflect (Br a t1 t2) = Br a (reflect t2) (reflect t1)"

primrec bt_map :: "('a => 'b) => ('a bt => 'b bt)" where
  "bt_map f Lf = Lf"
| "bt_map f (Br a t1 t2) = Br (f a) (bt_map f t1) (bt_map f t2)"

primrec preorder :: "'a bt => 'a list" where
  "preorder Lf = []"
| "preorder (Br a t1 t2) = [a] @ (preorder t1) @ (preorder t2)"

primrec inorder :: "'a bt => 'a list" where
  "inorder Lf = []"
| "inorder (Br a t1 t2) = (inorder t1) @ [a] @ (inorder t2)"

primrec postorder :: "'a bt => 'a list" where
  "postorder Lf = []"
| "postorder (Br a t1 t2) = (postorder t1) @ (postorder t2) @ [a]"

primrec append :: "'a bt => 'a bt => 'a bt" where
  "append Lf t = t"
| "append (Br a t1 t2) t = Br a (append t1 t) (append t2 t)"

text {* \medskip BT simplification *}

lemma n_leaves_reflect: "n_leaves (reflect t) = n_leaves t"
  apply (induct t)
   apply auto
  done

lemma n_nodes_reflect: "n_nodes (reflect t) = n_nodes t"
  apply (induct t)
   apply auto
  done

lemma depth_reflect: "depth (reflect t) = depth t"
  apply (induct t)
   apply auto
  done

text {*
  The famous relationship between the numbers of leaves and nodes.
*}

lemma n_leaves_nodes: "n_leaves t = Suc (n_nodes t)"
  apply (induct t)
   apply auto
  done

lemma reflect_reflect_ident: "reflect (reflect t) = t"
  apply (induct t)
   apply auto
  done

lemma bt_map_reflect: "bt_map f (reflect t) = reflect (bt_map f t)"
  apply (induct t)
   apply simp_all
  done

lemma preorder_bt_map: "preorder (bt_map f t) = map f (preorder t)"
  apply (induct t)
   apply simp_all
  done

lemma inorder_bt_map: "inorder (bt_map f t) = map f (inorder t)"
  apply (induct t)
   apply simp_all
  done

lemma postorder_bt_map: "postorder (bt_map f t) = map f (postorder t)"
  apply (induct t)
   apply simp_all
  done

lemma depth_bt_map [simp]: "depth (bt_map f t) = depth t"
  apply (induct t)
   apply simp_all
  done

lemma n_leaves_bt_map [simp]: "n_leaves (bt_map f t) = n_leaves t"
  apply (induct t)
   apply (simp_all add: distrib_right)
  done

lemma preorder_reflect: "preorder (reflect t) = rev (postorder t)"
  apply (induct t)
   apply simp_all
  done

lemma inorder_reflect: "inorder (reflect t) = rev (inorder t)"
  apply (induct t)
   apply simp_all
  done

lemma postorder_reflect: "postorder (reflect t) = rev (preorder t)"
  apply (induct t)
   apply simp_all
  done

text {*
 Analogues of the standard properties of the append function for lists.
*}

lemma append_assoc [simp]:
     "append (append t1 t2) t3 = append t1 (append t2 t3)"
  apply (induct t1)
   apply simp_all
  done

lemma append_Lf2 [simp]: "append t Lf = t"
  apply (induct t)
   apply simp_all
  done

lemma depth_append [simp]: "depth (append t1 t2) = depth t1 + depth t2"
  apply (induct t1)
   apply (simp_all add: max_add_distrib_left)
  done

lemma n_leaves_append [simp]:
     "n_leaves (append t1 t2) = n_leaves t1 * n_leaves t2"
  apply (induct t1)
   apply (simp_all add: distrib_right)
  done

lemma bt_map_append:
     "bt_map f (append t1 t2) = append (bt_map f t1) (bt_map f t2)"
  apply (induct t1)
   apply simp_all
  done

end


(* $Id$ *)
(*<*)
theory HEAP1
imports HEAP0
begin
(*>*)
subsection \<open> Heap level 1 \label{s:isa:models:level1}\<close>

text\<open>

 Firstly, we define a type type synonym for the state of the free store
 at level 1 to be a map from locations to sizes:
\<close>

type_synonym F1 = "Loc \<rightharpoonup> nat"

subsubsection\<open> Auxillary functions \label{s:isa:models:level1:aux} \<close>

text\<open>
Note that the size is only @{type nat} here so, as mentioned earlier, we must extend the
@{const nat1} predicate to operate on maps and sets to ensure that the model is consistent
with VDM:
\<close>

definition
  nat1_map :: "F1 \<Rightarrow> bool"
where
  "nat1_map f \<equiv> (\<forall> x. x \<in> dom f \<longrightarrow> nat1 (the (f x)))"

definition
  nat1_set :: "(nat set) \<Rightarrow> bool"
where
  "nat1_set S \<equiv> (\<forall> x. x \<in> S \<longrightarrow> nat1 x)"

text\<open>
The level 1 model introduces a new auxiliary function, \emph{locs}
that returns the set of all free locations withing a given map. We define the \emph{locs}
function using a union over the elements in the domain of the VDM map.
It is wrapped inside a conditional expression, however,
in order to ensure that the map is appropriately a @{text nat1_map}:
\<close>

definition
  locs :: "(Loc \<rightharpoonup> nat) \<Rightarrow> Loc set "
where
  "locs sm \<equiv> (if nat1_map sm then
                \<Union> s \<in> dom sm. locs_of s (the (sm s))
               else
                 undefined)" (* TODO: or {}?*)

text\<open>
  It is otherwise @{term undefined}, which is a polymorphic constant in Isabelle.
  That is, the VDM model uses a total map to @{text "\<nat>\<^sub>1"}, whereas here we can only
  use a map to @{text "\<nat>"} as a parameter. Thus, we totalise the definition of @{term locs}
  by giving it a bottom element (as Isabelle's @{term undefined}) when the expected type fails.

  It is important to emphasise this is not VDM's notion of undefinedness. For instance, it is
  possible to prove that @{lemma "undefined=undefined" by simp} in Isabelle, which is not true
  in VDM's three-valued logic. Thus, @{term undefined} should never feature in our proofs. If it
  does, it means we made some mistake somewhere by applying a function to the wrong type. For
  further discussion on the subtleties of handling partial functions, see
 \cite{Jones95e,SchmalzPhD}.
\<close>

subsubsection\<open> Invariant \<close>
text\<open>
\noindent Recall the level 1 invariant in Section~\ref{S-model-pp-l1}:

\begin{vdm}
\rtype{Free1}{\mapof{Loc}{\Nati}}{
      (f) \DeF \\
\forall*{l, l' \in \dom{f}}{l \neq l' \Implies is-disj(locs-of(l, f(l)), locs-of(l', f(l'))) \And} \\
\forall{l \in \dom{f}}{(l + f(l) ) \notin \dom{f}}
}
\end{vdm}

It contains two components (a conjunction):
\begin{itemize}
\item \emph{Disjoint}: that the locations defined by each element in the
map are disjoint;
\item and, \emph{sep}: that the locations defined by elements do not
abut on any end.
\end{itemize}

\noindent We encode these as individual definitions in Isabelle: \<close>
(*<*)
definition
  Locs_of :: "F1 \<Rightarrow> Loc \<Rightarrow> (Loc set)"
where
  "Locs_of f l \<equiv> (if (l \<in> dom f) then
                    locs_of l (the (f l))
                  else
                    undefined)"  (* TODO: or {}? *)

definition
  disjoint :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool"
where
 "disjoint A B \<equiv> A \<inter> B = {}"
(*>*)

definition
  Disjoint :: "F1 \<Rightarrow> bool"
where
 "Disjoint f \<equiv>
      (\<forall> a \<in> dom f. \<forall> b \<in> dom f . a \<noteq> b \<longrightarrow> disjoint (Locs_of f a) (Locs_of f b))"

definition
  sep :: "F1 \<Rightarrow> bool"
where
  "sep f \<equiv> (\<forall> l \<in> dom f . l + the(f l) \<notin> dom f)"

text\<open>
\noindent where @{term "disjoint A B"} is the same as @{term "A \<inter> B = \<emptyset>"}, and
@{term "Locs_of f a"} is the same as @{term "locs_of a (the(f a))"}.

Albeit trivial, this decomposition into separate concepts is invaluable in taming
the goal complexity during proofs (see discussion in Section~\ref{S-TP-exp}). They
create what we call ``zoom'' levels of interest/discourse. For instance, we create
various lemmas about these definitions and their relationship with, say @{term locs_of}
and @{term locs} or set theory and map operators. So, in actual POs, these issues
of mechanisation are already distilled and resolved.

We must also, however, have additional components to the invariant.
They are the implicit VDM notion of finiteness of maps and sets, and the
subtype checking on map range type for @{text "\<nat>\<^sub>1"}.

\begin{itemize}
\item \emph{nat1\_map}: that the state doesn't contain any
locations that map to size 0.
\item \emph{finite domain}: that the domain of the map is finite, similarly to level 0 state.
\end{itemize}

\noindent Thus, the invariant definition is as follows:
 \<close>

definition
  F1_inv :: "F1 \<Rightarrow> bool"
where
(*<*)  [intro!]:  (*>*) "F1_inv f \<equiv> Disjoint f \<and> sep f \<and> nat1_map f \<and> finite(dom f)"

definition
  VDM_F1_inv :: "F1 \<Rightarrow> bool"
where
  "VDM_F1_inv f \<equiv> Disjoint f \<and> sep f "

text\<open>
\noindent We also define the VDM invariant, as we may wish to discharge the
Isabelle parts the invariant first (finiteness etc), as they are often
simpler. We provide a lemma to `shape' the goal as such:

%\plannote{LF: IJW, didn't follow underline above. Isn't it the other way roung? I.e. VDM_F1_inv
%is harder to prove than the other trivial bits?}
%IJW: I've reworded this. I agree: I was trying to say the conditions that arise from the translation
%is simpler.
\<close>
lemma invF1_shape: "nat1_map f \<Longrightarrow> finite (dom f) \<Longrightarrow> VDM_F1_inv f\<Longrightarrow> F1_inv f"
unfolding F1_inv_def VDM_F1_inv_def by simp

text\<open>
\noindent Such proof decomposition is again essential for automation and proof strategy reuse,
as it informs (meta-)data collection (see Chapter~\ref{C-why} on meta-data and
Chapter~\ref{C-isaproofs} on Isabelle proofs).

Furthermore, we define introduction and elimination rules
to help unfold the invariant; we also provide weakening rules
for the case that only one part of the invariant is required
(we only show the @{term sep} version here):
\<close>
(*<*)
lemma invVDMF1[intro!]: "sep f \<Longrightarrow> Disjoint f \<Longrightarrow> VDM_F1_inv f"
 unfolding VDM_F1_inv_def by simp
(*>*)
lemma invF1E[elim!]: "F1_inv f \<Longrightarrow> (sep f \<Longrightarrow> Disjoint f \<Longrightarrow> nat1_map f \<Longrightarrow> finite (dom f) \<Longrightarrow> R) \<Longrightarrow> R"
 unfolding F1_inv_def by simp

lemma invF1I[intro!]: "sep f \<Longrightarrow> Disjoint f \<Longrightarrow> nat1_map f \<Longrightarrow> finite (dom f) \<Longrightarrow> F1_inv f"
 unfolding F1_inv_def by simp

lemma invF1_sep_weaken: "F1_inv f \<Longrightarrow> sep f"
  unfolding F1_inv_def by simp
(*<*)
lemma invF1_Disjoint_weaken: "F1_inv f \<Longrightarrow> Disjoint f"
  unfolding F1_inv_def by simp

lemma invF1_nat1_map_weaken: "F1_inv f \<Longrightarrow> nat1_map f"
  unfolding F1_inv_def by simp

lemma invF1_finite_weaken: "F1_inv f \<Longrightarrow> finite (dom  f)"
  unfolding F1_inv_def by simp
(*>*)
(*
text\<open>
  Weakening rules are for both forward and backward reasoning and is part of our armory
  of proof patterns.

%  \plannote{LF: I am seeing these comments on proof patterns scattered around various parts of text.
%  This is okay, yet I am worried reader won't get a cohesive understanding of what they are about.
%  Perhaps at least a section somewhere summarising them, and a pointer to the other TR/paper? Comments?}
\<close>
*)
(* More unnecessary stuff *)
(*<*)
(*------------------------------------------------------------------------*)
subsection \<open> Alternative definitions \<close>
(*------------------------------------------------------------------------*)

definition
  Locs_of2 :: "F1 \<Rightarrow> Loc \<Rightarrow> (Loc set)"
where
  "l \<in> dom f \<Longrightarrow> nat1 (the(f l)) \<Longrightarrow> Locs_of2 f l \<equiv> locs_of l (the (f l))"

definition
  Disjoint2 :: "F1 \<Rightarrow> bool"
where
 "Disjoint2 f \<equiv>
      (\<forall> a \<in> dom f. \<forall> b \<in> dom f . a \<noteq> b \<longrightarrow>
        disjoint (locs_of a (the(f a))) (locs_of b (the(f b))))"

(*code_type F1(Scala)*)

(*========================================================================*)
section \<open> VDM function definitions \<close>
(*========================================================================*)
(*>*)

subsubsection\<open> NEW operation\<close>

text\<open>
Following the style of level 0 in Section~\ref{s:isa:models:level0}, we create definitions
for the pre and post-conditions for the operations. We split
the NEW post-condition into two separate definitions, corresponding to each disjunct
in the VDM operation. Again, this is useful for proof decomposition within POs and also
to help identify hidden case analysis, another of our proof patterns.
\<close>

definition
  new1_pre :: "F1 \<Rightarrow> nat \<Rightarrow> bool"
where
  "new1_pre f s \<equiv> (\<exists> l \<in> dom f . the(f l) \<ge> s)"

definition
   new1_post_eq :: "F1 \<Rightarrow> nat \<Rightarrow> F1 \<Rightarrow> Loc \<Rightarrow> bool"
where
   "new1_post_eq f s f' r \<equiv> r \<in> dom f \<and> the(f r) = s \<and> f' = {r} -\<triangleleft> f"

definition
   new1_post_gr :: "F1 \<Rightarrow> nat \<Rightarrow> F1 \<Rightarrow> Loc \<Rightarrow> bool"
where
   "new1_post_gr f s f' r \<equiv> r \<in> dom f \<and> the(f r) > s \<and>
                            f' = ({r} -\<triangleleft> f) \<union>m [r + s \<mapsto> the(f r) - s]"

definition
   new1_post :: "F1 \<Rightarrow> nat \<Rightarrow> F1 \<Rightarrow> Loc \<Rightarrow> bool"
where
   "new1_post f s f' r \<equiv> new1_post_eq f s f' r \<or> new1_post_gr f s f' r"

subsubsection\<open> DISPOSE operation \<close>
text\<open>
Before showing the locale definitions corresponding to the $DISPOSE1$
operation, we create auxiliary definitions for dispose. The way these came
about is discussed in Section~\ref{S-TP-exp}. First are the
two auxilliary functions called \emph{sum\_size} and \emph{min\_loc}
which are used in the postcondition are defined using Isabelle's operators
for set minimal and summation, respectively.
\<close>
definition
   min_loc :: "(Loc \<rightharpoonup> nat) \<Rightarrow> nat"
where
   "min_loc sm = (if sm \<noteq> Map.empty then
                      Min (dom sm)
                  else
                      undefined)"

definition
  sum_size :: "(Loc \<rightharpoonup> nat) \<Rightarrow> nat"
where
  "sum_size sm = (if sm \<noteq> Map.empty then
                      (\<Sum> x\<in>(dom sm) . the (sm x))
                  else
                      undefined)" (*TODO: or 0? *)
text\<open>
Once again, we used Isabelle's @{term undefined} to enable a total function over a subtype,
as we did for @{term locs}.

We have two versions of the postconditions: the exact translation from
the VDM specification and a version where \emph{above}, \emph{below}, and \emph{ext}
are given as definitions. The latter definition makes proof more straightforward
since we can refer to the maps by name and unfold where necessary. We do, of course,
prove both definitions equivalent. This is another example of zooming:~the use of
different levels of interest in involved operators, that is based on the problem at hand,
and is useful in helping proof decomposition and lemma discovery for higher automation.
\<close>
definition
   dispose1_pre :: "F1 \<Rightarrow> Loc \<Rightarrow> nat \<Rightarrow> bool"
where
  "dispose1_pre f d s \<equiv> disjoint (locs_of d s) (locs f)"

definition
   dispose1_post :: "F1 \<Rightarrow> Loc \<Rightarrow> nat \<Rightarrow> F1 \<Rightarrow> bool"
where
   "dispose1_post f d s f' \<equiv>
      (\<exists> below above ext .
        below = { x \<in> dom f . x + the(f x) = d } \<triangleleft> f \<and>
        above = { x \<in> dom f . x = d + s } \<triangleleft> f \<and>
        ext   = (above \<union>m below) \<union>m [d \<mapsto> s] \<and>
        f' = ((dom below \<union> dom above) -\<triangleleft> f) \<union>m ([min_loc(ext) \<mapsto> sum_size(ext)]))
      "

(*
text\<open>
As explained in Section~\ref{S-TP-exp}, we modelled $DISPOSE1$ postcondition in various ways.
When we came to the Isabelle representation we encountered a few problems because of the VDM
model use of map comprehension for the definition of $DISPOSE1$. In Isabelle, map comprehension
isn't directly available. Thus, to model @{text below} as in the VDM

\begin{vdm}
\begin{formula}
    below= \map{ l \mapsto f(l) | l \in \dom{f} \And l + ~{f}(l) = d}
\end{formula}
\end{vdm}

\noindent we would need map comprehension in Isabelle. At first we tried something like this

@{term "map_of [ (x, the(f x)) . x \<leftarrow> sorted_list_of_set (dom f), l + (the(fhook x)) = d]"}

Although it does represent the map comprehension we need, it is rather protracted,
unecessarily complates proof, as well as automation. That is because of the many type jumps
between generator as a set (@{term "dom f"}) that gets transformed into a list for the list
comprehension term that is given to a recursive function (@{term "map_of"}), which translates
a given list to an Isabelle map.

This\footnote{And also discussion/suggestions within/from the Isabelle users mailing list} led
us to rethink the definition using available operators and avoiding map comprehension leading to
the current VDM as

\begin{vdm}
\begin{formula}
    below= \set{ l | l \in \dom{f} \And l + ~{f}(l) = d} \dsub f
\end{formula}
\end{vdm}

\noindent It avoid map comprehension and uses domain filtering (or restriction),
which was easier to encode in Isabelle as:
\<close>
*)
text\<open>
In our alternative formulation, the three existential variables are given as definitions, for example:
\<close>
definition
  dispose1_below :: "F1 \<Rightarrow> Loc \<Rightarrow> F1"
where
  "dispose1_below f d \<equiv>  { x \<in> dom f . x + the(f x) = d } \<triangleleft> f"

text\<open>
 \noindent These encoding considerations are crucial to ensure proofs are not complicated by
 technicalities unrelated to the problem. One must not, however, fall for the temptation to
 chisel the model into whatever the theorem prover would be happier with. Our modification
 is clearly equivalent, and can be proved as such if that's the case, we we have done for the
 layered definition of dispose with respect to the original one.

% \plannote{LF: Should we prove the map comprehension version equals the one with domain restriction?}
% Shouldn't mention it.

The other two definitions are:
\<close>

definition
  dispose1_above :: "F1 \<Rightarrow> Loc \<Rightarrow> nat \<Rightarrow> F1"
where
  "dispose1_above f d s \<equiv>  { x \<in> dom f . x = d + s } \<triangleleft> f"

definition
  dispose1_ext :: "F1 \<Rightarrow> Loc \<Rightarrow> nat \<Rightarrow> F1"
where
  "dispose1_ext f d s \<equiv>  (dispose1_above f d s  \<union>m dispose1_below f d) \<union>m [d \<mapsto> s] "

text\<open>
\noindent which allows us to write and prove:
\<close>
definition
   dispose1_post2 :: "F1 \<Rightarrow> Loc \<Rightarrow> nat \<Rightarrow> F1 \<Rightarrow> bool"
where
   "dispose1_post2 f d s f' \<equiv>
        (f' = ((dom (dispose1_below f d) \<union> dom (dispose1_above f d s)) -\<triangleleft> f)
        \<union>m ([min_loc(dispose1_ext f d s) \<mapsto> sum_size(dispose1_ext f d s)]))"

(*<*)
lemmas F1_inv_defs = F1_inv_def Disjoint_def nat1_def
                     Locs_of_def sep_def nat1_map_def
                        disjoint_def locs_of_def

lemmas new1_pre_defs      = new1_pre_def
lemmas new1_post_defs     = new1_post_def new1_post_eq_def new1_post_gr_def
lemmas dispose1_pre_defs  = dispose1_pre_def disjoint_def nat1_def
                            locs_def nat1_map_def locs_of_def
lemmas dispose1_post_defs = dispose1_post_def

lemmas dispose1_post2_defs = dispose1_post2_def dispose1_below_def
							 dispose1_above_def dispose1_ext_def
(*>*)

lemma dispose1_equiv:
	"dispose1_post f d s f' = dispose1_post2 f d s f'"
unfolding dispose1_post_defs dispose1_post2_defs
by auto

(*========================================================================*)
subsubsection \<open> VDM operation definitions and feasibility goals \<close>
(*========================================================================*)

text\<open>
Finally, we put everything together in locales and construct definitions
relating to the feasibility proofs. As with level 1, we encode the shared inputs,
state, assumptions and invariant in a separate locale:
\<close>
locale level1_basic =
   fixes f1 :: F1 (* State  0 \<mapsto> 12, 12 \<mapsto> 4 *)
   and   s1 :: nat (* Size!!! *)
  assumes l1_input_notempty_def: "nat1 s1" (* Type info *)
   and    l1_invariant_def     : "F1_inv f1" (* Invariant on initial state *)

text\<open>
The individual operations are then specified as localte extensions and the post-conditions
are given as definitions within the locale:

\<close>

locale level1_new = level1_basic +
   assumes l1_new1_precondition_def: "new1_pre f1 s1"

locale level1_dispose = level1_basic +
    fixes d1 :: Loc
   assumes l1_dispose1_precondition_def: "dispose1_pre f1 d1 s1"

definition (in level1_new)
  new1_postcondition :: "F1 \<Rightarrow> nat \<Rightarrow> bool"
where
  "new1_postcondition f' r \<equiv> new1_post f1 s1 f' r \<and> F1_inv f'"

definition (in level1_dispose)
  dispose1_postcondition :: "F1 \<Rightarrow> bool"
where
  "dispose1_postcondition f' \<equiv> dispose1_post f1 d1 s1 f' \<and> F1_inv f'"

definition (in level1_dispose)
  dispose1_postconditionpsg :: "F1 \<Rightarrow> bool"
where
  "dispose1_postconditionpsg f' \<equiv> dispose1_post2 f1 d1 s1 f' \<and> F1_inv f'"

(*<*)
locale level1_complete = level1_new + level1_dispose

(*========================================================================*)
section \<open> VDM proof obligations for level 1 \<close>
(*========================================================================*)
(*>*)

text\<open>
As in level 0, the feasibility proof operations are encoded as definitions as follows:
\<close>
definition (in level1_new)
  PO_new1_feasibility :: "bool"
where
  "PO_new1_feasibility \<equiv> (\<exists> f' r' . new1_postcondition f' r')"

definition (in level1_dispose)
  PO_dispose1_feasibility :: "bool"
where
  "PO_dispose1_feasibility \<equiv> (\<exists> f' . dispose1_postcondition f')"

definition (in level1_dispose)
  PO_dispose1_feasibilitypsg :: "bool"
where
  "PO_dispose1_feasibilitypsg \<equiv> (\<exists> f' . dispose1_postconditionpsg f')"

subsection\<open> Summary \label{s:isa:models:summary} \<close>

text\<open>
The translation from VDM to Isabelle is relatively straightforward and faithful to the
original model. Operations in VDM have a fairly natural translation to Isabelle's locale
module system, where definitions can be used for the post-condition. It is future work to build
a VDM package on top of Isabelle that would enable a syntactic emulation of VDM operations, thus
reducing the chance of a human error in the translation (we, for example, forgot the invariant
on our first iteration).
%
While our strategy of packaging up preconditions, postconditions, and the invariants in
definitions makes for additional proof steps, it ensures a comparmentalised proof and constructs
explicit `zoom' levels to have a clear domain of discourse.
%
Additionally, our naming scheme makes it relatively straightforward to pick a definition `from the
air' and have it be the right one, an oft overlooked but crucial requirement when models become
large.
%
%
The next section details the Isabelle proofs of the proof obligations for the above model,
including:
\begin{itemize}
\item Feasibility proofs for both operations for both levels;
\item Adaquecy proof for the reification;
\item Widen-precondition for both operations;
\item Narrow-postcondition for both operations;
\item Sanity proofs that state that, for example, $\mathit{DISPOSE(NEW) = Id}$.
\end{itemize}
\<close>

(*<*)
(* EXAMPLE HERE!!! *)

definition
  PO_new1_fsb :: "bool"
where
  "PO_new1_fsb \<equiv> (\<forall> f s . F1_inv f \<and> nat1 s \<and> new1_pre f s \<longrightarrow>
                        (\<exists> f' r' . new1_post f s f' r' \<and> F1_inv f'))"

definition
  PO_dispose1_fsb :: "bool"
where
  "PO_dispose1_fsb \<equiv> (\<forall> f d s . F1_inv f \<and> nat1 s \<and> dispose1_pre f d s \<longrightarrow>
                        (\<exists> f' . dispose1_post f d s f' \<and> F1_inv f'))"

unused_thms

(*
lemmX (in level1_dispose) "False"
nitpick [show_all]
oops
lemmX (in level1_new) "False"
nitpick [show_all]
oops
*)
(* NOTE: Nitpick trick to see if any axiom involved in the locales is inconsistent.
         i.e. if axioms are inconsistent, then we shouldn't be able to find a mode
         for False. If we do, then the axioms are conistent (i.e. it's unprovable
         as it should be).
 *)

end
(*>*)