theory weird_nat_add3_same
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S y2) z = add3acc Z y2 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun add3 :: "Nat => Nat => Nat => Nat" where
"add3 (Z) (Z) z = z"
| "add3 (Z) (S y2) z = S (add3 Z y2 z)"
| "add3 (S x2) y z = S (add3 x2 y z)"

(*hipster add3acc add3 *)

theorem x0 :
  "!! (x :: Nat) (y :: Nat) (z :: Nat) .
     (add3 x y z) = (add3acc x y z)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_list_nat_elem
imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun x :: "'a list => Nat => 'a" where
"x (cons2 z2 x2) (Z) = z2"
| "x (cons2 z2 x2) (S x3) = x x2 x3"

fun elem :: "'a => 'a list => bool" where
"elem y (nil2) = False"
| "elem y (cons2 z2 xs) = ((z2 = y) | (elem y xs))"

theorem property0 :
  "((elem y xs) ==> (? (z :: Nat) . (y = (x xs z))))"
  oops

end


theory OT_Functionalities imports
  CryptHOL.CryptHOL
begin

datatype 'a' inputs_ot12 = M2 "('a' \<times> 'a')" | C1 bool

datatype 'a' outputs_ot12 = P_ot12 'a' | U_ot12 unit

fun f_ot12 :: "'a' inputs_ot12 list \<Rightarrow> 'a' outputs_ot12 list"
  where "f_ot12 [M2 (m0,m1), C1 \<sigma>] = [U_ot12 (), if \<sigma> then (P_ot12 m1) else (P_ot12 m0)]"

datatype 'a' inputs_ot14 = M4 "('a' \<times> 'a' \<times> 'a' \<times> 'a')" | C2 "(bool \<times> bool)"

datatype 'a' outputs_ot14 = P_ot14 'a' | U_ot14 unit

fun f_ot14 :: "'a' inputs_ot14 list \<Rightarrow> 'a' outputs_ot14 list"
  where "f_ot14 [M4 (m00, m01, m10, m11), C2 (c0,c1)]
              = [U_ot14 (), if c0 then (if c1 then P_ot14 m11 else P_ot14 m10) else (if c1 then P_ot14 m01 else P_ot14 m00)]"

fun xor_ot12 :: "bool outputs_ot12 \<Rightarrow> bool outputs_ot12 \<Rightarrow> bool"
  where "xor_ot12 (P_ot12 a) (P_ot12 b) = a \<oplus> b"

fun output_ot_rev where "output_ot_rev (P_ot12 n) = n"

lemma f_ot12_if_unfold: "\<forall> a b x.(f_ot12 [M2 (if x then (a,b) else (b,a)), C1 x]) = [U_ot12 (), P_ot12 b] "
  by simp

lemma f_ot12_if_unfold_neg: "\<forall> a b x.(f_ot12 [M2 (if (\<not> x) then (a,b) else (b,a)), C1 x]) = [U_ot12 (), P_ot12 a] "
  by simp

end


theory P11 imports Main begin

lemma eq_conv: "(A=B) = ((A\<longrightarrow>B) \<and> (B\<longrightarrow>A))"
  by blast

lemma neg_conv: "\<not>A = (A\<longrightarrow>False)"
  by blast

lemma or_conv: "(A\<or>B) = ((A\<longrightarrow>False)\<longrightarrow>B)"
  by blast

lemma "A \<or> (B \<and> C) = A"
proof (simp only: eq_conv neg_conv or_conv)
  oops

end


(*  Title:      HOL/IMPP/EvenOdd.thy
    Author:     David von Oheimb, TUM
*)

section \<open>Example of mutually recursive procedures verified with Hoare logic\<close>

theory EvenOdd
imports Main Misc
begin

axiomatization
  Even :: pname and
  Odd :: pname
where
  Even_neq_Odd: "Even ~= Odd" and
  Arg_neq_Res:  "Arg  ~= Res"

definition
  evn :: com where
 "evn = (IF (%s. s<Arg> = 0)
         THEN Loc Res:==(%s. 0)
         ELSE(Loc Res:=CALL Odd(%s. s<Arg> - 1);;
              Loc Arg:=CALL Odd(%s. s<Arg> - 1);;
              Loc Res:==(%s. s<Res> * s<Arg>)))"

definition
  odd :: com where
 "odd = (IF (%s. s<Arg> = 0)
         THEN Loc Res:==(%s. 1)
         ELSE(Loc Res:=CALL Even (%s. s<Arg> - 1)))"

overloading bodies \<equiv> bodies
begin
  definition "bodies == [(Even,evn),(Odd,odd)]"
end

definition
  Z_eq_Arg_plus :: "nat => nat assn" ("Z=Arg+_" [50]50) where
  "Z=Arg+n = (%Z s.      Z =  s<Arg>+n)"

definition
  Res_ok :: "nat assn" where
  "Res_ok = (%Z s. even Z = (s<Res> = 0))"

subsection "Arg, Res"

declare Arg_neq_Res [simp] Arg_neq_Res [THEN not_sym, simp]
declare Even_neq_Odd [simp] Even_neq_Odd [THEN not_sym, simp]

lemma Z_eq_Arg_plus_def2: "(Z=Arg+n) Z s = (Z = s<Arg>+n)"
apply (unfold Z_eq_Arg_plus_def)
apply (rule refl)
done

lemma Res_ok_def2: "Res_ok Z s = (even Z = (s<Res> = 0))"
apply (unfold Res_ok_def)
apply (rule refl)
done

lemmas Arg_Res_simps = Z_eq_Arg_plus_def2 Res_ok_def2

lemma body_Odd [simp]: "body Odd = Some odd"
apply (unfold body_def bodies_def)
apply auto
done

lemma body_Even [simp]: "body Even = Some evn"
apply (unfold body_def bodies_def)
apply auto
done

subsection "verification"

lemma Odd_lemma: "{{Z=Arg+0}. BODY Even .{Res_ok}}|-{Z=Arg+Suc 0}. odd .{Res_ok}"
apply (unfold odd_def)
apply (rule hoare_derivs.If)
apply (rule hoare_derivs.Ass [THEN conseq1])
apply  (clarsimp simp: Arg_Res_simps)
apply (rule export_s)
apply (rule hoare_derivs.Call [THEN conseq1])
apply  (rule_tac P = "Z=Arg+Suc (Suc 0) " in conseq12)
apply (rule single_asm)
apply (auto simp: Arg_Res_simps)
done

lemma Even_lemma: "{{Z=Arg+1}. BODY Odd .{Res_ok}}|-{Z=Arg+0}. evn .{Res_ok}"
apply (unfold evn_def)
apply (rule hoare_derivs.If)
apply (rule hoare_derivs.Ass [THEN conseq1])
apply  (clarsimp simp: Arg_Res_simps)
apply (rule hoare_derivs.Comp)
apply (rule_tac [2] hoare_derivs.Ass)
apply clarsimp
apply (rule_tac Q = "%Z s. P Z s & Res_ok Z s" and P = P for P in hoare_derivs.Comp)
apply (rule export_s)
apply  (rule_tac I1 = "%Z l. Z = l Arg & 0 < Z" and Q1 = "Res_ok" in Call_invariant [THEN conseq12])
apply (rule single_asm [THEN conseq2])
apply   (clarsimp simp: Arg_Res_simps)
apply  (force simp: Arg_Res_simps)
apply (rule export_s)
apply (rule_tac I1 = "%Z l. even Z = (l Res = 0) " and Q1 = "%Z s. even Z = (s<Arg> = 0) " in Call_invariant [THEN conseq12])
apply (rule single_asm [THEN conseq2])
apply  (clarsimp simp: Arg_Res_simps)
apply (force simp: Arg_Res_simps)
done

lemma Even_ok_N: "{}|-{Z=Arg+0}. BODY Even .{Res_ok}"
apply (rule BodyN)
apply (simp (no_asm))
apply (rule Even_lemma [THEN hoare_derivs.cut])
apply (rule BodyN)
apply (simp (no_asm))
apply (rule Odd_lemma [THEN thin])
apply (simp (no_asm))
done

lemma Even_ok_S: "{}|-{Z=Arg+0}. BODY Even .{Res_ok}"
apply (rule conseq1)
apply  (rule_tac Procs = "{Odd, Even}" and pn = "Even" and P = "%pn. Z=Arg+ (if pn = Odd then 1 else 0) " and Q = "%pn. Res_ok" in Body1)
apply    auto
apply (rule hoare_derivs.insert)
apply (rule Odd_lemma [THEN thin])
apply  (simp (no_asm))
apply (rule Even_lemma [THEN thin])
apply (simp (no_asm))
done

end


(*  Author:  Gertrud Bauer, Tobias Nipkow  *)

header{* Properties of Patch Enumeration*}

theory EnumeratorProps
imports Enumerator GraphProps
begin

lemma length_hideDupsRec[simp]: "\<And>x. length(hideDupsRec x xs) = length xs"
by(induct xs) auto

lemma length_hideDups[simp]: "length(hideDups xs) = length xs"
by(cases xs) simp_all

lemma length_indexToVertexList[simp]:
 "length(indexToVertexList x y xs) = length xs"
by(simp add:indexToVertexList_def)

(***************************** List not decreasing ***************************)
definition increasing :: "('a::linorder) list \<Rightarrow> bool" where
 "increasing ls \<equiv> \<forall> x y as bs. ls = as @ x # y # bs \<longrightarrow> x \<le> y"

lemma increasing1: "\<And> as x. increasing ls \<Longrightarrow> ls = as @ x # cs @ y # bs \<Longrightarrow> x \<le> y"
proof (induct cs)
  case Nil then show ?case
    by (auto simp: increasing_def)
next
  case (Cons c cs) then show ?case
    apply (subgoal_tac "c \<le> y")
    apply (force simp: increasing_def)
    apply (rule_tac Cons) by simp_all
qed

lemma increasing2: "increasing (as@bs) \<Longrightarrow> x \<in> set as \<Longrightarrow> y \<in> set bs \<Longrightarrow> x \<le> y"
proof-
  assume n:"increasing (as@bs)" and x:"x \<in> set as" and y: "y \<in> set bs"
  from x obtain as' as'' where as: "as = as' @ x # as''" by (auto simp: in_set_conv_decomp)
  from y obtain bs' bs'' where bs: "bs = bs' @ y # bs''" by (auto simp: in_set_conv_decomp)
  from n as bs show ?thesis
  apply (auto intro!: increasing1)
  apply (subgoal_tac "as' @ x # as'' @ bs' @ y # bs'' = as' @ x # (as'' @ bs') @ y # bs''")
  by (assumption) auto
qed

lemma increasing3: "\<forall> as bs. (ls = as @ bs \<longrightarrow> (\<forall> x \<in> set as. \<forall> y \<in> set bs. x \<le> y)) \<Longrightarrow> increasing (ls)"
apply (simp add: increasing_def) apply safe
proof -
  fix as bs x y
  assume p: "\<forall>asa bsa. as @ x # y # bs = asa @ bsa \<longrightarrow> (\<forall>x\<in>set asa. \<forall>y\<in>set bsa. x \<le> y)"
  then have p': "\<And> asa bsa. as @ x # y # bs = asa @ bsa \<Longrightarrow> (\<forall>x\<in>set asa. \<forall>y\<in>set bsa. x \<le> y)" by auto
  then have "(\<forall>x\<in>set (as @ [x]). \<forall>y\<in>set (y # bs). x \<le> y)" by (rule_tac p') auto
  then show "x \<le> y" by (auto simp: increasing_def)
qed

lemma increasing4: "increasing (as@bs) \<Longrightarrow> increasing as"
apply (simp add: increasing_def) apply safe by auto

lemma increasing5: "increasing (as@bs) \<Longrightarrow> increasing bs"
proof -
  assume nd: "increasing (as@bs)"
  then have r: "\<And> x y asa bsa. (\<exists>asa bsa. as @ bs = asa @ x # y # bsa) \<Longrightarrow> x \<le> y" by (auto simp: increasing_def)
  show ?thesis apply (clarsimp simp add: increasing_def)
    apply (rule_tac r)
    apply (rule_tac x="as @ ?asa" in exI)
    apply auto
    done
qed

(*********************************** EnumeratorProps *************************************)

(********** enumBase ***********)

lemma enumBase_length: "ls \<in> set (enumBase nmax) \<Longrightarrow> length ls = 1"
by (auto simp: enumBase_def)

lemma enumBase_bound: "\<forall> y \<in> set (enumBase nmax). \<forall> z \<in> set y. z <= nmax"
by (auto simp: enumBase_def)

lemmas enumBase_simps = enumBase_length enumBase_bound

(********** enumAppend ************)

lemma enumAppend_bound: "ls \<in> set ((enumAppend nmax) lss) \<Longrightarrow>
 \<forall> y \<in> set lss. \<forall> z \<in> set y. z \<le> nmax \<Longrightarrow> x \<in> set ls \<Longrightarrow> x \<le>  nmax"
by (auto simp add: enumAppend_def split: split_if_asm)

lemma enumAppend_bound_rec: "ls \<in> set (((enumAppend nmax) ^^ n) lss) \<Longrightarrow>
  \<forall> y \<in> set lss. \<forall> z \<in> set y. z \<le> nmax \<Longrightarrow> x \<in> set ls \<Longrightarrow> x \<le>  nmax"
proof -
  assume ls: "ls \<in> set ((enumAppend nmax ^^ n) lss)" and lss: "\<forall>y\<in>set lss. \<forall>z\<in>set y. z \<le> nmax" and x: "x \<in> set ls"
  have ind:"\<And> lss. \<forall>y\<in>set lss. \<forall>z\<in>set y. z \<le> nmax \<Longrightarrow> \<forall> y \<in> set (((enumAppend nmax) ^^ n) lss). \<forall> z \<in> set y. z \<le> nmax"
  proof (induct n)
    case 0 then show ?case by auto
  next
    case (Suc n) show ?case apply (intro ballI) apply (rule enumAppend_bound) by (auto intro!: Suc)
  qed
  with lss have "\<forall> y \<in> set (((enumAppend nmax) ^^ n) lss). \<forall> z \<in> set y. z \<le> nmax" apply (rule_tac ind) .
  with ls x show ?thesis by auto
qed

lemma enumAppend_increase_rec:
  "\<And> m as bs. ls \<in> set (((enumAppend nmax) ^^ m) (enumBase nmax)) \<Longrightarrow>
  as @ bs = ls \<Longrightarrow>  \<forall> x \<in> set as. \<forall> y \<in> set bs. x \<le> y"
apply (induct ls rule: rev_induct) apply force apply auto apply (case_tac "m") apply simp  apply (drule_tac enumBase_length)
apply (case_tac as) apply simp_all
proof -
  fix x xs m as bs xa xb n
  assume ih: "\<And>m as bs.
           \<lbrakk>xs \<in> set ((enumAppend nmax ^^ m) (enumBase nmax)); as @ bs = xs\<rbrakk>
           \<Longrightarrow> \<forall>x\<in>set as. \<forall>xa\<in>set bs. x \<le> xa"
    and xs:"xs @ [x] \<in> set (enumAppend nmax ((enumAppend nmax ^^ n) (enumBase nmax)))"
    and asbs: "as @ bs = xs @ [x]" and xa:"xa \<in> set as" and xb: "xb \<in> set bs" and m: "m = Suc n"
  from ih have ih2: "\<And> as bs x y. \<lbrakk>xs \<in> set ((enumAppend nmax ^^ n) (enumBase nmax)); as @ bs = xs; x \<in> set as; y \<in> set bs\<rbrakk>
           \<Longrightarrow> x \<le> y" by auto

  from xb have "bs \<noteq> []"  by auto
  then obtain bs' b where bs': "bs = bs' @ [b]" apply (cases rule: rev_exhaust) by auto
  with asbs have beq:"b = x" by auto
  from bs' asbs have xs': "as @ bs' = xs" by auto
  with xs have "xa \<le> x"
  proof (cases "xs" rule: rev_exhaust)
    case Nil with xa xs' show ?thesis by auto
  next
    case (snoc ys y)
    have "xa \<le> y"
    proof (cases "xa = y")
      case True then show ?thesis by auto
    next
      case False
      from xa xs' have "xa \<in> set xs" by auto
      with False snoc have "xa \<in> set ys" by auto
      with xs snoc  show ?thesis
        apply (rule_tac ih2)
        by (auto simp: enumAppend_def)
    qed
    with xs snoc show "xa \<le> x" by (auto simp: enumAppend_def split:split_if_asm)
  qed
  then show "xa \<le> xb" apply (cases "xb = b") apply (simp add: beq)
  proof (rule_tac ih2)
    from xs
    show "xs \<in> set ((enumAppend nmax ^^ n) (enumBase nmax))"
    by (auto simp: enumAppend_def)
  next
    from xs' show "as @ bs' = xs" by auto
  next
    from xa show "xa \<in> set as" by auto
  next
    assume "xb \<noteq> b"
    with xb bs' show "xb \<in> set bs'" by auto
  qed
qed

lemma enumAppend_length1: "\<And>ls. ls \<in> set ((enumAppend nmax ^^ n) lss) \<Longrightarrow>
 (\<forall>l \<in> set lss. |l| = k) \<Longrightarrow> |ls| = k + n"
apply (induct n)
apply simp
by (auto simp add:enumAppend_def split: split_if_asm)

lemma enumAppend_length2: "\<And>ls. ls \<in> set ((enumAppend nmax ^^ n) lss) \<Longrightarrow>
 (\<And>l. l \<in> set lss \<Longrightarrow> |l| = k) \<Longrightarrow> K = k + n \<Longrightarrow> |ls| = K"
 by (auto simp add: enumAppend_length1)

(*********** enum *********)

lemma enum_enumerator:
 "enum i j = enumerator i j"
by(simp add: enum_def enumTab_def tabulate2_def tabulate_def)

(*********** enumerator *********)

lemma enumerator_hd: "ls \<in> set (enumerator m n) \<Longrightarrow> hd ls = 0"
by (auto simp: enumerator_def split: split_if_asm)

lemma enumerator_last: "ls \<in> set (enumerator m n) \<Longrightarrow> last ls = (n - 1)"
by (auto simp: enumerator_def split: split_if_asm)

lemma enumerator_length: "ls \<in> set (enumerator m n) \<Longrightarrow> 2 \<le> length ls"
by (auto simp: enumerator_def split: split_if_asm)

lemmas set_enumerator_simps = enumerator_hd enumerator_last enumerator_length

lemma enumerator_not_empty[dest]: "ls \<in> set (enumerator m n) \<Longrightarrow> ls \<noteq>  []"
apply (subgoal_tac "2 \<le> length ls") apply force  by (rule enumerator_length)

lemma enumerator_length2: "ls \<in> set (enumerator m n) \<Longrightarrow> 2 < m \<Longrightarrow> length ls = m"
proof -
  assume ls:"ls \<in> set (enumerator m n)" and m: "2 < m"
  def k \<equiv> "m - 3"
  with m have k: "m = k + 3" by arith
  with ls have "ls \<in> set (enumerator (k+3) n)" by auto
  then have "length ls = k + 3"
    apply (auto simp: enumerator_def enumBase_def)
    apply (erule enumAppend_length2) by auto
  with k show ?thesis by simp
qed

lemma enumerator_bound: "ls \<in> set (enumerator m nmax) \<Longrightarrow>
 0 < nmax \<Longrightarrow> x \<in> set ls \<Longrightarrow> x < nmax"
apply (auto simp: enumerator_def split: split_if_asm)
apply (subgoal_tac "x \<le> nmax - 2") apply arith
apply (rule_tac enumAppend_bound_rec) by(auto simp:enumBase_simps)

lemma enumerator_bound3: "ls \<in> set (enumerator m nmax) \<Longrightarrow> 1 < nmax \<Longrightarrow> last (butlast ls) < nmax - Suc 0"
apply (case_tac "ls" rule: rev_exhaust) apply force
apply (rule_tac enumerator_bound2) apply assumption
apply auto
apply (case_tac "ys" rule: rev_exhaust) apply simp
apply (subgoal_tac "2 \<le> length (ys @ [y])") apply simp
apply (rule_tac enumerator_length) by auto

lemma enumerator_increase: "\<And> as bs. ls \<in> set (enumerator m nmax) \<Longrightarrow>  as @ bs = ls \<Longrightarrow> \<forall> x \<in> set as. \<forall> y \<in> set bs. x \<le> y"
apply (auto simp: enumerator_def del: Nat.diff_is_0_eq' split: split_if_asm intro: enumAppend_increase_rec)
apply (case_tac as) apply simp apply simp
apply (case_tac bs rule: rev_exhaust)  apply simp apply simp apply auto
apply (drule_tac enumAppend_bound_rec) apply (auto simp:enumBase_simps)
by (auto dest!: enumAppend_increase_rec)

lemma enumerator_increasing: "ls \<in> set (enumerator m nmax) \<Longrightarrow> increasing ls"
apply (rule increasing3)
by (auto dest: enumerator_increase)

definition incrIndexList :: "nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
 "incrIndexList ls m nmax \<equiv>
  1 < m \<and> 1 < nmax \<and>
  hd ls = 0 \<and> last ls = (nmax - 1) \<and> length ls = m
 \<and> last (butlast ls) < last ls \<and> increasing ls"

lemma incrIndexList_1lem[simp]: "incrIndexList ls m nmax \<Longrightarrow> Suc 0 < m"
by (unfold incrIndexList_def) simp

lemma incrIndexList_1len[simp]: "incrIndexList ls m nmax \<Longrightarrow> Suc 0 < nmax"
by (unfold incrIndexList_def) simp

lemma incrIndexList_help2[simp]: "incrIndexList ls m nmax \<Longrightarrow> hd ls = 0"
by (unfold incrIndexList_def) simp

lemma incrIndexList_help21[simp]: "incrIndexList (l # ls) m nmax \<Longrightarrow> l = 0"
by (auto dest: incrIndexList_help2)

lemma incrIndexList_help3[simp]: "incrIndexList ls m nmax \<Longrightarrow> last ls = (nmax - (Suc 0))"
by (unfold incrIndexList_def)  simp

lemma incrIndexList_help4[simp]: "incrIndexList ls m nmax \<Longrightarrow> length ls = m "
by (unfold incrIndexList_def)  simp

lemma incrIndexList_help5[intro]: "incrIndexList ls m nmax \<Longrightarrow>  last (butlast ls) < nmax - Suc 0"
by (unfold incrIndexList_def) auto

lemma incrIndexList_help6[simp]: "incrIndexList ls m nmax \<Longrightarrow> increasing ls"
by (unfold incrIndexList_def) simp

lemma incrIndexList_help7[simp]: "incrIndexList ls m nmax \<Longrightarrow> ls \<noteq> []"
apply (subgoal_tac "length ls \<noteq>  0") apply force
apply simp
apply (subgoal_tac "1 < m")  apply arith apply force done

lemma incrIndexList_help71[simp]: "\<not> incrIndexList [] m nmax"
by (auto dest: incrIndexList_help7)

lemma incrIndexList_help8[simp]: "incrIndexList ls m nmax \<Longrightarrow> butlast ls \<noteq> []"
proof (rule ccontr)
  assume props: "incrIndexList ls m nmax" and butl: "\<not> butlast ls \<noteq> []"
  then have "ls \<noteq> []" by auto
  then have ls': "ls = (butlast ls) @ [last ls]" by auto
  def l \<equiv> "last ls"
  with butl ls' have "ls = [l]" by auto
  then have "length ls = 1" by auto
  with props have "m = 1" by auto
  with props show "False" by (auto dest: incrIndexList_1lem)
qed

lemma incrIndexList_help81[simp]: "\<not> incrIndexList [l] m nmax"
by (auto dest: incrIndexList_help8)

lemma incrIndexList_help9[intro]: "(incrIndexList ls m nmax)  \<Longrightarrow>
  x \<in> set (butlast ls) \<Longrightarrow> x \<le> nmax - 2"
proof -
  assume props: "(incrIndexList ls m nmax)"  and x: "x \<in> set (butlast ls)"
  then have "last (butlast ls) < last ls" by auto
  with props have "last (butlast ls) < nmax - 1" by auto
  then have leq: "last (butlast ls) \<le>  nmax - 2" by arith
  from props  have "ls \<noteq> []" by auto
  then have ls1: "ls = butlast ls @ [last ls]" by auto
  def ls' \<equiv> "(butlast (butlast ls))"
  def last2 \<equiv> "last (butlast ls)"
  def last1 \<equiv> "last ls"
  from props  have "butlast ls \<noteq> []" by auto
  with ls'_def last2_def have bls: "butlast ls = ls' @ [last2]" by auto
  with last1_def ls1 props have ls3: "ls = ls' @ [last2] @ [last1]" by auto
  from props  have "increasing ls" by auto
  with ls3 have increasing: "increasing (ls' @ ([last2] @ [last1]))" by auto
  then have "x \<in> set ls' \<Longrightarrow> x \<le> last2" by (auto intro: increasing2)
  then have "x \<in> set (ls' @ [last2]) \<Longrightarrow> x \<le> last2" by auto
  with bls x have "x \<le> last2" by auto
  with leq last2_def show ?thesis by auto
qed

lemma incrIndexList_help10[intro]: "(incrIndexList ls m nmax)  \<Longrightarrow>
  x \<in> set ls \<Longrightarrow> x < nmax" apply (cases ls rule: rev_exhaust) apply auto
  apply (frule incrIndexList_help3) apply (auto dest: incrIndexList_1len)
  apply (frule incrIndexList_help9) apply auto apply (drule incrIndexList_1len)
  by arith

lemma enumerator_correctness: "2 < m \<Longrightarrow> 1 < nmax \<Longrightarrow>
  ls \<in> set (enumerator m nmax) \<Longrightarrow>
  incrIndexList ls m nmax"
proof -
  assume m: "2 < m" and nmax: "1 < nmax" and enum: "ls \<in> set (enumerator m nmax)"
  then have "(hd ls = 0 \<and> last ls = (nmax - 1) \<and> length ls = m \<and> last (butlast ls) < last ls \<and>  increasing ls)"
    by (auto intro: enumerator_increasing enumerator_hd enumerator_last enumerator_length2 enumerator_bound3 simp: set_enumerator_simps)
  with m nmax show ?thesis by (unfold incrIndexList_def) auto
qed

lemma enumerator_completeness_help: "\<And> ls. increasing ls \<Longrightarrow> ls \<noteq> [] \<Longrightarrow> length ls = Suc ks \<Longrightarrow> list_all (\<lambda>x. x < Suc nmax) ls \<Longrightarrow> ls \<in> set ((enumAppend nmax ^^ ks) (enumBase nmax))"
proof (induct ks)
  case 0
  assume "increasing ls" "ls \<noteq> []" "length ls = Suc 0" "list_all (\<lambda>x. x < Suc nmax) ls"
  then have "\<exists> x. ls = [x]"
    apply (case_tac "ls::nat list") by auto
  then obtain x where ls1: "ls = [x]" by auto
  with 0 have "x < Suc nmax" by auto
  with ls1 show ?case apply (simp add: enumBase_def) by auto
next
  case (Suc n)
  def ls' \<equiv> "butlast ls"
  def l \<equiv> "last ls"
  def ll \<equiv> "last ls'"
  def bl \<equiv> "butlast ls'"
  def ls'list \<equiv> "(enumAppend nmax ^^ n) (enumBase nmax)"
  then have short: "(enumAppend nmax ^^ n) (enumBase nmax) = ls'list" by simp
  from Suc have "ls \<noteq> []" by auto
  then have "ls = butlast ls @ [last ls]" by auto
  with ls'_def l_def have ls1: "ls = ls' @ [l]" by auto
  with Suc have "length ls' = Suc n" by auto
  then have ls'ne: "ls' \<noteq> []" by auto
  with ll_def bl_def have ls'1: "ls' = bl @ [ll]" by auto
  then have ll_in_ls': "ll \<in> set ls'" by simp
  from Suc ls1 have "list_all (\<lambda>x. x < Suc nmax) ls'" by auto
  with ll_in_ls' have "ll < Suc nmax" by (induct ls') auto
  with ll_def have llsmall: "last ls' \<le> nmax"  by auto

  from ls1 have l_in_ls: "l \<in> set ls" by auto
  from Suc have "list_all (\<lambda>x. x < Suc nmax) ls" by auto
  with l_in_ls have "l < Suc nmax" by (induct ls) auto
  then have lo: "l \<le> nmax" by auto

  from Suc ls1 ls'1 have "increasing ((bl @ [ll]) @ [l])" by auto
  then have "ll \<le>  l" by (rule increasing2) auto
  with ll_def have lu: "last ls' \<le> l" by simp

  from Suc ls1 have vors: "ls' \<in> set ((enumAppend nmax ^^ n) (enumBase nmax))"
    by (rule_tac Suc) (auto intro: increasing4)
  with short have "ls' \<in> set ls'list"  by  auto
  with short llsmall ls1 lo lu show ?case  apply simp  apply (simp add: enumAppend_def)
    apply (intro bexI) by auto
qed

lemma enumerator_completeness: "2 < m \<Longrightarrow> incrIndexList ls m nmax \<Longrightarrow>
  ls \<in> set (enumerator m nmax)"
proof -
  assume m: "2 < m" and props: "incrIndexList ls m nmax"
  then have props': "(hd ls = 0 \<and> last ls = (nmax - 1)
   \<and> length ls = m \<and> last (butlast ls) < last ls \<and>  increasing ls)"
   by (unfold incrIndexList_def) auto
  show ?thesis
  proof -
    have props'': "hd ls = 0 \<and> last ls = (nmax - 1) \<and> length ls = m \<and>
       increasing ls"
      by (auto simp: props')
    show "ls \<in> set (enumerator m nmax)"
    proof -
      from m props'' have l_ls: "2 < length ls"  by auto
      then have "\<exists> x y ks. ls = x # ks @ [y]"
        apply (case_tac "ls::(nat list)") apply auto
        apply (case_tac "list" rule: rev_exhaust) by auto
      then obtain x y ks where "ls = x # ks @ [y]" by auto
      with props'' have ls': "ls = 0 # ks @ [nmax - 1]" by auto
      with l_ls have l_ms: "0 < length ks" by auto
      then have ms_ne: "ks \<noteq> []" by auto
      from ls' have lks: "length ks = length ls - 2" by auto
      from props'' have nd: "increasing ls" by auto
      from props'' have "\<And> z. z \<in> set ks \<Longrightarrow> 0 \<le> z" by auto
      from props'' ls' have "increasing ((0 # ks) @ [nmax - 1])" by auto
      then have z: "\<And> z. z \<in> set ks \<Longrightarrow> z \<le> (nmax - 1)"
        by (drule_tac increasing2) auto
      from props  ls' have z': "\<And> z. z \<in> set ks \<Longrightarrow> z \<le> (nmax - 2)" by auto

      have "ks \<in> set ((enumAppend (nmax - 2)
         ^^ (length ks - Suc 0)) (enumBase (nmax - 2)))"
      proof (cases "ks = []")
        case True with ms_ne show ?thesis by simp
      next
        case False
        from props'' have "increasing ls" by auto
        with ls' have "increasing (0 # ks)" by (auto intro: increasing4)
        then have "increasing ([0] @ ks)" by auto
        then have ndks: "increasing ks" by (rule_tac increasing5)
        have listall: "list_all (\<lambda>x. x < Suc (nmax - 2)) ks"
          apply (simp add: list_all_iff)
          by (auto dest: z')
        with False ndks show ?thesis
          apply (rule_tac enumerator_completeness_help) by auto
      qed
      with lks props' have
        "ks \<in> set ((enumAppend (nmax - 2) ^^ (m - 3)) (enumBase (nmax - 2)))" by auto
      with m ls' show ?thesis by (simp add: enumerator_def)
    qed
  qed
qed

lemma enumerator_equiv[simp]:
 "2 < n \<Longrightarrow> 1 < m \<Longrightarrow> is \<in> set(enumerator n m) = incrIndexList is n m"
by (auto intro: enumerator_correctness enumerator_completeness)

end


(*  Title:      HOL/BNF_Composition.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2012, 2013, 2014

Composition of bounded natural functors.
*)

section \<open>Composition of Bounded Natural Functors\<close>

theory BNF_Composition
imports BNF_Def
begin

lemma ssubst_mem: "\<lbrakk>t = s; s \<in> X\<rbrakk> \<Longrightarrow> t \<in> X"
  by simp

lemma empty_natural: "(\<lambda>_. {}) \<circ> f = image g \<circ> (\<lambda>_. {})"
  by (rule ext) simp

lemma Union_natural: "Union \<circ> image (image f) = image f \<circ> Union"
  by (rule ext) (auto simp only: comp_apply)

lemma in_Union_o_assoc: "x \<in> (Union \<circ> gset \<circ> gmap) A \<Longrightarrow> x \<in> (Union \<circ> (gset \<circ> gmap)) A"
  by (unfold comp_assoc)

lemma comp_single_set_bd:
  assumes fbd_Card_order: "Card_order fbd" and
    fset_bd: "\<And>x. |fset x| \<le>o fbd" and
    gset_bd: "\<And>x. |gset x| \<le>o gbd"
  shows "|\<Union>(fset ` gset x)| \<le>o gbd *c fbd"
  apply simp
  apply (rule ordLeq_transitive)
  apply (rule card_of_UNION_Sigma)
  apply (subst SIGMA_CSUM)
  apply (rule ordLeq_transitive)
  apply (rule card_of_Csum_Times')
  apply (rule fbd_Card_order)
  apply (rule ballI)
  apply (rule fset_bd)
  apply (rule ordLeq_transitive)
  apply (rule cprod_mono1)
  apply (rule gset_bd)
  apply (rule ordIso_imp_ordLeq)
  apply (rule ordIso_refl)
  apply (rule Card_order_cprod)
  done

lemma csum_dup: "cinfinite r \<Longrightarrow> Card_order r \<Longrightarrow> p +c p' =o r +c r \<Longrightarrow> p +c p' =o r"
  apply (erule ordIso_transitive)
  apply (frule csum_absorb2')
  apply (erule ordLeq_refl)
  by simp

lemma cprod_dup: "cinfinite r \<Longrightarrow> Card_order r \<Longrightarrow> p *c p' =o r *c r \<Longrightarrow> p *c p' =o r"
  apply (erule ordIso_transitive)
  apply (rule cprod_infinite)
  by simp

lemma Union_image_insert: "\<Union>(f ` insert a B) = f a \<union> \<Union>(f ` B)"
  by simp

lemma Union_image_empty: "A \<union> \<Union>(f ` {}) = A"
  by simp

lemma image_o_collect: "collect ((\<lambda>f. image g \<circ> f) ` F) = image g \<circ> collect F"
  by (rule ext) (auto simp add: collect_def)

lemma conj_subset_def: "A \<subseteq> {x. P x \<and> Q x} = (A \<subseteq> {x. P x} \<and> A \<subseteq> {x. Q x})"
  by blast

lemma UN_image_subset: "\<Union>(f ` g x) \<subseteq> X = (g x \<subseteq> {x. f x \<subseteq> X})"
  by blast

lemma comp_set_bd_Union_o_collect: "|\<Union>(\<Union>((\<lambda>f. f x) ` X))| \<le>o hbd \<Longrightarrow> |(Union \<circ> collect X) x| \<le>o hbd"
  by (unfold comp_apply collect_def) simp

lemma Collect_inj: "Collect P = Collect Q \<Longrightarrow> P = Q"
  by blast

lemma Grp_fst_snd: "(Grp (Collect (case_prod R)) fst)\<inverse>\<inverse> OO Grp (Collect (case_prod R)) snd = R"
  unfolding Grp_def fun_eq_iff relcompp.simps by auto

lemma OO_Grp_cong: "A = B \<Longrightarrow> (Grp A f)\<inverse>\<inverse> OO Grp A g = (Grp B f)\<inverse>\<inverse> OO Grp B g"
  by (rule arg_cong)

lemma vimage2p_relcompp_mono: "R OO S \<le> T \<Longrightarrow>
  vimage2p f g R OO vimage2p g h S \<le> vimage2p f h T"
  unfolding vimage2p_def by auto

lemma type_copy_map_cong0: "M (g x) = N (h x) \<Longrightarrow> (f \<circ> M \<circ> g) x = (f \<circ> N \<circ> h) x"
  by auto

lemma type_copy_set_bd: "(\<And>y. |S y| \<le>o bd) \<Longrightarrow> |(S \<circ> Rep) x| \<le>o bd"
  by auto

lemma vimage2p_cong: "R = S \<Longrightarrow> vimage2p f g R = vimage2p f g S"
  by simp

lemma Ball_comp_iff: "(\<lambda>x. Ball (A x) f) \<circ> g = (\<lambda>x. Ball ((A \<circ> g) x) f)"
  unfolding o_def by auto

lemma conj_comp_iff: "(\<lambda>x. P x \<and> Q x) \<circ> g = (\<lambda>x. (P \<circ> g) x \<and> (Q \<circ> g) x)"
  unfolding o_def by auto

context
  fixes Rep Abs
  assumes type_copy: "type_definition Rep Abs UNIV"
begin

lemma type_copy_map_id0: "M = id \<Longrightarrow> Abs \<circ> M \<circ> Rep = id"
  using type_definition.Rep_inverse[OF type_copy] by auto

lemma type_copy_map_comp0: "M = M1 \<circ> M2 \<Longrightarrow> f \<circ> M \<circ> g = (f \<circ> M1 \<circ> Rep) \<circ> (Abs \<circ> M2 \<circ> g)"
  using type_definition.Abs_inverse[OF type_copy UNIV_I] by auto

lemma type_copy_set_map0: "S \<circ> M = image f \<circ> S' \<Longrightarrow> (S \<circ> Rep) \<circ> (Abs \<circ> M \<circ> g) = image f \<circ> (S' \<circ> g)"
  using type_definition.Abs_inverse[OF type_copy UNIV_I] by (auto simp: o_def fun_eq_iff)

lemma type_copy_wit: "x \<in> (S \<circ> Rep) (Abs y) \<Longrightarrow> x \<in> S y"
  using type_definition.Abs_inverse[OF type_copy UNIV_I] by auto

lemma type_copy_vimage2p_Grp_Rep: "vimage2p f Rep (Grp (Collect P) h) =
    Grp (Collect (\<lambda>x. P (f x))) (Abs \<circ> h \<circ> f)"
  unfolding vimage2p_def Grp_def fun_eq_iff
  by (auto simp: type_definition.Abs_inverse[OF type_copy UNIV_I]
   type_definition.Rep_inverse[OF type_copy] dest: sym)

lemma type_copy_vimage2p_Grp_Abs:
  "\<And>h. vimage2p g Abs (Grp (Collect P) h) = Grp (Collect (\<lambda>x. P (g x))) (Rep \<circ> h \<circ> g)"
  unfolding vimage2p_def Grp_def fun_eq_iff
  by (auto simp: type_definition.Abs_inverse[OF type_copy UNIV_I]
   type_definition.Rep_inverse[OF type_copy] dest: sym)

lemma type_copy_ex_RepI: "(\<exists>b. F b) = (\<exists>b. F (Rep b))"
proof safe
  fix b assume "F b"
  show "\<exists>b'. F (Rep b')"
  proof (rule exI)
    from \<open>F b\<close> show "F (Rep (Abs b))" using type_definition.Abs_inverse[OF type_copy] by auto
  qed
qed blast

lemma vimage2p_relcompp_converse:
  "vimage2p f g (R\<inverse>\<inverse> OO S) = (vimage2p Rep f R)\<inverse>\<inverse> OO vimage2p Rep g S"
  unfolding vimage2p_def relcompp.simps conversep.simps fun_eq_iff image_def
  by (auto simp: type_copy_ex_RepI)

end

bnf DEADID: 'a
  map: "id :: 'a \<Rightarrow> 'a"
  bd: natLeq
  rel: "(=) :: 'a \<Rightarrow> 'a \<Rightarrow> bool"
  by (auto simp add: natLeq_card_order natLeq_cinfinite)

definition id_bnf :: "'a \<Rightarrow> 'a" where
  "id_bnf \<equiv> (\<lambda>x. x)"

lemma id_bnf_apply: "id_bnf x = x"
  unfolding id_bnf_def by simp

bnf ID: 'a
  map: "id_bnf :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
  sets: "\<lambda>x. {x}"
  bd: natLeq
  rel: "id_bnf :: ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
  pred: "id_bnf :: ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool"
  unfolding id_bnf_def
  apply (auto simp: Grp_def fun_eq_iff relcompp.simps natLeq_card_order natLeq_cinfinite)
  apply (rule ordLess_imp_ordLeq[OF finite_ordLess_infinite[OF _ natLeq_Well_order]])
  apply (auto simp add: Field_card_of Field_natLeq card_of_well_order_on)[3]
  done

lemma type_definition_id_bnf_UNIV: "type_definition id_bnf id_bnf UNIV"
  unfolding id_bnf_def by unfold_locales auto

ML_file \<open>Tools/BNF/bnf_comp_tactics.ML\<close>
ML_file \<open>Tools/BNF/bnf_comp.ML\<close>

hide_fact
  DEADID.inj_map DEADID.inj_map_strong DEADID.map_comp DEADID.map_cong DEADID.map_cong0
  DEADID.map_cong_simp DEADID.map_id DEADID.map_id0 DEADID.map_ident DEADID.map_transfer
  DEADID.rel_Grp DEADID.rel_compp DEADID.rel_compp_Grp DEADID.rel_conversep DEADID.rel_eq
  DEADID.rel_flip DEADID.rel_map DEADID.rel_mono DEADID.rel_transfer
  ID.inj_map ID.inj_map_strong ID.map_comp ID.map_cong ID.map_cong0 ID.map_cong_simp ID.map_id
  ID.map_id0 ID.map_ident ID.map_transfer ID.rel_Grp ID.rel_compp ID.rel_compp_Grp ID.rel_conversep
  ID.rel_eq ID.rel_flip ID.rel_map ID.rel_mono ID.rel_transfer ID.set_map ID.set_transfer

end


section \<open>Verification Condition Testing\<close>

theory control_flow_partial_examples
  imports "../hoare/utp_hoare"
begin
section "Examples"

text{*In this section we provide a set of examples on the verification
      of programs that uses  control flow statements
      with Hoare logic for partial correctness.
      The combination of
      relational algebra, ie. UTP, and lens algebra allows for a semantic based
      framework for the specification of programming languages and their features. It also
      allows a powerful proof tactics for the framework such as @{method rel_auto},
      @{method pred_auto}, etc.*}

text{*
   In the following examples:
      \begin{itemize}
         \<^item> The formal notation @{term "\<lbrace>Pre\<rbrace>prog\<lbrace>Post\<rbrace>\<^sub>u"} represent a hoare triple for partial
            correctness.
         \<^item> All variables are represented by lenses and have the type @{typ "'v \<Longrightarrow> 's"}:
           where  @{typ "'v"} is the view type of the lens and @{typ "'s"} is the type of the state.
         \<^item> Lens properties such as @{term "weak_lens"}, @{term "mwb_lens"}, @{term "wb_lens"},
           @{term "vwb_lens"}, @{term "ief_lens"}, @{term "bij_lens"}
           are used to semantically express what does not change in the state space. For example
           applying the property @{term "bij_lens"} of variable @{term "x"} gives the term
           @{term "bij_lens x"}. Informally this means that any change on x will appear on all
           other variables in the state space.The property @{term "ief_lens"} is just the opposite
           of @{term "bij_lens"}.
         \<^item> The formal notation @{term "x \<sharp>\<sharp> P"} is a syntactic sugar for
            @{term "unrest_relation x P"}:
           informally it is used to semantically express that the variable x does not occur
           in the program P.
         \<^item> The formal notation @{term "x :== v"} is a syntactic sugar for @{term "assigns_r [x \<mapsto>\<^sub>s v]"}:
           informally it represent an assignment of a value v to a variable x.
         \<^item> The formal notation @{term "&x"} is a syntactic sugar for @{term "\<langle>id\<rangle>\<^sub>s x"}:
           informally it represent the content of a variable x.
         \<^item> The formal notation @{term "\<guillemotleft>l\<guillemotright>"} is a syntactic sugar for @{term "lit l"}:
            informally it represent a lifting of an HOL literal l to utp expression.
         \<^item> The formal notation @{term "x \<bowtie> y"} is a syntactic sugar for @{term "lens_indep x y"}:
           informally it is a semantic representation that uses two variables
           to characterise independence between two state space regions.
         \<^item> The tactics @{method rel_auto}, @{method pred_auto}, @{method rel_simp},
           @{method pred_simp}, @{method rel_blast}, @{method pred_blast} are used
           to discharge proofs related to UTP-relations and UTP-predicates.
     \end{itemize}
     *}

subsection {*block feature*}

text {*block_test1 is a scenario. The scenario represent a program where i is name of the variable
       in the scope of the initial state s. In the scenario, and using the command block,
       we create a new variable with the same name inside the block ie., inside the new scope.
       Now i is a local var for the scope t.
       In that case we can use a restore function on the state s to set the variable to its
       previous value ie.,its value in the scope s, and this before we exit the block.*}

lemma   blocks_test1:
  assumes "weak_lens i"
  shows "\<lbrace>true\<rbrace>
          i :== \<guillemotleft>2::int\<guillemotright>;;
          block (i :== \<guillemotleft>5\<guillemotright>) (II) (\<lambda> (s, s') (t, t').  i:== \<guillemotleft>\<lbrakk>\<langle>id\<rangle>\<^sub>s i\<rbrakk>\<^sub>e s\<guillemotright>) (\<lambda> (s, s') (t, t').  II)
         \<lbrace>&i =\<^sub>u \<guillemotleft>2::int\<guillemotright>\<rbrace>\<^sub>u"
  using assms by rel_auto

text {*block_test2 is similar to  block_test1 but the var i is a global var.
       In that case we can use restore function and the state t to set the variable to its
       latest value, ie.,its value in in the scope t,probably modified inside the scope of the block.*}

lemma   blocks_test2:
  assumes "weak_lens i"
  shows "\<lbrace>true\<rbrace>
          i :== \<guillemotleft>2::int\<guillemotright>;;
          block (i :== \<guillemotleft>5\<guillemotright>) (II) (\<lambda> (s, s') (t, t').  i:== \<guillemotleft>\<lbrakk>\<langle>id\<rangle>\<^sub>s i\<rbrakk>\<^sub>e t\<guillemotright>) (\<lambda> (s, s') (t, t').  II)
         \<lbrace>&i =\<^sub>u \<guillemotleft>5::int\<guillemotright>\<rbrace>\<^sub>u"
  using assms by rel_auto

subsection {*Infinite loops*}
text{*The next two lemmas are the witness needed to justify the theory of designs.*}

lemma 1:"while\<^sub>\<bottom> true do II od = true"
  unfolding while_bot_def
  apply rel_simp unfolding gfp_def apply transfer apply auto done

lemma "in\<alpha> \<sharp> ( x :== \<guillemotleft>c\<guillemotright>) \<Longrightarrow> while\<^sub>\<bottom> true  do II od;; x :== \<guillemotleft>c\<guillemotright> = x :== \<guillemotleft>c\<guillemotright>"
  apply (subst 1) apply (simp only: assigns_r.abs_eq )
  apply (simp only: seqr_def) apply simp
 apply rel_simp  apply transfer apply auto done

end


(*
    Title:      Echelon_Form_Inverse.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Inverse matrix over principal ideal rings\<close>

theory Echelon_Form_Inverse
  imports
    Echelon_Form_Det
    Gauss_Jordan.Inverse
begin

subsection\<open>Computing the inverse of matrix over rings\<close>

lemma scalar_mult_mat:
  fixes x :: "'a::comm_semiring_0"
  shows "x *k mat y = mat (x * y)"
  by (simp add: matrix_scalar_mult_def mat_def vec_eq_iff)

lemma matrix_mul_mat:
  fixes A :: "'a::comm_semiring_1 ^ 'm ^ 'n"
  shows "A ** mat x = x *k A"
  by (simp add: matrix_matrix_mult_def mat_def if_distrib sum.If_cases matrix_scalar_mult_def vec_eq_iff ac_simps)

lemma mult_adjugate_det: "A ** adjugate A = mat (det A)"
  using mult_adjugate_det[of "from_vec A"]
  unfolding det_sq_matrix_eq adjugate_eq to_vec_eq_iff[symmetric] to_vec_matrix_matrix_mult to_vec_from_vec
  by (simp add: to_vec_diag)

lemma invertible_imp_matrix_inv:
  assumes i: "invertible (A :: ('a :: {comm_ring_1,euclidean_semiring}) ^ 'b ^ 'b)"
  shows "matrix_inv A = (1 div (det A)) *k adjugate A"
proof -
  let ?A = "adjugate A"
  have "A ** ?A = det A *k mat 1"
    unfolding mult_adjugate_det by (simp add: scalar_mult_mat)
  hence "matrix_inv A ** (A ** ?A) = matrix_inv A ** (det A *k mat 1)"
    by auto
  hence "?A = det A *k matrix_inv A"
    unfolding matrix_mul_assoc matrix_inv_left[OF i] matrix_mul_lid scalar_mult_mat matrix_mul_mat
    by simp
  with i show ?thesis
    by (metis (no_types, lifting) dvd_mult_div_cancel invertible_iff_is_unit
                 matrix_mul_assoc matrix_mul_mat matrix_mul_rid scalar_mult_mat mult.commute)
qed

lemma inverse_matrix_code_rings[code_unfold]:
  fixes A::"'a::{euclidean_ring}^'n::{mod_type}^'n::{mod_type}"
  shows "inverse_matrix A = (let d=det A in if is_unit d then Some ((1 div d) *k adjugate A) else None)"
  using invertible_imp_matrix_inv[of A]
  unfolding inverse_matrix_def invertible_iff_is_unit by auto

end


(*:maxLineLen=78:*)

theory Highway
  imports
    Main
    "HOL-Lattice.Orders"
    HOL.Rat
begin

sledgehammer_params [smt_proofs = false]

section \<open>Axiomatization\<close>

text \<open> Isabelle/HOL will not let us have a function
   \<open>weight ::validator \<Rightarrow> rat\<close> in a type class because it is missing a
   parameter. We use phantom parameters to get around this. \<close>

datatype 'a validator = validator nat
datatype 'a vote_option = vote_for nat | abstain ("\<emptyset>")

class highway = partial_order +
  fixes vote_value :: "'a \<Rightarrow> 'a vote_option"
  fixes sender :: "'a \<Rightarrow> 'a validator"
  fixes weight :: "'a validator \<Rightarrow> rat"
  assumes non_neg_weights: "weight v \<ge> 0"

section \<open>Consistency\<close>

text \<open> \<^emph>\<open> This is an elementary consistency proof, however it will be
          desirable to have model more complex sets of assumptions \<close> \<close>

datatype example = example

instantiation example :: highway
begin
fun leq_example :: "example \<Rightarrow> example \<Rightarrow> bool" where
  "example \<sqsubseteq> example = True"

definition vote_value_example :: "example \<Rightarrow> example vote_option" where
  "vote_value_example m = vote_for 0"
definition sender_example :: "example \<Rightarrow> example validator" where
  "sender_example m = validator 0"
definition weight_example :: "example validator \<Rightarrow> rat" where
  "weight_example v = 1"

instance
  apply (standard)
    apply (metis (full_types) example.exhaust leq_example.simps)
    apply (metis (full_types) example.exhaust)
    apply (metis (full_types) example.exhaust)
    apply (simp add: weight_example_def)
  done
end

section \<open>Equivocations\<close>

definition (in highway)
  equivocation :: "'a validator \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "equivocation v x y \<equiv>
       v = sender x \<and> v = sender y \<and> \<not> (x \<sqsubseteq> y) \<and> \<not> (y \<sqsubseteq> x)"

lemma (in highway) equivocation_neg:
  assumes "v = sender x" and "v = sender y"
  shows "\<not> equivocation v x y \<equiv> x \<sqsubseteq> y \<or> y \<sqsubseteq> x"
  using assms equivocation_def by auto

abbreviation (in partial_order) downset :: "'a set \<Rightarrow> 'a set" ("\<down>") where
  "\<down> S \<equiv> { m . \<exists> s \<in> S. m \<sqsubseteq> s }"

lemma (in partial_order) downset_universe:
  "\<down> (UNIV :: 'a set) = UNIV"
  using leq_refl
  by fastforce

definition (in highway)
  byzantine_in :: "'a set \<Rightarrow> 'a validator \<Rightarrow> bool" where
  "byzantine_in S v \<equiv> \<exists> x \<in> \<down> S. \<exists> y \<in> \<down> S. equivocation v x y"

definition (in highway) byzantine :: "'a validator \<Rightarrow> bool" where
  "byzantine v \<equiv> byzantine_in UNIV v"

lemma byzantine_def':
  "byzantine v = (\<exists> x y. equivocation v x y)"
  unfolding byzantine_def byzantine_in_def
  by (metis (mono_tags, lifting) UNIV_I downset_universe)

definition (in highway)
  honest_message_weight :: "'a set \<Rightarrow> 'a set \<Rightarrow> rat" ("weight\<^sub>\<M>") where
  "weight\<^sub>\<M> S T =
     (\<Sum> v | (\<exists> s \<in> T . v = sender s)
                 \<and> weight v \<noteq> 0
                 \<and> \<not> byzantine_in S v
                 . weight v)"

lemma (in highway) messages_weight_mono:
  assumes
    "T \<subseteq> U"
    "finite {v. \<exists> s \<in> U. v = sender s \<and> weight v \<noteq> 0 \<and> \<not> byzantine_in S v}"
  shows "weight\<^sub>\<M> S T \<le> weight\<^sub>\<M> S U"
proof -
  have "{v. \<exists> s \<in> T. v = sender s \<and> weight v \<noteq> 0 \<and> \<not> byzantine_in S v}
          \<subseteq> {v. \<exists> s \<in> U. v = sender s \<and> weight v \<noteq> 0 \<and> \<not> byzantine_in S v}"
    using assms(1)
    by blast
  with assms(2) show ?thesis
    unfolding honest_message_weight_def
    by (simp add: non_neg_weights sum_mono2)
qed

definition (in highway)
  most_recent_for :: "'a validator \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "most_recent_for v S =
     { s \<in> S . v = sender s
        \<and> (\<forall> t \<in> S. v = sender t \<longrightarrow> s \<sqsubseteq> t \<longrightarrow> s = t) }"

lemma (in highway) most_recent_for_idem:
  "most_recent_for v (most_recent_for v S) = most_recent_for v S"
  unfolding most_recent_for_def by fastforce

fun (in partial_order) descending_chain_list :: "'a list \<Rightarrow> bool" where
  "descending_chain_list [] = True"
| "descending_chain_list [x] = True"
| "descending_chain_list (x1 # x2 # xs)
     = (x2 \<sqsubseteq> x1 \<and> x2 \<noteq> x1 \<and> descending_chain_list (x2 # xs))"

lemma (in partial_order) descending_chain_list_drop_penultimate:
  "descending_chain_list (x1 # x2 # xs) \<Longrightarrow> descending_chain_list (x1 # xs)"
  by (induct xs,
        simp,
        metis descending_chain_list.simps(3) leq_antisym leq_trans)

lemma (in partial_order) descending_chain_list_greater_than_others:
  assumes "descending_chain_list (x # xs)"
  shows "\<forall> y \<in> set xs . y \<sqsubseteq> x \<and> y \<noteq> x"
  using assms descending_chain_list_drop_penultimate
  by (induct xs, fastforce+)

lemma (in partial_order) descending_chain_list_distinct:
  "descending_chain_list xs \<Longrightarrow> distinct xs"
  by (induct xs,
        simp,
        metis
          distinct.simps(2)
          descending_chain_list.elims(3)
          descending_chain_list.simps(3)
          descending_chain_list_greater_than_others)

lemma (in highway) most_recent_exists:
  assumes "finite S" "m \<in> S" "v = sender m"
  shows "\<exists> n \<in> most_recent_for v S . m \<sqsubseteq> n"
proof (rule ccontr)
  assume "\<not> (\<exists> n \<in> most_recent_for v S . m \<sqsubseteq> n)"
  hence fresh:
    "\<forall> n \<in> S. m \<sqsubseteq> n
        \<longrightarrow> v = sender n
        \<longrightarrow> (\<exists> p \<in> S. v = sender p \<and> n \<noteq> p \<and> m \<sqsubseteq> n \<and> n \<sqsubseteq> p)"
    using most_recent_for_def by auto
  {
    fix n :: nat
    have "\<exists> xs .
            descending_chain_list xs
            \<and> length xs = n
            \<and> set xs \<subseteq> S
            \<and> (\<forall> x \<in> set xs. v = sender x \<and> m \<sqsubseteq> x)"
    proof (induct n)
      case 0
      then show ?case
        by simp
    next
      case (Suc n)
      then show ?case
      proof (cases "n = 0")
        assume "n = 0"
        have
          "descending_chain_list [m]"
          "length [m] = Suc 0"
          "set [m] \<subseteq> S"
          "\<forall> x \<in> set [m] . v = sender x \<and> m \<sqsubseteq> x"
          using assms leq_refl
          by auto
        thus ?case
          unfolding \<open>n = 0\<close>
          by blast
      next
        assume
          "n \<noteq> 0"
          "\<exists>xs.
             descending_chain_list xs
             \<and> length xs = n
             \<and> set xs \<subseteq> S
             \<and> (\<forall>x\<in>set xs. v = sender x \<and> m \<sqsubseteq> x)"
        from this obtain x xs where
            "descending_chain_list (x # xs)"
            "length (x # xs) = n"
            "set (x # xs) \<subseteq> S"
            "\<forall> x' \<in> set (x # xs). v = sender x' \<and> m \<sqsubseteq> x'"
            "m \<sqsubseteq> x"
          by (metis
                (no_types, lifting)
                length_0_conv
                length_greater_0_conv
                descending_chain_list.elims(2)
                nth_Cons_0 nth_mem)
        moreover from this obtain y where
            "y \<in> S"
            "v = sender y"
            "y \<noteq> x"
            "x \<sqsubseteq> y"
            "m \<sqsubseteq> y"
          by (metis fresh list.set_intros(1) leq_trans subset_eq)
        ultimately have
            "descending_chain_list (y # x # xs)"
            "length (y # x # xs) = Suc n"
            "set (y # x # xs) \<subseteq> S"
            "\<forall> x' \<in> set (y # x # xs). v = sender x' \<and> m \<sqsubseteq> x'"
          by auto
        thus ?case by blast
      qed
    qed
  }
  from this obtain xs :: "'a list" where
    "descending_chain_list xs"
    "length xs = card S + 1"
    "set xs \<subseteq> S"
    by blast
  with \<open>finite S\<close> \<open>descending_chain_list xs\<close> \<open>set xs \<subseteq> S\<close>
  have "length xs \<le> card S"
    by (metis card_mono distinct_card descending_chain_list_distinct)
  with \<open>length xs = card S + 1\<close> show False
    by linarith
qed

lemma (in highway) non_byzantine_most_recent_for:
  assumes "\<not> byzantine_in S v"
      and "m \<in> most_recent_for v S"
      and "n \<in> most_recent_for v S"
    shows "m = n"
proof -
  have "m \<in> S" "n \<in> S" "v = sender m" "v = sender n"
    using assms most_recent_for_def by auto
  moreover with assms(1) have "m \<sqsubseteq> n \<or> n \<sqsubseteq> m"
    unfolding byzantine_in_def equivocation_def
    using leq_refl by blast
  ultimately show ?thesis
    using assms(2) assms(3) most_recent_for_def by force
qed

lemma (in highway) most_recent_exists_unique:
  assumes
    "finite S"
    "\<not> byzantine_in S v"
    "m \<in> S"
    "v = sender m"
  shows "\<exists>! n \<in> most_recent_for v S . m \<sqsubseteq> n"
proof (rule ccontr)
  assume "\<not> (\<exists>! n . n \<in> most_recent_for v S \<and> m \<sqsubseteq> n)"
  moreover have "\<exists> n. n \<in> most_recent_for v S \<and> m \<sqsubseteq> n"
    using assms(1) assms(3) assms(4) most_recent_exists by blast
  ultimately obtain p q where
    "p \<in> most_recent_for v S"
    "q \<in> most_recent_for v S"
    "p \<noteq> q"
    by blast
  thus False
    using assms(2) non_byzantine_most_recent_for
    by blast
qed

definition (in highway) most_recent :: "'a set \<Rightarrow> 'a set" where
  "most_recent S = \<Union>{ s . \<exists> v. s = most_recent_for v S }"

lemma (in highway) most_recent_idem:
  "most_recent (most_recent S) = most_recent S"
  unfolding most_recent_def most_recent_for_def by auto

lemma (in highway) downset_most_recent_for_subset:
  "\<down> (most_recent S) \<subseteq> \<down> S"
proof (intro subsetI)
  fix x
  assume "x \<in> \<down> (most_recent S)"
  hence "\<exists> y \<in> S . x \<sqsubseteq> y"
    unfolding most_recent_def most_recent_for_def
    by blast
  thus "x \<in> \<down> S" by auto
qed

lemma (in highway) downset_most_recent_for:
  assumes "finite S"
  shows "\<down> (most_recent S) = \<down> S"
proof (intro equalityI subsetI)
  fix x
  assume "x \<in> \<down> (most_recent S)"
  thus "x \<in> \<down> S"
    using downset_most_recent_for_subset by blast
next
  fix x
  assume "x \<in> \<down> S"
  from this obtain v y m where
      "v = sender y"
      "m \<in> most_recent_for v S"
      "x \<sqsubseteq> y"
      "y \<sqsubseteq> m"
    using \<open>finite S\<close> most_recent_exists by fastforce
  hence "x \<in> \<down> (most_recent_for v S)"
    by (metis CollectI leq_trans)
  thus "x \<in> \<down> (most_recent S)"
    unfolding most_recent_def
    by blast
qed

lemma (in highway) most_recent_byzantine_impl:
  "byzantine_in (most_recent S) v \<Longrightarrow> byzantine_in S v"
  unfolding
    most_recent_def
    most_recent_for_def
    byzantine_in_def
    equivocation_def
  by blast

lemma (in highway) most_recent_byzantine_iff:
  assumes "finite S"
  shows "byzantine_in (most_recent S) v = byzantine_in S v"
proof
  assume "byzantine_in (most_recent S) v"
  thus "byzantine_in S v"
    unfolding
      most_recent_def
      most_recent_for_def
      byzantine_in_def
      equivocation_def
    by blast
next
  assume "byzantine_in S v"
  from this obtain x y p q t u where
      "p \<in> S"
      "q \<in> S"
      "t = sender p"
      "u = sender q"
      "x \<sqsubseteq> p"
      "y \<sqsubseteq> q"
      "v = sender x"
      "v = sender y"
      "\<not> x \<sqsubseteq> y"
      "\<not> y \<sqsubseteq> x"
    unfolding byzantine_in_def equivocation_def
    by blast
  moreover from this obtain m n where
      "p \<sqsubseteq> m"
      "q \<sqsubseteq> n"
      "m \<in> most_recent S"
      "n \<in> most_recent S"
    unfolding most_recent_def
    using
      most_recent_exists [ OF \<open>finite S\<close> \<open>p \<in> S\<close> \<open>t = sender p\<close> ]
      most_recent_exists [ OF \<open>finite S\<close> \<open>q \<in> S\<close> \<open>u = sender q\<close> ]
    by blast
  ultimately
  show "byzantine_in (most_recent S) v"
    unfolding byzantine_in_def equivocation_def
    using leq_trans by blast
qed

definition (in highway)
  majority_option :: "'a set \<Rightarrow> 'a vote_option \<Rightarrow> bool" where
  "majority_option S a =
     (weight\<^sub>\<M> S { s \<in> most_recent S . a = vote_value s }
     > weight\<^sub>\<M> S { s \<in> most_recent S . a \<noteq> vote_value s })"

lemma (in highway) at_most_one_majority_option:
  assumes "finite S" "majority_option S v" and "majority_option S w"
  shows "v = w"
proof (rule ccontr)
  let ?S' = "most_recent S"
  assume "v \<noteq> w"
  hence
    "{ s \<in> ?S' . v = vote_value s } \<subseteq> { s \<in> ?S' . w \<noteq> vote_value s }"
    (is "?v_votes \<subseteq> ?w_opposing_votes")
    "{ s \<in> ?S' . w = vote_value s } \<subseteq> { s \<in> ?S' . v \<noteq> vote_value s }"
    (is "?w_votes \<subseteq> ?v_opposing_votes")
    by blast+
  moreover have "?S' \<subseteq> S"
    unfolding most_recent_def most_recent_for_def
    by blast
  hence "finite ?S'"
    using assms(1) infinite_super by auto
  ultimately have
    "weight\<^sub>\<M> S ?v_votes \<le> weight\<^sub>\<M> S ?w_opposing_votes"
    "weight\<^sub>\<M> S ?w_votes \<le> weight\<^sub>\<M> S ?v_opposing_votes"
    by (simp add: messages_weight_mono)+
  hence
    "weight\<^sub>\<M> S ?v_votes < weight\<^sub>\<M> S ?w_votes"
    "weight\<^sub>\<M> S ?w_votes < weight\<^sub>\<M> S ?v_votes"
    using assms
    unfolding majority_option_def
    by linarith+
  thus False
    by auto
qed

section \<open> Finality \<close>

class highway_summit = highway +
  assumes finite_weight: "finite { v . weight v \<noteq> 0 }"
  assumes finite_citations: "finite (\<down> { m })"
  assumes majority_driven:
    "majority_option {u . u \<sqsubseteq> m \<and> u \<noteq> m} a \<Longrightarrow> vote_value m = a"

definition (in highway)
  horizon :: "'a set \<Rightarrow> 'a vote_option \<Rightarrow> 'a set \<Rightarrow> bool" where
  "horizon state a x \<equiv>
    x \<noteq> {} \<and> x \<subseteq> \<down> state
    \<and> (\<forall> m \<in> x. \<forall> n \<in> \<down> state.
           sender m = sender n
           \<longrightarrow> m \<sqsubseteq> n
           \<longrightarrow> vote_value n = a)"

definition (in highway) validator_weight :: "('a validator) set \<Rightarrow> rat" where
  [simp]: "validator_weight V = (\<Sum> v | v \<in> V \<and> weight v \<noteq> 0 . weight v)"

definition (in highway) committee_weight
  :: "'a \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> rat" where
  [simp]: "committee_weight m y x =
             validator_weight
                { v. \<exists> u \<in> y. v = sender u
                      \<and> (\<exists> n \<in> x. v = sender n \<and> n \<sqsubseteq> u \<and> n \<sqsubseteq> m) }"

fun (in highway) summit
   :: "rat \<Rightarrow> 'a set \<Rightarrow> 'a vote_option \<Rightarrow> ('a set) list \<Rightarrow> bool" where
    "summit _ _ _ [] = True"
  | "summit _ state a [x] = horizon state a x"
  | "summit q state a (x # x' # xs) =
       (horizon state a x
           \<and> (\<forall> m \<in> x. q \<le> committee_weight m x x')
           \<and> summit q state a (x' # xs))"

lemma (in highway) summit_left_weaken:
  "summit q state a (xs @ ys) \<Longrightarrow> summit q state a xs"
proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  then show ?case
  proof (cases "xs = []")
    case True
    show ?thesis
      by (metis
            True
            Cons.prems
            append_Cons
            summit.simps(2)
            summit.simps(3)
            min_list.cases)
  next
    case False
    from this obtain x' xs' where
      "xs = x' # xs'"
      by (meson neq_Nil_conv)
    then show ?thesis
      using Cons.hyps Cons.prems
      unfolding summit.simps(3) by auto
  qed
qed

definition (in highway) message_weight :: "'a set \<Rightarrow> rat" where
  [simp]: "message_weight M = validator_weight (image sender M)"

theorem (in highway_summit) elementary_finality:
  assumes
    "summit (validator_weight UNIV / 2) S a [y,x]"
    "validator_weight { v. byzantine v } = 0"
    "y \<subseteq> \<down> {n}"
  shows "vote_value n = a"
  sorry

(*
theorem (in highway_summit) finality:
  fixes m
  fixes t :: rat
  assumes
    "S \<subseteq> {u . u \<sqsubseteq> m \<and> u \<noteq> m}"
    and "\<forall> v . \<not> byzantine_in S v"
    and "0 < t"
    and "m \<sqsubseteq> n"
    and \<dagger>: "summit (message_weight S / 2 + t) S a xs"
    and \<ddagger>:
      "validator_weight { v. byzantine v }
           \<le> 2 * t * (1 - (1 / 2) ^ length xs)" (is "?byz_weight \<le> _")
  shows "vote_value n = a"
  using \<dagger> \<ddagger>
proof (induct xs)
  case Nil
  hence "?byz_weight \<le> t * 3 / 2" sorry
  show ?case
  proof (rule ccontr)
    let ?n_lt = "{u . u \<sqsubseteq> n \<and> u \<noteq> n}"
    let ?not_a_votes = "{s \<in> most_recent ?n_lt. a \<noteq> vote_value s}"
    let ?a_votes = "{s \<in> most_recent ?n_lt. a = vote_value s}"
    assume "vote_value n \<noteq> a"
    hence "weight\<^sub>\<M> ?n_lt ?not_a_votes \<ge> weight\<^sub>\<M> ?n_lt ?not_a_votes"
      using
        majority_driven [where m=n and a=a]
        le_less_linear
      unfolding
        majority_option_def
        honest_message_weight_def
      by blast
    show False sorry
  qed
next
  case (Cons a xs)
  then show ?case sorry
qed
*)

end


(*<*)
theory ClimateEngineering_old
imports embedding
begin
(* Configuration defaults *)
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format = 3] (*default settings*)
(*>*)

section\<open>Case Study: Arguments in the Climate Engineering Debate\<close>
(**
Formalisation and evaluation of an extract of the argument network presented by Gregor Betz and
Sebastian Cacean in their work "Ethical Aspects of Climate Engineering", freely available for download at:
http://books.openedition.org/ksp/pdf/1780
*)

subsection\<open>Individual (Component) Arguments\<close>
(**The arguments below primarily support the thesis: "CE deployment is morally wrong"
and make for an argument cluster with a non-trivial dialectical structure which we aim at
reconstructing in this section. We focus on six arguments from the ethics of risk,
which entail that the deployment of CE technologies (today as in the future) is not desirable
because of being morally wrong (argument A22). Supporting arguments of A22 are: A45, A46, A47, A48, A49.
In particular, two of these arguments, namely A48 and A49, are further attacked by A50 and A51.
*)

subsubsection\<open>Ethics of Risk Argument (A22)\<close>
(**The argument has as premise: "CE deployment is morally wrong" and as conclusion:
"CE deployment is not desirable". Notice that both are formalised as (modally) valid propositions,
i.e. true in all possible worlds or situations. We are thus presupossing a possible-worlds semantics.*)

consts CEisWrong::"w\<Rightarrow>bool"  (**notice type for world-contingent propositions*)
consts CEisNotDesirable::"w\<Rightarrow>bool"

definition "A22_P1 \<equiv> [\<turnstile> CEisWrong]" (*CE is wrong (in all situations)*)
definition "A22_P2 \<equiv> [\<turnstile> CEisWrong \<^bold>\<rightarrow> CEisNotDesirable]" (*implicit premise*)
definition "A22_C  \<equiv> [\<turnstile> CEisNotDesirable]" (*...also in all situations*)

(**We use Nitpick to find a model satisfying the premises and the conclusion of the formalised argument.*)
lemma assumes A22_P1 and A22_P2 and A22_C shows True
  nitpick [satisfy] oops (**consistency is shown: nitpick presents a simple model*)

theorem A22_valid: assumes A22_P1 and A22_P2 shows A22_C
  using A22_C_def A22_P2_def A22_P1_def assms(1) assms(2) by blast

subsubsection\<open>Termination Problem (A45)\<close>
(**CE measures do not possess viable exit options. If deployment is terminated abruptly,
catastrophic climate change ensues.
*)
consts CEisTerminated::"w\<Rightarrow>bool"   (**world-contingent propositional constants*)
consts CEisCatastrophic::"w\<Rightarrow>bool"

definition "A45_P1 \<equiv> [\<turnstile> \<^bold>\<diamond>CEisTerminated]" (*implicit premise*)
definition "A45_P2 \<equiv> [\<turnstile> CEisTerminated \<^bold>\<rightarrow> CEisCatastrophic]"
definition "A45_C  \<equiv> [\<turnstile> \<^bold>\<diamond>CEisCatastrophic]"

(**Notice that we have introduced in the above formalisation the @{text "\<diamond>"}
modal operator to signify that a proposition is possibly true (e.g. at a future point in time).*)
theorem A45_valid: assumes A45_P1 and A45_P2 shows "A45_C"
  using A45_C_def A45_P1_def A45_P2_def assms(1) assms(2) by blast

subsubsection\<open>No Long-term Risk Control (A46)\<close>
(**Our social systems and institutions are possibly not capable of controlling risk technologies
on long time scales and of ensuring that they are handled with proper technical care.
Notice that we can make best sense of this objection as (implicitly?) presupossing a risk of
CE-caused catastrophes.*)

consts RiskControlAbility::"w\<Rightarrow>bool"
definition "A46_P1 \<equiv> [\<turnstile> \<^bold>\<diamond>\<^bold>\<not>RiskControlAbility]"
definition "A46_P2 \<equiv> [\<turnstile> \<^bold>\<not>RiskControlAbility \<^bold>\<rightarrow> \<^bold>\<diamond>CEisCatastrophic]" (*implicit premise*)
definition "A46_C  \<equiv> [\<turnstile> \<^bold>\<diamond>CEisCatastrophic]"

(**The argument A46 needs a modal logic "K4" to succeed.
The implicit premise thus being:  @{text "Ax4: [\<turnstile> \<forall>\<phi>. \<box>\<box>\<phi> \<rightarrow> \<box>\<phi>]"}. *)
lemma assumes A46_P1 and A46_P2 shows A46_C
  nitpick oops (**counterexample found, since modal axiom 4 is needed here*)
theorem A46_valid: assumes A46_P1 and A46_P2 and Ax4 shows A46_C
  using A46_C_def A46_P1_def A46_P2_def assms(1) assms(2) assms(3) by blast

subsubsection\<open>CE Interventions are Irreversible (A47)\<close>
(**This argument consists of a simple sentence (its conclusion), which
states that CE represents an irreversible intervention, i.e., that once the first
interventions on world's climate have been set in motion, there is no way to "undo" them.
For the following arguments we work with a predicate logic (incl. quantification), and
thus introduce a type ("e") for actions (interventions).*)

typedecl e (**introduces a new type for actions*)
consts CEAction::"e\<Rightarrow>w\<Rightarrow>bool" (**notice type for (world-dependent) predicates*)
consts Irreversible::"e\<Rightarrow>w\<Rightarrow>bool"

definition "A47_C \<equiv> [\<turnstile> \<^bold>\<forall>I. CEAction(I) \<^bold>\<rightarrow> Irreversible(I)]"

subsubsection\<open>No Ability to Retain Options after Irreversible Interventions (A48)\<close>
(**Irreversible interventions (of any kind) narrow the options of future generations in an unacceptable way,
i.e., it is wrong to carry them out.*)

consts WrongAction::"e\<Rightarrow>w\<Rightarrow>bool"
definition "A48_C \<equiv> [\<turnstile> \<^bold>\<forall>I. Irreversible(I) \<^bold>\<rightarrow> WrongAction(I)]"

subsubsection\<open>Unpredictable Side-Effects are Wrong (A49)\<close>
(**As long as side-effects of CE technologies cannot be reliably predicted,
their deployment is morally wrong.*)

consts USideEffects::"e\<Rightarrow>w\<Rightarrow>bool"

definition "A49_P1 \<equiv> [\<turnstile>\<^bold>\<forall>I. CEAction(I) \<^bold>\<rightarrow> USideEffects(I)]"
definition "A49_P2 \<equiv> [\<turnstile>\<^bold>\<forall>I. USideEffects(I) \<^bold>\<rightarrow> WrongAction(I)]" (*implicit premise*)
definition "A49_C  \<equiv> [\<turnstile>\<^bold>\<forall>I. CEAction(I) \<^bold>\<rightarrow> WrongAction(I)]"

theorem A49_valid: assumes A49_P1 and A49_P2 shows A49_C (*blast verifies validity*)
  using A49_C_def A49_P1_def A49_P2_def assms(1) assms(2) by blast

subsubsection\<open>Mitigation is also Irreversible (A50)\<close>
(**Mitigation of climate change (i.e., the "preventive alternative" to CE), too, is, at least to some
extent, an irreversible intervention with unforeseen side-effects.*)

consts Mitigation::e (**constant of same type as actions/interventions*)

definition "A50_C \<equiv> [\<turnstile> Irreversible(Mitigation) \<^bold>\<and> USideEffects(Mitigation)]"

subsubsection\<open>All Interventions have Unpredictable Side-Effects (A51)\<close>
(**This defense of CE states that we do never completely foresee the consequences of our actions anyways,
and thus aims at somehow trivializing the concerns regarding unforeseen side-effects of CE.*)

definition "A51_C \<equiv> [\<turnstile> \<^bold>\<forall>I. USideEffects(I)]"

subsection\<open>Reconstructing the Argument Graph\<close>
(**Below we introduce our generalized attack/support relations between arguments.*)

abbreviation "attacks1 \<phi> \<psi>    \<equiv> (\<phi> \<and> \<psi>) \<longrightarrow> False" (**one attacker*)
abbreviation "supports1 \<phi> \<psi>   \<equiv> \<phi> \<longrightarrow> \<psi>" (**only one supporter*)
abbreviation "attacks2 \<gamma> \<phi> \<psi>  \<equiv> (\<gamma> \<and> \<phi> \<and> \<psi>) \<longrightarrow> False" (*two attackers *)
abbreviation "supports2 \<gamma> \<phi> \<psi> \<equiv> (\<gamma> \<and> \<phi>) \<longrightarrow> \<psi>" (**two supporters*)

subsubsection\<open>Does A45 support A22?\<close>
(**Implicit premise needed.*)
lemma "supports1 A45_C A22_P1" nitpick oops (**countermodel found*)
theorem assumes "[\<turnstile> \<^bold>\<diamond>CEisCatastrophic \<^bold>\<rightarrow> CEisWrong]" (**implicit*)
  shows "supports1 A45_C A22_P1" using A22_P1_def A45_C_def assms(1) by blast

subsubsection\<open>Does A46 support A22?\<close>
(**The same implicit premise as before is needed.*)
lemma "supports1 A46_C A22_P1" nitpick oops (**countermodel found*)
theorem assumes "[\<turnstile> \<^bold>\<diamond>CEisCatastrophic \<^bold>\<rightarrow> CEisWrong]" (**implicit*)
  shows "supports1 A46_C A22_P1" using A22_P1_def A46_C_def assms(1) by blast

subsubsection\<open>Do A47 and A48 (together) support A22?\<close>
(**An implicit premise is also needed.*)
lemma "supports2 A47_C A48_C A22_P1" nitpick oops (**countermodel found*)
theorem assumes "[\<turnstile>\<^bold>\<forall>I. CEAction(I) \<^bold>\<rightarrow> WrongAction(I)]\<longrightarrow>[\<turnstile> CEisWrong]" (*implicit*)
  shows "supports2 A47_C A48_C A22_P1"
  using A22_P1_def A47_C_def A48_C_def assms(1) by blast (**assms(1) implicit*)

subsubsection\<open>Does A49 support A22?\<close>
(**The same implicit premise as before is needed.*)
lemma "supports1 A49_C A22_P1" nitpick oops (**countermodel found*)
theorem assumes "[\<turnstile> \<^bold>\<forall>I. CEAction(I) \<^bold>\<rightarrow> WrongAction(I)] \<longrightarrow> [\<turnstile> CEisWrong]" (*implicit*)
  shows "supports1 A49_C A22_P1" using A22_P1_def A49_C_def assms(1) by blast

subsubsection\<open>Does A50 attack both A48 and A49?\<close>
(**We reconstruct the arguments corresponding to the \emph{attack} relations,
noting that here, too, is an additional implicit premise needed.*)

lemma "attacks1 A50_C A48_C" nitpick oops (** countermodel found*)
lemma "attacks1 A50_C A49_P2" nitpick oops (** countermodel found*)

theorem assumes "[\<turnstile> \<^bold>\<not>WrongAction(Mitigation)]" (** implicit premise*)
  shows "attacks1 A50_C A48_C"
  using A48_C_def A50_C_def assms(1) by blast

theorem assumes "[\<turnstile> \<^bold>\<not>WrongAction(Mitigation)]" (** implicit premise*)
  shows "attacks1 A50_C A49_P2"
  using A49_P2_def A50_C_def assms(1) by blast

subsubsection\<open>Does A51 attack A49?\<close>
(**The same implicit premise as before is needed.*)
lemma "attacks1 A51_C A49_P2" nitpick oops (** countermodel found*)

theorem assumes "[\<turnstile> \<^bold>\<not>WrongAction(Mitigation)]" (**implicit premise *)
  shows "attacks1 A51_C A49_P2" using A49_P2_def A51_C_def assms(1) by blast

(*<*)
end
(*>*)


(*
    File:        ZF_aux.thy
    Time-stamp:  <2016-01-06T17:35:18Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: ZF (of Isabelle2015)
*)

theory ZF_aux imports ZF Nat_ZF Arith begin

lemma function_apply_eq:
    "a = b ==> f(a) = f(b)"
by (erule subst_context)

lemma singleton_iff2:
    "{A} = {B} <-> A = B"
apply blast
done

lemma Pow_Un_0_simps:
  "Pow(A) Un {0} = Pow(A)"
  "{0} Un Pow(A) = Pow(A)"
by blast+

lemmas succ_neq_self_simps = succ_neq_self succ_neq_self[THEN not_sym]

(** disjoint **)
lemma disjointI:
    "[| !!x. [| x: X; x: Y |] ==> False |] ==> X Int Y = 0"
by blast

lemma disjointE:
    "[| A Int B = 0; x: A; x: B |] ==> R"
by blast

lemma disjoint_sym:
    "A Int B = 0 ==> B Int A = 0"
by blast

lemma disjoint_subset:
    "[| A Int B = 0; C <= A; D <= B |] ==> C Int D = 0"
by blast

lemma disjoint_UnI:
    "[| A Int C = 0; B Int C = 0 |] ==> (A Un B) Int C = 0"
by blast

lemma disjoint_Un_iff:
    "(A Un B) Int C = 0 <-> A Int C = 0 & B Int C = 0"
by blast

lemma disjoint_Un_iff2:
  "A Int (B Un C) = 0 <-> A Int B = 0 & A Int C = 0"
by blast

lemma disjoint_cons_iff:
    "cons(a, A) Int B = 0 <-> a ~: B & A Int B = 0"
by blast

lemma disjoint_cons_iff2:
    "A Int cons(b, B) = 0 <-> A Int B = 0 & b ~: A"
by blast

(** continuous **)
lemma domain_continuous:
    "domain(Union(X)) = (UN x: X. domain(x))"
by blast

lemma continuous_simps_1:
  "{f(x). x: {g(y). y: X}} = {f(g(y)). y: X}"
  "Union(X) * A = (UN x: X. x * A)"
by blast+

lemmas continuous_simps = domain_continuous
                          continuous_simps_1

(** Nat **)
lemma mem_nat_in_nat:
    "[| a: b; b: nat |] ==> a: nat"
apply (rule lt_nat_in_nat)
apply (erule ltI)
apply (erule nat_into_Ord)
apply assumption
done

lemma lt_Un_eq_lemma:
    "A < B ==> A Un B = B"
apply (frule leI [THEN le_imp_subset])
apply blast
done

lemma le_Un_eq_lemma:
    "A le B ==> A Un B = B"
apply (frule le_imp_subset)
apply blast
done

lemma nat_succ_Un:
  "[| A: nat; B: nat |] ==> succ(A) Un succ(B) = succ(A Un B)"
apply (erule nat_into_Ord [THEN Ord_linear_lt])
apply (erule nat_into_Ord)
prefer 2
apply hypsubst
apply blast
apply (rule lt_Un_eq_lemma [THEN ssubst], assumption)
apply (drule succ_leI)
apply (drule lt_Un_eq_lemma, assumption)
apply (rule trans[OF Un_commute lt_Un_eq_lemma, THEN ssubst], assumption)
apply (drule succ_leI)
apply (drule trans[OF Un_commute lt_Un_eq_lemma], assumption)
done

lemma nat_UnI:
    "[| A: nat; B: nat |] ==> A Un B: nat"
apply (rule_tac i="A" and j="B" in Ord_linear_lt)
apply (erule nat_into_Ord)
apply (erule nat_into_Ord)
apply (drule_tac [3] lt_Un_eq_lemma)
apply (drule lt_Un_eq_lemma)
apply (simp_all add: Un_commute)
done

lemma gt_not_eq:
    "[| p < n; n:nat|]==> n~=p"
by blast

lemma lt_asym_if:
    "p < n ==> if (n < p, a, b) = b"
by (blast elim: lt_asym intro: if_not_P)

lemma le_asym_if:
    "p le n ==> if (n < p, a, b) = b"
apply (simp only: le_iff)
apply (blast elim: lt_asym intro: if_not_P)
done

lemma lt_irrefl_if:
    "if (n < n, a, b) = b"
by (blast intro: if_not_P)

(** Arith **)
lemma succ_pred:
    "[|j:nat; i:nat|]==> i < j --> succ(j #- 1) = j"
apply (erule nat_induct)
apply blast
apply simp
done

lemma lt_pred:
  "[|succ(x)<n; n:nat; x:nat|]==> x < n#-1 "
apply (rule succ_leE)
apply (frule nat_into_Ord [THEN le_refl, THEN lt_trans], assumption)
apply (simp add: succ_pred)
done

lemma gt_pred:
    "[|n < succ(x); p<n; p:nat; n:nat; x:nat|]==> n#-1 < x "
apply (rule succ_leE)
apply (simp add: succ_pred)
done

lemma lt_imp_le_pred:
    "[| i < j; j: nat |] ==> i le j #- 1"
apply (erule natE)
apply simp_all
done

lemma diff_eq_0D:
    "[| m #- n = 0; m: nat; n: nat |] ==> m le n"
apply (erule rev_mp)
apply (rule_tac x="m" in bspec)
prefer 2
apply assumption
apply (erule_tac n="n" in nat_induct)
apply (rule_tac [2] ballI)
apply (rename_tac [2] v)
apply (erule_tac [2] n="v" in natE)
apply simp_all
done

lemma Un_diff [rule_format]:
  assumes prem: "m: nat"
  shows "ALL n:nat. ALL l:nat. (m Un n) #- l = (m #- l) Un (n #- l)"
apply (rule prem [THEN nat_induct])
apply simp
apply (intro ballI)
apply (erule_tac n="n" in natE)
apply (erule_tac [2] n="l" in natE)
apply (simp_all add: nat_succ_Un)
done

lemma Un_least_ltE:
    "[| i Un j < k; Ord(i); Ord(j);
       [| i < k; j < k |] ==> R |] ==> R"
apply (frule_tac i1="i" and j1="j" in Un_least_lt_iff [THEN iffD1])
apply assumption+
apply blast
done

lemma diff_le_mono1:
  assumes major: "i le j"
      and prem1: "i: nat"
      and prem2: "j: nat"
      and prem3: "k: nat"
  shows "i #- k le j #- k"
apply (rule major [THEN rev_mp])
apply (rule prem2 [THEN [2] bspec])
apply (rule prem3 [THEN [2] bspec])
apply (rule prem1 [THEN nat_induct])
apply simp
apply (intro ballI impI)
apply (rename_tac u v)
apply (erule_tac n="u" in natE)
apply (erule_tac [2] n="v" in natE)
apply simp_all
done

lemma diff_ltD:
  assumes major: "i #- j < k"
      and prem1: "i: nat"
      and prem2: "j: nat"
  shows "k: nat ==> i < j #+ k"
apply (rule major [THEN rev_mp])
apply (rule prem1 [THEN [2] bspec])
apply (rule prem2 [THEN nat_induct])
apply simp
apply (intro ballI impI)
apply (rename_tac v)
apply (erule_tac n="v" in natE)
apply simp_all
done

lemma diff_leI:
  assumes major: "i le j #+ k"
      and prem1: "i: nat"
      and prem2: "j: nat"
    shows "k: nat  ==> i #- j le k"
apply (rule major [THEN rev_mp])
apply (rule prem1 [THEN [2] bspec])
apply (rule prem2 [THEN nat_induct])
apply simp
apply (intro ballI impI)
apply (rename_tac v)
apply (erule_tac n="v" in natE)
apply simp_all
done

lemma diff_le_iff:
    "[| i: nat; j: nat; k: nat |] ==> i #- j le k <-> i le j #+ k"
apply (rule iffI)
apply (rule_tac [2] diff_leI)
apply (drule diff_ltD)
apply simp_all
done

lemma lt_diffI:
  assumes major: "i #+ j < k"
      and prem1: "i: nat"
      and prem2: "j: nat"
      and prem3: "k: nat"
    shows "j < k #- i"
apply (insert prem2)
apply (rule major [THEN rev_mp])
apply (rule prem1 [THEN [2] bspec])
apply (rule prem3 [THEN nat_induct])
apply simp
apply (intro ballI impI)
apply (rename_tac v)
apply (erule_tac n="v" in natE)
apply simp_all
done

lemma lt_diffD:
  assumes major: "j < k #- i"
      and prem1: "i: nat"
      and prem2: "j: nat"
      and prem3: "k: nat"
    shows "i #+ j < k"
apply (insert prem2)
apply (rule major [THEN rev_mp])
apply (rule prem1 [THEN [2] bspec])
apply (rule prem3 [THEN nat_induct])
apply simp
apply (intro ballI impI)
apply (rename_tac v)
apply (erule_tac n="v" in natE)
apply simp_all
done

lemma lt_diff_iff:
    "[| i: nat; j: nat; k: nat |] ==> j < k #- i <-> i #+ j < k"
apply (rule iffI)
apply (erule_tac [2] lt_diffI)
apply (erule lt_diffD)
apply assumption+
done

lemma diff_diff_eq_diff_add:
  assumes prem1: "i: nat"
      and prem2: "j: nat"
      and prem3: "k: nat"
    shows "i #- j #- k = i #- (k #+ j)"
apply (rule prem1 [THEN [2] bspec])
apply (rule prem3 [THEN [2] bspec])
apply (rule prem2 [THEN nat_induct])
apply simp
apply (intro ballI)
apply (rename_tac u v)
apply (erule_tac n="v" in natE)
apply simp_all
done

(** Quantifiers Bounded by Natural Number **)
lemmas nat_ltI = nat_into_Ord [THEN [2] ltI]

lemma ball_mem_nat_in_nat:
    "n: nat ==> (ALL x:n. x:nat) <-> True"
apply (blast intro: mem_nat_in_nat)
done

lemma nat_succ_mono:
    "[| n:m; m: nat |] ==> succ(n): succ(m)"
apply (rule ltD)
apply (simp add: nat_ltI)
done

lemma nat_ball_succ:
    "n: nat ==> (ALL x:succ(n). P(x)) <-> P(0) & (ALL x:n. P(succ(x)))"
apply safe
apply (erule bspec)
apply (rule ltD)
apply simp
apply (drule nat_ltI, assumption)
apply (erule bspec)
apply (rule ltD)
apply simp
apply (erule natE)
apply simp+
apply (frule_tac mem_nat_in_nat, assumption)
apply (erule_tac n="x" in natE)
apply simp
apply (rename_tac v)
apply (drule_tac x="v" in bspec)
apply simp_all
apply (rule ltD)
apply (drule_tac i="succ(v)" in ltI)
apply (erule nat_into_Ord)
apply (simp add: succ_lt_iff)
done

lemma nat_bex_succ:
  "n: nat ==> (EX x:succ(n). P(x)) <-> P(0) | (EX x:n. P(succ(x)))"
apply safe
apply simp_all
apply (erule natE)
apply simp
apply (drule_tac x="x" in bspec)
apply simp
apply simp
apply (frule mem_nat_in_nat, assumption)
apply (erule_tac n="x" in natE)
apply simp
apply (rename_tac v)
apply (drule_tac x="v" in bspec)
apply simp
apply (rule ltD)
apply (drule_tac i="succ(v)" in ltI)
apply (erule nat_into_Ord)
apply (simp add: succ_lt_iff)
apply simp
apply (erule natE)
apply simp
apply hypsubst
apply (rule disjI2)
apply (rule bexI, assumption)
apply (rule ltD)
apply (erule nat_0_le)
apply (case_tac "n = succ(x)")
apply simp
apply (rule disjI2)
apply (rule bexI, assumption)
apply (frule_tac i="n" and j="succ(x)" in nat_into_Ord [THEN Ord_linear])
apply (rule nat_into_Ord)
apply (frule mem_nat_in_nat, assumption)
apply (erule nat_succI)
apply simp
apply (blast elim: mem_irrefl mem_asym)
done

lemma nat_ball_cong:
  assumes prem1: "A = A'"
      and prem2: "!!x. x < A' ==> P(x) <-> P'(x)"
      and prem3: "!!x. [| x: A'; A'~: nat |] ==> P(x) <-> P'(x)"
    shows "Ball(A, P) <-> Ball(A', P')"
apply (rule prem1 [THEN ball_cong])
apply (case_tac "A' : nat")
apply (rule prem2)
apply (erule ltI)
apply (erule nat_into_Ord)
apply (erule prem3)
apply assumption
done

lemma nat_bex_cong:
  assumes prem1: "A = A'"
      and prem2: "!!x. x < A' ==> P(x) <-> P'(x)"
      and prem3: "!!x. [| x: A'; A'~: nat |] ==> P(x) <-> P'(x)"
    shows "Bex(A, P) <-> Bex(A', P')"
apply (rule prem1 [THEN bex_cong])
apply (case_tac "A' : nat")
apply (rule prem2)
apply (erule ltI)
apply (erule nat_into_Ord)
apply (erule prem3)
apply assumption
done

lemmas nat_bquant_congs = nat_ball_cong nat_bex_cong

lemma nat_bquant_succ1_1:
  "(ALL x:succ(i).P(x)) <-> P(i) & (ALL x:i. P(x))"
by simp

lemma nat_bquant_succ1_2:
  "(EX  x:succ(i).P(x)) <-> P(i) | (EX x:i. P(x))"
by simp

lemmas nat_bquant_succ1 = nat_bquant_succ1_1 nat_bquant_succ1_2

lemmas nat_bquant_succ2 = nat_ball_succ nat_bex_succ

(*
declare nat_bquant_succ1 [simp del]
declare nat_bquant_succ2 [simp]
*)

lemma complete_induct0:
  "[| i : nat; !! i. [| i : nat; (ALL j: i. P(j)) |] ==> P(i) |] ==> P(i)"
apply (erule complete_induct)
apply simp
done

end