(*<*)
theory Brent
imports
  Basis
begin
(*>*)
section\<open> Brent's algorithm \label{sec:brent} \<close>

text\<open>

@{cite "Brent:1980"} improved on the Tortoise and Hare algorithm and
used it to factor large primes. In practice it makes significantly
fewer calls to the function \<open>f\<close> before detecting a loop.

We begin by defining the base-2 logarithm.

\<close>

fun lg :: "nat \<Rightarrow> nat" where
[simp del]: "lg x = (if x \<le> 1 then 0 else 1 + lg (x div 2))"

lemma lg_safe:
  "lg 0 = 0"
  "lg (Suc 0) = 0"
  "lg (Suc (Suc 0)) = 1"
  "0 < x \<Longrightarrow> lg (x + x) = 1 + lg x"
by (simp_all add: lg.simps)

lemma lg_inv:
  "0 < x \<Longrightarrow> lg (2 ^ x) = x"
proof(induct x)
  case (Suc x) then show ?case
    by (cases x, simp_all add: lg.simps Suc_lessI not_le)
qed simp

lemma lg_inv2:
  "2 ^ i = x \<Longrightarrow> 2 ^ lg x = x"
by (induct i arbitrary: x) (auto simp: lg.simps, arith)

lemmas lg_simps = lg_safe lg_inv lg_inv2

subsection\<open> Finding \<open>lambda\<close> \<close>

text (in properties) \<open>

Imagine now that the Tortoise carries an unbounded number of carrots,
which he passes to the Hare when they meet, and the Hare has a
teleporter. The Hare eats a carrot each time she waits for the
function @{term "f"} to execute, and initially has just one. If she
runs out of carrots before meeting the Tortoise again, she teleports
him to her position, and he gives her twice as many carrots as the
last time they met (tracked by the variable \<open>carrots\<close>). By
counting how many carrots she has eaten from when she last teleported
the Tortoise (recorded in \<open>l\<close>) until she finally has surplus
carrots when she meets him again, the Hare directly discovers @{term
"lambda"}.

\<close>

record 'a state =
  m :: nat  \<comment> \<open>\<open>\<mu>\<close>\<close>
  l :: nat  \<comment> \<open>\<open>\<lambda>\<close>\<close>
  carrots :: nat
  hare :: "'a"
  tortoise :: "'a"

context properties
begin

definition (in fx0) find_lambda :: "'a state \<Rightarrow> 'a state" where
  "find_lambda \<equiv>
    (\<lambda>s. s\<lparr> carrots := 1, l := 1, tortoise := x0, hare := f x0 \<rparr>) ;;
    while (hare \<^bold>\<noteq> tortoise)
          ( ( \<^bold>if carrots \<^bold>= l \<^bold>then (\<lambda>s. s\<lparr> tortoise := hare s, carrots := 2 * carrots s, l := 0 \<rparr>)
                             \<^bold>else SKIP ) ;;
            (\<lambda>s. s\<lparr> hare := f (hare s), l := l s + 1 \<rparr>) )"

text\<open>

The termination argument goes intuitively as follows. The Hare eats as
many carrots as it takes to teleport the Tortoise into the
loop. Afterwards she continues the teleportation dance until the
Tortoise has given her enough carrots to make it all the way around
the loop and back to him.

We can calculate the Tortoise's position as a function of \<open>carrots\<close>.

\<close>

definition carrots_total :: "nat \<Rightarrow> nat" where
  "carrots_total c \<equiv> \<Sum>i<lg c. 2 ^ i"

lemma carrots_total_simps:
  "carrots_total (Suc 0) = 0"
  "carrots_total (Suc (Suc 0)) = 1"
  "2 ^ i = c \<Longrightarrow> carrots_total (c + c) = c + carrots_total c"
by (auto simp: carrots_total_def lg_simps)

definition find_lambda_measures :: "( (nat \<times> nat) \<times> (nat \<times> nat) ) set" where
  "find_lambda_measures \<equiv>
    measures [\<lambda>(l, c). mu - carrots_total c,
              \<lambda>(l, c). LEAST i. lambda \<le> c * 2^i,
              \<lambda>(l, c). c - l]"

lemma find_lambda_measures_wellfounded:
  "wf find_lambda_measures"
by (simp add: find_lambda_measures_def)

lemma find_lambda_measures_decreases1:
  assumes "c = 2 ^ i"
  assumes "mu \<le> carrots_total c \<longrightarrow> c \<le> lambda"
  assumes "seq (carrots_total c) \<noteq> seq (carrots_total c + c)"
  shows "( (c', 2 * c), (c, c) ) \<in> find_lambda_measures"
proof(cases "mu \<le> carrots_total c")
  case False with assms show ?thesis
    by (auto simp: find_lambda_measures_def carrots_total_simps mult_2 field_simps diff_less_mono2)
next
  case True
  { fix x assume x: "(0::nat) < x" have "\<exists>n. lambda \<le> x * 2 ^ n"
    proof(induct lambda)
      case (Suc i)
      then obtain n where "i \<le> x * 2 ^ n" by blast
      with x show ?case
        by (clarsimp intro!: exI[where x="Suc n"] simp: field_simps mult_2)
           (metis Nat.add_0_right Suc_leI linorder_neqE_nat mult_eq_0_iff nat_add_left_cancel not_le numeral_2_eq_2 old.nat.distinct(2) power_not_zero trans_le_add2)
    qed simp } note ex = this
  have "(LEAST j. lambda \<le> 2 ^ (i + 1) * 2 ^ j) < (LEAST j. lambda \<le> 2 ^ i * 2 ^ j)"
  proof(rule LeastI2_wellorder_ex[OF ex, rotated], rule LeastI2_wellorder_ex[OF ex, rotated])
    fix x y
    assume "lambda \<le> 2 ^ i * 2 ^ y"
           "lambda \<le> 2 ^ (i + 1) * 2 ^ x"
           "\<forall>z. lambda \<le> 2 ^ (i + 1) * 2 ^ z \<longrightarrow> x \<le> z"
    with True assms properties_loop[where i="carrots_total c" and j=1]
    show "x < y" by (cases y, auto simp: less_Suc_eq_le)
  qed simp_all
  with True \<open>c = 2 ^ i\<close> show ?thesis
    by (clarsimp simp: find_lambda_measures_def mult_2 carrots_total_simps field_simps power_add)
qed

lemma find_lambda_measures_decreases2:
  assumes "ls < c"
  shows "( (Suc ls, c), (ls, c) ) \<in> find_lambda_measures"
using assms by (simp add: find_lambda_measures_def)

lemma find_lambda:
  "\<lbrace>\<langle>True\<rangle>\<rbrace> find_lambda \<lbrace>l \<^bold>= \<langle>lambda\<rangle>\<rbrace>"
apply (simp add: find_lambda_def)
apply (rule hoare_pre)
apply (rule whileI[where I="\<langle>0\<rangle> \<^bold>< l \<^bold>\<and> l \<^bold>\<le> carrots \<^bold>\<and> (\<langle>mu\<rangle> \<^bold>\<le> carrots_total \<circ> carrots \<^bold>\<longrightarrow> l \<^bold>\<le> \<langle>lambda\<rangle>) \<^bold>\<and> (\<^bold>\<exists>i. carrots \<^bold>= \<langle>2^i\<rangle>)
                           \<^bold>\<and> tortoise \<^bold>= seq \<circ> carrots_total \<circ> carrots \<^bold>\<and> hare \<^bold>= seq \<circ> (l \<^bold>+ (carrots_total \<circ> carrots))"
                      and r="inv_image find_lambda_measures (l \<^bold>\<bowtie> carrots)"]
            wp_intro)+
   using properties_lambda_gt_0
   apply (clarsimp simp: field_simps mult_2_right carrots_total_simps)
   apply (intro conjI impI)
      apply (metis mult_2 power_Suc)
     apply (case_tac "mu \<le> carrots_total (l s)")
      apply (cut_tac i="carrots_total (l s)" and j="l s" in properties_distinct_contrapos, simp_all add: field_simps)[1]
     apply (cut_tac i="carrots_total (l s)" and j="l s" in properties_loops_ge_mu, simp_all add: field_simps)[1]
    apply (cut_tac i="carrots_total (2 ^ x)" and j=1 in properties_loop, simp)
    apply (fastforce simp: le_eq_less_or_eq field_simps)
   apply (cut_tac i="carrots_total (2 ^ x)" and j="l s" in properties_loops_ge_mu, simp_all add: field_simps)[1]
   apply (cut_tac i="carrots_total (2 ^ x)" and j="l s" in properties_distinct_contrapos, simp_all add: field_simps)[1]
  apply (simp add: find_lambda_measures_wellfounded)
 apply (clarsimp simp: add.commute find_lambda_measures_decreases1 find_lambda_measures_decreases2)
apply (rule wp_intro)
using properties_lambda_gt_0
apply (simp add: carrots_total_simps exI[where x=0])
done

subsection\<open> Finding \<open>mu\<close> \<close>

text\<open>

With @{term "lambda"} in hand, we can find \<open>mu\<close> using the same
approach as for the Tortoise and Hare (\S\ref{sec:th-finding-mu}),
after we first move the Hare to @{term "lambda"}.

\<close>

definition (in fx0) find_mu :: "'a state \<Rightarrow> 'a state" where
  "find_mu \<equiv>
    (\<lambda>s. s\<lparr> m := 0, tortoise := x0, hare := seq (l s) \<rparr>) ;;
    while (hare \<^bold>\<noteq> tortoise)
          (\<lambda>s. s\<lparr> tortoise := f (tortoise s), hare := f (hare s), m := m s + 1 \<rparr>)"

lemma find_mu:
  "\<lbrace>l \<^bold>= \<langle>lambda\<rangle>\<rbrace> find_mu \<lbrace>l \<^bold>= \<langle>lambda\<rangle> \<^bold>\<and> m \<^bold>= \<langle>mu\<rangle>\<rbrace>"
apply (simp add: find_mu_def)
apply (rule hoare_pre)
apply (rule whileI[where I="l \<^bold>= \<langle>lambda\<rangle> \<^bold>\<and> m \<^bold>\<le> \<langle>mu\<rangle> \<^bold>\<and> tortoise \<^bold>= seq \<circ> m \<^bold>\<and> hare \<^bold>= seq \<circ> (m \<^bold>+ l)"
                      and r="measure (\<langle>mu\<rangle> \<^bold>- m)"]
            wp_intro)+
   using properties_lambda_gt_0 properties_loop[where i=mu and j=1]
   apply (fastforce simp: le_less dest: properties_loops_ge_mu)
  apply simp
 using properties_loop[where i=mu and j=1, simplified]
 apply (fastforce simp: le_eq_less_or_eq)
apply (rule wp_intro)
apply simp
done

subsection\<open> Top level \<close>

definition (in fx0) brent :: "'a state \<Rightarrow> 'a state" where
  "brent \<equiv> find_lambda ;; find_mu"

theorem brent:
  "\<lbrace>\<langle>True\<rangle>\<rbrace> brent \<lbrace>l \<^bold>= \<langle>lambda\<rangle> \<^bold>\<and> m \<^bold>= \<langle>mu\<rangle>\<rbrace>"
unfolding brent_def
by (rule find_lambda find_mu wp_intro)+

end

corollary brent_correct:
  assumes s': "s' = fx0.brent f x arbitrary"
  shows "fx0.properties f x (l s') (m s')"
using assms properties.brent[where f=f and ?x0.0=x]
by (fastforce intro: fx0.properties_existence[where f=f and ?x0.0=x]
               simp:  Basis.properties_def valid_def)

schematic_goal brent_code[code]:
  "fx0.brent f x = ?code"
unfolding fx0.brent_def fx0.find_lambda_def fx0.find_mu_def fcomp_assoc[symmetric] fcomp_comp
by (rule refl)

export_code fx0.brent in SML
(*<*)

end
(*>*)


theory Eplus_commut
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer

codatatype ENat = is_zero: EZ | ESuc (epred: ENat)

primcorec eplus :: "ENat \<Rightarrow> ENat \<Rightarrow> ENat" where
"eplus m n = (if is_zero m then n else ESuc (eplus (epred m) n))"

(*hipster eplus*)
lemma lemma_a [thy_expl]: "eplus x EZ = x"
  apply (coinduction  arbitrary: x rule: Eplus_commut.ENat.coinduct_strong)
  by simp

lemma lemma_aa [thy_expl]: "eplus EZ x = x"
apply (coinduction  arbitrary: x rule: Eplus_commut.ENat.coinduct_strong)
by simp

lemma lemma_ab [thy_expl]: "eplus (ESuc x) y = eplus x (ESuc y)"
apply (coinduction  arbitrary: x y rule: Eplus_commut.ENat.coinduct_strong)
apply simp
by (metis ENat.collapse(2) eplus.code)

lemma lemma_ac [thy_expl]: "ESuc (eplus x y) = eplus x (ESuc y)"
apply (coinduction  arbitrary: x y rule: Eplus_commut.ENat.coinduct_strong)
apply simp
by (metis eplus.code)

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

lemma lemma_ae [thy_expl]: "eplus y x = eplus x y"
apply (coinduction  arbitrary: x y rule: Eplus_commut.ENat.coinduct_strong)
apply simp
by (metis ENat.collapse(1) ENat.collapse(2) lemma_a lemma_ab)

theorem eplus_commut: "eplus a b = eplus b a"
  (*by hipster_coinduct_sledgehammer fails *)
  by (simp add: lemma_ae)

end


section "A Typed Language"

theory Chapter9_Ex3 imports "~~/src/HOL/IMP/Star" Complex_Main begin

text {* We build on @{theory Complex_Main} instead of @{theory Main} to access
the real numbers. *}

subsection "Arithmetic Expressions"

datatype val = Iv int | Rv real

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

text_raw{*\snip{aexptDef}{0}{2}{% *}
datatype aexp =  Ic int | Rc real | V vname | Plus aexp aexp
text_raw{*}%endsnip*}

inductive taval :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
"taval (Ic i) s (Iv i)" |
"taval (Rc r) s (Rv r)" |
"taval (V x) s (s x)" |
"taval a1 s (Iv i1) \<Longrightarrow> taval a2 s (Iv i2)
 \<Longrightarrow> taval (Plus a1 a2) s (Iv(i1+i2))" |
"taval a1 s (Rv r1) \<Longrightarrow> taval a2 s (Rv r2)
 \<Longrightarrow> taval (Plus a1 a2) s (Rv(r1+r2))"

inductive_cases [elim!]:
  "taval (Ic i) s v"  "taval (Rc i) s v"
  "taval (V x) s v"
  "taval (Plus a1 a2) s v"

subsection "Boolean Expressions"

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

inductive tbval :: "bexp \<Rightarrow> state \<Rightarrow> bool \<Rightarrow> bool" where
"tbval (Bc v) s v" |
"tbval b s bv \<Longrightarrow> tbval (Not b) s (\<not> bv)" |
"tbval b1 s bv1 \<Longrightarrow> tbval b2 s bv2 \<Longrightarrow> tbval (And b1 b2) s (bv1 & bv2)" |
"taval a1 s (Iv i1) \<Longrightarrow> taval a2 s (Iv i2) \<Longrightarrow> tbval (Less a1 a2) s (i1 < i2)" |
"taval a1 s (Rv r1) \<Longrightarrow> taval a2 s (Rv r2) \<Longrightarrow> tbval (Less a1 a2) s (r1 < r2)"

subsection "Syntax of Commands"
(* a copy of Com.thy - keep in sync! *)

datatype
  com = SKIP
      | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
      | Seq    com  com         ("_;; _"  [60, 61] 60)
      | If     bexp com com     ("IF _ THEN _ ELSE _"  [0, 0, 61] 61)
      | While  bexp com         ("WHILE _ DO _"  [0, 61] 61)
      | Repeat com  bexp        ("REPEAT _/ UNTIL _/" [0, 61] 61)

subsection "Small-Step Semantics of Commands"

inductive
  small_step :: "(com \<times> state) \<Rightarrow> (com \<times> state) \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "taval a s v \<Longrightarrow> (x ::= a, s) \<rightarrow> (SKIP, s(x := v))" |

Seq1:   "(SKIP;;c,s) \<rightarrow> (c,s)" |
Seq2:   "(c1,s) \<rightarrow> (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow> (c1';;c2,s')" |

IfTrue:  "tbval b s True \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c1,s)" |
IfFalse: "tbval b s False \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP,s)" |
Repeat: "(REPEAT c UNTIL b, s) \<rightarrow> (c;; IF b THEN SKIP ELSE REPEAT c UNTIL b, s)"

lemmas small_step_induct = small_step.induct[split_format(complete)]

subsection "The Type System"

datatype ty = Ity | Rty

type_synonym tyenv = "vname \<Rightarrow> ty"

inductive atyping :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty \<Rightarrow> bool"
  ("(1_/ \<turnstile>/ (_ :/ _))" [50,0,50] 50)
where
Ic_ty: "\<Gamma> \<turnstile> Ic i : Ity" |
Rc_ty: "\<Gamma> \<turnstile> Rc r : Rty" |
V_ty: "\<Gamma> \<turnstile> V x : \<Gamma> x" |
Plus_ty: "\<Gamma> \<turnstile> a1 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> a2 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> Plus a1 a2 : \<tau>"

declare atyping.intros [intro!]
inductive_cases [elim!]:
  "\<Gamma> \<turnstile> V x : \<tau>" "\<Gamma> \<turnstile> Ic i : \<tau>" "\<Gamma> \<turnstile> Rc r : \<tau>" "\<Gamma> \<turnstile> Plus a1 a2 : \<tau>"

text{* Warning: the ``:'' notation leads to syntactic ambiguities,
i.e. multiple parse trees, because ``:'' also stands for set membership.
In most situations Isabelle's type system will reject all but one parse tree,
but will still inform you of the potential ambiguity. *}

inductive btyping :: "tyenv \<Rightarrow> bexp \<Rightarrow> bool" (infix "\<turnstile>" 50)
where
B_ty: "\<Gamma> \<turnstile> Bc v" |
Not_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> Not b" |
And_ty: "\<Gamma> \<turnstile> b1 \<Longrightarrow> \<Gamma> \<turnstile> b2 \<Longrightarrow> \<Gamma> \<turnstile> And b1 b2" |
Less_ty: "\<Gamma> \<turnstile> a1 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> a2 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> Less a1 a2"

declare btyping.intros [intro!]
inductive_cases [elim!]: "\<Gamma> \<turnstile> Not b" "\<Gamma> \<turnstile> And b1 b2" "\<Gamma> \<turnstile> Less a1 a2"

inductive ctyping :: "tyenv \<Rightarrow> com \<Rightarrow> bool" (infix "\<turnstile>" 50) where
Skip_ty: "\<Gamma> \<turnstile> SKIP" |
Assign_ty: "\<Gamma> \<turnstile> a : \<Gamma>(x) \<Longrightarrow> \<Gamma> \<turnstile> x ::= a" |
Seq_ty: "\<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> c1;;c2" |
If_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> IF b THEN c1 ELSE c2" |
While_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> WHILE b DO c" |
Repeat_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> REPEAT c UNTIL b"

declare ctyping.intros [intro!]
inductive_cases [elim!]:
  "\<Gamma> \<turnstile> x ::= a"  "\<Gamma> \<turnstile> c1;;c2"
  "\<Gamma> \<turnstile> IF b THEN c1 ELSE c2"
  "\<Gamma> \<turnstile> WHILE b DO c"
  "\<Gamma> \<turnstile> REPEAT c UNTIL b"

subsection "Well-typed Programs Do Not Get Stuck"

fun type :: "val \<Rightarrow> ty" where
"type (Iv i) = Ity" |
"type (Rv r) = Rty"

lemma type_eq_Ity[simp]: "type v = Ity \<longleftrightarrow> (\<exists>i. v = Iv i)"
by (cases v) simp_all

lemma type_eq_Rty[simp]: "type v = Rty \<longleftrightarrow> (\<exists>r. v = Rv r)"
by (cases v) simp_all

definition styping :: "tyenv \<Rightarrow> state \<Rightarrow> bool" (infix "\<turnstile>" 50)
where "\<Gamma> \<turnstile> s  \<longleftrightarrow>  (\<forall>x. type (s x) = \<Gamma> x)"

lemma apreservation:
  "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> taval a s v \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> type v = \<tau>"
apply(induction arbitrary: v rule: atyping.induct)
apply (fastforce simp: styping_def)+
done

lemma aprogress: "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<exists>v. taval a s v"
proof(induction rule: atyping.induct)
  case (Plus_ty \<Gamma> a1 t a2)
  then obtain v1 v2 where v: "taval a1 s v1" "taval a2 s v2" by blast
  show ?case
  proof (cases v1)
    case Iv
    with Plus_ty v show ?thesis
      by(fastforce intro: taval.intros(4) dest!: apreservation)
  next
    case Rv
    with Plus_ty v show ?thesis
      by(fastforce intro: taval.intros(5) dest!: apreservation)
  qed
qed (auto intro: taval.intros)

lemma bprogress: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<exists>v. tbval b s v"
proof(induction rule: btyping.induct)
  case (Less_ty \<Gamma> a1 t a2)
  then obtain v1 v2 where v: "taval a1 s v1" "taval a2 s v2"
    by (metis aprogress)
  show ?case
  proof (cases v1)
    case Iv
    with Less_ty v show ?thesis
      by (fastforce intro!: tbval.intros(4) dest!:apreservation)
  next
    case Rv
    with Less_ty v show ?thesis
      by (fastforce intro!: tbval.intros(5) dest!:apreservation)
  qed
qed (auto intro: tbval.intros)

theorem progress:
  "\<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c \<noteq> SKIP \<Longrightarrow> \<exists>cs'. (c,s) \<rightarrow> cs'"
proof(induction rule: ctyping.induct)
  case Skip_ty thus ?case by simp
next
  case Assign_ty
  thus ?case by (metis Assign aprogress)
next
  case Seq_ty thus ?case by simp (metis Seq1 Seq2)
next
  case (If_ty \<Gamma> b c1 c2)
  then obtain bv where "tbval b s bv" by (metis bprogress)
  show ?case
  proof(cases bv)
    assume "bv"
    with `tbval b s bv` show ?case by simp (metis IfTrue)
  next
    assume "\<not>bv"
    with `tbval b s bv` show ?case by simp (metis IfFalse)
  qed
next
  case While_ty show ?case by (metis While)
next
  case Repeat_ty show ?case by (metis Repeat)
qed

theorem styping_preservation:
  "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<Gamma> \<turnstile> s'"
proof(induction rule: small_step_induct)
  case Assign thus ?case
    by (auto simp: styping_def) (metis Assign(1,3) apreservation)
qed auto

theorem ctyping_preservation:
  "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> c'"
by (induct rule: small_step_induct) (auto simp: ctyping.intros)

abbreviation small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

theorem type_sound:
  "(c,s) \<rightarrow>* (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c' \<noteq> SKIP
   \<Longrightarrow> \<exists>cs''. (c',s') \<rightarrow> cs''"
apply(induction rule:star_induct)
apply (metis progress)
by (metis styping_preservation ctyping_preservation)

end


theory ConcreteSemantics12_Hoare_Total
  imports "~~/src/HOL/IMP/Hoare_Examples"
begin

text\<open>Note that this definition of total validity \<open>\<Turnstile>\<^sub>t\<close> only
works if execution is deterministic (which it is in our case).\<close>

definition hoare_tvalid :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool"
  ("\<Turnstile>\<^sub>t {(1_)}/ (_)/ {(1_)}" 50) where
"\<Turnstile>\<^sub>t {P}c{Q}  \<longleftrightarrow>  (\<forall>s. P s \<longrightarrow> (\<exists>t. (c,s) \<Rightarrow> t \<and> Q t))"

text\<open>Provability of Hoare triples in the proof system for total
correctness is written \<open>\<turnstile>\<^sub>t {P}c{Q}\<close> and defined
inductively. The rules for \<open>\<turnstile>\<^sub>t\<close> differ from those for
\<open>\<turnstile>\<close> only in the one place where nontermination can arise: the
\<^term>\<open>While\<close>-rule.\<close>

inductive
  hoaret :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<turnstile>\<^sub>t ({(1_)}/ (_)/ {(1_)})" 50)
where

Skip:  "\<turnstile>\<^sub>t {P} SKIP {P}"  |

Assign:  "\<turnstile>\<^sub>t {\<lambda>s. P(s[a/x])} x::=a {P}"  |

Seq: "\<lbrakk> \<turnstile>\<^sub>t {P\<^sub>1} c\<^sub>1 {P\<^sub>2}; \<turnstile>\<^sub>t {P\<^sub>2} c\<^sub>2 {P\<^sub>3} \<rbrakk> \<Longrightarrow> \<turnstile>\<^sub>t {P\<^sub>1} c\<^sub>1;;c\<^sub>2 {P\<^sub>3}"  |

If: "\<lbrakk> \<turnstile>\<^sub>t {\<lambda>s. P s \<and> bval b s} c\<^sub>1 {Q}; \<turnstile>\<^sub>t {\<lambda>s. P s \<and> \<not> bval b s} c\<^sub>2 {Q} \<rbrakk>
  \<Longrightarrow> \<turnstile>\<^sub>t {P} IF b THEN c\<^sub>1 ELSE c\<^sub>2 {Q}"  |

While:
  "(\<And>n::nat.
    \<turnstile>\<^sub>t {\<lambda>s. P s \<and> bval b s \<and> T s n} c {\<lambda>s. P s \<and> (\<exists>n'<n. T s n')})
   \<Longrightarrow> \<turnstile>\<^sub>t {\<lambda>s. P s \<and> (\<exists>n. T s n)} WHILE b DO c {\<lambda>s. P s \<and> \<not>bval b s}"  |

conseq: "\<lbrakk> \<forall>s. P' s \<longrightarrow> P s; \<turnstile>\<^sub>t {P}c{Q}; \<forall>s. Q s \<longrightarrow> Q' s  \<rbrakk> \<Longrightarrow>
           \<turnstile>\<^sub>t {P'}c{Q'}"

text\<open>The \<^term>\<open>While\<close>-rule is like the one for partial correctness but it
requires additionally that with every execution of the loop body some measure
relation @{term[source]"T :: state \<Rightarrow> nat \<Rightarrow> bool"} decreases.
The following functional version is more intuitive:\<close>

lemma While_fun:
  "\<lbrakk> \<And>n::nat. \<turnstile>\<^sub>t {\<lambda>s. P s \<and> bval b s \<and> n = f s} c {\<lambda>s. P s \<and> f s < n}\<rbrakk>
   \<Longrightarrow> \<turnstile>\<^sub>t {P} WHILE b DO c {\<lambda>s. P s \<and> \<not>bval b s}"
  by (rule While[where T = "\<lambda> s n. n = f s", simplified])

text\<open>The soundness theorem:\<close>

(*Lemma 12.13 (Soundness of \<turnstile>\<^sub>t w.r.t. \<Turnstile>\<^sub>t.*)
theorem hoaret_sound: "\<turnstile>\<^sub>t {P}c{Q}  \<Longrightarrow>  \<Turnstile>\<^sub>t {P}c{Q}"
(*to simplify, we  unfold to induction on hoaret.induct *)
(*
The following two proof is not same.
- proof( unfold hoare_tvalid_def, induction rule: hoaret.induct)
- proof( induction rule: hoaret.induct, unfold hoare_tvalid_def)
*)
proof( unfold hoare_tvalid_def, induction rule: hoaret.induct)
  case (Skip P)
  then show ?case
    by auto
next
  case (Assign P a x)
  then show ?case by auto
next
  case (Seq P\<^sub>1 c\<^sub>1 P\<^sub>2 c\<^sub>2 P\<^sub>3)
  then show ?case
    by blast
next
  case (If P b c\<^sub>1 Q c\<^sub>2)
  then show ?case by blast
next
  case (While P b T c)
(*
    \<turnstile>\<^sub>t {\<lambda>s. P s \<and> bval b s \<and> T s ?n} c {\<lambda>s. P s \<and> (\<exists>n'<?n. T s n')}
*)
  let ?w = "WHILE b DO c"
  have "\<lbrakk>P s; T s n\<rbrakk> \<Longrightarrow> \<exists> t. (?w, s) \<Rightarrow> t \<and> P t \<and> \<not> bval b t" for s n
(*  proof (cases)
    assume "bval b s"
    assume "P s" "T s n"
    then obtain s' t' where "(c, s) \<Rightarrow> s'" "P s'" "T s' n'" "n' < n" for n' sledgehammer

    then show ?thesis sorry
  next
    assume "\<not> bval b s"
    then have "(?w, s) \<Rightarrow> t" sledgehammer
    then show ?thesis sledgehammer
    qed*)
  proof (induction n arbitrary: s rule: less_induct)
    case (less x)
    then show ?case
      by (metis While.IH WhileFalse WhileTrue)
    qed
  then show ?case
    by blast
next
  case (conseq P' P c Q Q')
  then show ?case by blast
qed

end


(*  Author: Stefan Berghofer, Lukas Bulwahn, TU Muenchen  *)

section \<open>A table-based implementation of the reflexive transitive closure\<close>

theory Transitive_Closure_Table
imports MainRLT
begin

inductive rtrancl_path :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool"
  for r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  base: "rtrancl_path r x [] x"
| step: "r x y \<Longrightarrow> rtrancl_path r y ys z \<Longrightarrow> rtrancl_path r x (y # ys) z"

lemma rtranclp_eq_rtrancl_path: "r\<^sup>*\<^sup>* x y \<longleftrightarrow> (\<exists>xs. rtrancl_path r x xs y)"
proof
  show "\<exists>xs. rtrancl_path r x xs y" if "r\<^sup>*\<^sup>* x y"
    using that
  proof (induct rule: converse_rtranclp_induct)
    case base
    have "rtrancl_path r y [] y" by (rule rtrancl_path.base)
    then show ?case ..
  next
    case (step x z)
    from \<open>\<exists>xs. rtrancl_path r z xs y\<close>
    obtain xs where "rtrancl_path r z xs y" ..
    with \<open>r x z\<close> have "rtrancl_path r x (z # xs) y"
      by (rule rtrancl_path.step)
    then show ?case ..
  qed
  show "r\<^sup>*\<^sup>* x y" if "\<exists>xs. rtrancl_path r x xs y"
  proof -
    from that obtain xs where "rtrancl_path r x xs y" ..
    then show ?thesis
    proof induct
      case (base x)
      show ?case
        by (rule rtranclp.rtrancl_refl)
    next
      case (step x y ys z)
      from \<open>r x y\<close> \<open>r\<^sup>*\<^sup>* y z\<close> show ?case
        by (rule converse_rtranclp_into_rtranclp)
    qed
  qed
qed

lemma rtrancl_path_trans:
  assumes xy: "rtrancl_path r x xs y"
    and yz: "rtrancl_path r y ys z"
  shows "rtrancl_path r x (xs @ ys) z" using xy yz
proof (induct arbitrary: z)
  case (base x)
  then show ?case by simp
next
  case (step x y xs)
  then have "rtrancl_path r y (xs @ ys) z"
    by simp
  with \<open>r x y\<close> have "rtrancl_path r x (y # (xs @ ys)) z"
    by (rule rtrancl_path.step)
  then show ?case by simp
qed

lemma rtrancl_path_appendE:
  assumes xz: "rtrancl_path r x (xs @ y # ys) z"
  obtains "rtrancl_path r x (xs @ [y]) y" and "rtrancl_path r y ys z"
  using xz
proof (induct xs arbitrary: x)
  case Nil
  then have "rtrancl_path r x (y # ys) z" by simp
  then obtain xy: "r x y" and yz: "rtrancl_path r y ys z"
    by cases auto
  from xy have "rtrancl_path r x [y] y"
    by (rule rtrancl_path.step [OF _ rtrancl_path.base])
  then have "rtrancl_path r x ([] @ [y]) y" by simp
  then show thesis using yz by (rule Nil)
next
  case (Cons a as)
  then have "rtrancl_path r x (a # (as @ y # ys)) z" by simp
  then obtain xa: "r x a" and az: "rtrancl_path r a (as @ y # ys) z"
    by cases auto
  show thesis
  proof (rule Cons(1) [OF _ az])
    assume "rtrancl_path r y ys z"
    assume "rtrancl_path r a (as @ [y]) y"
    with xa have "rtrancl_path r x (a # (as @ [y])) y"
      by (rule rtrancl_path.step)
    then have "rtrancl_path r x ((a # as) @ [y]) y"
      by simp
    then show thesis using \<open>rtrancl_path r y ys z\<close>
      by (rule Cons(2))
  qed
qed

lemma rtrancl_path_distinct:
  assumes xy: "rtrancl_path r x xs y"
  obtains xs' where "rtrancl_path r x xs' y" and "distinct (x # xs')" and "set xs' \<subseteq> set xs"
  using xy
proof (induct xs rule: measure_induct_rule [of length])
  case (less xs)
  show ?case
  proof (cases "distinct (x # xs)")
    case True
    with \<open>rtrancl_path r x xs y\<close> show ?thesis by (rule less) simp
  next
    case False
    then have "\<exists>as bs cs a. x # xs = as @ [a] @ bs @ [a] @ cs"
      by (rule not_distinct_decomp)
    then obtain as bs cs a where xxs: "x # xs = as @ [a] @ bs @ [a] @ cs"
      by iprover
    show ?thesis
    proof (cases as)
      case Nil
      with xxs have x: "x = a" and xs: "xs = bs @ a # cs"
        by auto
      from x xs \<open>rtrancl_path r x xs y\<close> have cs: "rtrancl_path r x cs y" "set cs \<subseteq> set xs"
        by (auto elim: rtrancl_path_appendE)
      from xs have "length cs < length xs" by simp
      then show ?thesis
        by (rule less(1))(blast intro: cs less(2) order_trans del: subsetI)+
    next
      case (Cons d ds)
      with xxs have xs: "xs = ds @ a # (bs @ [a] @ cs)"
        by auto
      with \<open>rtrancl_path r x xs y\<close> obtain xa: "rtrancl_path r x (ds @ [a]) a"
        and ay: "rtrancl_path r a (bs @ a # cs) y"
        by (auto elim: rtrancl_path_appendE)
      from ay have "rtrancl_path r a cs y" by (auto elim: rtrancl_path_appendE)
      with xa have xy: "rtrancl_path r x ((ds @ [a]) @ cs) y"
        by (rule rtrancl_path_trans)
      from xs have set: "set ((ds @ [a]) @ cs) \<subseteq> set xs" by auto
      from xs have "length ((ds @ [a]) @ cs) < length xs" by simp
      then show ?thesis
        by (rule less(1))(blast intro: xy less(2) set[THEN subsetD])+
    qed
  qed
qed

inductive rtrancl_tab :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
  for r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  base: "rtrancl_tab r xs x x"
| step: "x \<notin> set xs \<Longrightarrow> r x y \<Longrightarrow> rtrancl_tab r (x # xs) y z \<Longrightarrow> rtrancl_tab r xs x z"

lemma rtrancl_path_imp_rtrancl_tab:
  assumes path: "rtrancl_path r x xs y"
    and x: "distinct (x # xs)"
    and ys: "({x} \<union> set xs) \<inter> set ys = {}"
  shows "rtrancl_tab r ys x y"
  using path x ys
proof (induct arbitrary: ys)
  case base
  show ?case
    by (rule rtrancl_tab.base)
next
  case (step x y zs z)
  then have "x \<notin> set ys"
    by auto
  from step have "distinct (y # zs)"
    by simp
  moreover from step have "({y} \<union> set zs) \<inter> set (x # ys) = {}"
    by auto
  ultimately have "rtrancl_tab r (x # ys) y z"
    by (rule step)
  with \<open>x \<notin> set ys\<close> \<open>r x y\<close> show ?case
    by (rule rtrancl_tab.step)
qed

lemma rtrancl_tab_imp_rtrancl_path:
  assumes tab: "rtrancl_tab r ys x y"
  obtains xs where "rtrancl_path r x xs y"
  using tab
proof induct
  case base
  from rtrancl_path.base show ?case
    by (rule base)
next
  case step
  show ?case
    by (iprover intro: step rtrancl_path.step)
qed

lemma rtranclp_eq_rtrancl_tab_nil: "r\<^sup>*\<^sup>* x y \<longleftrightarrow> rtrancl_tab r [] x y"
proof
  show "rtrancl_tab r [] x y" if "r\<^sup>*\<^sup>* x y"
  proof -
    from that obtain xs where "rtrancl_path r x xs y"
      by (auto simp add: rtranclp_eq_rtrancl_path)
    then obtain xs' where xs': "rtrancl_path r x xs' y" and distinct: "distinct (x # xs')"
      by (rule rtrancl_path_distinct)
    have "({x} \<union> set xs') \<inter> set [] = {}"
      by simp
    with xs' distinct show ?thesis
      by (rule rtrancl_path_imp_rtrancl_tab)
  qed
  show "r\<^sup>*\<^sup>* x y" if "rtrancl_tab r [] x y"
  proof -
    from that obtain xs where "rtrancl_path r x xs y"
      by (rule rtrancl_tab_imp_rtrancl_path)
    then show ?thesis
      by (auto simp add: rtranclp_eq_rtrancl_path)
  qed
qed

declare rtranclp_rtrancl_eq [code del]
declare rtranclp_eq_rtrancl_tab_nil [THEN iffD2, code_pred_intro]

code_pred rtranclp
  using rtranclp_eq_rtrancl_tab_nil [THEN iffD1] by fastforce

lemma rtrancl_path_Range: "\<lbrakk> rtrancl_path R x xs y; z \<in> set xs \<rbrakk> \<Longrightarrow> Rangep R z"
by(induction rule: rtrancl_path.induct) auto

lemma rtrancl_path_Range_end: "\<lbrakk> rtrancl_path R x xs y; xs \<noteq> [] \<rbrakk> \<Longrightarrow> Rangep R y"
by(induction rule: rtrancl_path.induct)(auto elim: rtrancl_path.cases)

lemma rtrancl_path_nth:
  "\<lbrakk> rtrancl_path R x xs y; i < length xs \<rbrakk> \<Longrightarrow> R ((x # xs) ! i) (xs ! i)"
proof(induction arbitrary: i rule: rtrancl_path.induct)
  case step thus ?case by(cases i) simp_all
qed simp

lemma rtrancl_path_last: "\<lbrakk> rtrancl_path R x xs y; xs \<noteq> [] \<rbrakk> \<Longrightarrow> last xs = y"
by(induction rule: rtrancl_path.induct)(auto elim: rtrancl_path.cases)

lemma rtrancl_path_mono:
  "\<lbrakk> rtrancl_path R x p y; \<And>x y. R x y \<Longrightarrow> S x y \<rbrakk> \<Longrightarrow> rtrancl_path S x p y"
by(induction rule: rtrancl_path.induct)(auto intro: rtrancl_path.intros)

end


(* Author: Tobias Nipkow *)

section \<open>2-3 Trees\<close>

theory Tree23
imports MainRLT
begin

class height =
fixes height :: "'a \<Rightarrow> nat"

datatype 'a tree23 =
  Leaf ("\<langle>\<rangle>") |
  Node2 "'a tree23" 'a "'a tree23"  ("\<langle>_, _, _\<rangle>") |
  Node3 "'a tree23" 'a "'a tree23" 'a "'a tree23"  ("\<langle>_, _, _, _, _\<rangle>")

fun inorder :: "'a tree23 \<Rightarrow> 'a list" where
"inorder Leaf = []" |
"inorder(Node2 l a r) = inorder l @ a # inorder r" |
"inorder(Node3 l a m b r) = inorder l @ a # inorder m @ b # inorder r"

instantiation tree23 :: (type)height
begin

fun height_tree23 :: "'a tree23 \<Rightarrow> nat" where
"height Leaf = 0" |
"height (Node2 l _ r) = Suc(max (height l) (height r))" |
"height (Node3 l _ m _ r) = Suc(max (height l) (max (height m) (height r)))"

instance ..

end

text \<open>Completeness:\<close>

fun complete :: "'a tree23 \<Rightarrow> bool" where
"complete Leaf = True" |
"complete (Node2 l _ r) = (height l = height r \<and> complete l & complete r)" |
"complete (Node3 l _ m _ r) =
  (height l = height m & height m = height r & complete l & complete m & complete r)"

lemma ht_sz_if_complete: "complete t \<Longrightarrow> 2 ^ height t \<le> size t + 1"
by (induction t) auto

end


theory Tree1
  imports Main
begin

datatype 'a Tree  = Leaf 'a | Branch 'a "'a Tree" "'a Tree"

primrec cont :: "'a Tree \<Rightarrow> 'a list" where
  "cont (Leaf val) = [val]"|
  "cont (Branch val lft rgt) =  val # cont lft @ cont rgt"

primrec sumT :: "int Tree \<Rightarrow> int" where
  "sumT (Leaf val) = val"|
  "sumT (Branch val lft rgt) = val + sumT lft + sumT rgt"

definition sumL :: "int list \<Rightarrow> int" where
  "sumL ls = foldl (op +) 0 ls"
(*
lemma helper1 : "val + vals = foldl (\<lambda> x y . x + y) 0  (val # ls) \<Longrightarrow> vals = foldl (\<lambda>x y . x + y) 0 ls"
proof -
  *)
lemma helper1_helper1_helper1_helper1 : fixes n::int shows "foldr op + (a#ls) n = foldr op + (ls @ [a]) n"
proof (induct ls)
  case Nil
  then show ?case by simp
next
  case (Cons aa ls)
  assume a:"foldr op + (a # ls) n = foldr op + (ls @ [a]) n"
  then show ?case by simp
qed

lemma helper1_helper1_helper1 : fixes n::int shows "foldr op + (rev ls) n = foldr op + ls n"
proof (induct ls)
  case Nil
  then show ?case by simp
next
  case (Cons a ls)
  assume hyp:"foldr op + (rev ls) n = foldr op + ls n"
  have "foldr op + (a # ls) n = a + foldr op + ls n" by simp
  also have "\<dots> = a + foldr op + (rev ls) n " using hyp by simp
  also have "\<dots> =  foldr op + (a # rev ls) n" by simp
  also have "\<dots> = foldr op + (rev ls @ [a]) n" using helper1_helper1_helper1_helper1 by simp
  finally show ?case by simp
qed

lemma helper1_helper1_helper2 : fixes n::int shows "foldr (\<lambda>x y . x + y) ls n = foldr (\<lambda> x y. y + x) ls n"
proof (induct ls)
  case Nil
  then show ?case by simp
next
  case (Cons a ls)
  assume hyp:"foldr op + ls n = foldr (\<lambda>x y. y + x) ls n"
  then show ?case by simp
qed

lemma helper1_helper1 : fixes n::int shows "foldl (op +) n ls = foldr (op +) ls n"
proof (induct ls)
  case Nil
  then show ?case by simp
next
  case (Cons a ls)
  assume hyp:"foldl op + n ls = foldr op + ls n"
  have "foldl op + n (a#ls) = foldr (\<lambda> x y . y + x) (rev (a#ls)) n" by (simp add :foldl_conv_foldr)
  also have "\<dots> = foldr (op +) (rev (a#ls)) n" by (simp only : helper1_helper1_helper2)
  also have "\<dots> = foldr (op +) (a#ls) n" by (simp only : helper1_helper1_helper1)
  finally show ?case by simp
qed

lemma helper1_helper2 : fixes n::int shows "a + foldl op + n ls = foldl op + n (a # ls)"
proof (induct ls)
  case Nil
  then show ?case by simp
next
  case (Cons aa ls)
  assume hyp:"a + foldl op + n ls = foldl op + n (a # ls)"
  have "a + foldl op + n (aa#ls) = a + foldr op + (aa#ls) n" by (simp only : helper1_helper1)
  also have "\<dots> = foldr op + (a # aa # ls) n" by simp
  also have "\<dots> = foldl op + n (a # aa # ls)" by (simp only : helper1_helper1 )
  finally show ?case using helper1_helper1 by simp
qed

(*
lemma helper1 : "foldl op + n ls = n + sumL ls"
proof (induct ls)
  case Nil
  then show ?case by (simp add : sumL_def)
next
  case (Cons a ls)
  assume hyp:"foldl op + n ls = n + sumL ls"
  have "foldl op + n (a # ls) = foldr op + (a # ls) n" by (simp only : helper1_helper1)
  also have "\<dots> = a + foldr op + ls n" by simp
  also have "\<dots> = a + foldl op + n ls" by (simp only : helper1_helper1)
  also have "\<dots> = a + n + sumL ls" using hyp by simp
  also have "\<dots> = n + sumL (a # ls)" using helper1_helper2 by (simp add : sumL_def)
  finally show ?case by simp
qed
  *)

lemma helper1_helper3 : fixes n::int shows "foldr op + (ls @ xs) n = foldr op + ls 0 + foldr op + xs n"
proof (induct ls)
  case Nil
  then show ?case by simp
next
  case (Cons a ls)
  assume hyp:"foldr op + (ls @ xs) n = foldr op + ls 0 + foldr op + xs n"
  then show ?case by simp
qed

lemma helper1 : fixes n::int shows "foldl op + n (ls @ xs) = foldl op + 0 ls + foldl op + n xs"
proof (induct ls)
  case Nil
  then show ?case by simp
next
  case (Cons a ls)
  assume hyp:"foldl op + n (ls @ xs) = foldl op + 0 ls + foldl op + n xs"
  then show "foldl op + n ((a # ls) @ xs) = foldl op + 0 (a # ls) + foldl op + n xs" using helper1_helper3 helper1_helper1 by presburger
qed

lemma  fixes tr::"int Tree" shows "sumT tr  = sumL (cont tr)"
proof (induct tr)
  case (Leaf x)
  then show ?case by (simp add : sumL_def)
next
  case (Branch x1a tr1 tr2)
  assume a:"sumT tr1 = sumL (cont tr1)"
  assume b:"sumT tr2 = sumL (cont tr2)"
  have "sumT (Branch x1a tr1 tr2) = x1a + sumT tr1 + sumT tr2" by simp
  also have "\<dots> = x1a + sumL (cont tr1) + sumL (cont tr2)" using a and b by simp
  also have "\<dots> = x1a + foldl op + 0 (cont tr1) + foldl op + 0 (cont tr2)" by (simp add : sumL_def)
  also have "\<dots> = x1a + foldl op + 0 (cont tr1 @ cont tr2)" by (simp only : helper1)
  also have "\<dots> = foldl op + 0 (x1a # cont tr1 @ cont tr2)" by (simp only : helper1_helper2)
  finally show ?case by (simp add : sumL_def)
qed