section\<open>Proof Systems\<close>
subsection\<open>Sequent Calculus\<close>

theory SC
imports Formulas "HOL-Library.Multiset"
begin

abbreviation msins ("_, _" [56,56] 56) where "x,M == add_mset x M"

text\<open>We do not formalize the concept of sequents, only that of sequent calculus derivations.\<close>
inductive SCp :: "'a formula multiset \<Rightarrow> 'a formula multiset \<Rightarrow> bool" ("(_ \<Rightarrow>/ _)" [53] 53) where
BotL: "\<bottom> \<in># \<Gamma> \<Longrightarrow> \<Gamma>\<Rightarrow>\<Delta>" |
Ax: "Atom k \<in># \<Gamma> \<Longrightarrow> Atom k \<in># \<Delta> \<Longrightarrow> \<Gamma>\<Rightarrow>\<Delta>" |
NotL: "\<Gamma> \<Rightarrow> F,\<Delta> \<Longrightarrow> Not F, \<Gamma> \<Rightarrow> \<Delta>" |
NotR: "F,\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> Not F, \<Delta>" |
AndL: "F,G,\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> And F G, \<Gamma> \<Rightarrow> \<Delta>" |
AndR: "\<lbrakk> \<Gamma> \<Rightarrow> F,\<Delta>; \<Gamma> \<Rightarrow> G,\<Delta> \<rbrakk> \<Longrightarrow> \<Gamma> \<Rightarrow> And F G, \<Delta>" |
OrL: "\<lbrakk> F,\<Gamma> \<Rightarrow> \<Delta>; G,\<Gamma> \<Rightarrow> \<Delta> \<rbrakk> \<Longrightarrow> Or F G, \<Gamma> \<Rightarrow> \<Delta>" |
OrR: "\<Gamma> \<Rightarrow> F,G,\<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> Or F G, \<Delta>" |
ImpL: "\<lbrakk> \<Gamma> \<Rightarrow> F,\<Delta>; G,\<Gamma> \<Rightarrow> \<Delta> \<rbrakk> \<Longrightarrow> Imp F G, \<Gamma> \<Rightarrow> \<Delta>" |
ImpR: "F,\<Gamma> \<Rightarrow> G,\<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> Imp F G, \<Delta>"

text\<open>Many of the proofs here are inspired Troelstra and Schwichtenberg~\<^cite>\<open>"troelstra2000basic"\<close>.\<close>

lemma
  shows BotL_canonical[intro!]: "\<bottom>,\<Gamma>\<Rightarrow>\<Delta>"
    and Ax_canonical[intro!]: "Atom k,\<Gamma> \<Rightarrow> Atom k,\<Delta>"
  by (meson SCp.intros union_single_eq_member)+

lemma lem1: "x \<noteq> y \<Longrightarrow> x, M = y,N \<longleftrightarrow> x \<in># N \<and> M = y,(N - {#x#})"
  by (metis (no_types, lifting) add_eq_conv_ex add_mset_remove_trivial add_mset_remove_trivial_eq)

text\<open>This is here to deal with a technical problem: the way the simplifier uses @{thm add_mset_commute} is really suboptimal for the unification of SC rules.\<close>

lemma sc_insertion_ordering[simp]:
  "NO_MATCH (I\<^bold>\<rightarrow>J) H \<Longrightarrow> H,F\<^bold>\<rightarrow>G,S = F\<^bold>\<rightarrow>G,H,S"
  "NO_MATCH (I\<^bold>\<rightarrow>J) H \<Longrightarrow> NO_MATCH (I\<^bold>\<or>J) H \<Longrightarrow> H,F\<^bold>\<or>G,S = F\<^bold>\<or>G,H,S"
  "NO_MATCH (I\<^bold>\<rightarrow>J) H \<Longrightarrow> NO_MATCH (I\<^bold>\<or>J) H \<Longrightarrow> NO_MATCH (I\<^bold>\<and>J) H \<Longrightarrow> H,F\<^bold>\<and>G,S = F\<^bold>\<and>G,H,S"
  "NO_MATCH (I\<^bold>\<rightarrow>J) H \<Longrightarrow> NO_MATCH (I\<^bold>\<or>J) H \<Longrightarrow> NO_MATCH (I\<^bold>\<and>J) H \<Longrightarrow> NO_MATCH (\<^bold>\<not>J) H \<Longrightarrow> H,\<^bold>\<not>G,S = \<^bold>\<not>G,H,S"
  "NO_MATCH (I\<^bold>\<rightarrow>J) H \<Longrightarrow> NO_MATCH (I\<^bold>\<or>J) H \<Longrightarrow> NO_MATCH (I\<^bold>\<and>J) H \<Longrightarrow> NO_MATCH (\<^bold>\<not>J) H \<Longrightarrow> NO_MATCH (\<bottom>) H \<Longrightarrow> H,\<bottom>,S = \<bottom>,H,S"
  "NO_MATCH (I\<^bold>\<rightarrow>J) H \<Longrightarrow> NO_MATCH (I\<^bold>\<or>J) H \<Longrightarrow> NO_MATCH (I\<^bold>\<and>J) H \<Longrightarrow> NO_MATCH (\<^bold>\<not>J) H \<Longrightarrow> NO_MATCH (\<bottom>) H \<Longrightarrow> NO_MATCH (Atom k) H \<Longrightarrow> H,Atom l,S = Atom l,H,S"
  (* I have decided that \<bottom> and atoms should be pulled outwards with the lowest priorities. this may not always be smart. *)
  by simp_all

lemma shows
     inR1: "\<Gamma> \<Rightarrow> G, H, \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> H, G, \<Delta>"
 and inL1: "G, H, \<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> H, G, \<Gamma> \<Rightarrow> \<Delta>"
 and inR2: "\<Gamma> \<Rightarrow> F, G, H, \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> G, H, F, \<Delta>"
 and inL2: "F, G, H, \<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> G, H, F, \<Gamma> \<Rightarrow> \<Delta>" by(simp_all add: add_mset_commute)
lemmas SCp_swap_applies[elim!,intro] = inL1 inL2 inR1 inR2

lemma NotL_inv: "Not F, \<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> F,\<Delta>"
proof(induction "Not F, \<Gamma>" \<Delta> arbitrary: \<Gamma> rule: SCp.induct)
  case (NotL \<Gamma>' G \<Delta>) thus ?case by(cases "Not F = Not G") (auto intro!: SCp.intros(3-) dest!: multi_member_split simp: lem1 lem2)
qed (auto intro!: SCp.intros(3-) dest!: multi_member_split simp: SCp.intros lem1 lem2)

lemma AndL_inv: "And F G, \<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> F,G,\<Gamma> \<Rightarrow> \<Delta>"
proof(induction "And F G, \<Gamma>" \<Delta> arbitrary: \<Gamma> rule: SCp.induct)
  case (AndL F' G' \<Gamma>' \<Delta>) thus ?case
    by(cases "And F G = And F' G'";
       auto intro!: SCp.intros(3-) dest!: multi_member_split simp: lem1 lem2;
       metis add_mset_commute)
qed (auto intro!: SCp.intros(3-) dest!: multi_member_split simp: SCp.intros lem1 lem2 inL2)

lemma OrL_inv:
  assumes "Or F G, \<Gamma> \<Rightarrow> \<Delta>"
  shows "F,\<Gamma> \<Rightarrow> \<Delta> \<and> G,\<Gamma> \<Rightarrow> \<Delta>"
proof(insert assms, induction "Or F G, \<Gamma>" \<Delta> arbitrary: \<Gamma> rule: SCp.induct)
  case (OrL F' \<Gamma>' \<Delta> G') thus ?case
    by(cases "Or F G = Or F' G'";
       auto intro!: SCp.intros(3-) dest!: multi_member_split simp: lem1 lem2;
       blast)
qed (fastforce intro!: SCp.intros(3-) dest!: multi_member_split simp: SCp.intros lem1 lem2)+

lemma ImpL_inv:
  assumes "Imp F G, \<Gamma> \<Rightarrow> \<Delta>"
  shows "\<Gamma> \<Rightarrow> F,\<Delta> \<and> G,\<Gamma> \<Rightarrow> \<Delta>"
proof(insert assms, induction "Imp F G, \<Gamma>" \<Delta> arbitrary: \<Gamma> rule: SCp.induct)
  case (ImpL \<Gamma>' F' \<Delta> G') thus ?case
    by(cases "Or F G = Or F' G'"; (* oops, I didn't pay attention and used the wrong constructor\<dots> doesn't matter! *)
       auto intro!: SCp.intros(3-) dest!: multi_member_split simp: lem1 lem2;
       blast)
qed (fastforce intro!: SCp.intros(3-) dest!: multi_member_split simp: SCp.intros lem1 lem2)+

lemma ImpR_inv:
  assumes "\<Gamma> \<Rightarrow> Imp F G,\<Delta>"
  shows "F,\<Gamma> \<Rightarrow> G,\<Delta>"
proof(insert assms, induction \<Gamma> "Imp F G, \<Delta>" arbitrary: \<Delta> rule: SCp.induct)
  case (ImpR  F' \<Gamma> G' \<Delta>') thus ?case
    by(cases "Or F G = Or F' G'";
       auto intro!: SCp.intros(3-) dest!: multi_member_split simp: lem1 lem2;
       blast)
qed (fastforce intro!: SCp.intros(3-) dest!: multi_member_split simp: SCp.intros lem1 lem2)+

lemma AndR_inv:
shows "\<Gamma> \<Rightarrow> And F G, \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> F, \<Delta> \<and> \<Gamma> \<Rightarrow> G, \<Delta>"
proof(induction \<Gamma> "And F G, \<Delta>" arbitrary: \<Delta> rule: SCp.induct)
  case (AndR  \<Gamma> F' \<Delta>' G') thus ?case
    by(cases "Or F G = Or F' G'";
       auto intro!: SCp.intros(3-) dest!: multi_member_split simp: lem1 lem2;
       blast)
qed (fastforce intro!: SCp.intros(3-) dest!: multi_member_split simp: SCp.intros lem1 lem2)+

lemma OrR_inv: "\<Gamma> \<Rightarrow> Or F G, \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> F,G,\<Delta>"
proof(induction \<Gamma> "Or F G, \<Delta>" arbitrary: \<Delta> rule: SCp.induct)
  case (OrR  \<Gamma> F' G' \<Delta>') thus ?case
    by(cases "Or F G = Or F' G'";
       auto intro!: SCp.intros(3-) dest!: multi_member_split simp: lem1 lem2;
       metis add_mset_commute)
qed (fastforce intro!: SCp.intros(3-) dest!: multi_member_split simp: SCp.intros lem1 lem2)+

lemma NotR_inv: "\<Gamma> \<Rightarrow> Not F, \<Delta> \<Longrightarrow> F,\<Gamma> \<Rightarrow> \<Delta>"
proof(induction \<Gamma> "Not F, \<Delta>" arbitrary: \<Delta> rule: SCp.induct)
  case (NotR  G \<Gamma> \<Delta>') thus ?case
    by(cases "Not F = Not G";
       auto intro!: SCp.intros(3-) dest!: multi_member_split simp: lem1 lem2;
       metis add_mset_commute)
qed (fastforce intro!: SCp.intros(3-) dest!: multi_member_split simp: SCp.intros lem1 lem2)+

lemma weakenL: "\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> F,\<Gamma> \<Rightarrow> \<Delta>"
  by(induction rule: SCp.induct)
    (auto intro!: SCp.intros(3-) intro: SCp.intros(1,2))

lemma weakenR: "\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> F,\<Delta> "
  by(induction rule: SCp.induct)
    (auto intro!: SCp.intros(3-) intro: SCp.intros(1,2))

lemma weakenL_set: "\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> F + \<Gamma> \<Rightarrow> \<Delta>"
  by(induction F; simp add: weakenL)
lemma weakenR_set: "\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> F + \<Delta>"
  by(induction F; simp add: weakenR)

lemma extended_Ax: "\<Gamma> \<inter># \<Delta> \<noteq> {#} \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>"
proof -
  assume "\<Gamma> \<inter># \<Delta> \<noteq> {#}"
  then obtain W where "W \<in># \<Gamma>" "W \<in># \<Delta>" by force
  then show ?thesis proof(induction W arbitrary: \<Gamma> \<Delta>)
    case (Not W)
    from Not.prems obtain \<Gamma>' \<Delta>' where [simp]: "\<Gamma> = Not W,\<Gamma>'" "\<Delta> = Not W,\<Delta>'" by (metis insert_DiffM)
    have "W \<in># W,\<Gamma>'" "W \<in># W,\<Delta>'" by simp_all
    from Not.IH[OF this] obtain n where "W, \<Gamma>' \<Rightarrow> W, \<Delta>'" by presburger
    hence "Not W, \<Gamma>' \<Rightarrow> Not W, \<Delta>'" using SCp.intros(3,4) add_mset_commute by metis
    thus "\<Gamma> \<Rightarrow> \<Delta>" by auto
  next
    case (And G H)
    from And.prems obtain \<Gamma>' \<Delta>' where [simp]: "\<Gamma> = And G H,\<Gamma>'" "\<Delta> = And G H,\<Delta>'" by (metis insert_DiffM)
    have "G \<in># G, H, \<Gamma>'" "G \<in># G, \<Delta>'" by simp_all
    with And.IH(1) have IH1: "G, H, \<Gamma>' \<Rightarrow> G, \<Delta>'" .
    have "H \<in># G, H, \<Gamma>'" "H \<in># H, \<Delta>'" by simp_all
    with And.IH(2) have IH2: "G, H, \<Gamma>' \<Rightarrow> H, \<Delta>'" .
    from IH1 IH2 have "G, H, \<Gamma>' \<Rightarrow> G, \<Delta>'" "G, H, \<Gamma>' \<Rightarrow> H, \<Delta>'" by fast+
    thus "\<Gamma> \<Rightarrow> \<Delta>" using SCp.intros(5,6) by fastforce
  next
    case (Or G H)
    case (Imp G H)
    text\<open>analogously\<close> (*<*)
  next
    case (Or G H)
    from Or.prems obtain \<Gamma>' \<Delta>' where [simp]: "\<Gamma> = Or G H,\<Gamma>'" "\<Delta> = Or G H,\<Delta>'" by (metis insert_DiffM)
    with Or.IH show ?case using SCp.intros(7,8)[where 'a='a] by fastforce
  next
    case (Imp G H)
    from Imp.prems obtain \<Gamma>' \<Delta>' where [simp]: "\<Gamma> = Imp G H,\<Gamma>'" "\<Delta> = Imp G H,\<Delta>'" by (metis insert_DiffM)
    from Imp.IH have "G, \<Gamma>' \<Rightarrow> G, H, \<Delta>'" "H, G, \<Gamma>' \<Rightarrow> H, \<Delta>'" by simp_all
    thus ?case by(auto intro!: SCp.intros(3-))
  (*>*)
  qed (auto intro: SCp.intros)
qed

lemma Bot_delR: "\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>-{#\<bottom>#}"
proof(induction rule: SCp.induct)
  case BotL
  thus ?case by (simp add: SCp.BotL)
next
  case Ax
  thus ?case
    by (metis SCp.Ax diff_union_swap formula.distinct(1) insert_DiffM union_single_eq_member)
next
  case NotL
  thus ?case
    by (metis SCp.NotL diff_single_trivial diff_union_swap2)
next
  case NotR
  thus ?case by(simp add: SCp.NotR)
next
  case AndL
  thus ?case by (simp add: SCp.AndL)
next
  case AndR
  thus ?case
    by (metis SCp.AndR diff_single_trivial diff_union_swap diff_union_swap2 formula.distinct(13))
next
  case OrL
  thus ?case by(simp add: SCp.OrL)
next
  case OrR
  thus ?case
    by (metis SCp.OrR diff_single_trivial diff_union_swap2 formula.distinct(15) insert_iff set_mset_add_mset_insert)
next
  case ImpL
  thus ?case by (metis SCp.ImpL diff_single_trivial diff_union_swap2)
next
  case ImpR
  thus ?case
    by (metis SCp.ImpR diff_single_trivial diff_union_swap diff_union_swap2 formula.distinct(17))
qed
corollary Bot_delR_simp: "\<Gamma> \<Rightarrow> \<bottom>,\<Delta> = \<Gamma> \<Rightarrow> \<Delta>"
  using Bot_delR weakenR by fastforce

end


(*  Title:       Conflict analysis/List Interleaving Operator
    Author:      Peter Lammich <peter.lammich@uni-muenster.de>
    Maintainer:  Peter Lammich <peter.lammich@uni-muenster.de>
*)
section "List Interleaving Operator"
theory Interleave
imports Main "HOL-Library.Permutation" Misc
begin
text_raw \<open>\label{thy:Interleave}\<close>

text \<open>
  This theory defines an operator to return the set of all possible interleavings of two lists.
\<close>

(*
  Is \<Otimes>-operator needed ?
    Should we better do a reformulation of \<otimes> on sets of lists, to get an associative, commutative operator with identity (ACI ?) ?
*)

subsection "Definitions"

subsubsection "Prepend and concatenate lifted to sets"

definition list_set_cons :: "'a \<Rightarrow> 'a list set \<Rightarrow> 'a list set" (infixr "\<cdot>" 65)
  where [simp]: "a\<cdot>S = (#) a ` S"

definition list_set_append :: "'a list \<Rightarrow> 'a list set \<Rightarrow> 'a list set" (infixr "\<odot>" 65)
  where [simp]: "a\<odot>S = (@) a ` S"

subsubsection "The interleaving operator"

function
  interleave :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list set" (infixr "\<otimes>" 64)
where
  "[]\<otimes>b = {b}"
  | "a\<otimes>[] = {a}"
  | "a#l \<otimes> b#r = ((a\<cdot>(l \<otimes> b#r)) \<union> (b\<cdot>(a#l \<otimes> r)))"
by pat_completeness auto
termination by lexicographic_order

subsection "Properties"

subsubsection "Lifted prepend and concatenate operators"
lemma cons_set_cons_eq: "a#l \<in> b\<cdot>S = (a=b & l\<in>S)"
  by auto
lemma append_set_append_eq: "\<lbrakk>length a = length b\<rbrakk> \<Longrightarrow> a@l \<in> b\<odot>S = (a=b & l\<in>S)"
  by auto

lemma list_set_cons_cases[cases set]: "\<lbrakk>w\<in>a\<cdot>S; !!w'. \<lbrakk> w=a#w'; w'\<in>S \<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by auto
lemma list_set_append_cases[cases set]: "\<lbrakk>w\<in>a\<odot>S; !!w'. \<lbrakk> w=a@w'; w'\<in>S \<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by auto

subsubsection "Standard simplification-, introduction-, elimination-, and induction rules"
lemma interleave_cons1: "l \<in> a\<otimes>b \<Longrightarrow> x#l \<in> x#a \<otimes> b"
  apply(case_tac b)
  apply(auto)
done

lemma interleave_cons2: "l \<in> a\<otimes>b \<Longrightarrow> x#l \<in> a \<otimes> x#b"
  apply(case_tac a)
  apply(auto)
done

lemmas interleave_cons = interleave_cons1 interleave_cons2

lemma interleave_empty[simp]: "[]\<in>a\<otimes>b = (a=[] & b=[])"
  apply(case_tac a)
  apply(case_tac b)
  apply(simp)
  apply(simp)
  apply(case_tac b)
  apply(auto)
done

(* TODO: Is this wise as default simp ?*)
lemma interleave_length[rule_format, simp]: "ALL x : a\<otimes>b . length x = length a + length b"
  apply(induct rule: interleave.induct)
  apply(auto)
done

lemma interleave_same[simp]: "y\<in>l\<otimes>y = (l=[])"
  apply (rule iffI)
  apply (subgoal_tac "length y = length l + length y")
  apply (simp del: interleave_length)
  apply (erule interleave_length)
  apply simp
done

lemma interleave_comm[simp]: "a\<otimes>b = b\<otimes>a" (is "?P f a b")
  apply(induct rule: interleave.induct)
  apply(auto)
done

lemma interleave_cont_conc[rule_format, simp]: "ALL b . a@b \<in> a\<otimes>b"
  apply(induct_tac a)
  apply(auto simp add: interleave_cons)
done

lemma interleave_cont_rev_conc[simp]: "b@a \<in> a\<otimes>b"
  apply (subgoal_tac "b@a \<in> b\<otimes>a")
  apply(simp)
  apply(simp only: interleave_cont_conc)
done

lemma interleave_not_empty: "a\<otimes>b ~= {}"
  apply(induct rule: interleave.induct)
  apply(auto)
done

lemma cons_interleave_split: "\<lbrakk>a#l \<in> l1\<otimes>l2\<rbrakk> \<Longrightarrow> (EX lh . l1=a#lh & l \<in> lh\<otimes>l2 | l2=a#lh & l \<in> l1\<otimes>lh )"
  apply(case_tac l1)
  apply(auto)
  apply(case_tac l2)
  apply(auto)
done

lemma cons_interleave_cases[cases set, case_names left right]: "\<lbrakk>a#l \<in> l1\<otimes>l2; !!lh . \<lbrakk>l1=a#lh; l \<in> lh\<otimes>l2\<rbrakk> \<Longrightarrow> P; !!lh. \<lbrakk>l2=a#lh; l \<in> l1\<otimes>lh\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (blast dest: cons_interleave_split)

lemma interleave_cases[cases set, case_names empty left right]: "\<lbrakk>l\<in>l1\<otimes>l2; \<lbrakk> l=[]; l1=[]; l2=[] \<rbrakk> \<Longrightarrow> P; !!a l' l1'. \<lbrakk>l=a#l'; l1=a#l1'; l'\<in>l1'\<otimes>l2\<rbrakk> \<Longrightarrow> P; !!a l' l2'. \<lbrakk>l=a#l'; l2=a#l2'; l'\<in>l1\<otimes>l2'\<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  apply (cases l)
  apply (simp)
  apply simp
  apply (erule cons_interleave_cases)
  apply simp_all
  done

lemma interleave_elem_induct[induct set, case_names empty left right]:
  "!!w1 w2. \<lbrakk> w\<in>w1\<otimes>w2; P [] [] []; !!e w w1 w2. \<lbrakk> P w w1 w2; w\<in>w1\<otimes>w2 \<rbrakk> \<Longrightarrow> P (e#w) (e#w1) w2; !!e w w1 w2. \<lbrakk> P w w1 w2; w\<in>w1\<otimes>w2 \<rbrakk> \<Longrightarrow> P (e#w) w1 (e#w2) \<rbrakk> \<Longrightarrow> P w w1 w2"
  by (induct w) (auto elim!: cons_interleave_cases intro!: interleave_cons)

lemma interleave_rev_cons1[rule_format]: "ALL a b . l \<in> a\<otimes>b \<longrightarrow> l@[x] \<in> a@[x] \<otimes> b" (is "?P l")
proof (induct l)
  case Nil show ?case by (simp)
  case (Cons e l)
    assume IH[rule_format]: "?P l"
    show "?P (e#l)" proof (intro allI impI)
      fix a b
      assume "e#l \<in> a\<otimes>b"
      then obtain c where SPLIT: "a=e#c & l\<in>c\<otimes>b | b=e#c & l\<in>a\<otimes>c" by (blast dest: cons_interleave_split)
      with IH have "a=e#c & l@[x]\<in>c@[x]\<otimes>b | b=e#c & l@[x]\<in>a@[x]\<otimes>c" by auto
      hence "a=e#c & e#l@[x]\<in>e#c@[x]\<otimes>b | b=e#c & e#l@[x]\<in>a@[x]\<otimes>e#c" by (auto simp add: interleave_cons)
      thus "(e#l)@[x]\<in>a@[x]\<otimes>b" by auto
    qed
qed

corollary interleave_rev_cons2: "l \<in> a\<otimes>b \<Longrightarrow> l@[x] \<in> a \<otimes> b@[x]"
proof -
  assume "l \<in> a\<otimes>b"
  hence "l\<in>b\<otimes>a" by auto
  hence "l@[x] \<in> b@[x] \<otimes> a" by (blast dest: interleave_rev_cons1)
  thus ?thesis by auto
qed

lemmas interleave_rev_cons = interleave_rev_cons1 interleave_rev_cons2

subsubsection "Interleaving and list concatenation"

lemma interleave_append1: "\<lbrakk>l \<in> a\<otimes>b\<rbrakk> \<Longrightarrow> x@l \<in> x@a \<otimes> b" proof -
  have "ALL l a b . l \<in> a\<otimes>b \<longrightarrow> x@l \<in> x@a \<otimes> b" (is "?P x") proof (induct x)
    show "?P []" by simp
  next
    fix e
    fix x::"'a list"
    assume IH: "?P x"
    show "?P (e#x)" proof (intro impI allI)
      fix l::"'a list"
      fix a b
      assume "l \<in> a \<otimes> b"
      with IH have "x@l \<in> x@a \<otimes> b" by auto
      with interleave_cons1 show "(e # x) @ l \<in> (e # x) @ a \<otimes> b" by force
    qed
  qed
  moreover assume "l \<in> a \<otimes> b"
  ultimately show ?thesis by blast
qed

lemma interleave_append2: "\<lbrakk>l \<in> a\<otimes>b\<rbrakk> \<Longrightarrow> x@l \<in> a \<otimes> x@b" proof -
  have "ALL l a b . l \<in> a\<otimes>b \<longrightarrow> x@l \<in> a \<otimes> x@b" (is "?P x") proof (induct x)
    show "?P []" by simp
  next
    fix a
    fix x::"'a list"
    assume IH: "\<forall>l a b. l \<in> a \<otimes> b \<longrightarrow> x @ l \<in> a \<otimes> x @ b"
    show "\<forall>l aa b. l \<in> aa \<otimes> b \<longrightarrow> (a # x) @ l \<in> aa \<otimes> (a # x) @ b" proof (intro impI allI)
      fix l::"'a list"
      fix aa b
      assume "l \<in> aa \<otimes> b"

      with IH have "x@l \<in> aa \<otimes> x@b" by auto
      with interleave_cons2 show "(a # x) @ l \<in> aa \<otimes> (a # x) @ b" by force
    qed
  qed
  moreover assume "l \<in> a \<otimes> b"
  ultimately show ?thesis by blast
qed

lemmas interleave_append = interleave_append1 interleave_append2

lemma interleave_rev_append1: "!!a b w. w\<in>a\<otimes>b \<Longrightarrow> w@w' \<in> a@w' \<otimes> b"
proof (induct w' rule: rev_induct)
  case Nil thus ?case by simp
next
  case (snoc e w') note IHP=this
  hence "w@w'\<in>a@w'\<otimes>b" by auto
  thus ?case using interleave_rev_cons1[of "w@w'" "a@w'" "b"] by (simp)
qed

lemma interleave_rev1[rule_format]: "ALL w1 w2 . (w\<in>w1\<otimes>w2) \<longrightarrow> (rev w \<in> rev w1 \<otimes> rev w2)" (is "?P w")
proof (induct w)
  case Nil show ?case by (simp)
  case (Cons e w)
    assume IH[rule_format]: "?P w"
    show ?case proof (clarsimp)
      fix w1 w2
      assume "e # w \<in> w1 \<otimes> w2"
      then obtain w' where "w1=e#w' & w\<in>w'\<otimes>w2 | w2=e#w' & w\<in>w1\<otimes>w'" by (blast dest: cons_interleave_split)
      with IH have "w1=e#w' & rev w\<in>rev w' \<otimes> rev w2 | w2=e#w' & rev w \<in> rev w1 \<otimes> rev w'" by auto
      thus "rev w @ [e]\<in>rev w1 \<otimes> rev w2" by (auto simp add: interleave_rev_cons)
    qed
qed

corollary interleave_rev2: "(rev w \<in> rev w1 \<otimes> rev w2) \<Longrightarrow> (w\<in>w1\<otimes>w2)"
  apply (subgoal_tac "(rev w\<in>rev w1\<otimes>rev w2) = (rev (rev w) \<in> rev (rev w1) \<otimes> rev (rev w2))")
  apply(simp)
  apply (blast dest: interleave_rev1)
done

lemmas interleave_rev = interleave_rev1 interleave_rev2

lemma rev_cons_interleave_split: "\<lbrakk>l@[a] \<in> l1\<otimes>l2\<rbrakk> \<Longrightarrow> (EX lh . l1=lh@[a] & l \<in> lh\<otimes>l2 | l2=lh@[a] & l \<in> l1\<otimes>lh )"
proof -
  assume "l@[a] \<in> l1\<otimes>l2"
  hence "a#rev l \<in> rev l1 \<otimes> rev l2" by (auto dest: interleave_rev)
  then obtain lh where "rev l1 = a#lh & rev l \<in> lh\<otimes>rev l2 | rev l2 = a#lh & rev l \<in> rev l1 \<otimes> lh" by (blast dest: cons_interleave_split)
  hence "rev l1 = a#lh & l \<in> rev lh \<otimes> l2 | rev l2 = a#lh & l \<in> l1 \<otimes> rev lh" by (auto dest: interleave_rev)
  hence "l1 = rev lh @ [a] & l \<in> rev lh \<otimes> l2 | l2 = rev lh @ [a] & l \<in> l1 \<otimes> rev lh" by (simp add: rev_swap)
  thus ?thesis by blast
qed

subsubsection "Associativity"

lemma interleave_s_assoc1[rule_format]: "ALL w1 ws w2 w3 . (w\<in>w1\<otimes>ws & ws\<in>w2\<otimes>w3 \<longrightarrow> (EX ws' : w1\<otimes>w2 . w \<in> ws'\<otimes>w3))" proof (induct w)
  case Nil show ?case by (auto)
  case (Cons e w)
    assume IH: "ALL w1 ws w2 w3 . w\<in>w1\<otimes>ws & ws\<in>w2\<otimes>w3 \<longrightarrow> (EX ws' : w1\<otimes>w2 . w \<in> ws'\<otimes>w3)"
    show ?case proof (intro impI allI)
      fix w1 ws w2 w3
      assume A: "e#w \<in> w1 \<otimes> ws \<and> ws \<in> w2 \<otimes> w3"
      then obtain wh where CASES: "w1=e#wh & w\<in>wh\<otimes>ws | ws=e#wh & w\<in>w1\<otimes>wh" by (blast dest!: cons_interleave_split)
      moreover {
        assume CASE: "w1=e#wh & w\<in>wh\<otimes>ws"
        with A IH obtain ws' where "ws'\<in>wh\<otimes>w2 & w\<in>ws'\<otimes>w3" by (blast)
        hence "e#ws'\<in> (e#wh)\<otimes>w2 & e#w \<in> (e#ws')\<otimes>w3" by (auto simp add: interleave_cons)
        with CASE have "\<exists>ws'\<in>w1 \<otimes> w2. e # w \<in> ws' \<otimes> w3" by blast
      } moreover {
        assume CASE: "ws=e#wh & w\<in>w1\<otimes>wh"
        with A obtain whh where "w2=e#whh & wh\<in>whh\<otimes>w3 | w3=e#whh & wh\<in>w2\<otimes>whh" by (blast dest!: cons_interleave_split)
        moreover {
          assume SCASE: "w2=e#whh & wh\<in>whh\<otimes>w3"
          with CASE IH obtain ws' where "ws'\<in>w1\<otimes>whh & w\<in>ws'\<otimes>w3" by blast
          with SCASE have "e#ws'\<in>w1\<otimes>w2 & e#w \<in> (e#ws')\<otimes>w3" by (auto simp add: interleave_cons)
          hence "\<exists>ws'\<in>w1 \<otimes> w2. e # w \<in> ws' \<otimes> w3" by blast
        } moreover {
          assume SCASE: "w3=e#whh & wh\<in>w2\<otimes>whh"
          with CASE IH obtain ws' where "ws'\<in>w1\<otimes>w2 & w\<in>ws'\<otimes>whh" by blast
          with SCASE have "ws'\<in>w1\<otimes>w2 & e#w \<in> ws'\<otimes>w3" by (auto simp add: interleave_cons)
          hence "\<exists>ws'\<in>w1 \<otimes> w2. e # w \<in> ws' \<otimes> w3" by blast
        } ultimately have "\<exists>ws'\<in>w1 \<otimes> w2. e # w \<in> ws' \<otimes> w3" by blast
      } ultimately show "\<exists>ws'\<in>w1 \<otimes> w2. e # w \<in> ws' \<otimes> w3" by blast
    qed
qed

lemma interleave_s_assoc2: "\<lbrakk>w\<in>ws\<otimes>w3; ws\<in>w1\<otimes>w2\<rbrakk> \<Longrightarrow> EX ws' : w2\<otimes>w3 . w \<in> w1\<otimes>ws'" proof -
  assume "w \<in> ws \<otimes> w3" "ws \<in> w1 \<otimes> w2"
  hence "w \<in> w3 \<otimes> ws & ws \<in> w2 \<otimes> w1" by simp
  hence "EX ws':w3\<otimes>w2 . w\<in>ws'\<otimes>w1" by (simp only: interleave_s_assoc1)
  thus ?thesis by simp
qed

lemmas interleave_s_assoc = interleave_s_assoc1 interleave_s_assoc2

subsubsection "Relation to other standard list operations"

lemma interleave_set: "w\<in>w1\<otimes>w2 \<Longrightarrow> set w = set w1 \<union> set w2"
  by (induct rule: interleave_elem_induct) auto
lemma interleave_map: "w\<in>w1\<otimes>w2 \<Longrightarrow> map f w \<in> map f w1 \<otimes> map f w2"
  by (induct rule: interleave_elem_induct) (auto intro!: interleave_cons)
lemma interleave_filter: "w\<in>w1\<otimes>w2 \<Longrightarrow> filter f w \<in> filter f w1 \<otimes> filter f w2"
  by (induct rule: interleave_elem_induct) (auto intro!: interleave_cons)

subsubsection "Relation to sublist order"

lemma ileq_interleave_alt: "l'\<preceq>l == \<exists>lb. l\<in>lb \<otimes> l'" proof (rule eq_reflection)
  {fix l' l have "l'\<preceq>l \<Longrightarrow> \<exists>lb. l\<in>lb \<otimes> l'" by (induct rule: less_eq_list_induct) (simp, (blast intro: interleave_cons)+)}
  moreover {fix l have "!!lb l'. l\<in>lb\<otimes>l' \<Longrightarrow> l'\<preceq>l" by (induct l) (auto intro: less_eq_list_drop elim!: cons_interleave_cases)}
  ultimately show "(l'\<preceq>l) = (\<exists>lb. l\<in>lb \<otimes> l')" by blast
qed

lemma ileq_interleave: "w\<in>w1\<otimes>w2 \<Longrightarrow> w1\<preceq>w & w2\<preceq>w"
  by (unfold ileq_interleave_alt, auto)

lemma ilt_ex_notempty: "x < y \<longleftrightarrow> (\<exists>xs. xs \<noteq> [] \<and> y \<in> xs \<otimes> x)"
  apply (auto simp add: order_less_le ileq_interleave_alt)
  apply (case_tac lb)
  apply auto
done

lemma ilt_interleave1: "\<lbrakk>w\<in>w1\<otimes>w2; w1~=[]\<rbrakk> \<Longrightarrow> w2<w"
  by (simp only: ilt_ex_notempty, blast)
lemma ilt_interleave2: "\<lbrakk>w\<in>w1\<otimes>w2; w2~=[]\<rbrakk> \<Longrightarrow> w1<w"
  by (simp only: ilt_ex_notempty interleave_comm[of w1 w2], blast)
lemmas ilt_interleave = ilt_interleave1 ilt_interleave2

subsubsection "Exotic/specialized lemmas"
\<comment> \<open>Recover structure of @{text w} wrt. to structure of @{text "w1"}\<close>
lemma interleave_recover1[rule_format]: "ALL w1a w1b w2 . w\<in>(w1a@w1b)\<otimes>w2 \<longrightarrow> (EX wa wb w2a w2b . w=wa@wb & w2=w2a@w2b & wa\<in>w1a\<otimes>w2a & wb\<in>w1b\<otimes>w2b)"
  (is "?P w" is "ALL w1a w1b w2 . ?PRE w w1a w1b w2 \<longrightarrow> ?CONS w w1a w1b w2")
proof (induct w)
  case Nil show ?case by (auto)
  case (Cons e w)
    assume IH[rule_format]: "?P w"
    show "?P (e#w)" proof (intro allI impI)
      fix w1a w1b w2
      assume PRE: "e # w \<in> w1a @ w1b \<otimes> w2"
      {
        assume CASE: "w1a=[]"
        with PRE have "e#w=[]@(e#w) & w2=[]@w2 & []\<in>w1a\<otimes>[] & e#w\<in>w1b\<otimes>w2" by (auto)
        hence "?CONS (e#w) w1a w1b w2" by blast
      } moreover {
        assume CASE: "w1a~=[]"
        with PRE obtain wh where SCASES: "w1a@w1b=e#wh & w\<in>wh\<otimes>w2 | w2=e#wh & w\<in>w1a@w1b\<otimes>wh" by (blast dest: cons_interleave_split)
        moreover {
          assume SCASE: "w1a@w1b=e#wh & w\<in>wh\<otimes>w2"
          with CASE obtain w1ah where W1AFMT: "w1a=e#w1ah & w1ah@w1b=wh" by (cases w1a, auto)
          with SCASE have "w\<in>w1ah@w1b\<otimes>w2" by auto
          with IH[of w1ah w1b w2] obtain wa wb w2a w2b where "w=wa@wb & w2=w2a@w2b & wa\<in>w1ah\<otimes>w2a & wb\<in>w1b\<otimes>w2b" by (blast)
          with W1AFMT have "e#w=(e#wa)@wb & e#w\<in>e#wa\<otimes>wb & w2=w2a@w2b & e#wa\<in>w1a\<otimes>w2a & wb\<in>w1b\<otimes>w2b" by (auto simp add: interleave_cons)
          hence "?CONS (e#w) w1a w1b w2" by blast
        } moreover {
          assume SCASE: "w2=e#wh & w\<in>w1a@w1b\<otimes>wh"
          with IH[of w1a w1b wh] obtain wa wb w2a w2b where "w=wa@wb & wh=w2a@w2b & wa\<in>w1a\<otimes>w2a & wb\<in>w1b\<otimes>w2b" by blast
          with SCASE have "e#w=(e#wa)@wb & w2=(e#w2a)@w2b & e#wa\<in>w1a\<otimes>e#w2a & wb\<in>w1b\<otimes>w2b" by (auto simp add: interleave_cons)
          hence "?CONS (e#w) w1a w1b w2" by blast
        }
        ultimately have "?CONS (e#w) w1a w1b w2" by blast
      }
      ultimately show "?CONS (e#w) w1a w1b w2" by blast
    qed
qed

lemma interleave_recover2: "w\<in>w1\<otimes>(w2a@w2b) \<Longrightarrow> EX wa wb w1a w1b . w=wa@wb & w1=w1a@w1b & wa\<in>w1a\<otimes>w2a & wb\<in>w1b\<otimes>w2b"
proof -
  assume "w\<in>w1\<otimes>(w2a@w2b)"
  hence "w\<in>(w2a@w2b)\<otimes>w1" by auto
  hence "EX wa wb w1a w1b . w=wa@wb & w1=w1a@w1b & wa\<in>w2a\<otimes>w1a & wb\<in>w2b\<otimes>w1b" by (blast dest: interleave_recover1)
  thus ?thesis by auto
qed

lemmas interleave_recover = interleave_recover1 interleave_recover2

\<comment> \<open>Split operands according to element of result\<close>
lemma interleave_unconc: "!! l2 w1 w2 . l1@l2 \<in> w1\<otimes>w2 \<Longrightarrow> \<exists> w11 w12 w21 w22 . w1=w11@w12 \<and> w2=w21@w22 \<and> l1\<in>w11\<otimes>w21 \<and> l2\<in>w12\<otimes>w22"
proof (induct l1)
  case Nil hence "w1=[]@w1 & w2=[]@w2 & []\<in>[]\<otimes>[] & l2\<in>w1\<otimes>w2" by auto
  thus ?case by fast
next
  case (Cons e l1') note IHP=this
  hence "e#(l1'@l2)\<in>w1\<otimes>w2" by auto
  with cons_interleave_split obtain w' where "(w1=e#w' & l1'@l2\<in>w'\<otimes>w2) | (w2=e#w' & l1'@l2\<in>w1\<otimes>w')" (is "?C1 | ?C2") by (fast)
  moreover {
    assume CASE: ?C1
    moreover then obtain w11' w12' w21 w22 where "w'=w11'@w12' \<and> w2=w21@w22 \<and> l1'\<in>w11'\<otimes>w21 \<and> l2\<in>w12'\<otimes>w22" by (fast dest: IHP(1))
    moreover hence "e#w'=(e#w11')@w12' & e#l1'\<in>(e#w11')\<otimes>w21" by (auto dest: interleave_cons)
    ultimately have ?case by fast
  } moreover {
    assume CASE: ?C2
    moreover then obtain w11 w12 w21' w22' where "w1=w11@w12 \<and> w'=w21'@w22' \<and> l1'\<in>w11\<otimes>w21' \<and> l2\<in>w12\<otimes>w22'" by (fast dest: IHP(1))
    moreover hence "e#w'=(e#w21')@w22' & e#l1'\<in>w11\<otimes>(e#w21')" by (auto dest: interleave_cons)
    ultimately have ?case by fast
  } ultimately show ?case by fast
qed

\<comment> \<open>Reverse direction of @{thm [source] "interleave_unconc"}\<close>
lemma interleave_reconc: "!!w11 w21 l2 w12 w22 . \<lbrakk>l1\<in>w11\<otimes>w21;l2\<in>w12\<otimes>w22\<rbrakk> \<Longrightarrow> l1@l2\<in>(w11@w12)\<otimes>(w21@w22)"
proof (induct l1)
  case Nil thus ?case by (auto)
next
  case (Cons e l1') note IHP=this
  then obtain w' where "(w11=e#w' & l1'\<in>w'\<otimes>w21) | (w21=e#w' & l1'\<in>w11\<otimes>w')" (is "?C1 | ?C2") by (fast dest: cons_interleave_split)
  moreover {
    assume CASE: ?C1
    moreover with IHP have "l1'@l2\<in>(w'@w12)\<otimes>(w21@w22)" by auto
    ultimately have ?case by (auto dest: interleave_cons)
  } moreover {
    assume CASE: ?C2
    moreover with IHP have "l1'@l2\<in>(w11@w12)\<otimes>(w'@w22)" by auto
    ultimately have ?case by (auto dest: interleave_cons)
  } ultimately show ?case by fast
qed

(* interleave_unconc and interleave_reconc as equivalence *)
lemma interleave_unconc_eq: "!! l2 w1 w2 . l1@l2 \<in> w1\<otimes>w2 = (\<exists> w11 w12 w21 w22 . w1=w11@w12 \<and> w2=w21@w22 \<and> l1\<in>w11\<otimes>w21 \<and> l2\<in>w12\<otimes>w22)"
  by (fast dest: interleave_reconc interleave_unconc)

end


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

section\<open>Examples of computations over abstract matrices\<close>

theory Examples_Gauss_Jordan_Abstract
imports
  Determinants2
  Inverse
  System_Of_Equations
  Code_Z2
  "HOL-Library.Code_Target_Numeral"
begin
subsection\<open>Transforming a list of lists to an abstract matrix\<close>

text\<open>Definitions to transform a matrix to a list of list and vice versa\<close>
definition vec_to_list :: "'a^'n::{finite, enum} => 'a list"
  where "vec_to_list A = map (($) A) (enum_class.enum::'n list)"

definition matrix_to_list_of_list :: "'a^'n::{finite, enum}^'m::{finite, enum} => 'a list list"
  where "matrix_to_list_of_list A = map (vec_to_list) (map (($) A) (enum_class.enum::'m list))"

text\<open>This definition should be equivalent to \<open>vector_def\<close> (in suitable types)\<close>
definition list_to_vec :: "'a list => 'a^'n::{finite, enum, mod_type}"
  where "list_to_vec xs = vec_lambda (% i. xs ! (to_nat i))"

lemma [code abstract]: "vec_nth (list_to_vec xs) = (%i. xs ! (to_nat i))"
  unfolding list_to_vec_def by fastforce

definition list_of_list_to_matrix :: "'a list list => 'a^'n::{finite, enum, mod_type}^'m::{finite, enum, mod_type}"
  where "list_of_list_to_matrix xs = vec_lambda (%i. list_to_vec (xs ! (to_nat i)))"

lemma [code abstract]: "vec_nth (list_of_list_to_matrix xs) = (%i. list_to_vec (xs ! (to_nat i)))"
  unfolding list_of_list_to_matrix_def by auto

subsection\<open>Examples\<close>

text\<open>The following three lemmas are presented in both this file and in the
\<open>Examples_Gauss_Jordan_IArrays\<close> one. They allow a more convenient printing of rational and
real numbers after evaluation. They have already been added to the repository version of Isabelle,
so after Isabelle2014 they should be removed from here.\<close>

lemma [code_post]:
  "int_of_integer (- 1) = - 1"
 by simp

lemma [code_abbrev]:
 "(of_rat (- 1) :: real) = - 1"
  by simp

lemma [code_post]:
 "(of_rat (- (1 / numeral k)) :: real) = - 1 / numeral k"
 "(of_rat (- (numeral k / numeral l)) :: real) = - numeral k / numeral l"
 by (simp_all add: of_rat_divide of_rat_minus)

subsubsection\<open>Ranks and dimensions\<close>
text\<open>Examples on computing ranks, dimensions of row space, null space and col space and the Gauss Jordan algorithm\<close>

value "matrix_to_list_of_list (Gauss_Jordan (list_of_list_to_matrix ([[1,0,0,0,0,0],[0,1,0,0,0,0],[0,0,0,0,0,0],[0,0,0,0,8,2]])::real^6^4))"
value "matrix_to_list_of_list (Gauss_Jordan (list_of_list_to_matrix ([[1,-2,1,-3,0],[3,-6,2,-7,0]])::rat^5^2))"
value "matrix_to_list_of_list (Gauss_Jordan (list_of_list_to_matrix ([[1,0,0,1,1],[1,0,1,1,1]])::bit^5^2))"
value "(reduced_row_echelon_form_upt_k (list_of_list_to_matrix ([[1,0,8],[0,1,9],[0,0,0]])::real^3^3)) 3"
value "matrix_to_list_of_list (Gauss_Jordan (list_of_list_to_matrix [[Complex 1 1,Complex 1 (- 1), Complex 0 0],[Complex 2 (- 1),Complex 1 3, Complex 7 3]]::complex^3^2))"
value "DIM(real^5)"
value "vec.dimension (TYPE(bit)) (TYPE(5))"
value "vec.dimension (TYPE(real)) (TYPE(2))"
(*value "complex_over_reals.dimension"*)
(*value "vector_space_over_itself.dimension (TYPE(real))"*)
value "DIM(real^5^4)"
value "row_rank (list_of_list_to_matrix [[1,0,0,7,5],[1,0,4,8,-1],[1,0,0,9,8],[1,2,3,6,5]]::real^5^4)"
value "vec.dim (row_space (list_of_list_to_matrix [[1,0,0,7,5],[1,0,4,8,-1],[1,0,0,9,8],[1,2,3,6,5]]::real^5^4))"
value "col_rank (list_of_list_to_matrix [[1,0,0,7,5],[1,0,4,8,-1],[1,0,0,9,8],[1,2,3,6,5]]::real^5^4)"
value "vec.dim (col_space (list_of_list_to_matrix [[1,0,0,7,5],[1,0,4,8,-1],[1,0,0,9,8],[1,2,3,6,5]]::real^5^4))"
value "rank (list_of_list_to_matrix [[1,0,0,7,5],[1,0,4,8,-1],[1,0,0,9,8],[1,2,3,6,5]]::real^5^4)"
value "vec.dim (null_space (list_of_list_to_matrix [[1,0,0,7,5],[1,0,4,8,-1],[1,0,0,9,8],[1,2,3,6,5]]::real^5^4))"
value "rank (list_of_list_to_matrix [[Complex 1 1,Complex 1 (- 1), Complex 0 0],[Complex 2 (- 1),Complex 1 3, Complex 7 3]]::complex^3^2)"

subsubsection\<open>Inverse of a matrix\<close>
text\<open>Examples on computing the inverse of matrices\<close>

value "let A=(list_of_list_to_matrix [[1,1,2,4,5,9,8],[3,0,8,4,5,0,8],[3,2,0,4,5,9,8], [3,2,8,0,5,9,8] ,[3,2,8,4,0,9,8] ,[3,2,8,4,5,0,8], [3,2,8,4,5,9,0]]::real^7^7)
                    in matrix_to_list_of_list (P_Gauss_Jordan A)"
value "let A=(list_of_list_to_matrix [[1,1,2,4,5,9,8],[3,0,8,4,5,0,8],[3,2,0,4,5,9,8], [3,2,8,0,5,9,8] ,[3,2,8,4,0,9,8] ,[3,2,8,4,5,0,8], [3,2,8,4,5,9,0]]::real^7^7) in
              matrix_to_list_of_list (A ** (P_Gauss_Jordan A))"
value "let A=(list_of_list_to_matrix [[1,1,2,4,5,9,8],[3,0,8,4,5,0,8],[3,2,0,4,5,9,8], [3,2,8,0,5,9,8] ,[3,2,8,4,0,9,8] ,[3,2,8,4,5,0,8], [3,2,8,4,5,9,0]]::real^7^7)
                    in (inverse_matrix A)"
value "let A=(list_of_list_to_matrix [[1,1,2,4,5,9,8],[3,0,8,4,5,0,8],[3,2,0,4,5,9,8], [3,2,8,0,5,9,8] ,[3,2,8,4,0,9,8] ,[3,2,8,4,5,0,8], [3,2,8,4,5,9,0]]::real^7^7)
                    in matrix_to_list_of_list (the (inverse_matrix A))"
value "let A=(list_of_list_to_matrix [[1,1,1,1,1,1,1],[2,2,2,2,2,2,2],[3,2,0,4,5,9,8], [3,2,8,0,5,9,8] ,[3,2,8,4,0,9,8] ,[3,2,8,4,5,0,8], [3,2,8,4,5,9,0]]::real^7^7)
                    in (inverse_matrix A)"
value "let A=(list_of_list_to_matrix [[Complex 1 1,Complex 1 (- 1), Complex 0 0],[Complex 1 1,Complex 1 (- 1), Complex 8 0],[Complex 2 (- 1),Complex 1 3, Complex 7 3]]::complex^3^3)
                    in matrix_to_list_of_list (the (inverse_matrix A))"

subsubsection\<open>Determinant of a matrix\<close>
text\<open>Examples on computing determinants of matrices\<close>

value "(let A = list_of_list_to_matrix[[1,2,7,8,9],[3,4,12,10,7],[-5,4,8,7,4],[0,1,2,4,8],[9,8,7,13,11]]::real^5^5 in det A)"
value "det (list_of_list_to_matrix ([[1,0,0],[0,1,0],[0,0,1]])::real^3^3)"
value "det (list_of_list_to_matrix ([[1,8,9,1,47],[7,2,2,5,9],[3,2,7,7,4],[9,8,7,5,1],[1,2,6,4,5]])::rat^5^5)"

subsubsection\<open>Bases of the fundamental subspaces\<close>
text\<open>Examples on computing basis for null space, row space, column space and left null space\<close>
(*Null_space basis:*)
value "let A = (list_of_list_to_matrix ([[1,3,-2,0,2,0],[2,6,-5,-2,4,-3],[0,0,5,10,0,15],[2,6,0,8,4,18]])::real^6^4)
  in vec_to_list` (basis_null_space A)"
value "let A = (list_of_list_to_matrix ([[3,4,0,7],[1,-5,2,-2],[-1,4,0,3],[1,-1,2,2]])::real^4^4)
  in vec_to_list` (basis_null_space A)"
(*Row_space basis*)
value "let A = (list_of_list_to_matrix ([[1,3,-2,0,2,0],[2,6,-5,-2,4,-3],[0,0,5,10,0,15],[2,6,0,8,4,18]])::real^6^4)
    in vec_to_list` (basis_row_space A)"
value "let A = (list_of_list_to_matrix ([[3,4,0,7],[1,-5,2,-2],[-1,4,0,3],[1,-1,2,2]])::real^4^4)
  in vec_to_list` (basis_row_space A)"
(*Col_space basis*)
value "let A = (list_of_list_to_matrix ([[1,3,-2,0,2,0],[2,6,-5,-2,4,-3],[0,0,5,10,0,15],[2,6,0,8,4,18]])::real^6^4)
    in vec_to_list` (basis_col_space A)"
value "let A = (list_of_list_to_matrix ([[3,4,0,7],[1,-5,2,-2],[-1,4,0,3],[1,-1,2,2]])::real^4^4)
  in vec_to_list` (basis_col_space A)"
(*Left_null_space basis*)
value "let A = (list_of_list_to_matrix ([[1,3,-2,0,2,0],[2,6,-5,-2,4,-3],[0,0,5,10,0,15],[2,6,0,8,4,18]])::real^6^4)
    in vec_to_list` (basis_left_null_space A)"
value "let A = (list_of_list_to_matrix ([[3,4,0,7],[1,-5,2,-2],[-1,4,0,3],[1,-1,2,2]])::real^4^4)
  in vec_to_list` (basis_left_null_space A)"

subsubsection\<open>Consistency and inconsistency\<close>
text\<open>Examples on checking the consistency/inconsistency of a system of equations\<close>
value "independent_and_consistent (list_of_list_to_matrix ([[1,0,0],[0,1,0],[0,0,1],[0,0,0],[0,0,0]])::real^3^5) (list_to_vec([2,3,4,0,0])::real^5)"
value "consistent (list_of_list_to_matrix ([[1,0,0],[0,1,0],[0,0,1],[0,0,0],[0,0,0]])::real^3^5) (list_to_vec([2,3,4,0,0])::real^5)"
value "inconsistent (list_of_list_to_matrix ([[1,0,0],[0,1,0],[3,0,1],[0,7,0],[0,0,9]])::real^3^5) (list_to_vec([2,0,4,0,0])::real^5)"
value "dependent_and_consistent (list_of_list_to_matrix ([[1,0,0],[0,1,0]])::real^3^2) (list_to_vec([3,4])::real^2)"
value "independent_and_consistent (mat 1::real^3^3) (list_to_vec([3,4,5])::real^3)"

subsubsection\<open>Solving systems of linear equations\<close>

text\<open>Examples on solving linear systems.\<close>

definition print_result_solve
  where "print_result_solve A = (if A = None then None else Some (vec_to_list (fst (the A)), vec_to_list` (snd (the A))))"

value "let A = (list_of_list_to_matrix [[4,5,8],[9,8,7],[4,6,1]]::real^3^3);
                  b=(list_to_vec [4,5,8]::real^3)
                  in (print_result_solve (solve A b))"

value "let A = (list_of_list_to_matrix [[0,0,0],[0,0,0],[0,0,1]]::real^3^3);
                  b=(list_to_vec [4,5,0]::real^3)
                  in (print_result_solve (solve A b))"

value "let A = (list_of_list_to_matrix [[3,2,5,2,7],[6,4,7,4,5],[3,2,-1,2,-11],[6,4,1,4,-13]]::real^5^4);
                  b=(list_to_vec [0,0,0,0]::real^4)
                  in (print_result_solve (solve A b))"

value "let A = (list_of_list_to_matrix [[1,2,1],[-2,-3,-1],[2,4,2]]::real^3^3);
                  b=(list_to_vec [-2,1,-4]::real^3)
                  in (print_result_solve (solve A b))"

value "let A = (list_of_list_to_matrix [[1,1,-4,10],[3,-2,-2,6]]::real^4^2);
                  b=(list_to_vec [24,15]::real^2)
                  in (print_result_solve (solve A b))"

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.*)
  theory TIP_sort_StoogeSortPermutes
imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

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

fun take :: "int => 'a list => 'a list" where
"take y z =
   (if y <= 0 then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => cons2 z2 (take (y - 1) xs)))"

fun sort2 :: "int => int => int list" where
"sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

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

fun length :: "'a list => int" where
"length (nil2) = 0"
| "length (cons2 z l) = 1 + (length l)"

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

fun drop :: "int => 'a list => 'a list" where
"drop y z =
   (if y <= 0 then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => drop (y - 1) xs1))"

fun splitAt :: "int => 'a list =>
                (('a list), ('a list)) pair" where
"splitAt y z = pair2 (take y z) (drop y z)"

function stooge1sort2 :: "int list => int list"
         and stoogesort :: "int list => int list"
         and stooge1sort1 :: "int list => int list" where
"stooge1sort2 y =
   (case splitAt ((op div) (length y) 3) (reverse y) of
      pair2 ys2 zs2 => x (stoogesort zs2) (reverse ys2))"
| "stoogesort (nil2) = nil2"
| "stoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge1sort2
       (stooge1sort1 (stooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge1sort1 y =
     (case splitAt ((op div) (length y) 3) y of
        pair2 ys2 zs1 => x ys2 (stoogesort zs1))"
by pat_completeness auto

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy y z (nil2) = nil2"
| "deleteBy y z (cons2 y2 ys) =
     (if (y z) y2 then ys else cons2 y2 (deleteBy y z ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z2 x2) = False"
| "isPermutation (cons2 x3 xs) z =
     ((elem x3 z) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 z)))"

theorem property0 :
  "isPermutation (stoogesort xs) xs"
  oops

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.*)
  theory TIP_relaxedprefix_is_prefix_4
imports "../../Test_Base"
begin

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

datatype It = A | B | C

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

fun isPrefix :: "It list => It list => bool" where
"isPrefix (nil2) z = True"
| "isPrefix (cons2 z2 x2) (nil2) = False"
| "isPrefix (cons2 z2 x2) (cons2 x3 x4) =
     ((z2 = x3) & (isPrefix x2 x4))"

fun isRelaxedPrefix :: "It list => It list => bool" where
"isRelaxedPrefix (nil2) z = True"
| "isRelaxedPrefix (cons2 z2 (nil2)) z = True"
| "isRelaxedPrefix (cons2 z2 (cons2 x3 x4)) (nil2) = False"
| "isRelaxedPrefix (cons2 z2 (cons2 x3 x4)) (cons2 x5 x6) =
     (if (z2 = x5) then isRelaxedPrefix (cons2 x3 x4) x6 else
        isPrefix (cons2 x3 x4) (cons2 x5 x6))"

theorem property0 :
  "isRelaxedPrefix (cons2 y xs) (x xs ys)"
  oops

end


(*
 * Copyright (C) 2014 NICTA
 * All rights reserved.
 *)

(* Author: David Cock - David.Cock@nicta.com.au *)

section "The Monty Hall Problem"

theory Monty imports "../pGCL" begin

text \<open>
We now tackle a more substantial example, allowing us to demonstrate
the tools for compositional reasoning and the use of invariants in
non-recursive programs.  Our example is the well-known Monty Hall puzzle
in statistical inference \citep{Selvin_75}.

The setting is a game show:  There is a prize hidden behind one
of three doors, and the contestant is invited to choose one.  Once
the guess is made, the host than opens one of the remaining two
doors, revealing a goat and showing that the prize is elsewhere.  The
contestent is then given the choice of switching their guess to the
other unopened door, or sticking to their first guess.

The puzzle is whether the contestant is better off switching or
staying put; or indeed whether it makes a difference at all.  Most people's
intuition suggests that it make no difference, whereas in fact,
switching raises the chance of success from 1/3 to 2/3.
\<close>

subsection \<open>The State Space\<close>

text \<open>The game state consists of the prize location, the guess,
and the clue (the door the host opens).  These are not constrained a
priori to the range @{term "{1::real,2,3}"}, but are simply natural numbers:
We instead show that this is in fact an invariant.
\<close>

record game =
  prize  :: nat
 "guess" :: nat
  clue   :: nat

text \<open>The victory condition: The player wins if they have guessed the
  correct door, when the game ends.\<close>
definition player_wins :: "game \<Rightarrow> bool"
where "player_wins g \<equiv> guess g = prize g"

subsubsection \<open>Invariants\<close>

text \<open>We prove explicitly that only valid doors are ever chosen.\<close>

definition inv_prize :: "game \<Rightarrow> bool"
where "inv_prize g \<equiv> prize g \<in> {1,2,3}"

definition inv_clue :: "game \<Rightarrow> bool"
where "inv_clue g \<equiv> clue g \<in> {1,2,3}"

definition inv_guess :: "game \<Rightarrow> bool"
where "inv_guess g \<equiv> guess g \<in> {1,2,3}"

subsection \<open>The Game\<close>

text \<open>Hide the prize behind door @{term D}.\<close>
definition hide_behind :: "nat \<Rightarrow> game prog"
where "hide_behind D \<equiv> Apply (prize_update (\<lambda>x. D))"

text \<open>Choose door @{term D}.\<close>
definition guess_behind :: "nat \<Rightarrow> game prog"
where "guess_behind D \<equiv> Apply (guess_update (\<lambda>x. D))"

text \<open>Open door @{term D} and reveal what's behind.\<close>
definition open_door :: "nat \<Rightarrow> game prog"
where "open_door D \<equiv> Apply (clue_update (\<lambda>x. D))"

text \<open>Hide the prize behind door 1, 2 or 3, demonically i.e.~according
  to any probability distribution (or none).\<close>
definition hide_prize :: "game prog"
where "hide_prize \<equiv> hide_behind 1 \<Sqinter> hide_behind 2 \<Sqinter> hide_behind 3"

text \<open>Guess uniformly at random.\<close>
definition make_guess :: "game prog"
where "make_guess \<equiv> guess_behind 1 \<^bsub>(\<lambda>s. 1/3)\<^esub>\<oplus>
                    guess_behind 2 \<^bsub>(\<lambda>s. 1/2)\<^esub>\<oplus> guess_behind 3"

text \<open>Open one of the two doors that \emph{doesn't} hide the prize.\<close>
definition reveal :: "game prog"
where "reveal \<equiv> \<Sqinter>d\<in>(\<lambda>s. {1,2,3} - {prize s, guess s}). open_door d"

text \<open>Switch your guess to the other unopened door.\<close>
definition switch_guess :: "game prog"
where "switch_guess \<equiv> \<Sqinter>d\<in>(\<lambda>s. {1,2,3} - {clue s, guess s}). guess_behind d"

text \<open>The complete game, either with or without switching guesses.\<close>
definition monty :: "bool \<Rightarrow> game prog"
where
  "monty switch \<equiv> hide_prize ;;
                  make_guess ;;
                  reveal ;;
                  (if switch then switch_guess else Skip)"

subsection \<open>A Brute Force Solution\<close>

text \<open>For sufficiently simple programs, we can calculate the exact weakest
  pre-expectation by unfolding.\<close>

lemma eval_win[simp]:
  "p = g \<Longrightarrow> \<guillemotleft>player_wins\<guillemotright> (s\<lparr> prize := p, guess := g, clue := c \<rparr>) = 1"
  by(simp add:embed_bool_def player_wins_def)

lemma eval_loss[simp]:
  "p \<noteq> g \<Longrightarrow> \<guillemotleft>player_wins\<guillemotright> (s\<lparr> prize := p, guess := g, clue := c \<rparr>) = 0"
  by(simp add:embed_bool_def player_wins_def)

text \<open>If they stick to their guns, the player wins with $p=1/3$.\<close>
lemma wp_monty_noswitch:
  "(\<lambda>s. 1/3) = wp (monty False) \<guillemotleft>player_wins\<guillemotright>"
  unfolding monty_def hide_prize_def make_guess_def reveal_def
            hide_behind_def guess_behind_def open_door_def
            switch_guess_def
  by(simp add:wp_eval insert_Diff_if o_def)

lemma swap_upd:
  "s\<lparr> prize := p, clue := c, guess := g \<rparr> =
   s\<lparr> prize := p, guess := g, clue := c \<rparr>"
  by(simp)

text \<open>If they switch, they win with $p=2/3$.  Brute force here
  takes longer, but is still feasible.  On larger programs,
  this will rapidly become impossible, as the size of the terms
  (generally) grows exponentially with the length of the program.\<close>

lemma wp_monty_switch_bruteforce:
  "(\<lambda>s. 2/3) = wp (monty True) \<guillemotleft>player_wins\<guillemotright>"
  unfolding monty_def hide_prize_def make_guess_def reveal_def
            hide_behind_def guess_behind_def open_door_def
            switch_guess_def
  \<comment> \<open>Note that this is getting slow\<close>
  by (simp add: wp_eval insert_Diff_if swap_upd o_def cong del: INF_cong_simp)

subsection \<open>A Modular Approach\<close>

text \<open>We can solve the problem more efficiently, at the cost of
  a little more user effort, by breaking up the problem and annotating
  each step of the game separately.  While this is not strictly necessary
  for this program, it will scale to larger examples, as the work in
  annotation only increases linearly with the length of the program.\<close>

subsubsection \<open>Healthiness\<close>

text \<open>We first establish healthiness for each step. This follows
  straightforwardly by applying the supplied rulesets.\<close>

lemma wd_hide_prize:
  "well_def hide_prize"
  unfolding hide_prize_def hide_behind_def
  by(simp add:wd_intros)

lemma wd_make_guess:
  "well_def make_guess"
  unfolding make_guess_def guess_behind_def
  by(simp add:wd_intros)

lemma wd_reveal:
  "well_def reveal"
proof -
  txt \<open>Here, we do need a subsidiary lemma: that there is always
    a `fresh' door available.  The rest of the healthiness proof follows
    as usual.\<close>
  have "\<And>s. {1, 2, 3} - {prize s, guess s} \<noteq> {}"
    by(auto simp:insert_Diff_if)
  thus ?thesis
    unfolding reveal_def open_door_def
    by(intro wd_intros, auto)
qed

lemma wd_switch_guess:
  "well_def switch_guess"
proof -
  have "\<And>s. {1, 2, 3} - {clue s, guess s} \<noteq> {}"
    by(auto simp:insert_Diff_if)
  thus ?thesis
    unfolding switch_guess_def guess_behind_def
    by(intro wd_intros, auto)
qed

lemmas monty_healthy =
  wd_switch_guess wd_reveal wd_make_guess wd_hide_prize

subsubsection \<open>Annotations\<close>

text \<open>We now annotate each step individually, and then combine them to
  produce an annotation for the entire program.\<close>

text \<open>@{term hide_prize} chooses a valid door.\<close>
lemma wp_hide_prize:
  "(\<lambda>s. 1) \<tturnstile> wp hide_prize \<guillemotleft>inv_prize\<guillemotright>"
  unfolding hide_prize_def hide_behind_def wp_eval o_def
  by(simp add:embed_bool_def inv_prize_def)

text \<open>Given the prize invariant, @{term make_guess} chooses a valid
  door, and guesses incorrectly with probability at least 2/3.\<close>
lemma wp_make_guess:
  "(\<lambda>s. 2/3 * \<guillemotleft>\<lambda>g. inv_prize g\<guillemotright> s) \<tturnstile>
   wp make_guess \<guillemotleft>\<lambda>g. guess g \<noteq> prize g \<and> inv_prize g \<and> inv_guess g\<guillemotright>"
  unfolding make_guess_def guess_behind_def wp_eval o_def
  by(auto simp:embed_bool_def inv_prize_def inv_guess_def)

lemma last_one:
  assumes "a \<noteq> b" and "a \<in> {1::nat,2,3}" and "b \<in> {1,2,3}"
  shows "\<exists>!c. {1,2,3} - {b,a} = {c}"
  apply(simp add:insert_Diff_if)
  using assms by(auto intro:assms)

text \<open>Given the composed invariants, and an incorrect guess, @{term reveal}
  will give a clue that is neither the prize, nor the guess.\<close>
lemma wp_reveal:
  "\<guillemotleft>\<lambda>g. guess g \<noteq> prize g \<and> inv_prize g \<and> inv_guess g\<guillemotright> \<tturnstile>
   wp reveal \<guillemotleft>\<lambda>g. guess g \<noteq> prize g \<and>
                  clue g \<noteq> prize g \<and>
                  clue g \<noteq> guess g \<and>
                  inv_prize g \<and> inv_guess g \<and> inv_clue g\<guillemotright>"
  (is "?X \<tturnstile> wp reveal ?Y")
proof(rule use_premise, rule well_def_wp_healthy[OF wd_reveal], clarify)
  fix s
  assume "guess s \<noteq> prize s"
     and "inv_prize s"
     and "inv_guess s"
  moreover then obtain c
    where singleton: "{Suc 0,2,3} -  {prize s, guess s} = {c}"
      and "c \<noteq> prize s"
      and "c \<noteq> guess s"
      and "c \<in> {Suc 0,2,3}"
    unfolding inv_prize_def inv_guess_def
    by(force dest:last_one elim!:ex1E)
  ultimately show "1 \<le> wp reveal ?Y s"
    by(simp add:reveal_def open_door_def wp_eval singleton o_def
                embed_bool_def inv_prize_def inv_guess_def inv_clue_def)
qed

text \<open>Showing that the three doors are all district is a largeish
  first-order problem, for which sledgehammer gives us a reasonable
  script.\<close>
lemma distinct_game:
  "\<lbrakk> guess g \<noteq> prize g; clue g \<noteq> prize g; clue g \<noteq> guess g;
     inv_prize g; inv_guess g; inv_clue g \<rbrakk> \<Longrightarrow>
   {1, 2, 3} = {guess g, prize g, clue g}"
  unfolding inv_prize_def inv_guess_def inv_clue_def
  apply(rule set_eqI)
  apply(rule iffI)
   apply(clarify)
   apply(metis (full_types) empty_iff insert_iff)
  apply(metis insert_iff)
  done

text \<open>Given the invariants, switching from the wrong guess gives
  the right one.\<close>
lemma wp_switch_guess:
  "\<guillemotleft>\<lambda>g. guess g \<noteq> prize g \<and> clue g \<noteq> prize g \<and> clue g \<noteq> guess g \<and>
        inv_prize g \<and> inv_guess g \<and> inv_clue g\<guillemotright> \<tturnstile>
   wp switch_guess \<guillemotleft>player_wins\<guillemotright>"
proof(rule use_premise, safe)
  from wd_switch_guess show "healthy (wp switch_guess)" by(auto)

  fix s
  assume "guess s \<noteq> prize s" and "clue s \<noteq> prize s"
     and "clue s \<noteq> guess s" and "inv_prize s"
     and "inv_guess s" and "inv_clue s"
  note state = this
  hence "1 \<le> Inf ((\<lambda>a. \<guillemotleft> player_wins \<guillemotright> (s\<lparr>guess := a\<rparr>)) `
    ({guess s, prize s, clue s} - {clue s, guess s}))"
    by(auto simp:insert_Diff_if player_wins_def)
  also from state
  have "... = Inf ((\<lambda>a. \<guillemotleft> player_wins \<guillemotright> (s\<lparr>guess := a\<rparr>)) `
                  ({1, 2, 3} - {clue s, guess s}))"
    by(simp add:distinct_game[symmetric])
  also have "... = wp switch_guess \<guillemotleft>player_wins\<guillemotright> s"
    by(simp add:switch_guess_def guess_behind_def wp_eval o_def)
  finally show "1 \<le> wp switch_guess \<guillemotleft> player_wins \<guillemotright> s" .
qed

text \<open>Given componentwise specifications, we can glue them together
with calculational reasoning to get our result.\<close>
lemma wp_monty_switch_modular:
  "(\<lambda>s. 2/3) \<tturnstile> wp (monty True) \<guillemotleft>player_wins\<guillemotright>"
proof(rule wp_validD)  \<comment> \<open>Work in probabilistic Hoare triples\<close>
  note wp_validI[OF wp_scale, OF wp_hide_prize, simplified]
    \<comment> \<open>Here we apply scaling to match our pre-expectation\<close>
  also note wp_validI[OF wp_make_guess]
  also note wp_validI[OF wp_reveal]
  also note wp_validI[OF wp_switch_guess]
  finally show "\<lbrace>\<lambda>s. 2/3\<rbrace> monty True \<lbrace>\<guillemotleft>player_wins\<guillemotright>\<rbrace>p"
    unfolding monty_def
    by(simp add:wd_intros sound_intros monty_healthy)
qed

subsubsection \<open>Using the VCG\<close>

lemmas scaled_hide = wp_scale[OF wp_hide_prize, simplified]
declare scaled_hide[pwp] wp_make_guess[pwp] wp_reveal[pwp] wp_switch_guess[pwp]
declare wd_hide_prize[wd] wd_make_guess[wd] wd_reveal[wd] wd_switch_guess[wd]

text \<open>Alternatively, the VCG will get this using the same annotations.\<close>
lemma wp_monty_switch_vcg:
  "(\<lambda>s. 2/3) \<tturnstile> wp (monty True) \<guillemotleft>player_wins\<guillemotright>"
  unfolding monty_def
  by(simp, pvcg)

end


theory T79
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T162
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T54
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end