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

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

datatype Nat = Z | S "Nat"

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

fun last :: "Nat list => Nat" where
  "last (nil2) = Z"
| "last (cons2 z (nil2)) = z"
| "last (cons2 z (cons2 x2 x3)) = last (cons2 x2 x3)"

theorem property0 :
  "((last (x xs (cons2 y (nil2)))) = y)"
  oops

end


(*  Author:     Tobias Nipkow
    Copyright   1998 TUM
*)

header "Generic scanner"

theory MaxChop
imports MaxPrefix
begin

type_synonym 'a chopper = "'a list => 'a list list * 'a list"

definition
 is_maxchopper :: "('a list => bool) => 'a chopper => bool" where
"is_maxchopper P chopper =
 (!xs zs yss.
    (chopper(xs) = (yss,zs)) =
    (xs = concat yss @ zs & (!ys : set yss. ys ~= []) &
     (case yss of
        [] => is_maxpref P [] xs
      | us#uss => is_maxpref P us xs & chopper(concat(uss)@zs) = (uss,zs))))"

definition
 reducing :: "'a splitter => bool" where
"reducing splitf =
 (!xs ys zs. splitf xs = (ys,zs) & ys ~= [] --> length zs < length xs)"

function chop :: "'a splitter \<Rightarrow> 'a list \<Rightarrow> 'a list list \<times> 'a list" where
  [simp del]: "chop splitf xs = (if reducing splitf
                      then let pp = splitf xs
                           in if fst pp = [] then ([], xs)
                           else let qq = chop splitf (snd pp)
                                in (fst pp # fst qq, snd qq)
                      else undefined)"
by pat_completeness auto

termination apply (relation "measure (length o snd)")
apply (auto simp: reducing_def)
apply (case_tac "splitf xs")
apply auto
done

lemma chop_rule: "reducing splitf ==>
  chop splitf xs = (let (pre, post) = splitf xs
                    in if pre = [] then ([], xs)
                       else let (xss, zs) = chop splitf post
                            in (pre # xss,zs))"
apply (simp add: chop.simps)
apply (simp add: Let_def split: split_split)
done

lemma reducing_maxsplit: "reducing(%qs. maxsplit P ([],qs) [] qs)"
by (simp add: reducing_def maxsplit_eq)

lemma is_maxsplitter_reducing:
 "is_maxsplitter P splitf ==> reducing splitf";
by(simp add:is_maxsplitter_def reducing_def)

lemma chop_concat[rule_format]: "is_maxsplitter P splitf ==>
  (!yss zs. chop splitf xs = (yss,zs) --> xs = concat yss @ zs)"
apply (induct xs rule:length_induct)
apply (simp (no_asm_simp) split del: split_if
            add: chop_rule[OF is_maxsplitter_reducing])
apply (simp add: Let_def is_maxsplitter_def split: split_split)
done

lemma chop_nonempty: "is_maxsplitter P splitf ==>
  !yss zs. chop splitf xs = (yss,zs) --> (!ys : set yss. ys ~= [])"
apply (induct xs rule:length_induct)
apply (simp (no_asm_simp) add: chop_rule is_maxsplitter_reducing)
apply (simp add: Let_def is_maxsplitter_def split: split_split)
apply (intro allI impI)
apply (rule ballI)
apply (erule exE)
apply (erule allE)
apply auto
done

lemma is_maxchopper_chop:
 assumes prem: "is_maxsplitter P splitf" shows "is_maxchopper P (chop splitf)"
apply(unfold is_maxchopper_def)
apply clarify
apply (rule iffI)
 apply (rule conjI)
  apply (erule chop_concat[OF prem])
 apply (rule conjI)
  apply (erule prem[THEN chop_nonempty[THEN spec, THEN spec, THEN mp]])
 apply (erule rev_mp)
 apply (subst prem[THEN is_maxsplitter_reducing[THEN chop_rule]])
 apply (simp add: Let_def prem[simplified is_maxsplitter_def]
             split: split_split)
 apply clarify
 apply (rule conjI)
  apply (clarify)
 apply (clarify)
 apply simp
 apply (frule chop_concat[OF prem])
 apply (clarify)
apply (subst prem[THEN is_maxsplitter_reducing, THEN chop_rule])
apply (simp add: Let_def prem[simplified is_maxsplitter_def]
             split: split_split)
apply (clarify)
apply (rename_tac xs1 ys1 xss1 ys)
apply (simp split: list.split_asm)
 apply (simp add: is_maxpref_def)
 apply (blast intro: prefixeq_append[THEN iffD2])
apply (rule conjI)
 apply (clarify)
 apply (simp (no_asm_use) add: is_maxpref_def)
 apply (blast intro: prefixeq_append[THEN iffD2])
apply (clarify)
apply (rename_tac us uss)
apply (subgoal_tac "xs1=us")
 apply simp
apply simp
apply (simp (no_asm_use) add: is_maxpref_def)
apply (blast intro: prefixeq_append[THEN iffD2] prefix_order.antisym)
done

end


(*  Title:      Sequents/T.thy
    Author:     Martin Coen
    Copyright   1991  University of Cambridge
*)

theory T
imports Modal0
begin

axiomatization where
(* Definition of the star operation using a set of Horn clauses *)
(* For system T:  gamma * == {P | []P : gamma}                  *)
(*                delta * == {P | <>P : delta}                  *)

  lstar0:         "|L>" and
  lstar1:         "$G |L> $H ==> []P, $G |L> P, $H" and
  lstar2:         "$G |L> $H ==>   P, $G |L>    $H" and
  rstar0:         "|R>" and
  rstar1:         "$G |R> $H ==> <>P, $G |R> P, $H" and
  rstar2:         "$G |R> $H ==>   P, $G |R>    $H" and

(* Rules for [] and <> *)

  boxR:
   "[| $E |L> $E';  $F |R> $F';  $G |R> $G';
               $E'        |- $F', P, $G'|] ==> $E          |- $F, []P, $G" and
  boxL:     "$E, P, $F  |-         $G    ==> $E, []P, $F |-          $G" and
  diaR:     "$E         |- $F, P,  $G    ==> $E          |- $F, <>P, $G" and
  diaL:
   "[| $E |L> $E';  $F |L> $F';  $G |R> $G';
               $E', P, $F'|-         $G'|] ==> $E, <>P, $F |-          $G"

ML {*
structure T_Prover = Modal_ProverFun
(
  val rewrite_rls = @{thms rewrite_rls}
  val safe_rls = @{thms safe_rls}
  val unsafe_rls = @{thms unsafe_rls} @ [@{thm boxR}, @{thm diaL}]
  val bound_rls = @{thms bound_rls} @ [@{thm boxL}, @{thm diaR}]
  val aside_rls = [@{thm lstar0}, @{thm lstar1}, @{thm lstar2}, @{thm rstar0},
    @{thm rstar1}, @{thm rstar2}]
)
*}

method_setup T_solve = {* Scan.succeed (fn ctxt => SIMPLE_METHOD (T_Prover.solve_tac ctxt 2)) *}

(* Theorems of system T from Hughes and Cresswell and Hailpern, LNCS 129 *)

lemma "|- []P --> P" by T_solve
lemma "|- [](P-->Q) --> ([]P-->[]Q)" by T_solve   (* normality*)
lemma "|- (P--<Q) --> []P --> []Q" by T_solve
lemma "|- P --> <>P" by T_solve

lemma "|-  [](P & Q) <-> []P & []Q" by T_solve
lemma "|-  <>(P | Q) <-> <>P | <>Q" by T_solve
lemma "|-  [](P<->Q) <-> (P>-<Q)" by T_solve
lemma "|-  <>(P-->Q) <-> ([]P--><>Q)" by T_solve
lemma "|-        []P <-> ~<>(~P)" by T_solve
lemma "|-     [](~P) <-> ~<>P" by T_solve
lemma "|-       ~[]P <-> <>(~P)" by T_solve
lemma "|-      [][]P <-> ~<><>(~P)" by T_solve
lemma "|- ~<>(P | Q) <-> ~<>P & ~<>Q" by T_solve

lemma "|- []P | []Q --> [](P | Q)" by T_solve
lemma "|- <>(P & Q) --> <>P & <>Q" by T_solve
lemma "|- [](P | Q) --> []P | <>Q" by T_solve
lemma "|- <>P & []Q --> <>(P & Q)" by T_solve
lemma "|- [](P | Q) --> <>P | []Q" by T_solve
lemma "|- <>(P-->(Q & R)) --> ([]P --> <>Q) & ([]P--><>R)" by T_solve
lemma "|- (P--<Q) & (Q--<R) --> (P--<R)" by T_solve
lemma "|- []P --> <>Q --> <>(P & Q)" by T_solve

end


(* Author: Andreas Lochbihler, Digital Asset
   Author: Ognjen Maric, Digital Asset *)

theory ADS_Construction imports
  Merkle_Interface
  "HOL-Library.Simps_Case_Conv"
begin

(************************************************************)
section \<open> Building blocks for authenticated data structures on datatypes \<close>
(************************************************************)

(************************************************************)
subsection \<open> Building Block: Identity Functor \<close>
(************************************************************)

text \<open>If nothing is blindable in a type, then the type itself is the hash and the ADS of itself.\<close>

abbreviation (input) hash_discrete :: "('a, 'a) hash" where "hash_discrete \<equiv> id"

abbreviation (input) blinding_of_discrete :: "'a blinding_of" where
  "blinding_of_discrete \<equiv> (=)"

definition merge_discrete :: "'a merge" where
  "merge_discrete x y = (if x = y then Some y else None)"

lemma blinding_of_discrete_hash:
  "blinding_of_discrete \<le> vimage2p hash_discrete hash_discrete (=)"
  by(auto simp add: vimage2p_def)

lemma blinding_of_on_discrete [locale_witness]:
  "blinding_of_on UNIV hash_discrete blinding_of_discrete"
  by(unfold_locales)(simp_all add: OO_eq eq_onp_def blinding_of_discrete_hash)

lemma merge_on_discrete [locale_witness]:
  "merge_on UNIV hash_discrete blinding_of_discrete merge_discrete"
  by unfold_locales(auto simp add: merge_discrete_def)

lemma merkle_discrete [locale_witness]:
  "merkle_interface hash_discrete blinding_of_discrete merge_discrete"
  ..

parametric_constant merge_discrete_parametric [transfer_rule]: merge_discrete_def

(************************************************************)
subsubsection \<open>Example: instantiation for @{typ unit}\<close>
(************************************************************)

abbreviation (input) hash_unit :: "(unit, unit) hash" where "hash_unit \<equiv> hash_discrete"

abbreviation blinding_of_unit :: "unit blinding_of" where
  "blinding_of_unit \<equiv> blinding_of_discrete"

abbreviation merge_unit :: "unit merge" where "merge_unit \<equiv> merge_discrete"

lemma blinding_of_unit_hash:
  "blinding_of_unit \<le> vimage2p hash_unit hash_unit (=)"
  by(fact blinding_of_discrete_hash)

lemma blinding_of_on_unit:
  "blinding_of_on UNIV hash_unit blinding_of_unit"
  by(fact blinding_of_on_discrete)

lemma merge_on_unit:
  "merge_on UNIV hash_unit blinding_of_unit merge_unit"
  by(fact merge_on_discrete)

lemma merkle_interface_unit:
  "merkle_interface hash_unit blinding_of_unit merge_unit"
  by(intro merkle_interfaceI merge_on_unit)

(************************************************************)
subsection \<open> Building Block: Blindable Position \<close>
(************************************************************)

type_synonym 'a blindable = 'a

text \<open> The following type represents the hashes of a datatype. We model hashes as being injective,
  but not surjective; some hashes do not correspond to any values of the original datatypes. We
  model such values as "garbage" coming from a countable set (here, naturals). \<close>

type_synonym garbage = nat

datatype 'a\<^sub>h blindable\<^sub>h = Content 'a\<^sub>h | Garbage garbage

datatype ('a\<^sub>m, 'a\<^sub>h) blindable\<^sub>m = Unblinded 'a\<^sub>m | Blinded "'a\<^sub>h blindable\<^sub>h"

(************************************************************)
subsubsection \<open> Hashes \<close>
(************************************************************)

primrec hash_blindable' :: "(('a\<^sub>h, 'a\<^sub>h) blindable\<^sub>m, 'a\<^sub>h blindable\<^sub>h) hash" where
  "hash_blindable' (Unblinded x) = Content x"
| "hash_blindable' (Blinded x) = x"

definition hash_blindable :: "('a\<^sub>m, 'a\<^sub>h) hash \<Rightarrow> (('a\<^sub>m, 'a\<^sub>h) blindable\<^sub>m, 'a\<^sub>h blindable\<^sub>h) hash" where
  "hash_blindable h = hash_blindable' \<circ> map_blindable\<^sub>m h id"

lemma hash_blindable_simps [simp]:
  "hash_blindable h (Unblinded x) = Content (h x)"
  "hash_blindable h (Blinded y) = y"
  by(simp_all add: hash_blindable_def blindable\<^sub>h.map_id)

lemma hash_map_blindable_simp:
  "hash_blindable f (map_blindable\<^sub>m f' id x) = hash_blindable (f o f') x"
  by(cases x) (simp_all add: hash_blindable_def blindable\<^sub>h.map_comp)

parametric_constant hash_blindable'_parametric [transfer_rule]: hash_blindable'_def

parametric_constant hash_blindable_parametric [transfer_rule]: hash_blindable_def

(************************************************************)
subsubsection \<open> Blinding \<close>
(************************************************************)

context
  fixes h :: "('a\<^sub>m, 'a\<^sub>h) hash"
    and bo :: "'a\<^sub>m blinding_of"
begin

inductive blinding_of_blindable :: "('a\<^sub>m, 'a\<^sub>h) blindable\<^sub>m blinding_of" where
  "blinding_of_blindable (Unblinded x) (Unblinded y)" if "bo x y"
| "blinding_of_blindable (Blinded x) t" if "hash_blindable h t = x"

inductive_simps blinding_of_blindable_simps [simp]:
  "blinding_of_blindable (Unblinded x) y"
  "blinding_of_blindable (Blinded x) y"
  "blinding_of_blindable z (Unblinded x)"
  "blinding_of_blindable z (Blinded x)"

inductive_simps blinding_of_blindable_simps2:
   "blinding_of_blindable (Unblinded x) (Unblinded y)"
   "blinding_of_blindable (Unblinded x) (Blinded y')"
   "blinding_of_blindable (Blinded x') (Unblinded y)"
   "blinding_of_blindable (Blinded x') (Blinded y')"

end

lemma blinding_of_blindable_mono:
  assumes "bo \<le> bo'"
  shows "blinding_of_blindable h bo \<le> blinding_of_blindable h bo'"
  apply(rule predicate2I)
  apply(erule blinding_of_blindable.cases; hypsubst)
  subgoal by(rule blinding_of_blindable.intros)(rule assms[THEN predicate2D])
  subgoal by(rule blinding_of_blindable.intros) simp
  done

lemma blinding_of_blindable_hash:
  assumes "bo \<le> vimage2p h h (=)"
  shows "blinding_of_blindable h bo \<le> vimage2p (hash_blindable h) (hash_blindable h) (=)"
  apply(rule predicate2I vimage2pI)+
  apply(erule blinding_of_blindable.cases; hypsubst)
  subgoal using assms[THEN predicate2D] by(simp add: vimage2p_def)
  subgoal by simp
  done

lemma blinding_of_on_blindable [locale_witness]:
  assumes "blinding_of_on A h bo"
  shows "blinding_of_on {x. set1_blindable\<^sub>m x \<subseteq> A} (hash_blindable h) (blinding_of_blindable h bo)"
  (is "blinding_of_on ?A ?h ?bo")
proof -
  interpret blinding_of_on A h bo by fact
  show ?thesis
  proof
    show "?bo \<le> vimage2p ?h ?h (=)"
      by(rule blinding_of_blindable_hash)(rule hash)
    show "?bo x x" if "x \<in> ?A" for x using that by(cases x)(auto simp add: refl)
    show "?bo x z" if "?bo x y" "?bo y z" "x \<in> ?A" for x y z using that
      by(auto elim!: blinding_of_blindable.cases dest: trans blinding_hash_eq)
    show "x = y" if "?bo x y" "?bo y x" "x \<in> ?A" for x y using that
      by(auto elim!: blinding_of_blindable.cases dest: antisym)
  qed
qed

lemmas blinding_of_blindable [locale_witness] = blinding_of_on_blindable[of UNIV, simplified]

case_of_simps blinding_of_blindable_alt_def: blinding_of_blindable_simps2
parametric_constant blinding_of_blindable_parametric [transfer_rule]: blinding_of_blindable_alt_def

(************************************************************)
subsubsection \<open> Merging \<close>
(************************************************************)

context
  fixes h :: "('a\<^sub>m, 'a\<^sub>h) hash"
  fixes m :: "'a\<^sub>m merge"
begin

fun merge_blindable :: "('a\<^sub>m, 'a\<^sub>h) blindable\<^sub>m merge" where
  "merge_blindable (Unblinded x) (Unblinded y) = map_option Unblinded (m x y)"
| "merge_blindable (Blinded x) (Unblinded y) = (if x = Content (h y) then Some (Unblinded y) else None)"
| "merge_blindable (Unblinded y) (Blinded x) = (if x = Content (h y) then Some (Unblinded y) else None)"
| "merge_blindable (Blinded t) (Blinded u) = (if t = u then Some (Blinded u) else None)"

lemma merge_on_blindable [locale_witness]:
  assumes "merge_on A h bo m"
  shows "merge_on {x. set1_blindable\<^sub>m x \<subseteq> A} (hash_blindable h) (blinding_of_blindable h bo) merge_blindable"
  (is "merge_on ?A ?h ?bo ?m")
proof -
  interpret merge_on A h bo m by fact
  show ?thesis
  proof
    show "\<exists>ab. ?m a b = Some ab \<and> ?bo a ab \<and> ?bo b ab \<and> (\<forall>u. ?bo a u \<longrightarrow> ?bo b u \<longrightarrow> ?bo ab u)" if "?h a = ?h b" "a \<in> ?A" for a b
      using that by(cases "(a, b)" rule: merge_blindable.cases)(auto simp add: refl dest!: join)
    show "?m a b = None" if "?h a \<noteq> ?h b" "a \<in> ?A" for a b
      using that by(cases "(a, b)" rule: merge_blindable.cases)(auto simp add: dest!: undefined)
  qed
qed

lemmas merge_blindable [locale_witness] =
  merge_on_blindable[of UNIV, simplified]

end

lemma merge_blindable_alt_def:
  "merge_blindable h m x y = (case (x, y) of
    (Unblinded x, Unblinded y) \<Rightarrow> map_option Unblinded (m x y)
  | (Blinded x, Unblinded y) \<Rightarrow> (if Content (h y) = x then Some (Unblinded y) else None)
  | (Unblinded y, Blinded x) \<Rightarrow> (if Content (h y) = x then Some (Unblinded y) else None)
  | (Blinded t, Blinded u) \<Rightarrow> (if t = u then Some (Blinded u) else None))"
  by(simp split: blindable\<^sub>m.split blindable\<^sub>h.split)

parametric_constant merge_blindable_parametric [transfer_rule]: merge_blindable_alt_def

lemma merge_blindable_cong [fundef_cong]:
  assumes "\<And>a b. \<lbrakk> a \<in> set1_blindable\<^sub>m x; b \<in> set1_blindable\<^sub>m y \<rbrakk> \<Longrightarrow> m a b = m' a b"
  shows "merge_blindable h m x y = merge_blindable h m' x y"
  by(auto simp add: merge_blindable_alt_def split: blindable\<^sub>m.split intro: assms intro!: arg_cong[where f="map_option _"])

(************************************************************)
subsubsection \<open> Merkle interface \<close>
(************************************************************)

lemma merkle_blindable [locale_witness]:
  assumes "merkle_interface h bo m"
  shows "merkle_interface (hash_blindable h) (blinding_of_blindable h bo) (merge_blindable h m)"
proof -
  interpret merge_on UNIV h bo m using assms by(simp add: merkle_interface_aux)
  show ?thesis unfolding merkle_interface_aux ..
qed

(************************************************************)
subsubsection \<open> Non-recursive blindable positions \<close>
(************************************************************)

text \<open> For a non-recursive data type @{typ 'a}, the type of hashes in @{type blindable\<^sub>m} is fixed
to be simply @{typ "'a blindable\<^sub>h"}. We obtain this by instantiating the type variable with the
identity building block. \<close>

type_synonym 'a nr_blindable = "('a, 'a) blindable\<^sub>m"

abbreviation hash_nr_blindable :: "('a nr_blindable, 'a blindable\<^sub>h) hash" where
  "hash_nr_blindable \<equiv> hash_blindable hash_discrete"

abbreviation blinding_of_nr_blindable :: "'a nr_blindable blinding_of" where
  "blinding_of_nr_blindable \<equiv> blinding_of_blindable hash_discrete blinding_of_discrete"

abbreviation merge_nr_blindable :: "'a nr_blindable merge" where
  "merge_nr_blindable \<equiv> merge_blindable hash_discrete merge_discrete"

lemma merge_on_nr_blindable:
  "merge_on UNIV hash_nr_blindable blinding_of_nr_blindable merge_nr_blindable"
  ..

lemma merkle_nr_blindable:
  "merkle_interface hash_nr_blindable blinding_of_nr_blindable merge_nr_blindable"
  ..

(************************************************************)
subsection \<open> Building block: Sums \<close>
(************************************************************)

text \<open> We prove that we can lift the ADS construction through sums.\<close>

type_synonym ('a\<^sub>h, 'b\<^sub>h) sum\<^sub>h = "'a\<^sub>h + 'b\<^sub>h"
type_notation sum\<^sub>h (infixr "+\<^sub>h" 10)

type_synonym ('a\<^sub>m, 'b\<^sub>m) sum\<^sub>m = "'a\<^sub>m + 'b\<^sub>m"
  \<comment> \<open>If a functor does not introduce blindable positions, then we don't need the type variable copies.\<close>
type_notation sum\<^sub>m (infixr "+\<^sub>m" 10)

(************************************************************)
subsubsection \<open> Hashes \<close>
(************************************************************)

abbreviation (input) hash_sum' :: "('a\<^sub>h +\<^sub>h 'b\<^sub>h, 'a\<^sub>h +\<^sub>h 'b\<^sub>h) hash" where
  "hash_sum' \<equiv> id"

abbreviation (input) hash_sum :: "('a\<^sub>m, 'a\<^sub>h) hash \<Rightarrow> ('b\<^sub>m, 'b\<^sub>h) hash \<Rightarrow> ('a\<^sub>m +\<^sub>m 'b\<^sub>m, 'a\<^sub>h +\<^sub>h 'b\<^sub>h) hash"
  where "hash_sum \<equiv> map_sum"

(************************************************************)
subsubsection \<open> Blinding \<close>
(************************************************************)

abbreviation (input) blinding_of_sum :: "'a\<^sub>m blinding_of \<Rightarrow> 'b\<^sub>m blinding_of \<Rightarrow> ('a\<^sub>m +\<^sub>m 'b\<^sub>m) blinding_of" where
  "blinding_of_sum \<equiv> rel_sum"

lemmas blinding_of_sum_mono = sum.rel_mono

lemma blinding_of_sum_hash:
  assumes "boa \<le> vimage2p rha rha (=)" "bob \<le> vimage2p rhb rhb (=)"
  shows "blinding_of_sum boa bob \<le> vimage2p (hash_sum rha rhb) (hash_sum rha rhb) (=)"
  using assms by(auto simp add: vimage2p_def elim!: rel_sum.cases)

lemma blinding_of_on_sum [locale_witness]:
  assumes "blinding_of_on A rha boa" "blinding_of_on B rhb bob"
  shows "blinding_of_on {x. setl x \<subseteq> A \<and> setr x \<subseteq> B} (hash_sum rha rhb) (blinding_of_sum boa bob)"
  (is "blinding_of_on ?A ?h ?bo")
proof -
  interpret a: blinding_of_on A rha boa by fact
  interpret b: blinding_of_on B rhb bob by fact
  show ?thesis
  proof
    show "?bo x x" if "x \<in> ?A" for x using that by(intro sum.rel_refl_strong)(auto intro: a.refl b.refl)
    show "?bo x z" if "?bo x y" "?bo y z" "x \<in> ?A" for x y z
      using that by(auto elim!: rel_sum.cases dest: a.trans b.trans)
    show "x = y" if "?bo x y" "?bo y x" "x \<in> ?A" for x y
      using that by(auto elim!: rel_sum.cases dest: a.antisym b.antisym)
  qed(rule blinding_of_sum_hash a.hash b.hash)+
qed

lemmas blinding_of_sum [locale_witness] = blinding_of_on_sum[of UNIV _ _ UNIV, simplified]

(************************************************************)
subsubsection \<open> Merging \<close>
(************************************************************)

context
  fixes ma :: "'a\<^sub>m merge"
  fixes mb :: "'b\<^sub>m merge"
begin

fun merge_sum :: "('a\<^sub>m +\<^sub>m 'b\<^sub>m) merge" where
  "merge_sum (Inl x) (Inl y) = map_option Inl (ma x y)"
| "merge_sum (Inr x) (Inr y) = map_option Inr (mb x y)"
| "merge_sum _ _ = None"

lemma merge_on_sum [locale_witness]:
  assumes "merge_on A rha boa ma" "merge_on B rhb bob mb"
  shows "merge_on {x. setl x \<subseteq> A \<and> setr x \<subseteq> B} (hash_sum rha rhb) (blinding_of_sum boa bob) merge_sum"
  (is "merge_on ?A ?h ?bo ?m")
proof -
  interpret a: merge_on A rha boa ma by fact
  interpret b: merge_on B rhb bob mb by fact
  show ?thesis
  proof
    show "\<exists>ab. ?m a b = Some ab \<and> ?bo a ab \<and> ?bo b ab \<and> (\<forall>u. ?bo a u \<longrightarrow> ?bo b u \<longrightarrow> ?bo ab u)"
      if "?h a = ?h b" "a \<in> ?A" for a b using that
      by(cases "(a, b)" rule: merge_sum.cases)(auto dest!: a.join b.join elim!: rel_sum.cases)
    show "?m a b = None" if "?h a \<noteq> ?h b" "a \<in> ?A" for a b using that
      by(cases "(a, b)" rule: merge_sum.cases)(auto dest!: a.undefined b.undefined)
  qed
qed

lemmas merge_sum [locale_witness] = merge_on_sum[where A=UNIV and B=UNIV, simplified]

lemma merge_sum_alt_def:
  "merge_sum x y = (case (x, y) of
    (Inl x, Inl y) \<Rightarrow> map_option Inl (ma x y)
  | (Inr x, Inr y) \<Rightarrow> map_option Inr (mb x y)
  | _ \<Rightarrow> None)"
  by(simp add: split: sum.split)

end

lemma merge_sum_cong[fundef_cong]:
  "\<lbrakk> x = x'; y = y';
    \<And>xl yl. \<lbrakk> x = Inl xl; y = Inl yl \<rbrakk> \<Longrightarrow> ma xl yl = ma' xl yl;
    \<And>xr yr. \<lbrakk> x = Inr xr; y = Inr yr \<rbrakk> \<Longrightarrow> mb xr yr = mb' xr yr \<rbrakk> \<Longrightarrow>
    merge_sum ma mb x y = merge_sum ma' mb' x' y'"
  by(cases x; simp_all; cases y; auto)

parametric_constant merge_sum_parametric [transfer_rule]: merge_sum_alt_def

subsubsection \<open> Merkle interface \<close>

lemma merkle_sum [locale_witness]:
  assumes "merkle_interface rha boa ma" "merkle_interface rhb bob mb"
  shows "merkle_interface (hash_sum rha rhb) (blinding_of_sum boa bob) (merge_sum ma mb)"
proof -
  interpret a: merge_on UNIV rha boa ma unfolding merkle_interface_aux[symmetric] by fact
  interpret b: merge_on UNIV rhb bob mb unfolding merkle_interface_aux[symmetric] by fact
  show ?thesis unfolding merkle_interface_aux[symmetric] ..
qed

(************************************************************)
subsection \<open> Building Block: Products\<close>
(************************************************************)

text \<open> We prove that we can lift the ADS construction through products.\<close>

type_synonym ('a\<^sub>h, 'b\<^sub>h) prod\<^sub>h = "'a\<^sub>h \<times> 'b\<^sub>h"
type_notation prod\<^sub>h ("(_ \<times>\<^sub>h/ _)" [21, 20] 20)

type_synonym ('a\<^sub>m, 'b\<^sub>m) prod\<^sub>m = "'a\<^sub>m \<times> 'b\<^sub>m"
  \<comment> \<open>If a functor does not introduce blindable positions, then we don't need the type variable copies.\<close>
type_notation prod\<^sub>m ("(_ \<times>\<^sub>m/ _)" [21, 20] 20)

(************************************************************)
subsubsection \<open> Hashes \<close>
(************************************************************)

abbreviation (input) hash_prod' :: "('a\<^sub>h \<times>\<^sub>h 'b\<^sub>h, 'a\<^sub>h \<times>\<^sub>h 'b\<^sub>h) hash" where
  "hash_prod' \<equiv> id"

abbreviation (input) hash_prod :: "('a\<^sub>m, 'a\<^sub>h) hash \<Rightarrow> ('b\<^sub>m, 'b\<^sub>h) hash \<Rightarrow> ('a\<^sub>m \<times>\<^sub>m 'b\<^sub>m, 'a\<^sub>h \<times>\<^sub>h 'b\<^sub>h) hash"
  where "hash_prod \<equiv> map_prod"

(************************************************************)
subsubsection \<open> Blinding \<close>
(************************************************************)

abbreviation (input) blinding_of_prod :: "'a\<^sub>m blinding_of \<Rightarrow> 'b\<^sub>m blinding_of \<Rightarrow> ('a\<^sub>m \<times>\<^sub>m 'b\<^sub>m) blinding_of" where
  "blinding_of_prod \<equiv> rel_prod"

lemmas blinding_of_prod_mono = prod.rel_mono

lemma blinding_of_prod_hash:
  assumes "boa \<le> vimage2p rha rha (=)" "bob \<le> vimage2p rhb rhb (=)"
  shows "blinding_of_prod boa bob \<le> vimage2p (hash_prod rha rhb) (hash_prod rha rhb) (=)"
  using assms by(auto simp add: vimage2p_def)

lemma blinding_of_on_prod [locale_witness]:
  assumes "blinding_of_on A rha boa" "blinding_of_on B rhb bob"
  shows "blinding_of_on {x. fsts x \<subseteq> A \<and> snds x \<subseteq> B} (hash_prod rha rhb) (blinding_of_prod boa bob)"
  (is "blinding_of_on ?A ?h ?bo")
proof -
  interpret a: blinding_of_on A rha boa by fact
  interpret b: blinding_of_on B rhb bob by fact
  show ?thesis
  proof
    show "?bo x x" if "x \<in> ?A" for x using that by(cases x)(auto intro: a.refl b.refl)
    show "?bo x z" if "?bo x y" "?bo y z" "x \<in> ?A" for x y z using that
      by(auto elim!: rel_prod.cases dest: a.trans b.trans)
    show "x = y" if "?bo x y" "?bo y x" "x \<in> ?A" for x y using that
      by(auto elim!: rel_prod.cases dest: a.antisym b.antisym)
  qed(rule blinding_of_prod_hash a.hash b.hash)+
qed

lemmas blinding_of_prod [locale_witness] = blinding_of_on_prod[where A=UNIV and B=UNIV, simplified]

(************************************************************)
subsubsection \<open> Merging \<close>
(************************************************************)

context
  fixes ma :: "'a\<^sub>m merge"
  fixes mb :: "'b\<^sub>m merge"
begin

fun merge_prod :: "('a\<^sub>m \<times>\<^sub>m 'b\<^sub>m) merge" where
  "merge_prod (x, y) (x', y') = Option.bind (ma x x') (\<lambda>x''. map_option (Pair x'') (mb y y'))"

lemma merge_on_prod [locale_witness]:
  assumes "merge_on A rha boa ma" "merge_on B rhb bob mb"
  shows "merge_on {x. fsts x \<subseteq> A \<and> snds x \<subseteq> B} (hash_prod rha rhb) (blinding_of_prod boa bob) merge_prod"
  (is "merge_on ?A ?h ?bo ?m")
proof -
  interpret a: merge_on A rha boa ma by fact
  interpret b: merge_on B rhb bob mb by fact
  show ?thesis
  proof
    show "\<exists>ab. ?m a b = Some ab \<and> ?bo a ab \<and> ?bo b ab \<and> (\<forall>u. ?bo a u \<longrightarrow> ?bo b u \<longrightarrow> ?bo ab u)"
      if "?h a = ?h b" "a \<in> ?A" for a b using that
      by(cases "(a, b)" rule: merge_prod.cases)(auto dest!: a.join b.join)
    show "?m a b = None" if "?h a \<noteq> ?h b" "a \<in> ?A" for a b using that
      by(cases "(a, b)" rule: merge_prod.cases)(auto dest!: a.undefined b.undefined)
  qed
qed

lemmas merge_prod [locale_witness] = merge_on_prod[where A=UNIV and B=UNIV, simplified]

lemma merge_prod_alt_def:
  "merge_prod = (\<lambda>(x, y) (x', y'). Option.bind (ma x x') (\<lambda>x''. map_option (Pair x'') (mb y y')))"
  by(simp add: fun_eq_iff)

end

lemma merge_prod_cong[fundef_cong]:
  assumes "\<And>a b. \<lbrakk> a \<in> fsts p1; b \<in> fsts p2 \<rbrakk> \<Longrightarrow> ma a b = ma' a b"
    and "\<And>a b. \<lbrakk> a \<in> snds p1; b \<in> snds p2 \<rbrakk> \<Longrightarrow> mb a b = mb' a b"
  shows "merge_prod ma mb p1 p2 = merge_prod ma' mb' p1 p2"
  using assms by(cases p1; cases p2) auto

parametric_constant merge_prod_parametric [transfer_rule]: merge_prod_alt_def

(************************************************************)
subsubsection \<open> Merkle Interface \<close>
(************************************************************)

lemma merkle_product [locale_witness]:
  assumes "merkle_interface rha boa ma" "merkle_interface rhb bob mb"
  shows "merkle_interface (hash_prod rha rhb) (blinding_of_prod boa bob) (merge_prod ma mb)"
proof -
  interpret a: merge_on UNIV rha boa ma unfolding merkle_interface_aux[symmetric] by fact
  interpret b: merge_on UNIV rhb bob mb unfolding merkle_interface_aux[symmetric] by fact
  show ?thesis unfolding merkle_interface_aux[symmetric] ..
qed

(************************************************************)
subsection \<open>Building Block: Lists\<close>
(************************************************************)

text \<open>The ADS construction on lists is done the easiest through a separate isomorphic datatype
  that has only a single constructor. We hide this construction in a locale. \<close>

locale list_R1 begin

type_synonym ('a, 'b) list_F = "unit + 'a \<times> 'b"

abbreviation (input) "set_base_F\<^sub>m \<equiv> \<lambda>x. setr x \<bind> fsts"
abbreviation (input) "set_rec_F\<^sub>m \<equiv> \<lambda>A. setr A \<bind> snds"
abbreviation (input) "map_F \<equiv> \<lambda>fb fr. map_sum id (map_prod fb fr)"

datatype 'a list_R1 = list_R1 (unR: "('a, 'a list_R1) list_F")

lemma list_R1_const_into_dest: "list_R1 F = l \<longleftrightarrow> F = unR l"
  by auto

declare list_R1.split[split]

lemma list_R1_induct[case_names list_R1]:
  assumes "\<And>F. \<lbrakk> \<And>l'. l' \<in> set_rec_F\<^sub>m F  \<Longrightarrow> P l' \<rbrakk> \<Longrightarrow> P (list_R1 F)"
  shows "P l"
  apply(rule list_R1.induct)
  apply(auto intro!: assms)
  done

lemma set_list_R1_eq:
  "{x. set_base_F\<^sub>m x \<subseteq> A \<and> set_rec_F\<^sub>m x \<subseteq> B} =
   {x. setl x \<subseteq> UNIV \<and> setr x \<subseteq> {x. fsts x \<subseteq> A \<and> snds x \<subseteq> B}}"
  by(auto simp add: bind_UNION)

(************************************************************)
subsubsection \<open> The Isomorphism \<close>
(************************************************************)

primrec (transfer) list_R1_to_list :: "'a list_R1 \<Rightarrow> 'a list" where
  "list_R1_to_list (list_R1 l) = (case map_sum id (map_prod id list_R1_to_list) l of Inl () \<Rightarrow> [] | Inr (x, xs) \<Rightarrow> x # xs)"

lemma list_R1_to_list_simps [simp]:
  "list_R1_to_list (list_R1 (Inl ())) = []"
  "list_R1_to_list (list_R1 (Inr (x, xs))) = x # list_R1_to_list xs"
  by(simp_all split: unit.split)

declare list_R1_to_list.simps [simp del]

primrec (transfer) list_to_list_R1 :: "'a list \<Rightarrow> 'a list_R1" where
  "list_to_list_R1 [] = list_R1 (Inl ())"
| "list_to_list_R1 (x#xs) = list_R1 (Inr (x, list_to_list_R1 xs))"

lemma R1_of_list: "list_R1_to_list (list_to_list_R1 x) = x"
  by(induct x) (auto)

lemma list_of_R1: "list_to_list_R1 (list_R1_to_list x) = x"
  apply(induct x)
  subgoal for x
    by(cases x) (auto)
  done

lemma list_R1_def: "type_definition list_to_list_R1 list_R1_to_list UNIV"
  by(unfold_locales)(auto intro: R1_of_list list_of_R1)

setup_lifting list_R1_def

lemma map_list_R1_list_to_list_R1: "map_list_R1 f (list_to_list_R1 xs) = list_to_list_R1 (map f xs)"
  by(induction xs) auto

lemma list_R1_map_trans [transfer_rule]: includes lifting_syntax shows
  "(((=) ===> (=)) ===> pcr_list (=) ===> pcr_list (=)) map_list_R1 map"
  by(auto 4 3 simp add: list.pcr_cr_eq rel_fun_eq cr_list_def map_list_R1_list_to_list_R1)

lemma set_list_R1_list_to_list_R1: "set_list_R1 (list_to_list_R1 xs) = set xs"
  by(induction xs) auto

lemma list_R1_set_trans [transfer_rule]: includes lifting_syntax shows
  "(pcr_list (=) ===> (=)) set_list_R1 set"
  by(auto simp add: list.pcr_cr_eq cr_list_def set_list_R1_list_to_list_R1)

lemma rel_list_R1_list_to_list_R1:
   "rel_list_R1 R (list_to_list_R1 xs) (list_to_list_R1 ys) \<longleftrightarrow> list_all2 R xs ys"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  define xs' and ys' where "xs' = list_to_list_R1 xs" and "ys' = list_to_list_R1 ys"
  assume "rel_list_R1 R xs' ys'"
  then have "list_all2 R (list_R1_to_list xs') (list_R1_to_list ys')"
    by induction(auto elim!: rel_sum.cases)
  thus ?rhs by(simp add: xs'_def ys'_def R1_of_list)
next
  show ?lhs if ?rhs using that by induction auto
qed

lemma list_R1_rel_trans[transfer_rule]: includes lifting_syntax shows
  "(((=) ===> (=) ===> (=)) ===> pcr_list (=) ===> pcr_list (=) ===> (=)) rel_list_R1 list_all2"
  by(auto 4 4 simp add: list.pcr_cr_eq rel_fun_eq cr_list_def rel_list_R1_list_to_list_R1)

(************************************************************)
subsubsection \<open> Hashes \<close>
(************************************************************)

type_synonym ('a\<^sub>h, 'b\<^sub>h) list_F\<^sub>h = "unit +\<^sub>h 'a\<^sub>h \<times>\<^sub>h 'b\<^sub>h"

type_synonym ('a\<^sub>m, 'b\<^sub>m) list_F\<^sub>m = "unit +\<^sub>m 'a\<^sub>m \<times>\<^sub>m 'b\<^sub>m"

type_synonym 'a\<^sub>h list_R1\<^sub>h = "'a\<^sub>h list_R1"
  \<comment> \<open>In theory, we should define a separate datatype here of the functor @{typ "('a\<^sub>h, _) list_F\<^sub>h"}.
    We take a shortcut because they're isomorphic.\<close>

type_synonym 'a\<^sub>m list_R1\<^sub>m = "'a\<^sub>m list_R1"
  \<comment> \<open>In theory, we should define a separate datatype here of the functor @{typ "('a\<^sub>m, _) list_F\<^sub>m"}.
    We take a shortcut because they're isomorphic.\<close>

definition hash_F :: "('a\<^sub>m, 'a\<^sub>h) hash \<Rightarrow> ('b\<^sub>m, 'b\<^sub>h) hash \<Rightarrow> (('a\<^sub>m, 'b\<^sub>m) list_F\<^sub>m, ('a\<^sub>h, 'b\<^sub>h) list_F\<^sub>h) hash" where
  "hash_F h rhL = hash_sum hash_unit (hash_prod h rhL)"

abbreviation (input) hash_R1 :: "('a\<^sub>m, 'a\<^sub>h) hash \<Rightarrow> ('a\<^sub>m list_R1\<^sub>m, 'a\<^sub>h list_R1\<^sub>h) hash" where
  "hash_R1 \<equiv> map_list_R1"

parametric_constant hash_F_parametric[transfer_rule]: hash_F_def

(************************************************************)
subsubsection \<open> Blinding \<close>
(************************************************************)

definition blinding_of_F :: "'a\<^sub>m blinding_of \<Rightarrow> 'b\<^sub>m blinding_of \<Rightarrow> ('a\<^sub>m, 'b\<^sub>m) list_F\<^sub>m blinding_of" where
  "blinding_of_F bo bL = blinding_of_sum blinding_of_unit (blinding_of_prod bo bL)"

abbreviation (input) blinding_of_R1 :: "'a blinding_of \<Rightarrow> 'a list_R1 blinding_of" where
  "blinding_of_R1 \<equiv> rel_list_R1"

lemma blinding_of_hash_R1:
  assumes "bo \<le> vimage2p h h (=)"
  shows "blinding_of_R1 bo \<le> vimage2p (hash_R1 h) (hash_R1 h) (=)"
  apply(rule predicate2I vimage2pI)+
  apply(auto simp add: predicate2D_vimage2p[OF assms] elim!: list_R1.rel_induct rel_sum.cases rel_prod.cases)
  done

lemma blinding_of_on_R1 [locale_witness]:
  assumes "blinding_of_on A h bo"
  shows "blinding_of_on {x. set_list_R1 x \<subseteq> A} (hash_R1 h) (blinding_of_R1 bo)"
  (is "blinding_of_on ?A ?h ?bo")
proof -
  interpret a: blinding_of_on A h bo by fact
  show ?thesis
  proof
    show hash: "?bo \<le> vimage2p ?h ?h (=)" using a.hash by(rule blinding_of_hash_R1)

    have "?bo x x \<and> (?bo x y \<longrightarrow> ?bo y z \<longrightarrow> ?bo x z) \<and> (?bo x y \<longrightarrow> ?bo y x \<longrightarrow> x = y)" if "x \<in> ?A" for x y z using that
    proof(induction x arbitrary: y z)
      case (list_R1 x y' z')
      from list_R1.prems have s1: "set_base_F\<^sub>m x \<subseteq> A" by(fastforce)
      from list_R1.prems have s3: "set_rec_F\<^sub>m x \<bind> set_list_R1 \<subseteq> A" by(fastforce intro: rev_bexI)

      interpret F: blinding_of_on "{y. set_base_F\<^sub>m y \<subseteq> A \<and> set_rec_F\<^sub>m y \<subseteq> set_rec_F\<^sub>m x}"
        "hash_F h (hash_R1 h)" "blinding_of_F bo (blinding_of_R1 bo)"
        unfolding hash_F_def blinding_of_F_def set_list_R1_eq
      proof
        let ?A' = "setr x \<bind> snds" and ?bo' = "rel_list_R1 bo"
        show "?bo' x x" if "x \<in> ?A'" for x using that list_R1 by(force simp add: eq_onp_def)
        show "?bo' x z" if "?bo' x y" "?bo' y z" "x \<in> ?A'" for x y z
          using that list_R1.IH[of _ x y z] list_R1.prems
          by(force simp add: bind_UNION prod_set_defs)
        show "x = y" if "?bo' x y" "?bo' y x" "x \<in> ?A'" for x y
          using that list_R1.IH[of _ x y] list_R1.prems
          by(force simp add: prod_set_defs)
      qed(rule hash)
      show ?case using list_R1.prems
        apply(intro conjI)
        subgoal using F.refl[of x] s1 unfolding blinding_of_F_def by(auto intro: list_R1.rel_intros)
        subgoal using s1 by(auto elim!: list_R1.rel_cases F.trans[unfolded blinding_of_F_def] intro: list_R1.rel_intros)
        subgoal using s1 by(auto elim!: list_R1.rel_cases dest: F.antisym[unfolded blinding_of_F_def])
        done
    qed
    then show "x \<in> ?A \<Longrightarrow> ?bo x x"
      and "\<lbrakk> ?bo x y; ?bo y z; x \<in> ?A \<rbrakk> \<Longrightarrow> ?bo x z"
      and "\<lbrakk> ?bo x y; ?bo y x; x \<in> ?A \<rbrakk> \<Longrightarrow> x = y"
      for x y z by blast+
  qed
qed

lemmas blinding_of_R1 [locale_witness] = blinding_of_on_R1[where A=UNIV, simplified]

parametric_constant blinding_of_F_parametric[transfer_rule]: blinding_of_F_def

(************************************************************)
subsubsection \<open> Merging \<close>
(************************************************************)

definition merge_F :: "'a\<^sub>m merge \<Rightarrow> 'b\<^sub>m merge \<Rightarrow> ('a\<^sub>m, 'b\<^sub>m) list_F\<^sub>m merge" where
  "merge_F m mL = merge_sum merge_unit (merge_prod m mL)"

lemma merge_F_cong[fundef_cong]:
  assumes "\<And>a b. \<lbrakk> a \<in> set_base_F\<^sub>m x; b \<in> set_base_F\<^sub>m y \<rbrakk> \<Longrightarrow> m a b = m' a b"
    and "\<And>a b. \<lbrakk> a \<in> set_rec_F\<^sub>m x; b \<in> set_rec_F\<^sub>m y \<rbrakk> \<Longrightarrow> mL a b = mL' a b"
  shows "merge_F m mL x y = merge_F m' mL' x y"
  using assms
  apply(cases x; cases y)
     apply(simp_all add: merge_F_def)
  apply(rule arg_cong[where f="map_option _"])
  apply(blast intro: merge_prod_cong)
  done

context
  fixes m :: "'a\<^sub>m merge"
  notes setr.simps[simp]
begin
fun merge_R1 :: "'a\<^sub>m list_R1\<^sub>m merge" where
  "merge_R1 (list_R1 l1) (list_R1 l2) = map_option list_R1 (merge_F m merge_R1 l1 l2)"
end

case_of_simps merge_cases [simp]: merge_R1.simps

lemma merge_on_R1:
  assumes "merge_on A h bo m"
  shows "merge_on {x. set_list_R1 x \<subseteq> A } (hash_R1 h) (blinding_of_R1 bo) (merge_R1 m)"
  (is "merge_on ?A ?h ?bo ?m")
proof -
  interpret a: merge_on A h bo m by fact
  show ?thesis
  proof
    have "(?h a = ?h b \<longrightarrow> (\<exists>ab. ?m a b = Some ab \<and> ?bo a ab \<and> ?bo b ab \<and> (\<forall>u. ?bo a u \<longrightarrow> ?bo b u \<longrightarrow> ?bo ab u))) \<and>
      (?h a \<noteq> ?h b \<longrightarrow> ?m a b = None)"
      if "a \<in> ?A" for a b using that unfolding mem_Collect_eq
    proof(induction a arbitrary: b rule: list_R1_induct)
      case wfInd: (list_R1 l)
      interpret merge_on "{y. set_base_F\<^sub>m y \<subseteq> A \<and> set_rec_F\<^sub>m y \<subseteq> set_rec_F\<^sub>m l}"
        "hash_F h ?h" "blinding_of_F bo ?bo" "merge_F m ?m"
        unfolding set_list_R1_eq hash_F_def merge_F_def blinding_of_F_def
      proof
        fix a
        assume a: "a \<in> set_rec_F\<^sub>m l"
        with wfInd.prems have a': "set_list_R1 a \<subseteq> A"
          by fastforce

        show "hash_R1 h a = hash_R1 h b
           \<Longrightarrow> \<exists>ab. ?m a b = Some ab \<and> ?bo a ab \<and> ?bo b ab \<and>
                    (\<forall>u. ?bo a u \<longrightarrow> ?bo b u \<longrightarrow> ?bo ab u)"
          and "?h a \<noteq> ?h b \<Longrightarrow> ?m a b = None" for b
          using wfInd.IH[OF a a', rule_format, of b]
          by(auto dest: sym)
      qed
      show ?case using wfInd.prems
        apply(intro conjI strip)
        subgoal
          by(auto 4 4 dest!: join[unfolded hash_F_def]
              simp add: blinding_of_F_def UN_subset_iff list_R1.rel_sel)
        subgoal by(auto 4 3 intro!: undefined[simplified hash_F_def])
        done
    qed
    then show
      "?h a = ?h b \<Longrightarrow> \<exists>ab. ?m a b = Some ab \<and> ?bo a ab \<and> ?bo b ab \<and> (\<forall>u. ?bo a u \<longrightarrow> ?bo b u \<longrightarrow> ?bo ab u)"
      "?h a \<noteq> ?h b \<Longrightarrow> ?m a b = None"
      if "a \<in> ?A" for a b using that by blast+
  qed
qed

lemmas merge_R1 [locale_witness] = merge_on_R1[where A=UNIV, simplified]

lemma merkle_list_R1 [locale_witness]:
  assumes "merkle_interface h bo m"
  shows "merkle_interface (hash_R1 h) (blinding_of_R1 bo) (merge_R1 m)"
proof -
  interpret merge_on UNIV h bo m using assms by(unfold merkle_interface_aux)
  show ?thesis unfolding merkle_interface_aux[symmetric] ..
qed

lemma merge_R1_cong [fundef_cong]:
  assumes "\<And>a b. \<lbrakk> a \<in> set_list_R1 x; b \<in> set_list_R1 y \<rbrakk> \<Longrightarrow> m a b = m' a b"
  shows "merge_R1 m x y = merge_R1 m' x y"
  using assms
  apply(induction x y rule: merge_R1.induct)
  apply(simp del: merge_cases)
  apply(rule arg_cong[where f="map_option _"])
  apply(blast intro: merge_F_cong[unfolded bind_UNION])
  done

parametric_constant merge_F_parametric[transfer_rule]: merge_F_def

lemma merge_R1_parametric [transfer_rule]:
  includes lifting_syntax
  notes [simp del] = merge_cases
  assumes [transfer_rule]: "bi_unique A"
  shows "((A ===> A ===> rel_option A) ===> rel_list_R1 A ===> rel_list_R1 A ===> rel_option (rel_list_R1 A))
   merge_R1 merge_R1"
  apply(intro rel_funI)
  subgoal premises prems [transfer_rule] for m1 m2 xs1 xs2 ys1 ys2 using prems(2, 3)
    apply(induction xs1 ys1 arbitrary: xs2 ys2 rule: merge_R1.induct)
    apply(elim list_R1.rel_cases rel_sum.cases; clarsimp simp add: option.rel_map merge_F_def merge_discrete_def)
    apply(elim meta_allE; (erule meta_impE, simp)+)
    subgoal premises [transfer_rule] by transfer_prover
    done
  done

end

subsubsection \<open> Transferring the Constructions to Lists \<close>
type_synonym 'a\<^sub>h list\<^sub>h = "'a\<^sub>h list"
type_synonym 'a\<^sub>m list\<^sub>m = "'a\<^sub>m list"

context begin
interpretation list_R1 .

abbreviation (input) hash_list :: "('a\<^sub>m, 'a\<^sub>h) hash \<Rightarrow> ('a\<^sub>m list\<^sub>m, 'a\<^sub>h list\<^sub>h) hash"
  where "hash_list \<equiv> map"
abbreviation (input) blinding_of_list :: "'a\<^sub>m blinding_of \<Rightarrow> 'a\<^sub>m list\<^sub>m blinding_of"
  where "blinding_of_list \<equiv> list_all2"
lift_definition merge_list :: "'a\<^sub>m merge \<Rightarrow> 'a\<^sub>m list\<^sub>m merge" is merge_R1 .

lemma blinding_of_list_mono:
  "\<lbrakk> \<And>x y. bo x y \<longrightarrow> bo' x y \<rbrakk> \<Longrightarrow>
  blinding_of_list bo x y \<longrightarrow> blinding_of_list bo' x y"
  by (transfer) (blast intro: list_R1.rel_mono_strong)

lemmas blinding_of_list_hash = blinding_of_hash_R1[Transfer.transferred]
  and blinding_of_on_list [locale_witness] = blinding_of_on_R1[Transfer.transferred]
  and blinding_of_list [locale_witness] = blinding_of_R1[Transfer.transferred]
  and merge_on_list [locale_witness] = merge_on_R1[Transfer.transferred]
  and merge_list [locale_witness] = merge_R1[Transfer.transferred]
  and merge_list_cong = merge_R1_cong[Transfer.transferred]

lemma blinding_of_list_mono_pred:
  "R \<le> R' \<Longrightarrow> blinding_of_list R \<le> blinding_of_list R'"
  by(transfer) (rule list_R1.rel_mono)

lemma blinding_of_list_simp: "blinding_of_list = list_all2"
  by(transfer) (rule refl)

lemma merkle_list [locale_witness]:
  assumes [locale_witness]: "merkle_interface h bo m"
  shows "merkle_interface (hash_list h) (blinding_of_list bo) (merge_list m)"
  by(transfer fixing: h bo m) unfold_locales

parametric_constant merge_list_parametric [transfer_rule]: merge_list_def

lifting_update list.lifting
lifting_forget list.lifting

end

(************************************************************)
subsection \<open>Building block: function space\<close>
(************************************************************)

text \<open> We prove that we can lift the ADS construction through functions.\<close>

type_synonym ('a, 'b\<^sub>h) fun\<^sub>h = "'a \<Rightarrow> 'b\<^sub>h"
type_notation fun\<^sub>h (infixr "\<Rightarrow>\<^sub>h" 0)

type_synonym ('a, 'b\<^sub>m) fun\<^sub>m = "'a \<Rightarrow> 'b\<^sub>m"
type_notation fun\<^sub>m (infixr "\<Rightarrow>\<^sub>m" 0)

(************************************************************)
subsubsection \<open> Hashes \<close>
(************************************************************)

text \<open> Only the range is live, the domain is dead like for BNFs. \<close>

abbreviation (input) hash_fun' :: "('a \<Rightarrow>\<^sub>m 'b\<^sub>h, 'a \<Rightarrow>\<^sub>h 'b\<^sub>h) hash" where
  "hash_fun' \<equiv> id"

abbreviation (input) hash_fun :: "('b\<^sub>m, 'b\<^sub>h) hash \<Rightarrow> ('a \<Rightarrow>\<^sub>m 'b\<^sub>m, 'a \<Rightarrow>\<^sub>h 'b\<^sub>h) hash"
  where "hash_fun \<equiv> comp"

(************************************************************)
subsubsection \<open> Blinding \<close>
(************************************************************)

abbreviation (input) blinding_of_fun :: "'b\<^sub>m blinding_of \<Rightarrow> ('a \<Rightarrow>\<^sub>m 'b\<^sub>m) blinding_of" where
  "blinding_of_fun \<equiv> rel_fun (=)"

lemmas blinding_of_fun_mono = fun.rel_mono

lemma blinding_of_fun_hash:
  assumes "bo \<le> vimage2p rh rh (=)"
  shows "blinding_of_fun bo \<le> vimage2p (hash_fun rh) (hash_fun rh) (=)"
  using assms by(auto simp add: vimage2p_def rel_fun_def le_fun_def)

lemma blinding_of_on_fun [locale_witness]:
  assumes "blinding_of_on A rh bo"
  shows "blinding_of_on {x. range x \<subseteq> A} (hash_fun rh) (blinding_of_fun bo)"
  (is "blinding_of_on ?A ?h ?bo")
proof -
  interpret a: blinding_of_on A rh bo by fact
  show ?thesis
  proof
    show "?bo x x" if "x \<in> ?A" for x using that by(auto simp add: rel_fun_def intro: a.refl)
    show "?bo x z" if "?bo x y" "?bo y z" "x \<in> ?A" for x y z using that
      by(auto 4 3 simp add: rel_fun_def intro: a.trans)
    show "x = y" if "?bo x y" "?bo y x" "x \<in> ?A" for x y using that
      by(fastforce simp add: fun_eq_iff rel_fun_def intro: a.antisym)
  qed(rule blinding_of_fun_hash a.hash)+
qed

lemmas blinding_of_fun [locale_witness] = blinding_of_on_fun[where A=UNIV, simplified]

(************************************************************)
subsubsection \<open> Merging \<close>
(************************************************************)

context
  fixes m :: "'b\<^sub>m merge"
begin

definition merge_fun :: "('a \<Rightarrow>\<^sub>m 'b\<^sub>m) merge" where
  "merge_fun f g = (if \<forall>x. m (f x) (g x) \<noteq> None then Some (\<lambda>x. the (m (f x) (g x))) else None)"

lemma merge_on_fun [locale_witness]:
  assumes "merge_on A rh bo m"
  shows "merge_on {x. range x \<subseteq> A} (hash_fun rh) (blinding_of_fun bo) merge_fun"
  (is "merge_on ?A ?h ?bo ?m")
proof -
  interpret a: merge_on A rh bo m by fact
  show ?thesis
  proof
    show "\<exists>ab. ?m a b = Some ab \<and> ?bo a ab \<and> ?bo b ab \<and> (\<forall>u. ?bo a u \<longrightarrow> ?bo b u \<longrightarrow> ?bo ab u)"
      if "?h a = ?h b" "a \<in> ?A" for a b
      using that(1)[THEN fun_cong, unfolded o_apply, THEN a.join, OF that(2)[unfolded mem_Collect_eq, THEN subsetD, OF rangeI]]
      by atomize(subst (asm) choice_iff; auto simp add: merge_fun_def rel_fun_def)
    show "?m a b = None" if "?h a \<noteq> ?h b" "a \<in> ?A" for a b using that
      by(auto simp add: merge_fun_def fun_eq_iff dest: a.undefined)
  qed
qed

lemmas merge_fun [locale_witness] = merge_on_fun[where A=UNIV, simplified]

end

lemma merge_fun_cong[fundef_cong]:
  assumes "\<And>a b. \<lbrakk> a \<in> range f; b \<in> range g \<rbrakk> \<Longrightarrow> m a b = m' a b"
  shows "merge_fun m f g = merge_fun m' f g"
  using assms[OF rangeI rangeI] by(clarsimp simp add: merge_fun_def)

lemma is_none_alt_def: "Option.is_none x \<longleftrightarrow> (case x of None \<Rightarrow> True | Some _ \<Rightarrow> False)"
  by(auto simp add: Option.is_none_def split: option.splits)

parametric_constant is_none_parametric [transfer_rule]: is_none_alt_def

lemma merge_fun_parametric [transfer_rule]: includes lifting_syntax shows
  "((A ===> B ===> rel_option C) ===> ((=) ===> A) ===> ((=) ===> B) ===> rel_option ((=) ===> C))
   merge_fun merge_fun"
proof(intro rel_funI)
  fix m :: "'a merge" and m' :: "'b merge" and f :: "'c \<Rightarrow> 'a" and f' :: "'c \<Rightarrow> 'b" and g :: "'c \<Rightarrow> 'a" and g' :: "'c \<Rightarrow> 'b"
  assume m: "(A ===> B ===> rel_option C) m m'"
    and f: "((=) ===> A) f f'" and g: "((=) ===> B) g g'"
  note [transfer_rule] = this
  have cond [unfolded Option.is_none_def]: "(\<forall>x. \<not> Option.is_none (m (f x) (g x))) \<longleftrightarrow> (\<forall>x. \<not> Option.is_none (m' (f' x) (g' x)))"
    by transfer_prover
  moreover
  have "((=) ===> C) (\<lambda>x. the (m (f x) (g x))) (\<lambda>x. the (m' (f' x) (g' x)))" if *: "\<forall>x. \<not> m (f x) (g x) = None"
  proof -
    obtain fg fg' where m: "m (f x) (g x) = Some (fg x)" and m': "m' (f' x) (g' x) = Some (fg' x)" for x
      using * *[simplified cond]
      by(simp)(subst (asm) (1 2) choice_iff; clarsimp)
    have "rel_option C (Some (fg x)) (Some (fg' x))" for x unfolding m[symmetric] m'[symmetric] by transfer_prover
    then show ?thesis by(simp add: rel_fun_def m m')
  qed
  ultimately show "rel_option ((=) ===> C) (merge_fun m f g) (merge_fun m' f' g')"
    unfolding merge_fun_def by(simp)
qed

(************************************************************)
subsubsection \<open> Merkle Interface \<close>
(************************************************************)

lemma merkle_fun [locale_witness]:
  assumes "merkle_interface rh bo m"
  shows "merkle_interface (hash_fun rh) (blinding_of_fun bo) (merge_fun m)"
proof -
  interpret a: merge_on UNIV rh bo m unfolding merkle_interface_aux[symmetric] by fact
  show ?thesis unfolding merkle_interface_aux[symmetric] ..
qed

(************************************************************)
subsection \<open>Rose trees\<close>
(************************************************************)

text \<open>
We now define an ADS over rose trees, which is like a arbitrarily branching Merkle tree where each
node in the tree can be blinded, including the root. The number of children and the position of a
child among its siblings cannot be hidden. The construction allows to plug in further blindable
positions in the labels of the nodes.
\<close>

type_synonym ('a, 'b) rose_tree_F = "'a \<times> 'b list"

abbreviation (input) map_rose_tree_F where
  "map_rose_tree_F f1 f2 \<equiv> map_prod f1 (map f2)"
definition map_rose_tree_F_const where
  "map_rose_tree_F_const f1 f2 \<equiv> map_rose_tree_F f1 f2"

datatype 'a rose_tree = Tree "('a, 'a rose_tree) rose_tree_F"

type_synonym ('a\<^sub>h, 'b\<^sub>h) rose_tree_F\<^sub>h = "('a\<^sub>h \<times>\<^sub>h 'b\<^sub>h list\<^sub>h) blindable\<^sub>h"

datatype 'a\<^sub>h rose_tree\<^sub>h = Tree\<^sub>h "('a\<^sub>h, 'a\<^sub>h rose_tree\<^sub>h) rose_tree_F\<^sub>h"

type_synonym ('a\<^sub>m, 'a\<^sub>h, 'b\<^sub>m, 'b\<^sub>h) rose_tree_F\<^sub>m = "('a\<^sub>m \<times>\<^sub>m 'b\<^sub>m list\<^sub>m, 'a\<^sub>h \<times>\<^sub>h 'b\<^sub>h list\<^sub>h) blindable\<^sub>m"

datatype ('a\<^sub>m, 'a\<^sub>h) rose_tree\<^sub>m = Tree\<^sub>m "('a\<^sub>m, 'a\<^sub>h, ('a\<^sub>m, 'a\<^sub>h) rose_tree\<^sub>m, 'a\<^sub>h rose_tree\<^sub>h) rose_tree_F\<^sub>m"

abbreviation (input) map_rose_tree_F\<^sub>m
  :: "('ma \<Rightarrow> 'a) \<Rightarrow> ('mr \<Rightarrow> 'r) \<Rightarrow> ('ma, 'ha, 'mr, 'hr) rose_tree_F\<^sub>m \<Rightarrow> ('a, 'ha, 'r, 'hr) rose_tree_F\<^sub>m"
  where
  "map_rose_tree_F\<^sub>m f g \<equiv> map_blindable\<^sub>m (map_prod f (map g)) id"

(************************************************************)
subsubsection \<open> Hashes \<close>
(************************************************************)

abbreviation (input) hash_rt_F'
  :: "(('a\<^sub>h, 'a\<^sub>h, 'b\<^sub>h, 'b\<^sub>h) rose_tree_F\<^sub>m, ('a\<^sub>h, 'b\<^sub>h) rose_tree_F\<^sub>h) hash"
  where
  "hash_rt_F' \<equiv> hash_blindable id"

definition hash_rt_F\<^sub>m
  :: "('a\<^sub>m, 'a\<^sub>h) hash \<Rightarrow> ('b\<^sub>m, 'b\<^sub>h) hash \<Rightarrow>
    (('a\<^sub>m, 'a\<^sub>h, 'b\<^sub>m, 'b\<^sub>h) rose_tree_F\<^sub>m, ('a\<^sub>h, 'b\<^sub>h) rose_tree_F\<^sub>h) hash" where
  "hash_rt_F\<^sub>m h rhm \<equiv> hash_rt_F' o map_rose_tree_F\<^sub>m h rhm"

lemma hash_rt_F\<^sub>m_alt_def: "hash_rt_F\<^sub>m h rhm = hash_blindable (map_prod h (map rhm))"
  by(simp add: hash_rt_F\<^sub>m_def fun_eq_iff hash_map_blindable_simp)

primrec (transfer) hash_rt_tree'
  :: "(('a\<^sub>h, 'a\<^sub>h) rose_tree\<^sub>m, 'a\<^sub>h rose_tree\<^sub>h) hash" where
  "hash_rt_tree' (Tree\<^sub>m x) = Tree\<^sub>h (hash_rt_F' (map_rose_tree_F\<^sub>m id hash_rt_tree' x))"

definition hash_tree
  :: "('a\<^sub>m, 'a\<^sub>h) hash \<Rightarrow> (('a\<^sub>m, 'a\<^sub>h) rose_tree\<^sub>m, 'a\<^sub>h rose_tree\<^sub>h) hash" where
  "hash_tree h = hash_rt_tree' o map_rose_tree\<^sub>m h id"

lemma blindable\<^sub>m_map_compositionality:
  "map_blindable\<^sub>m f g o map_blindable\<^sub>m f' g' = map_blindable\<^sub>m (f o f') (g o g')"
  by(rule ext) (simp add: blindable\<^sub>m.map_comp)

lemma hash_tree_simps [simp]:
  "hash_tree h (Tree\<^sub>m x) = Tree\<^sub>h (hash_rt_F\<^sub>m h (hash_tree h) x)"
  by(simp add: hash_tree_def hash_rt_F\<^sub>m_def
      map_prod.comp map_sum.comp rose_tree\<^sub>h.map_comp blindable\<^sub>m.map_comp
      prod.map_id0 rose_tree\<^sub>h.map_id0)

parametric_constant hash_rt_F\<^sub>m_parametric [transfer_rule]: hash_rt_F\<^sub>m_alt_def

parametric_constant hash_tree_parametric [transfer_rule]: hash_tree_def

(************************************************************)
subsubsection \<open> Blinding \<close>
(************************************************************)

abbreviation (input) blinding_of_rt_F\<^sub>m
  :: "('a\<^sub>m, 'a\<^sub>h) hash \<Rightarrow> 'a\<^sub>m blinding_of \<Rightarrow> ('b\<^sub>m, 'b\<^sub>h) hash \<Rightarrow> 'b\<^sub>m blinding_of
      \<Rightarrow> ('a\<^sub>m, 'a\<^sub>h, 'b\<^sub>m, 'b\<^sub>h) rose_tree_F\<^sub>m blinding_of" where
  "blinding_of_rt_F\<^sub>m ha boa hb bob \<equiv> blinding_of_blindable (hash_prod ha (map hb))
    (blinding_of_prod boa (blinding_of_list bob))"

lemma blinding_of_rt_F\<^sub>m_mono:
  "\<lbrakk> boa \<le> boa'; bob \<le> bob' \<rbrakk> \<Longrightarrow> blinding_of_rt_F\<^sub>m ha boa hb bob \<le> blinding_of_rt_F\<^sub>m ha boa' hb bob'"
  by(intro blinding_of_blindable_mono prod.rel_mono list.rel_mono)

lemma blinding_of_rt_F\<^sub>m_mono_inductive:
  assumes "\<And>x y. boa x y \<longrightarrow> boa' x y" "\<And>x y. bob x y \<longrightarrow> bob' x y"
  shows "blinding_of_rt_F\<^sub>m ha boa hb bob x y \<longrightarrow> blinding_of_rt_F\<^sub>m ha boa' hb bob' x y"
  apply(rule impI)
  apply(erule blinding_of_rt_F\<^sub>m_mono[THEN predicate2D, rotated -1])
  using assms by blast+

context
  fixes h :: "('a\<^sub>m, 'a\<^sub>h) hash"
    and bo :: "'a\<^sub>m blinding_of"
begin

inductive blinding_of_tree :: "('a\<^sub>m, 'a\<^sub>h) rose_tree\<^sub>m blinding_of" where
  "blinding_of_tree (Tree\<^sub>m t1) (Tree\<^sub>m t2)"
  if "blinding_of_rt_F\<^sub>m h bo (hash_tree h) blinding_of_tree t1 t2"
monos blinding_of_rt_F\<^sub>m_mono_inductive

end

inductive_simps blinding_of_tree_simps [simp]:
  "blinding_of_tree h bo (Tree\<^sub>m t1) (Tree\<^sub>m t2)"

lemma blinding_of_rt_F\<^sub>m_hash:
  assumes "boa \<le> vimage2p ha ha (=)" "bob \<le> vimage2p hb hb (=)"
  shows "blinding_of_rt_F\<^sub>m ha boa hb bob \<le> vimage2p (hash_rt_F\<^sub>m ha hb) (hash_rt_F\<^sub>m ha hb) (=)"
  apply(rule order_trans)
   apply(rule blinding_of_blindable_hash)
   apply(fold relator_eq)
   apply(unfold vimage2p_map_rel_prod vimage2p_map_list_all2)
   apply(rule prod.rel_mono assms list.rel_mono)+
  apply(simp only: hash_rt_F\<^sub>m_def vimage2p_comp o_apply hash_blindable_def blindable\<^sub>m.map_id0 id_def[symmetric] vimage2p_id id_apply)
  done

abbreviation (input) set1_rt_F\<^sub>m :: "('a\<^sub>m, 'a\<^sub>h, 'b\<^sub>h, 'b\<^sub>m) rose_tree_F\<^sub>m \<Rightarrow> 'a\<^sub>m set" where
  "set1_rt_F\<^sub>m x \<equiv> set1_blindable\<^sub>m x \<bind> fsts"

abbreviation (input) set3_rt_F\<^sub>m :: "('a\<^sub>m, 'a\<^sub>h, 'b\<^sub>m, 'b\<^sub>h) rose_tree_F\<^sub>m \<Rightarrow> 'b\<^sub>m set" where
  "set3_rt_F\<^sub>m x \<equiv> (set1_blindable\<^sub>m x \<bind> snds) \<bind> set"

lemma set_rt_F\<^sub>m_eq:
  "{x. set1_rt_F\<^sub>m x \<subseteq> A \<and> set3_rt_F\<^sub>m x \<subseteq> B} =
   {x. set1_blindable\<^sub>m x \<subseteq> {x. fsts x \<subseteq> A \<and> snds x \<subseteq> {x. set x \<subseteq> B}}}"
  by force

lemma hash_blindable_map: "hash_blindable f \<circ> map_blindable\<^sub>m g id = hash_blindable (f \<circ> g)"
  by(rule ext) (simp add: hash_blindable_def blindable\<^sub>m.map_comp)

lemma blinding_of_on_tree [locale_witness]:
  assumes "blinding_of_on A h bo"
  shows "blinding_of_on {x. set1_rose_tree\<^sub>m x \<subseteq> A} (hash_tree h) (blinding_of_tree h bo)"
  (is "blinding_of_on ?A ?h ?bo")
proof -
  interpret a: blinding_of_on A h bo by fact
  show ?thesis
  proof
    show "?bo \<le> vimage2p ?h ?h (=)" using a.hash by(rule blinding_of_tree_hash)
    have "?bo x x \<and> (?bo x y \<longrightarrow> ?bo y z \<longrightarrow> ?bo x z) \<and> (?bo x y \<longrightarrow> ?bo y x \<longrightarrow> x = y)" if "x \<in> ?A" for x y z using that
    proof(induction x arbitrary: y z)
      case (Tree\<^sub>m x)
      have [locale_witness]: "blinding_of_on (set3_rt_F\<^sub>m x) (hash_tree h) (blinding_of_tree h bo)"
        apply unfold_locales
        subgoal by(rule blinding_of_tree_hash)(rule a.hash)
        subgoal using Tree\<^sub>m.IH Tree\<^sub>m.prems by(fastforce simp add: eq_onp_def)
        subgoal for x y z using Tree\<^sub>m.IH[of _ _ x y z] Tree\<^sub>m.prems by fastforce
        subgoal for x y using Tree\<^sub>m.IH[of _ _ x y] Tree\<^sub>m.prems by fastforce
        done
      interpret blinding_of_on
        "{a. set1_rt_F\<^sub>m a \<subseteq> A \<and> set3_rt_F\<^sub>m a \<subseteq> set3_rt_F\<^sub>m x}"
        "hash_rt_F\<^sub>m h ?h" "blinding_of_rt_F\<^sub>m h bo ?h ?bo"
        unfolding set_rt_F\<^sub>m_eq hash_rt_F\<^sub>m_alt_def ..
      from Tree\<^sub>m.prems show ?case
        apply(intro conjI)
        subgoal by(fastforce intro!: blinding_of_tree.intros refl[unfolded hash_rt_F\<^sub>m_alt_def])
        subgoal by(fastforce elim!: blinding_of_tree.cases trans[unfolded hash_rt_F\<^sub>m_alt_def]
                    intro!: blinding_of_tree.intros)
        subgoal by(fastforce elim!: blinding_of_tree.cases antisym[unfolded hash_rt_F\<^sub>m_alt_def])
        done
    qed
    then show "x \<in> ?A \<Longrightarrow> ?bo x x"
      and "\<lbrakk> ?bo x y; ?bo y z; x \<in> ?A \<rbrakk> \<Longrightarrow> ?bo x z"
      and "\<lbrakk> ?bo x y; ?bo y x; x \<in> ?A \<rbrakk> \<Longrightarrow> x = y"
      for x y z by blast+
  qed
qed

lemmas blinding_of_tree [locale_witness] = blinding_of_on_tree[where A=UNIV, simplified]

lemma blinding_of_tree_mono:
  "bo \<le> bo' \<Longrightarrow> blinding_of_tree h bo \<le> blinding_of_tree h bo'"
  apply(rule predicate2I)
  apply(erule blinding_of_tree.induct)
  apply(rule blinding_of_tree.intros)
  apply(erule blinding_of_rt_F\<^sub>m_mono[THEN predicate2D, rotated -1])
  apply(blast)+
  done

(************************************************************)
subsubsection \<open> Merging \<close>
(************************************************************)

definition merge_rt_F\<^sub>m
  :: "('a\<^sub>m, 'a\<^sub>h) hash \<Rightarrow> 'a\<^sub>m merge \<Rightarrow> ('b\<^sub>m, 'b\<^sub>h) hash \<Rightarrow> 'b\<^sub>m merge \<Rightarrow>
      ('a\<^sub>m, 'a\<^sub>h, 'b\<^sub>m, 'b\<^sub>h) rose_tree_F\<^sub>m merge"
  where
  "merge_rt_F\<^sub>m ha ma hr mr \<equiv> merge_blindable (hash_prod ha (hash_list hr)) (merge_prod ma (merge_list mr))"

lemma merge_rt_F\<^sub>m_cong [fundef_cong]:
  assumes "\<And>a b. \<lbrakk> a \<in> set1_rt_F\<^sub>m x; b \<in> set1_rt_F\<^sub>m y \<rbrakk> \<Longrightarrow> ma a b = ma' a b"
    and "\<And>a b. \<lbrakk> a \<in> set3_rt_F\<^sub>m x; b \<in> set3_rt_F\<^sub>m y \<rbrakk> \<Longrightarrow> mm a b = mm' a b"
  shows "merge_rt_F\<^sub>m ha ma hm mm x y = merge_rt_F\<^sub>m ha ma' hm mm' x y"
  using assms
  apply(cases x; cases y; simp add: merge_rt_F\<^sub>m_def bind_UNION)
  apply(rule arg_cong[where f="map_option _"])
  apply(blast intro: merge_prod_cong merge_list_cong)
  done

lemma in_set1_blindable\<^sub>m_iff: "x \<in> set1_blindable\<^sub>m y \<longleftrightarrow> y = Unblinded x"
  by(cases y) auto

context
  fixes h :: "('a\<^sub>m, 'a\<^sub>h) hash"
    and ma :: "'a\<^sub>m merge"
  notes in_set1_blindable\<^sub>m_iff[simp]
begin
fun merge_tree :: "('a\<^sub>m, 'a\<^sub>h) rose_tree\<^sub>m merge" where
  "merge_tree (Tree\<^sub>m x) (Tree\<^sub>m y) = map_option Tree\<^sub>m (
    merge_rt_F\<^sub>m h ma (hash_tree h) merge_tree x y)"
end

lemma merge_on_tree [locale_witness]:
  assumes "merge_on A h bo m"
  shows "merge_on {x. set1_rose_tree\<^sub>m x \<subseteq> A} (hash_tree h) (blinding_of_tree h bo) (merge_tree h m)"
  (is "merge_on ?A ?h ?bo ?m")
proof -
  interpret a: merge_on A h bo m by fact
  show ?thesis
  proof
    have "(?h a = ?h b \<longrightarrow> (\<exists>ab. ?m a b = Some ab \<and> ?bo a ab \<and> ?bo b ab \<and> (\<forall>u. ?bo a u \<longrightarrow> ?bo b u \<longrightarrow> ?bo ab u))) \<and>
      (?h a \<noteq> ?h b \<longrightarrow> ?m a b = None)"
      if "a \<in> ?A" for a b using that unfolding mem_Collect_eq
    proof(induction a arbitrary: b rule: rose_tree\<^sub>m.induct)
      case (Tree\<^sub>m x y)
      interpret merge_on
        "{y. set1_rt_F\<^sub>m y \<subseteq> A \<and> set3_rt_F\<^sub>m y \<subseteq> set3_rt_F\<^sub>m x}"
        "hash_rt_F\<^sub>m h ?h"
        "blinding_of_rt_F\<^sub>m h bo ?h ?bo"
        "merge_rt_F\<^sub>m h m ?h ?m"
        unfolding set_rt_F\<^sub>m_eq hash_rt_F\<^sub>m_alt_def merge_rt_F\<^sub>m_def
      proof
        fix a
        assume a: "a \<in> set3_rt_F\<^sub>m x"
        with Tree\<^sub>m.prems have a': "set1_rose_tree\<^sub>m a \<subseteq> A"
          by(force simp add: bind_UNION)

        from a obtain l and ab where a'': "ab \<in> set1_blindable\<^sub>m x" "l \<in> snds ab" "a \<in> set l"
          by(clarsimp simp add: bind_UNION)

        fix b
        from Tree\<^sub>m.IH[OF a'' a', rule_format, of b]
        show "hash_tree h a = hash_tree h b
           \<Longrightarrow> \<exists>ab. merge_tree h m a b = Some ab \<and> blinding_of_tree h bo a ab \<and> blinding_of_tree h bo b ab \<and>
                    (\<forall>u. blinding_of_tree h bo a u \<longrightarrow> blinding_of_tree h bo b u \<longrightarrow> blinding_of_tree h bo ab u)"
          and "hash_tree h a \<noteq> hash_tree h b \<Longrightarrow> merge_tree h m a b = None"
          by(auto dest: sym)
      qed
      show ?case using Tree\<^sub>m.prems
        apply(intro conjI strip)
        subgoal by(cases y)(fastforce dest!: join simp add: blinding_of_tree.simps)
        subgoal by (cases y) (fastforce dest!: undefined)
        done
    qed
    then show
      "?h a = ?h b \<Longrightarrow> \<exists>ab. ?m a b = Some ab \<and> ?bo a ab \<and> ?bo b ab \<and> (\<forall>u. ?bo a u \<longrightarrow> ?bo b u \<longrightarrow> ?bo ab u)"
      "?h a \<noteq> ?h b \<Longrightarrow> ?m a b = None"
      if "a \<in> ?A" for a b using that by blast+
  qed
qed

lemmas merge_tree [locale_witness] = merge_on_tree[where A=UNIV, simplified]

lemma option_bind_comm:
 "((x :: 'a option) \<bind> (\<lambda>y. c \<bind> (\<lambda>z. f y z))) = (c \<bind> (\<lambda>y. x \<bind> (\<lambda>z. f z y)))"
  by(cases x; cases c; auto)

parametric_constant merge_rt_F\<^sub>m_parametric [transfer_rule]: merge_rt_F\<^sub>m_def

(************************************************************)
subsubsection \<open>Merkle interface\<close>
(************************************************************)

lemma merkle_tree [locale_witness]:
  assumes "merkle_interface h bo m"
  shows "merkle_interface (hash_tree h) (blinding_of_tree h bo) (merge_tree h m)"
proof -
  interpret merge_on UNIV h bo m using assms unfolding merkle_interface_aux .
  show ?thesis unfolding merkle_interface_aux[symmetric] ..
qed

lemma merge_tree_cong [fundef_cong]:
  assumes "\<And>a b. \<lbrakk> a \<in> set1_rose_tree\<^sub>m x; b \<in> set1_rose_tree\<^sub>m y \<rbrakk> \<Longrightarrow> m a b = m' a b"
  shows "merge_tree h m x y = merge_tree h m' x y"
  using assms
  apply(induction x y rule: merge_tree.induct)
  apply(simp add: bind_UNION)
  apply(rule arg_cong[where f="map_option _"])
  apply(rule merge_rt_F\<^sub>m_cong; simp add: bind_UNION; blast)
  done

end


(*
    File:        InitSeg.thy
    Time-stamp:  <2015-12-26T12:09:01Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: ZF (of Isabelle2015)
*)

theory InitSeg imports Nth Poset begin

definition initseg :: "[i,i,i]=>o" where
"initseg(A, l, m) == l: list(A) & m: list(A) &
                  (EX x: list(A). l@x = m)"

lemma app_typeD:
    "[| l @ m: list(A); l: list(A) |] ==> m: list(A)"
apply (erule rev_mp)
apply (erule list.induct)
apply simp_all
done

lemma app_Un_type:
  "!! a b. [| a: list(A); b: list(B) |] ==> a @ b: list(A Un B)"
apply (rule app_type)
apply (erule Un_upper1 [THEN list_mono, THEN subsetD])
apply (erule Un_upper2 [THEN list_mono, THEN subsetD])
done

lemma app_right_inj:
    "[| l@m = l@n; l: list(A) |] ==> m = n"
apply (erule rev_mp)
apply (erule list.induct)
apply simp_all
done

lemma app_right_inj_iff:
    "l: list(A) ==> l@m = l@n <-> m = n"
apply (rule iffI)
apply (erule app_right_inj, assumption)
apply (erule subst)
apply (rule refl)
done

lemma app_last_eqD:
  assumes major: "l @ [a] = m @ [b]"
  and prem1: "l: list(A)"
  and prem2: "m: list(B)"
  shows "l = m & a = b"
apply (rule major [THEN rev_mp])
apply (rule prem2 [THEN rev_bspec])
apply (rule prem1 [THEN list.induct])
apply (rule ballI)
apply (rule_tac [2] ballI)
apply (erule_tac [2] a="x" in list.cases)
apply (erule_tac [1] a="x" in list.cases)
apply (erule_tac [3] a="l" in list.cases)
apply (erule_tac [2] a="l" in list.cases)
apply simp_all
apply (rule impI)
apply (erule bspec [THEN mp], assumption)
apply (erule conjE)
apply assumption
done

lemma app_last_iff:
    "!!l m. [| l: list(A); m: list(B) |] ==>
           l @ [a] = m @ [b] <-> l = m & a = b"
apply (blast dest!: app_last_eqD)
done

lemma app_left_inj:
  assumes prem: "a@c = b@c"
  and major: "a: list(A)"
  and prem1: "b: list(B)"
  and prem2: "c: list(C)"
  shows "a = b"
apply (rule prem [THEN rev_mp])
apply (rule prem1 [THEN rev_bspec])
apply (rule major [THEN rev_bspec])
apply (rule prem2 [THEN list_append_induct])
apply simp
apply clarify
apply (simp only: app_assoc [THEN sym])
apply (blast dest!: app_last_eqD intro!: app_Un_type)
done

lemma app_left_inj_iff:
  "[| a: list(A); b: list(A); c: list(A) |] ==> a@c = b@c <-> a = b"
apply (rule iffI)
apply (erule app_left_inj, assumption+)
apply (erule subst)
apply (rule refl)
done

lemma app_appE_lemma:
    "m: list(A) ==> ALL l: list(A). m @ x = l @ y -->
          (EX z. l = m @ z) | (EX z. m = l @ z)"
apply (erule list.induct)
apply simp_all
apply (intro ballI impI)
apply (rename_tac v)
apply (erule_tac a="v" in list.cases)
apply simp_all
done

lemma app_appE:
  assumes major: "m @ x = l @ y"
  and m_list: "m: list(A)"
  and l_list: "l: list(A)"
  and prem1: "!! z. [| z: list(A); l = m @ z; x = z @ y |] ==> R"
  and prem2: "!! z. [| z: list(A); m = l @ z; y = z @ x |] ==> R"
  shows "R"
apply (insert m_list l_list major)
apply (rule m_list [THEN app_appE_lemma, THEN bspec, THEN mp, THEN disjE])
apply (rule l_list)
apply (rule major)
apply (erule exE)
apply (erule_tac [2] exE)
apply (rule_tac [2] prem2)
apply (rule prem1)
apply hypsubst
apply (erule app_typeD)
apply assumption+
prefer 2 apply hypsubst
apply (erule app_typeD)
apply assumption
prefer 2 apply assumption
apply (simp_all add: app_assoc app_right_inj_iff)
done

lemma app_Nil_eqD1:
  assumes major: "a@b = a"
  and prem: "a:list(A)"
  shows "b = []"
apply (rule major [THEN rev_mp])
apply (rule prem [THEN list.induct])
apply simp_all
done

lemma app_Nil_eqD2:
  assumes major: "a@b = b"
  and prem1: "a: list(A)"
  and prem2: "b: list(B)"
  shows "a = []"
apply (rule major [THEN rev_mp])
apply (rule prem1 [THEN rev_bspec])
apply (rule prem2 [THEN list_append_induct])
apply simp
apply (intro ballI impI)
apply (simp only: app_assoc [THEN sym])
apply (blast dest!: app_last_eqD intro: app_Un_type)
done

lemma app_eq_Nil_iff:
    "a: list(A) ==> a @ b = [] <-> a = [] & b = []"
apply (erule list.induct)
apply simp_all
done

lemma app_eq_NilD:
  "[| a @ b = []; a: list(A) |] ==> a = [] & b = []"
apply (rule app_eq_Nil_iff [THEN iffD1])
apply assumption+
done

lemma app_antisym:
    "[| a @ c = b; b @ d = a;
       a: list(A); b: list(B); c: list(C); d:list(D)
     |] ==> a = b"
apply hypsubst
apply (simp add: app_assoc)
done

lemma app_antisym2:
    "[| c @ a = b; d @ b = a;
      a: list(A); b: list(B); c: list(C); d:list(D)
     |] ==> a = b"
apply hypsubst
apply (simp only: app_assoc [THEN sym])
apply (safe dest!: app_Nil_eqD2 app_eq_NilD)
apply (assumption | (rule app_Un_type))+
apply simp
done

(** initseg **)
lemma initsegI:
  "!!a. [| a@x = b; x: list(A); a: list(A); b: list(A) |]
         ==> initseg(A, a, b)"
apply (unfold initseg_def)
apply blast
done

lemma initsegD1:
    "initseg(A, a, b) ==> a: list(A)"
apply (unfold initseg_def)
apply blast
done

lemma initsegD2:
    "initseg(A, a, b) ==> b: list(A)"
apply (unfold initseg_def)
apply blast
done

lemma initsegE:
    "[| initseg(A, a, b);
       !!x. [| a: list(A); b: list(A); x: list(A); b = a@x |] ==> R
     |] ==> R"
apply (unfold initseg_def)
apply blast
done

lemma initseg_antisym:
    "[| initseg(A, x, y); initseg(A, y, x) |] ==> x = y"
apply (unfold initseg_def)
apply (elim conjE bexE)
apply (erule app_antisym, assumption)
apply assumption+
done

lemma initseg_trans:
  "[| initseg(A, x, y); initseg(A, y, z) |] ==> initseg(A, x, z)"
apply (unfold initseg_def)
apply clarify
apply (simp add: app_assoc)
done

lemma initseg_refl:
    "x: list(A) ==> initseg(A, x, x)"
apply (unfold initseg_def)
apply simp
done

lemma initseg_appI1:
    "[| x: list(A); y: list(A) |] ==> initseg(A, x, x@y)"
apply (unfold initseg_def)
apply simp
done

lemma initseg_appI2:
    "[| x: list(A); initseg(A, y, z) |] ==> initseg(A, x@y, x@z)"
apply (unfold initseg_def)
apply (elim conjE bexE)
apply (rule conjI)
apply simp
apply (rule conjI)
apply simp
apply hypsubst
apply (simp add: app_assoc)
done

lemma initseg_NilI:
    "x: list(A) ==> initseg(A, [], x)"
apply (unfold initseg_def)
apply simp
done

lemma initseg_ConsI:
  "[| a: A; initseg(A, y, z) |] ==> initseg(A, Cons(a, y), Cons(a, z))"
apply (unfold initseg_def)
apply (elim conjE bexE)
apply (assumption | rule conjI list.intros)+
apply hypsubst
apply (rule bexI)
apply (rule app_Cons)
apply assumption
done

lemma initseg_NilE:
    "[| initseg(A, l, []); l = [] ==> R |] ==> R"
apply (unfold initseg_def)
apply (elim conjE bexE)
apply (blast dest!: app_eq_NilD)
done

lemma initseg_ConsE:
  assumes major: "initseg(A, l, Cons(b, m))"
  and nil_case: "l = [] ==> R"
  and cons_case: "!!n. [| initseg(A, n, m); b: A; l = Cons(b, n) |] ==> R"
  shows "R"
apply (insert major)
apply (unfold initseg_def)
apply (elim conjE bexE)
apply (erule list.cases)
apply (erule nil_case)
apply (rule cons_case [unfolded initseg_def])
apply (erule_tac [2] ConsE)
prefer 2 apply assumption
prefer 2 apply hypsubst
apply simp
apply hypsubst
apply (erule ConsE)
apply simp
apply (rule bexI)
apply (erule conjunct2)
apply assumption
done

lemma initseg_left_ConsE:
  assumes major: "initseg(A, Cons(b, l), m)"
  and prem: "!!n. [| m = Cons(b, n); b: A; initseg(A, l, n) |] ==>R"
  shows "R"
apply (insert major)
apply (unfold initseg_def)
apply (elim conjE bexE)
apply simp
apply (erule sym [THEN prem [unfolded initseg_def]])
apply safe
apply (assumption | rule app_type refl bexI)+
done

lemma initseg_left_appE:
  assumes major: "initseg(A, a@b, c)"
  and prem1: "a: list(A)"
  and prem2: "!!l. [| c = a@l; initseg(A, b, l) |] ==>R"
  shows "R"
apply (insert major prem1)
apply (unfold initseg_def)
apply (elim conjE bexE)
apply (drule app_typeD, assumption)
apply (simp add: app_assoc)
apply (erule sym [THEN prem2 [unfolded initseg_def]])
apply (assumption | rule conjI app_type refl bexI)+
done

lemma initseg_right_appE:
  assumes major: "initseg(A, l, m@n)"
  and m_list: "m: list(A)"
  and prem1: "[| n: list(A); initseg(A, l, m) |] ==> R"
  and prem2: "!!x y. [| x: list(A); y: list(A); n: list(A); l = m @ x; n = x @ y;
                  initseg(A, m, l) |] ==> R"
  shows "R"
apply (insert m_list)
apply (rule major [THEN initsegE])
apply (subgoal_tac "n: list(A)")
prefer 2 apply (erule app_typeD, assumption)
apply (rule app_appE_lemma [THEN bspec, THEN mp, THEN disjE])
prefer 3 apply assumption
apply assumption+
apply (erule_tac [2] exE)
apply (erule exE)
apply (rule_tac [2] prem1)
apply (rule_tac [1] prem2)
prefer 4 apply assumption
apply (simp_all add: app_right_inj_iff app_assoc)
apply (assumption | (erule app_typeD, assumption)
        | (rule initseg_appI1))+
done

lemma initseg_app_lastE:
  assumes major: "initseg(A, l, m@[b])"
  and prem: "m: list(A)"
  and prem1: "l = m @ [b] ==> R"
  and prem2: "[| initseg(A, l, m); b: A |] ==> R"
  shows "R"
apply (insert prem)
apply (rule major [THEN initseg_right_appE])
apply assumption
apply (rule prem2)
apply assumption
apply (erule ConsE)
apply assumption
apply (case_tac "initseg(A, l, m)")
apply (rule prem2)
apply assumption
apply (erule ConsE)
apply assumption
apply (rule prem1)
apply hypsubst
apply (erule_tac a="x" in list.cases)
apply hypsubst
apply (erule notE)
apply simp_all
done

(** We can regard a list as a poset under initseg **)
lemma poset_initseg:
    "poset(initseg(A), list(A))"
apply (rule posetI)
apply (erule initseg_refl)
apply (erule initseg_antisym, assumption)
apply (erule initseg_trans, assumption)
done

lemma initseg_downset_forms_a_chain:
  "l: list(A) ==> chain(initseg(A), downset(initseg(A), list(A), l))"
apply (rule chainI)
apply (rule poset_initseg [THEN downset_subset [THEN poset_subset]])
apply (blast elim!: downsetE initsegE app_appE intro!: initseg_appI1)
done

lemma initseg_appI3:
  "[| initseg(A, y, z); x: list(A) |] ==> initseg(A, y, z@x)"
apply (unfold initseg_def)
apply (elim conjE bexE)
apply (assumption | rule conjI app_type)+
apply (rule bexI)
apply hypsubst
apply (drule app_typeD, assumption)
apply (simp add: app_assoc)
apply (assumption | rule app_type)+
done

lemma initseg_downset_is_Finite:
  "l: list(A) ==> Finite(downset(initseg(A), list(A), l))"
apply (erule list_append_induct)
apply (rule_tac P="%x. Finite(x)" in ssubst)
apply (rule_tac [2] Finite_cons)
apply (rule_tac [2] Finite_0)
apply (rule_tac [2] P="%x. Finite(x)" in ssubst)
apply (erule_tac [3] Finite_cons)
apply (rule_tac [2] equalityI)
apply (rule equalityI)
apply (safe elim!: downsetE initseg_NilE)
apply (rule refl)
apply (rule downsetI)
apply (rule_tac [4] downsetI)
apply (rule_tac [5] initseg_refl)
apply (rule_tac [6] downsetI)
apply (erule_tac [7] initseg_appI3)
apply (assumption | rule list.intros initseg_NilI)+
defer 1
apply (assumption | rule list.intros app_type)+
apply (erule initseg_right_appE)
apply assumption
apply (erule notE)
apply (rule downsetI)
apply assumption+
apply (rename_tac u v)
apply (erule_tac a="u" in list.cases)
apply simp_all
apply (erule notE)
apply (assumption | rule downsetI initseg_refl)+
done

end


(* Title:      Strict Binary Iterings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Strict Binary Iterings\<close>

theory Binary_Iterings_Strict

imports Stone_Kleene_Relation_Algebras.Iterings Binary_Iterings

begin

class strict_itering = itering + while +
  assumes while_def: "x \<star> y = x\<^sup>\<circ> * y"
begin

text \<open>Theorem 8.1\<close>

subclass extended_binary_itering
  apply unfold_locales
  apply (metis circ_loop_fixpoint circ_slide_1 sup_commute while_def mult_assoc)
  apply (metis circ_sup mult_assoc while_def)
  apply (simp add: mult_left_dist_sup while_def)
  apply (simp add: while_def mult_assoc)
  apply (metis circ_simulate_left_plus mult_assoc mult_left_isotone mult_right_dist_sup mult_1_right while_def)
  apply (metis circ_simulate_right_plus mult_assoc mult_left_isotone mult_right_dist_sup while_def)
  by (metis circ_loop_fixpoint mult_right_sub_dist_sup_right while_def mult_assoc)

text \<open>Theorem 13.1\<close>

lemma while_associative:
  "(x \<star> y) * z = x \<star> (y * z)"
  by (simp add: while_def mult_assoc)

text \<open>Theorem 13.3\<close>

lemma while_one_mult:
  "(x \<star> 1) * x = x \<star> x"
  by (simp add: while_def)

lemma while_back_loop_is_fixpoint:
  "is_fixpoint (\<lambda>x . x * y \<squnion> z) (z * (y \<star> 1))"
  by (simp add: circ_back_loop_is_fixpoint while_def)

text \<open>Theorem 13.4\<close>

lemma while_sumstar_var:
  "(x \<squnion> y) \<star> z = ((x \<star> 1) * y) \<star> ((x \<star> 1) * z)"
  by (simp add: while_sumstar_3 while_associative)

text \<open>Theorem 13.2\<close>

lemma while_mult_1_assoc:
  "(x \<star> 1) * y = x \<star> y"
  by (simp add: while_def)

proposition "y \<star> (x \<star> 1) \<le> x \<star> (y \<star> 1) \<Longrightarrow> (x \<squnion> y) \<star> 1 = x \<star> (y \<star> 1)" oops
proposition "y * x \<le> (1 \<squnion> x) * (y \<star> 1) \<Longrightarrow> (x \<squnion> y) \<star> 1 = x \<star> (y \<star> 1)" oops
proposition while_square_1: "x \<star> 1 = (x * x) \<star> (x \<squnion> 1)" oops
proposition while_absorb_below_one: "y * x \<le> x \<Longrightarrow> y \<star> x \<le> 1 \<star> x" oops

end

class bounded_strict_itering = bounded_itering + strict_itering
begin

subclass bounded_extended_binary_itering ..

text \<open>Theorem 13.6\<close>

lemma while_top_2:
  "top \<star> z = top * z"
  by (simp add: circ_top while_def)

text \<open>Theorem 13.5\<close>

lemma while_mult_top_2:
  "(x * top) \<star> z = z \<squnion> x * top * z"
  by (metis circ_left_top mult_assoc while_def while_left_unfold)

text \<open>Theorem 13 counterexamples\<close>

proposition while_one_top: "1 \<star> x = top" nitpick [expect=genuine,card=2] oops
proposition while_top: "top \<star> x = top" nitpick [expect=genuine,card=2] oops
proposition while_sub_mult_one: "x * (1 \<star> y) \<le> 1 \<star> x" oops
proposition while_unfold_below_1: "x = y * x \<Longrightarrow> x \<le> y \<star> 1" oops
proposition while_unfold_below: "x = z \<squnion> y * x \<Longrightarrow> x \<le> y \<star> z" nitpick [expect=genuine,card=2] oops
proposition while_unfold_below: "x \<le> z \<squnion> y * x \<Longrightarrow> x \<le> y \<star> z" nitpick [expect=genuine,card=2] oops
proposition while_mult_top: "(x * top) \<star> z = z \<squnion> x * top" nitpick [expect=genuine,card=2] oops
proposition tarski_mult_top_idempotent: "x * top = x * top * x * top" oops

proposition while_loop_is_greatest_postfixpoint: "is_greatest_postfixpoint (\<lambda>x . y * x \<squnion> z) (y \<star> z)" nitpick [expect=genuine,card=2] oops
proposition while_loop_is_greatest_fixpoint: "is_greatest_fixpoint (\<lambda>x . y * x \<squnion> z) (y \<star> z)" nitpick [expect=genuine,card=2] oops
proposition while_sub_while_zero: "x \<star> z \<le> (x \<star> y) \<star> z" oops
proposition while_while_sub_associative: "x \<star> (y \<star> z) \<le> (x \<star> y) \<star> z" oops
proposition tarski: "x \<le> x * top * x * top" oops
proposition tarski_top_omega_below: "x * top \<le> (x * top) \<star> bot" nitpick [expect=genuine,card=2] oops
proposition tarski_top_omega: "x * top = (x * top) \<star> bot" nitpick [expect=genuine,card=2] oops
proposition tarski_below_top_omega: "x \<le> (x * top) \<star> bot" nitpick [expect=genuine,card=2] oops
proposition tarski: "x = bot \<or> top * x * top = top" oops
proposition "1 = (x * bot) \<star> 1" oops
proposition "1 \<squnion> x * bot = x \<star> 1" oops
proposition "x = x * (x \<star> 1)" oops
proposition "x * (x \<star> 1) = x \<star> 1" oops
proposition "x \<star> 1 = x \<star> (1 \<star> 1)" oops
proposition "(x \<squnion> y) \<star> 1 = (x \<star> (y \<star> 1)) \<star> 1" oops
proposition "z \<squnion> y * x = x \<Longrightarrow> y \<star> z \<le> x" oops
proposition "y * x = x \<Longrightarrow> y \<star> x \<le> x" oops
proposition "z \<squnion> x * y = x \<Longrightarrow> z * (y \<star> 1) \<le> x" oops
proposition "x * y = x \<Longrightarrow> x * (y \<star> 1) \<le> x" oops
proposition "x * z = z * y \<Longrightarrow> x \<star> z \<le> z * (y \<star> 1)" oops

end

class binary_itering_unary = extended_binary_itering + circ +
  assumes circ_def: "x\<^sup>\<circ> = x \<star> 1"
begin

text \<open>Theorem 50.7\<close>

subclass left_conway_semiring
  apply unfold_locales
  using circ_def while_left_unfold apply simp
  apply (metis circ_def mult_1_right while_one_mult_below while_slide)
  using circ_def while_one_while while_sumstar_2 by auto

end

class strict_binary_itering = binary_itering + circ +
  assumes while_associative: "(x \<star> y) * z = x \<star> (y * z)"
  assumes circ_def: "x\<^sup>\<circ> = x \<star> 1"
begin

text \<open>Theorem 2.8\<close>

subclass itering
  apply unfold_locales
  apply (simp add: circ_def while_associative while_sumstar)
  apply (metis circ_def mult_1_right while_associative while_productstar while_slide)
  apply (metis circ_def mult_1_right while_associative mult_1_left while_slide while_simulate_right_plus)
  by (metis circ_def mult_1_right while_associative mult_1_left while_simulate_left_plus mult_right_dist_sup)

text \<open>Theorem 8.5\<close>

subclass extended_binary_itering
  apply unfold_locales
  by (simp add: while_associative while_increasing mult_assoc)

end

end


chapter \<open>Löb's Theorem\<close>

(*<*)
theory Loeb imports Loeb_Formula Derivability_Conditions
begin
(*>*)

text \<open>We have set up the formalization of Gödel's first (easy half) and Gödel's second
so that the following generalizations, leading to Löb's theorem, are trivial
modifications of these, replacing negation with "implies @{term \<phi>}" in all proofs.\<close>

locale Loeb_Assumptions =
HBL1_2_3
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv bprv
  enc
  P
+
Loeb_Form
  var trm fmla Var num FvarsT substT Fvars subst
  eql cnj imp all exi
  prv bprv
  enc
  S
  P
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var num FvarsT substT Fvars subst
and eql cnj imp all exi
and prv bprv
and enc ("\<langle>_\<rangle>")
and S
and P
begin

text \<open>Generalization of $\mathit{goedel\_first\_theEasyHalf\_pos}$, replacing @{term fls} with a sentence @{term \<phi>}:\<close>
lemma loeb_aux_prv:
assumes \<phi>[simp]: "\<phi> \<in> fmla" "Fvars \<phi> = {}" and p: "prv (\<phi>L \<phi>)"
shows "prv \<phi>"
proof-
  have "prv (imp (PP \<langle>\<phi>L \<phi>\<rangle>) \<phi>)" using assms prv_eqv_prv[OF _ _ p prv_\<phi>L_eqv] by auto
  moreover have "bprv (PP \<langle>\<phi>L \<phi>\<rangle>)" using HBL1[OF \<phi>L[OF \<phi>] _ p] unfolding PP_def by simp
  from bprv_prv[OF _ _ this, simplified] have "prv (PP \<langle>\<phi>L \<phi>\<rangle>)" .
  ultimately show ?thesis using PP \<phi>L by (meson assms enc in_num prv_imp_mp)
qed

lemma loeb_aux_bprv:
assumes \<phi>[simp]: "\<phi> \<in> fmla" "Fvars \<phi> = {}" and p: "bprv (\<phi>L \<phi>)"
shows "bprv \<phi>"
proof-
  note pp = bprv_prv[OF _ _ p, simplified]
  have "bprv (imp (PP \<langle>\<phi>L \<phi>\<rangle>) \<phi>)" using assms B.prv_eqv_prv[OF _ _ p bprv_\<phi>L_eqv] by auto
  moreover have "bprv (PP \<langle>\<phi>L \<phi>\<rangle>)" using HBL1[OF \<phi>L[OF \<phi>] _ pp] unfolding PP_def by simp
  ultimately show ?thesis using PP \<phi>L by (meson assms enc in_num B.prv_imp_mp)
qed

text \<open>Generalization of $\mathit{P\_G}$, the main lemma used for Gödel's second:\<close>
lemma P_L:
assumes \<phi>[simp]: "\<phi> \<in> fmla" "Fvars \<phi> = {}"
shows "bprv (imp (PP \<langle>\<phi>L \<phi>\<rangle>) (PP \<langle>\<phi>\<rangle>))"
proof-
  have 0: "prv (imp (\<phi>L \<phi>) (imp (PP \<langle>\<phi>L \<phi>\<rangle>) \<phi>))"
    using prv_\<phi>L_eqv by (intro prv_imp_eqvEL) auto
  have 1: "bprv (PP \<langle>imp (\<phi>L \<phi>) (imp (PP \<langle>\<phi>L \<phi>\<rangle>) \<phi>)\<rangle>)"
    using HBL1_PP[OF _ _ 0] by simp
  have 2: "bprv (imp (PP \<langle>\<phi>L \<phi>\<rangle>) (PP \<langle>imp (PP \<langle>\<phi>L \<phi>\<rangle>) \<phi>\<rangle>))"
  using HBL2_imp2[OF _ _ _ _ 1] by simp
  have 3: "bprv (imp (PP \<langle>\<phi>L \<phi>\<rangle>) (PP \<langle>PP \<langle>\<phi>L \<phi>\<rangle>\<rangle>))"
    using HBL3[OF \<phi>L[OF \<phi>] _] by simp
  have 23: "bprv (imp (PP \<langle>\<phi>L \<phi>\<rangle>)
                      (cnj (PP \<langle>PP \<langle>\<phi>L \<phi>\<rangle>\<rangle>)
                           (PP \<langle>imp (PP \<langle>\<phi>L \<phi>\<rangle>) \<phi>\<rangle>)))"
  using B.prv_imp_cnj[OF _ _ _ 3 2] by simp
  have 4: "bprv (imp (cnj (PP \<langle>PP \<langle>\<phi>L \<phi>\<rangle>\<rangle>)
                          (PP \<langle>imp (PP \<langle>\<phi>L \<phi>\<rangle>) \<phi>\<rangle>))
                    (PP \<langle>\<phi>\<rangle>))"
    using HBL2[of "PP \<langle>\<phi>L \<phi>\<rangle>" \<phi>] by simp
  show ?thesis using B.prv_prv_imp_trans[OF _ _ _ 23 4] by simp
qed

text \<open>Löb's theorem generalizes the positive formulation Gödel's Second
($\mathit{goedel\_second}$). In our two-provability-relation framework, we get two variants of Löb's theorem.
A stronger variant, assuming @{term prv} and proving @{term bprv}, seems impossible.\<close>

theorem loeb_bprv:
assumes \<phi>[simp]: "\<phi> \<in> fmla" "Fvars \<phi> = {}" and p: "bprv (imp (PP \<langle>\<phi>\<rangle>) \<phi>)"
shows "bprv \<phi>"
proof-
  have "bprv (imp (PP \<langle>\<phi>L \<phi>\<rangle>) \<phi>)"
    by (rule B.prv_prv_imp_trans[OF _ _ _ P_L p]) auto
  hence "bprv (\<phi>L \<phi>)"
    by (rule B.prv_eqv_prv_rev[OF _ _ _ bprv_\<phi>L_eqv, rotated 2]) auto
  thus ?thesis using loeb_aux_bprv[OF \<phi>] by simp
qed

theorem loeb_prv:
assumes \<phi>[simp]: "\<phi> \<in> fmla" "Fvars \<phi> = {}" and p: "prv (imp (PP \<langle>\<phi>\<rangle>) \<phi>)"
shows "prv \<phi>"
proof-
  note PL = bprv_prv[OF _ _ P_L, simplified]
  have "prv (imp (PP \<langle>\<phi>L \<phi>\<rangle>) \<phi>)"
    by (rule prv_prv_imp_trans[OF _ _ _ PL p]) auto
  hence "prv (\<phi>L \<phi>)"
    by (rule prv_eqv_prv_rev[OF _ _ _ prv_\<phi>L_eqv, rotated 2]) auto
  thus ?thesis using loeb_aux_prv[OF \<phi>] by simp
qed

text \<open>We could have of course inferred $\mathit{goedel\_first\_theEasyHalf\_pos}$
and $\mathit{goedel\_second}$ from these more general versions, but we leave the original
arguments as they are more instructive.\<close>

end \<comment> \<open>context @{locale Loeb_Assumptions}\<close>

(*<*)
end
(*>*)