theory LanguageModule
  imports Language
begin

definition fold_rel :: "'a rel list \<Rightarrow> 'a rel" where
  "fold_rel xs = foldr op O xs Id"

definition eval_word :: "'a rel list \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "eval_word xs H = fold_rel xs `` H"

lemma eval_empty_word [simp]: "eval_word [] h = h"
  by (auto simp add: eval_word_def fold_rel_def)

lemma eval_cons_word [simp]: "eval_word (x # xs) h = eval_word xs (x `` h)"
  by (auto simp add: eval_word_def fold_rel_def)

lemma eval_append_word: "eval_word (xs @ ys) h = eval_word ys (eval_word xs h)"
  by (induct xs arbitrary: h) simp_all

definition module :: "'a rel lan \<Rightarrow> 'a set \<Rightarrow> 'a set" (infix "\<Colon>" 60) where
  "x \<Colon> h \<equiv> \<Union>{eval_word w h|w. w \<in> x}"

lemma eval_word_continuous: "eval_word w (\<Union>X) = \<Union>eval_word w ` X"
  by (induct w arbitrary: X) (auto simp add: image_def eval_word_def)

lemma mod_mult: "x\<cdot>y \<Colon> h = y \<Colon> (x \<Colon> h)"
proof -
  have "x\<cdot>y \<Colon> h = \<Union>{eval_word w h|w. w \<in> x\<cdot>y}"
    by (simp add: module_def)
  also have "... = \<Union>{eval_word (xw @ yw) h|xw yw. xw \<in> x \<and> yw \<in> y}"
    by (auto simp add: l_prod_def complex_product_def)
  also have "... = \<Union>{eval_word yw (eval_word xw h)|xw yw. xw \<in> x \<and> yw \<in> y}"
    by (simp add: eval_append_word)
  also have "... = \<Union>{\<Union>{eval_word yw (eval_word xw h)|xw. xw \<in> x}|yw. yw \<in> y}"
    by blast
  also have "... = \<Union>{eval_word yw (\<Union>{eval_word xw h|xw. xw \<in> x})|yw. yw \<in> y}"
    by (subst eval_word_continuous) (auto simp add: image_def)
  also have "... = \<Union>{eval_word yw (x \<Colon> h)|yw. yw \<in> y}"
    by (simp add: module_def)
  also have "... = y \<Colon> (x \<Colon> h)"
    by (simp add: module_def)
  finally show ?thesis .
qed

lemma mod_one [simp]: "{[]} \<Colon> h = h"
  by (simp add: module_def)

lemma mod_zero [simp]: "{} \<Colon> h = {}"
  by (simp add: module_def)

lemma mod_empty [simp]: "x \<Colon> {} = {}"
  by (simp add: module_def eval_word_def)

lemma mod_distl: "(x \<union> y) \<Colon> h = (x \<Colon> h) \<union> (y \<Colon> h)"
proof -
  have "(x \<union> y) \<Colon> h = \<Union>{eval_word w h|w. w \<in> x \<union> y}"
    by (simp add: module_def)
  also have "... = \<Union>{eval_word w h|w. w \<in> x \<or> w \<in> y}"
    by blast
  also have "... = \<Union>{eval_word w h|w. w \<in> x} \<union> \<Union>{eval_word w h|w. w \<in> y}"
    by blast
  also have "... = (x \<Colon> h) \<union> (y \<Colon> h)"
    by (simp add: module_def)
  finally show ?thesis .
qed

lemma mod_distr: "x \<Colon> (h \<union> g) = (x \<Colon> h) \<union> (x \<Colon> g)"
proof -
  have "x \<Colon> (h \<union> g) = \<Union>{eval_word w (h \<union> g)|w. w \<in> x}"
    by (simp add: module_def)
  also have "... = \<Union>{eval_word w h \<union> eval_word w g|w. w \<in> x}"
    by (simp add: eval_word_def) blast
  also have "... = \<Union>{eval_word w h|w. w \<in> x} \<union> \<Union>{eval_word w g|w. w \<in> x}"
    by blast
  also have "... = (x \<Colon> h) \<union> (x \<Colon> g)"
    by (simp add: module_def)
  finally show ?thesis .
qed

lemma mod_isol: "x \<subseteq> y \<Longrightarrow> x \<Colon> p \<subseteq> y \<Colon> p"
  by (auto simp add: module_def)

lemma mod_isor: "p \<subseteq> q \<Longrightarrow> x \<Colon> p \<subseteq> x \<Colon> q"
  by (metis mod_distr subset_Un_eq)

lemma mod_continuous: "\<Union>X \<Colon> p = \<Union>{x \<Colon> p|x. x \<in> X}"
  by (simp add: module_def) blast

lemma mod_continuous_var: "\<Union>{f x|x. P x} \<Colon> p = \<Union>{f x \<Colon> p|x. P x}"
  by (simp add: mod_continuous) blast

definition mod_test :: "'a set \<Rightarrow> 'a rel lan" ("_?" [101] 100) where
  "p? \<equiv> {[Id_on p]}"

lemma mod_test: "p? \<Colon> q = p \<inter> q"
  by (auto simp add: module_def mod_test_def)

lemma test_true: "q \<subseteq> p \<Longrightarrow> p? \<Colon> q = q"
  by (metis Int_absorb1 mod_test)

lemma test_false: "q \<subseteq> -p \<Longrightarrow> p? \<Colon> q = {}"
  by (metis Int_commute disjoint_eq_subset_Compl mod_test)

end


theory XO
imports Main
begin

(*=========================================================================================*)
section {* Introduction *}

text {* This example was translated from a VDM specification courtesy of Nick Battle from Fujistsu *}

(*=========================================================================================*)
section {* VDM values *}

text {* This section defines the VDM  \textsf{values} section of \textsf{XO.vdmsl}. *}

find_theorems name:Relation

text {* The size of the board is 3, but we could generalise the game, or even make it 3D! *}

abbreviation
  SIZE :: nat
where
  "SIZE \<equiv> 3"

text {* The maximum number of moves is the board dimensions *}

abbreviation "MAX \<equiv> SIZE * SIZE"

(*=========================================================================================*)
section {* VDM types *}

text {* This section defines the VDM  \textsf{types} section of \textsf{XO.vdmsl}. *}

text {* We also define two types for the play outcome options and the players.
        In VDM this is easier: we just need to extend the enumerated type.
      *}

datatype GameResult = NOUGHT_WON | CROSS_WON | DRAW | UNFINISHED

datatype Player = NOUGHT | CROSS

print_theorems

(* Teach proof by regular expressions *)
(*typedef Player = "{ NOUGHT, CROSS }" by (rule exI,simp,rule disjI1,simp) *)

text {* We also need to know the set of valid players as all possible players.
        This is a value in VDM *}

abbreviation "PLAYERS \<equiv> {NOUGHT, CROSS}"

text {* A move position is defined next as a pair of numbers with the invariant
        they are non negative and within @{text "SIZE"} *}

type_synonym Pos = "(nat \<times> nat)"

(*
definition
  inv_Pos :: "Pos \<Rightarrow> bool"
where
  "inv_Pos pos \<equiv> (fst pos) \<ge> 1 \<and> (fst pos) \<le> SIZE \<and>
                  (snd pos) \<ge> 1 \<and> (snd pos) \<le> SIZE"
*)

text {* For the @{term Pos} invariant we could either use field selection,
        or patterns matching like in VDM $mk-Pos(x,y)$; we will choose the later.
      *}

definition
  inv_Pos :: "Pos \<Rightarrow> bool"
where
  "inv_Pos z \<equiv> let (x,y) = z in
                  x \<ge> 1 \<and> x \<le> SIZE \<and>
                  y \<ge> 1 \<and> y \<le> SIZE"

find_theorems "inv_Pos _"
thm inv_Pos_def

text {* Next we need to decide how the game is to be modelled. Discuss options in class/practicals *}

text {* The game is modelled as VDM Isabelle Map from position to player. The invariant
        asserts that all positions in the domain satisfy the position type invariant as well.
        Isabelle maps are total functions to an optional type:~it maps elements outside of
        the domain to @{text "None"} and within the domain to @{text "Some x"}. So effectively,
        @{text "m :: T1 \<rightharpoonup> T2"} is the same as @{text "m :: T1 \<Rightarrow> T2 option"}, where
        @{text "m x"} can be either @{text "None"} if @{text "x \<notin> dom m"} or @{text "Some y"}
        if @{text "x \<in> dom m"}.

        This nesting of invariant checking is common place in our translation because VDM
        type invariants are not maintained by Isabelle, hence we need to keep them ourselves.
        For a manual translation, this obviously play a serious threat to correctness
        (i.e. in case one misses checking the invariant at all necessary places).

        As the @{text "Game"} invariant is on a set of @{text "Pos"}, we generalise it a bit.
      *}

type_synonym Game = "Pos \<rightharpoonup> Player"

definition
  inv_PosSet :: "Pos set \<Rightarrow> bool"
where
  "inv_PosSet ps \<equiv> (\<forall> pos \<in> ps . inv_Pos pos)"

definition
  inv_Game :: "Game \<Rightarrow> bool"
where
  "inv_Game g \<equiv> inv_PosSet (dom g)"

text {* Next we define play order and moves using lists. Play order as a list is a bit overkill.
        Perhaps just a boolean would suffice. \textbf{TODO: check - I guess it is modelled as a list because of Overture
        animation or for generalisation of players to more than two?}
      *}

type_synonym Moves = "Pos list"
type_synonym PlayOrder = "Player list"

definition
  inv_Moves :: "Moves \<Rightarrow> bool"
where
  "inv_Moves m \<equiv> inv_PosSet (set m) \<and>
                 length m = card(set m) \<and>
                 length m > (card PLAYERS) * (SIZE-(1::nat)) \<and>
                 length m \<le> MAX"

definition
  inv_PlayOrder :: "PlayOrder \<Rightarrow> bool"
where
  "inv_PlayOrder po \<equiv> length po > 0 \<and>
                       length po = card(set po) \<and>
                       (set po) = PLAYERS"

text {* Isabelle @{term "length xs"} is the same as VDM's $\len{xs}$, whereas
        @{term "set xs"} equals $\elems{xs}$. One key difference from VDM is that
        Isabelle lists are indexed from zero, whereas VDM sequences are indexed from one.
      *}

type_synonym Line = "Pos set"

definition
  inv_Line :: "Line \<Rightarrow> bool"
where
  "inv_Line l \<equiv> inv_PosSet l"

(* IJW: to me, this is not the invariant on a line!
{(1,2), (1,3), (2,3)} does not a line make. Nor
{(1,1)}
*)

(*-----------------------------------------------------------------------------------------*)
subsection {* Technical note *}

text {* Looking into Isabelle's libraries I guess there is  simpler and more efficient way
        of calculating sequence injectivity by asking that all elements are distinct.
      *}

(* Referencial transparency; show distinct and set *)
find_theorems "distinct _"
find_theorems "set _"
find_theorems "remdups _"

--"declare [[smt_trace]]"
lemma "distinct l \<longleftrightarrow> length l = card(set l)"
--"by (metis length_remdups_card_conv length_remdups_eq remdups_id_iff_distinct)"
by (metis card_distinct distinct_card)

thm card_distinct distinct_card

(* TODO: make defining this as part of coursework? *)

lemma "remdups m = m \<longleftrightarrow> length m = card(set m)"
by (metis length_remdups_card_conv length_remdups_eq)

(*=========================================================================================*)
section {* VDM functions *}

text {* This section defines the VDM \textsf{functions} section of \textsf{XO.vdmsl}. *}

(*-----------------------------------------------------------------------------------------*)
subsection {* Extra VDM operators *}

text {* Certain VDM map operators are not defined, like range filtering or restriction.
        We define it next as expected and give it a seemingly infix syntax.
      *}

definition
  ran_restr :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'b set \<Rightarrow> ('a \<rightharpoonup> 'b)" (infixl "\<triangleright>" 105)
where
  "m \<triangleright> s \<equiv> (\<lambda>x . if (\<exists> y. m x = Some y \<and> y \<in> s) then m x else None)"

(*-----------------------------------------------------------------------------------------*)
subsection {* Explicitly defined functions *}

definition
  movesForPlayer :: "Game \<Rightarrow> Player \<Rightarrow> Pos set"
where
  "movesForPlayer g p \<equiv> dom (g \<triangleright> {p})"

definition
  movesSoFar :: "Game \<Rightarrow> Pos set"
where
  "movesSoFar g \<equiv> dom g"

definition
  movesCountSoFar :: "Game \<Rightarrow> nat"
where
  "movesCountSoFar g \<equiv> card (dom g)"
  --{* same as @{term "(if (finite(dom g)) then card (dom g) else 0)"} *}

(* EXPLAIN: caveat about 0-3 = 0*)
definition
  movesCountLeft :: "Game \<Rightarrow> nat"
where
  "movesCountLeft g \<equiv> MAX - movesCountSoFar g"

definition
  makeMove :: "Game \<Rightarrow> Player \<Rightarrow> Pos \<Rightarrow> Game"
where
  "makeMove g p pos \<equiv> g(pos \<mapsto> p)"

(* See discussion below on post_makeMove on use or not of option types for resulting Game
definition
  makeMove :: "Game \<Rightarrow> Player \<Rightarrow> Pos \<Rightarrow> Game option"
where
  "makeMove g p pos \<equiv> Some (g(pos \<mapsto> p))"
*)

(*-----------------------------------------------------------------------------------------*)
subsection {* Game solution (comparison) value *}

abbreviation
  BOARD :: "nat set"
where
  "BOARD \<equiv> {1 .. SIZE}"

definition
  row :: "nat \<Rightarrow> Line"
where
  "row rr \<equiv> { (r, c) . c \<in> BOARD \<and> r=rr \<and> inv_Pos (r, c) }"

declare [[show_types]]
definition
  row2 :: "nat \<Rightarrow> Line"
where
  "row2 rr \<equiv> { (rr, c) | c . c \<in> BOARD \<and> inv_Pos (rr, c) }"

--"row2 1 \<equiv> { (1, c) | c . c \<in> 1..2 } \<equiv> { (1, 1), (1, 2) }"

lemma "row2 1 = { (1, 1), (1, 2), (1, 3) }"
unfolding row2_def inv_Pos_def
apply simp
apply auto
done

lemma "row2 r = row r"
unfolding row2_def row_def by auto

(* IJW: Have a correct line invariant then prove that row(rr) satisfies it
   IJW: Also, if c \<in> BOARD, then surely the inv_Pos is a consequence? COuld prove to...

*)
definition
  col :: "nat \<Rightarrow> Line"
where
  "col cc \<equiv> { (r,cc) | r . r \<in> BOARD \<and> inv_Pos (r, cc) }"

value "{ [A,B,C] ! i | i . i \<in> {1, 2} }"

abbreviation
  allRows0 :: "Line set"
where
  "allRows0 \<equiv> { row 1, row 2, row 3 }"

abbreviation
  allRows :: "Line set"
where
  "allRows \<equiv> \<Union> r \<in> BOARD . { row r }"

abbreviation
  allCols :: "Line set"
where
  "allCols \<equiv> \<Union> c \<in> BOARD . { col c }"

abbreviation
  downwardDiag0 :: "Line"
where
  "downwardDiag0 \<equiv> { (x,x) . x \<in> BOARD }" --"variable capture on snd x?"
(* IJW: no capture, this just isn't set comprehension as you imagine it.
   It should look like:
 *)
abbreviation
  downwardDiagIJW :: "Line"
where
  "downwardDiagIJW \<equiv> { (x,x)| x . x \<in> BOARD }"
(* Now the lemma can be proved, see below. *)

abbreviation
  downwardDiag :: "Line"
where
  "downwardDiag \<equiv> { (x,y) . x \<in> BOARD \<and> x=y }"

(* IJW: you'll need to do the same for this *)
abbreviation
  upwardDiag0 :: "Line"
where
  "upwardDiag0 \<equiv> { (x,y) . x \<in> BOARD \<and> y = x-SIZE+(1::nat) }" --"flipped x and SIZE"

abbreviation
  upwardDiag :: "Line"
where
  "upwardDiag \<equiv> { (x,y) . x \<in> BOARD \<and> y = SIZE-x+(1::nat) }"

(* Use definition to tame unfolding *)
definition
  winningLines :: "Line set"
where
(*  "winningLines \<equiv> \<Union> {allRows, allCols, {downwardDiag}, {upwardDiag}}"*)
   "winningLines \<equiv> allRows \<union> allCols \<union> {downwardDiag, upwardDiag}"
(* IJW: Hmm, maybe rather than sets of sets, use allRows \<union> allCols \<union> ...? *)

abbreviation
  explicitWinningLines :: "Line set"
where
  "explicitWinningLines \<equiv>
          { {(1, 1), (1, 2), (1, 3)},
					 	{(2, 1), (2, 2), (2, 3)},
					  {(3, 1), (3, 2), (3, 3)},

					  {(1, 1), (2, 1), (3, 1)},
					  {(1, 2), (2, 2), (3, 2)},
					  {(1, 3), (2, 3), (3, 3)},

					  {(1, 1), (2, 2), (3, 3)},

					  {(1, 3), (2, 2), (3, 1)}
				  }"

(* Give me some sanity please :-) *)
lemma "(\<Union> x \<in> BOARD . {(x,y) . inv_Pos (x,y) }) = { (r, c) . inv_Pos (r, c) }"
by (rule,rule,simp,rule,simp)

lemma lBoardKeepsPos: "x \<in> BOARD \<and> y \<in> BOARD \<Longrightarrow> inv_Pos (x,y) \<and> inv_Pos (y,x)"
unfolding inv_Pos_def by auto

lemma "BOARD = {1,2,3}" by auto

lemma "row 1 = ({ (r,c) . r=1 \<and> c \<in> BOARD })"
unfolding inv_Pos_def row_def by auto
lemma "row 1 = { (1,1), (1,2), (1,3) }"
unfolding inv_Pos_def row_def by auto
lemma "col 1 = { (1,1), (2,1), (3,1) }"
unfolding inv_Pos_def col_def by auto

lemma ar: "allRows = allRows0"
apply (rule)
apply (rule_tac[1-] subsetI)
apply simp_all
apply (erule bexE)
apply simp
apply (elim conjE)
apply (case_tac r)
apply simp_all
apply (case_tac nat)
apply simp_all
apply (case_tac nata)
apply simp_all
apply (rule disjI2,rule disjI1)
defer
apply (rule disjI2,rule disjI2)
defer
apply (erule disjE)
apply (rule_tac x="Suc 0" in bexI,simp_all)
apply (erule disjE)
apply (rule_tac x="2" in bexI,simp_all)
apply (rule_tac x="SIZE" in bexI,simp_all)
unfolding row_def
apply auto
done (* why so protracted! *)

(* Now provable by auto *)
lemma "downwardDiagIJW = { (1,1), (2,2), (3,3) }" nitpick
  by auto

lemma "downwardDiag0 = { (1,1), (2,2), (3,3) }"
apply simp
nitpick oops

lemma dwd: "downwardDiag = { (1,1), (2,2), (3,3) }"
apply rule
apply simp_all
apply rule
apply simp (* Hum... there is something fishy about way pairs are handled *)
apply (case_tac x,simp)
apply (elim conjE)
apply (case_tac a,simp_all)
apply (case_tac nat,simp_all)
apply (case_tac nata,simp_all) (* something fishy here on range as well *)
done

lemma "upwardDiag0 = { (3,1), (2,2), (1,3) }"
apply simp nitpick oops

lemma wdd: "upwardDiag = { (3,1), (2,2), (1,3) }"
apply rule
apply simp_all
apply rule
apply simp (* Hum... there is something fishy about way pairs are handled *)
apply (case_tac x,simp)
apply (elim conjE)
apply (case_tac a,simp_all)
apply (case_tac nat,simp_all)
apply (case_tac nata,simp_all) (* something fishy here on range as well *)
done

(* quit unmanageable / tedious *)
lemma "winningLines = explicitWinningLines"
unfolding winningLines_def apply rule
apply simp_all  oops
(* IJW: maybe slightly easier with some of the simplifications above? *)

(*-----------------------------------------------------------------------------------------*)
subsection {* Game solution (predicates) testing functions *}

definition
  hasWon :: "Game \<Rightarrow> Player \<Rightarrow> bool"
where
  "hasWon g p \<equiv> \<exists> line \<in> winningLines . line \<subseteq> (movesForPlayer g p)"

find_theorems "\<exists>! _ . _"

definition
  isWon :: "Game \<Rightarrow> bool"
where
  "isWon g \<equiv> \<exists>! p . hasWon g p"

definition
  whoWon :: "Game \<Rightarrow> Player"
where
  "whoWon g \<equiv> THE p . hasWon g p"

definition
  isDraw :: "Game \<Rightarrow> bool"
where
  "isDraw g \<equiv> \<not> isWon g \<and> movesCountLeft g = 0"

definition
  isUnfinished :: "Game \<Rightarrow> bool"
where
  "isUnfinished g \<equiv> \<not> isWon g \<and> \<not> isDraw g"

(*=========================================================================================*)
section {* VDM state and operations *}

text {* The only VDM operation is the one that ``plays'' the game, but first we need a conversion
        function between the two (obviously related) datatypes.

        The game play is defined recursively on the length of the moves to be played,
        where the game remains unfinished if there are no more moves. We also augment the
        original VDM definition to tolerate (as an unfinished game) empty player ordering
        (i.e. it should really be ust boolean, so this is just glitch from the VDM model?).

        The recursive case makes the move in the game according to who is playing and,
        either decides the result, if possible, or else cary on playing. We should perhaps
        consider a iterative version of the game play function.
  *}

definition
  conv_playerToPlayOpt :: "Player \<Rightarrow> GameResult"
where
  "conv_playerToPlayOpt p \<equiv> (case p of NOUGHT \<Rightarrow> NOUGHT_WON | CROSS \<Rightarrow> CROSS_WON)"

thm Let_def

fun
  play :: "Game \<Rightarrow> PlayOrder \<Rightarrow> Moves \<Rightarrow> GameResult"
where
  "play g ps []             = UNFINISHED"
| "play g [] ms             = UNFINISHED" --"extra equation for pat-completeness"
| "play g (p # ps) (m # ms) =
      (let g' = makeMove g p m in
          (if (isWon g') then
                conv_playerToPlayOpt (whoWon g')
           else if (isDraw g') then
                DRAW
           else
                play g' (ps @ [p]) ms))"

(*-----------------------------------------------------------------------------------------*)
subsubsection {* Technical note *}

text {* extra equation + recursive def + etc *}

(*
fun
  itplay :: "Game \<Rightarrow> PlayOrder \<Rightarrow> Moves \<Rightarrow> Game \<Rightarrow> PlayOrder \<Rightarrow> Moves \<Rightarrow> GameResult"
where
  "itplay g ps [] g'             = UNFINISHED"     --"when moves finished get result"
| "itplay g [] ms g'             = UNFINISHED"     --"when playorder is screw up it's UNFINISHED"
| "itplay g (p # ps) (m # ms) g' = CROSS_WON"
*)

(*=========================================================================================*)
section {* VDM test data *}

find_theorems "insort"
thm Finite_Set.fold_def

value "sorted_list_of_set {1,2}"
value "sorted_list_of_set BOARD"
value "zip (sorted_list_of_set BOARD) (sorted_list_of_set BOARD)"
lemma "(sorted_list_of_set BOARD) = [1,2,3]" oops

abbreviation
  allPos :: "Pos set"
where
  "allPos \<equiv> { (r, c) . inv_Pos (r, c) }"

find_theorems name:choice
thm inv_def
find_theorems name:Hilbert

abbreviation
  somePos :: "Pos set \<Rightarrow> Pos"
where
  "somePos ps \<equiv> Eps (\<lambda> x . x \<in> ps \<and> inv_PosSet ps)" --{* or @{text "inv_Pos x"}? *}

value "somePos"

definition
  randomMove :: Moves
where
  "randomMove \<equiv>
     let m1 = (somePos allPos) in
       let m2 = (somePos (allPos - {m1})) in
        let m3 = (somePos (allPos - {m1,m2})) in
          let m4 = (somePos (allPos - {m1,m2,m3})) in
            let m5 = (somePos (allPos - {m1,m2,m3,m4})) in
              [m1,m2,m3,m4,m5]
    "
(*
let m1 in set ALLPOS in										-- 9 1st moves
		let m2 in set ALLPOS \ {m1} in								-- 72 1st-2nd pairs
		let m3 in set ALLPOS \ {m1, m2} in							-- 504 1st-2nd-3rd etc...
		let m4 in set ALLPOS \ {m1, m2, m3} in						-- 3024
		let m5 in set ALLPOS \ {m1, m2, m3, m4} in					-- 15120 (minimum)
--		let m6 in set ALLPOS \ {m1, m2, m3, m4, m5} in				-- 60480
--		let m7 in set ALLPOS \ {m1, m2, m3, m4, m5, m6} in			-- 181440
--		let m8 in set ALLPOS \ {m1, m2, m3, m4, m5, m6, m7} in		-- 362880
--		let m9 in set ALLPOS \ {m1, m2, m3, m4, m5, m6, m7, m8} in	-- 362880
*)

find_theorems name:induct name:Finite_Set
thm finite_induct

(* I wish! How to define recursive functions over sets?
definition
  complexMove :: "Pos set \<Rightarrow> Moves"
where
  "complexMove ps =
      (if (ps = {}) then []
       else
          let x = (somePos ps) in
             x # (complexMove (ps - {x})))"
*)

abbreviation
  simpleMoves :: Moves
where
  "simpleMoves \<equiv> [(x,y) . x \<leftarrow> sorted_list_of_set BOARD, y \<leftarrow> sorted_list_of_set BOARD]"

abbreviation
  winningMoves :: Moves
where
  "winningMoves \<equiv> [(2,2),(1,3),(3,1),(2,3),(3,3),(1,1),(3,2)]"

value simpleMoves
--"value randomMove"

definition
  testPlay0 :: "GameResult"
where
  "testPlay0 \<equiv> play empty [CROSS, NOUGHT] []"

definition
  testPlayCross :: "GameResult"
where
  "testPlayCross \<equiv> play empty [CROSS, NOUGHT] winningMoves"

definition
  testPlayNought :: "GameResult"
where
  "testPlayNought \<equiv> play empty [NOUGHT, CROSS] winningMoves"

thm Let_def list.split Pair_def split_if split_if_asm

(*
lemma "testPlayCross = CROSS_WON"
unfolding testPlayCross_def
apply auto
(* TODO: bugger! let's are complicated *)
oops
*)

declare [[smt_trace=false]]
lemma "allPos = { (1,1),(1,2),(1,3),(2,1),(2,2),(2,3),(3,1),(3,2),(3,3)}"
apply (rule,rule,simp,unfold inv_Pos_def,simp_all)
apply (case_tac x,simp,elim conjE)
by smt

(*=========================================================================================*)
section {* VDM pre and post condition definitions for functions *}

(*-----------------------------------------------------------------------------------------*)
subsection {* Implicitly definined pre and post *}

text {* All VDM functions have an implicitly defined pre and post condition functions.
        If no explicit pre/post condition is defined by the user, these functions just
        check the type invariants and return @{term "True"}.

        In our translation, because the type invariants are not guaranteed by Isabelle,
        we use the definitions to achieve that. Moreover, because these are functions,
        and not operations, there is no need to check after state on postconditions.

        Furthermore, when no explicit postcondition is given, we assert the explicit VDM
        definition as part of the postcondition.

        TODO: Q for nick when calling functions within the definitions are their pre/post called?
        If so, the repetitiveness of defnitions below can be aliviated. Also, is asserting explicit
        defs as part of (implicit) post okay? Should be?
      *}

definition
  pre_movesForPlayer :: "Game \<Rightarrow> Player \<Rightarrow> bool"
where
  "pre_movesForPlayer g p \<equiv> inv_Game g"

definition
  post_movesForPlayer :: "Game \<Rightarrow> Player \<Rightarrow> Pos set \<Rightarrow> bool"
where
  "post_movesForPlayer g p ps \<equiv> inv_Game g \<and> inv_PosSet ps \<and> ps = movesForPlayer g p"

definition
  pre_movesSoFar :: "Game \<Rightarrow> bool"
where
  "pre_movesSoFar g \<equiv> inv_Game g"

definition
  post_movesSoFar :: "Game  \<Rightarrow> Pos set \<Rightarrow> bool"
where
  "post_movesSoFar g ps \<equiv> inv_Game g \<and> inv_PosSet ps \<and> ps = movesSoFar g"

definition
  pre_movesCountSoFar :: "Game \<Rightarrow> bool"
where
  "pre_movesCountSoFar g \<equiv> inv_Game g"

definition
  post_movesCountSoFar :: "Game \<Rightarrow> nat \<Rightarrow> bool"
where
  "post_movesCountSoFar g n \<equiv> inv_Game g \<and> n = movesCountSoFar g" -- {* maybe add @{term "n > 0"}? *}

definition
  pre_movesCountLeft :: "Game \<Rightarrow> bool"
where
  "pre_movesCountLeft g \<equiv> inv_Game g"

definition
  post_movesCountLeft :: "Game \<Rightarrow> nat \<Rightarrow> bool"
where
  "post_movesCountLeft g n \<equiv> inv_Game g \<and> n = MAX - movesCountSoFar(g)"
                        -- {* should we call here pre_movesCountSoFar g; should @{text "n > 0"}? *}

(*-----------------------------------------------------------------------------------------*)
subsection {* Explicitly definined pre and post by the user *}

text {* When the user explicitly provides a pre and post condition, we need to be careful.
        We still need our implicit translations becasue of the type invariants, yet we also
        need the explicit definitions given by the user.
        Thus, we define both these as boolean functions with suffix I and without suffix:~the
        former for the type invariant, whereas the latter is for the external user's definition.
        The user defined translation must call the implicitly defined one in order to check the
        invariant holds.
 *}

definition
  pre_makeMoveI :: "Game \<Rightarrow> Player \<Rightarrow> Pos \<Rightarrow> bool"
where
  "pre_makeMoveI g p pos \<equiv> inv_Game g \<and> inv_Pos pos"

definition
  pre_makeMove :: "Game \<Rightarrow> Player \<Rightarrow> Pos \<Rightarrow> bool"
where
  "pre_makeMove g p pos \<equiv> pre_makeMoveI g p pos \<and> pos \<notin> movesSoFar g \<and> movesCountLeft g > 0"

text {* Note that for the postcondition we needed to make some changes. Firstly, the implicit
        (invariant checking) definition remains the same, whereas the implicit post condition
        does not generate a call to @{text "makeMove"} given there is a post condition.

        \textbf{TODO: simplify this? Yes, because makeMove doesn't have option either?
        Moreover, it would entail having all sorts of option types in general? THINK/ASK Nick/Cliff.}
*}

definition
  post_makeMoveI :: "Game \<Rightarrow> Player \<Rightarrow> Pos \<Rightarrow> Game \<Rightarrow> bool"
where
  "post_makeMoveI g p pos g' \<equiv> inv_Game g \<and> inv_Pos pos \<and> inv_Game g'"

definition
  post_makeMove :: "Game \<Rightarrow> Player \<Rightarrow> Pos \<Rightarrow> Game \<Rightarrow> bool"
where
  "post_makeMove g p pos g' \<equiv>
        post_makeMoveI g p pos g' \<and>
        pos \<notin> dom g \<and>
        movesCountSoFar g' = movesCountSoFar g - 1"
        -- {* no call to @{term "g' = makeMove g p pos"}! *}

(*
definition
  inv_GameOpt :: "Game option \<Rightarrow> bool"
where
  "inv_GameOpt g \<equiv> (case g of None \<Rightarrow> False | (Some gg) \<Rightarrow> inv_Game gg)"

definition
  post_makeMoveI :: "Game \<Rightarrow> Player \<Rightarrow> Pos \<Rightarrow> Game option \<Rightarrow> bool"
where
  "post_makeMoveI g p pos g' \<equiv> inv_Game g \<and> inv_Pos pos \<and> inv_GameOpt g'"

definition
  post_makeMoveE :: "Game \<Rightarrow> Player \<Rightarrow> Pos \<Rightarrow> Game option \<Rightarrow> bool"
where
  "post_makeMoveE g p pos g' \<equiv>
        post_makeMoveI g p pos g' \<and>
        pos \<notin> dom g \<and>
        g' \<noteq> None \<and>
        movesCountSoFar (the g') = movesCountSoFar g - 1"
*)

(*-----------------------------------------------------------------------------------------*)
subsection {* Implicitly defined pre and post for solution (boolean-valued) functions *}

text {* Boolean valued functions (or predicates) in VDM perhaps could have a simpler translation?
        Their very definition is already a postcondition
      *}

definition
  pre_hasWon :: "Game \<Rightarrow> Player \<Rightarrow> bool"
where
  "pre_hasWon g p \<equiv> inv_Game g"

definition
  post_hasWon :: "Game \<Rightarrow> Player \<Rightarrow> bool"
where
  "post_hasWon g p \<equiv> inv_Game g \<and> hasWon g p"

definition
  pre_isWon :: "Game \<Rightarrow> bool"
where
  "pre_isWon g \<equiv> inv_Game g"

definition
  post_isWon :: "Game \<Rightarrow> bool"
where
  "post_isWon g \<equiv> inv_Game g \<and> isWon g"

definition
  pre_whoWon :: "Game \<Rightarrow> bool"
where
  "pre_whoWon g \<equiv> inv_Game g"

definition
  pre_whoWonG :: "Game \<Rightarrow> bool"
where
  "pre_whoWonG g \<equiv> inv_Game g \<and> isWon g"

(* This one is not quite boolean valued, though :-) *)
definition
  post_whoWon :: "Game \<Rightarrow> Player \<Rightarrow> bool"
where
  "post_whoWon g p \<equiv> inv_Game g \<and> p = whoWon g"

definition
  post_whoWonG :: "Game \<Rightarrow> Player \<Rightarrow> bool"
where
  "post_whoWonG g p \<equiv> inv_Game g \<and> (\<exists>! x . hasWon g x \<and> x = p)"

definition
  pre_isDraw :: "Game \<Rightarrow> bool"
where
  "pre_isDraw g \<equiv> inv_Game g"

definition
  post_isDraw :: "Game \<Rightarrow> bool"
where
  "post_isDraw g \<equiv> inv_Game g \<and> isDraw g"

definition
  pre_isUnfinished :: "Game \<Rightarrow> bool"
where
  "pre_isUnfinished g \<equiv> inv_Game g"

definition
  post_isUnfinished :: "Game \<Rightarrow> bool"
where
  "post_isUnfinished g \<equiv> inv_Game g \<and> isUnfinished g"

(*=========================================================================================*)
section {* VDM pre and post condition definitions for operations *}

(*-----------------------------------------------------------------------------------------*)
subsection {* Implicitly defined pre and post for operations *}

(*-----------------------------------------------------------------------------------------*)
subsection {* Explicitly defined pre and post by the user for operations *}

definition
  pre_play :: "Game \<Rightarrow> PlayOrder \<Rightarrow> Moves \<Rightarrow> bool"
where
  "pre_play g po m \<equiv> inv_Game g \<and> inv_PlayOrder po \<and> inv_Moves m"

definition
  post_playI :: "Game \<Rightarrow> PlayOrder \<Rightarrow> Moves \<Rightarrow> (Game \<times> GameResult) \<Rightarrow> bool"
where
  "post_playI g po m RESULT \<equiv> inv_Game g \<and> inv_PlayOrder po \<and> inv_Moves m \<and> inv_Game (fst RESULT)"

(* Interesting: Game isn't talked about in the result? *)
definition
  post_play :: "Game \<Rightarrow> PlayOrder \<Rightarrow> Moves \<Rightarrow> (Game \<times> GameResult) \<Rightarrow> bool"
where
  "post_play g po m RESULT \<equiv>
       post_playI g po m RESULT \<and>
       (if (snd RESULT) = DRAW then
          isDraw g
       else if (snd RESULT) = UNFINISHED then
          isUnfinished g
       else
          (snd RESULT) = conv_playerToPlayOpt (whoWon g))"

(*=========================================================================================*)
section {* VDM proof obligations *}

(*-----------------------------------------------------------------------------------------*)
subsection {* Satisfiability *}

text {* From Overture proof obligations tools, we get these translated and proved *}

(*
(forall g:Game & isWon(g) =>
  exists1 p:Player & hasWon(g, p))
*)
lemma "\<forall> g . isWon g \<longrightarrow> (\<exists>! p . hasWon g p)"
unfolding isWon_def by simp

(*
(forall g:Game &
  pre_whoWonG(g) => exists p:Player & post_whoWonG(g, p))
*)
lemma "\<forall> g . pre_whoWonG g \<longrightarrow> (\<exists> p . post_whoWonG g p)"
unfolding pre_whoWonG_def post_whoWonG_def isWon_def by auto

(*<*)

(*-----------------------------------------------------------------------------------------*)
(*=========================================================================================*)

lemma "2 = (THE n . (n::nat) + 4 = 6)"
by auto

lemma "3 \<noteq> (THE n . (n::nat) + 4 = 6)"
by auto

lemma "1 = (THE n . n = (n::nat) + 0)"
apply auto
oops

lemma "1 = (THE n . n = (n::nat) + 1)"
apply auto
nitpick
oops

lemma "(x \<noteq> y \<and> a=b) = (\<not> (x = y \<or> a \<noteq> b))"
by auto

lemma "(x \<noteq> y \<and> a=b) = (\<not> (a = b \<longrightarrow> x = y))"
by auto

lemma "(\<forall> x \<in> S . \<not>(\<exists> y \<in> S . x \<noteq> y \<and> a=b)) = (\<forall> x \<in> S . \<not>(\<exists> y \<in> S . (\<not> (a = b \<longrightarrow> x = y))))"
by auto

lemma "(\<forall> x \<in> S . \<not>(\<exists> y \<in> S . x \<noteq> y \<and> a=b)) = (\<forall> x \<in> S . (\<forall> y \<in> S . ((a = b \<longrightarrow> x = y))))"
by auto

end
(*>*)


section\<open>Value Types\<close>

theory Valuetypes
imports ReadShow
begin

fun iter :: "(int \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> int \<Rightarrow> 'b"
where
  "iter f v x = (if x \<le> 0 then v
                 else f (x-1) (iter f v (x-1)))"

fun iter' :: "(int \<Rightarrow> 'b \<Rightarrow> 'b option) \<Rightarrow> 'b \<Rightarrow> int \<Rightarrow> 'b option"
where
  "iter' f v x = (if x \<le> 0 then Some v
                  else case iter' f v (x-1) of
                          Some v' \<Rightarrow> f (x-1) v'
                        | None \<Rightarrow> None)"

type_synonym Address = String.literal
type_synonym Location = String.literal
type_synonym Valuetype = String.literal

(*Covered*)
datatype Types = TSInt nat
               | TUInt nat
               | TBool
               | TAddr

(*Covered*)
fun createSInt :: "nat \<Rightarrow> int \<Rightarrow> Valuetype"
where
  "createSInt b v =
    (if v \<ge> 0
      then ShowL\<^sub>i\<^sub>n\<^sub>t (-(2^(b-1)) + (v+2^(b-1)) mod (2^b))
      else ShowL\<^sub>i\<^sub>n\<^sub>t (2^(b-1) - (-v+2^(b-1)-1) mod (2^b) - 1))"

lemma upper_bound:
  fixes b::nat
    and c::int
  assumes "b > 0"
      and "c < 2^(b-1)"
    shows "c + 2^(b-1) < 2^b"
proof -
  have a1: "\<And>P. (\<forall>b::nat. P b) \<Longrightarrow> (\<forall>b>0. P ((b-1)::nat))" by simp
  have b2: "\<forall>b::nat. (\<forall>(c::int)<2^b. (c + 2^b) < 2^(Suc b))" by simp
  show ?thesis using a1[OF b2] assms by simp
qed

lemma upper_bound2:
  fixes b::nat
      and c::int
    assumes "b > 0"
      and "c < 2^b"
      and "c \<ge> 0"
    shows "c - (2^(b-1)) < 2^(b-1)"
proof -
  have a1: "\<And>P. (\<forall>b::nat. P b) \<Longrightarrow> (\<forall>b>0. P ((b-1)::nat))" by simp
  have b2: "\<forall>b::nat. (\<forall>(c::int)<2^(Suc b). c\<ge>0 \<longrightarrow> (c - 2^b) < 2^b)" by simp
  show ?thesis using a1[OF b2] assms by simp
qed

lemma upper_bound3:
  fixes b::nat
    and v::int
      defines "x \<equiv> - (2 ^ (b - 1)) + (v + 2 ^ (b - 1)) mod 2 ^ b"
    assumes "b>0"
    shows "x < 2^(b-1)"
  using upper_bound2 assms by auto

lemma lower_bound:
    fixes b::nat
  assumes "b>0"
    shows "\<forall>(c::int) \<ge> -(2^(b-1)). (-c + 2^(b-1) - 1 < 2^b)"
proof -
  have a1: "\<And>P. (\<forall>b::nat. P b) \<Longrightarrow> (\<forall>b>0. P ((b-1)::nat))" by simp
  have b2: "\<forall>b::nat. \<forall>(c::int) \<ge> -(2^b). (-c + (2^b) - 1) < 2^(Suc b)" by simp
  show ?thesis using a1[OF b2] assms by simp
qed

lemma lower_bound2:
  fixes b::nat
    and v::int
      defines "x \<equiv> 2^(b - 1) - (-v+2^(b-1)-1) mod 2^b - 1"
    assumes "b>0"
    shows "x \<ge> - (2 ^ (b - 1))"
  using upper_bound2 assms by auto

lemma createSInt_id_g0:
    fixes b::nat
      and v::int
  assumes "v \<ge> 0"
      and "v < 2^(b-1)"
      and "b > 0"
    shows "createSInt b v = ShowL\<^sub>i\<^sub>n\<^sub>t v"
proof -
  from assms have "v + 2^(b-1) \<ge> 0" by simp
  moreover from assms have "v + (2^(b-1)) < 2^b" using upper_bound[of b] by auto
  ultimately have "(v + 2^(b-1)) mod (2^b) = v + 2^(b-1)" by simp
  moreover from assms have "createSInt b v=ShowL\<^sub>i\<^sub>n\<^sub>t (-(2^(b-1)) + (v+2^(b-1)) mod (2^b))" by simp
  ultimately show ?thesis by simp
qed

lemma createSInt_id_l0:
    fixes b::nat
      and v::int
  assumes "v < 0"
      and "v \<ge> -(2^(b-1))"
      and "b > 0"
    shows "createSInt b v = ShowL\<^sub>i\<^sub>n\<^sub>t v"
proof -
  from assms have "-v + 2^(b-1) - 1 \<ge> 0" by simp
  moreover from assms have "-v + 2^(b-1) - 1 < 2^b" using lower_bound[of b] by auto
  ultimately have "(-v + 2^(b-1) - 1) mod (2^b) = (-v + 2^(b-1) - 1)" by simp
  moreover from assms have "createSInt b v= ShowL\<^sub>i\<^sub>n\<^sub>t (2^(b-1) - (-v+2^(b-1)-1) mod (2^b) - 1)" by simp
  ultimately show ?thesis by simp
qed

lemma createSInt_id:
    fixes b::nat
      and v::int
  assumes "v < 2^(b-1)"
      and "v \<ge> -(2^(b-1))"
      and "b > 0"
    shows "createSInt b v = ShowL\<^sub>i\<^sub>n\<^sub>t v" using createSInt_id_g0 createSInt_id_l0 assms by simp

(*Covered*)
fun createUInt :: "nat \<Rightarrow> int \<Rightarrow> Valuetype"
  where "createUInt b v = ShowL\<^sub>i\<^sub>n\<^sub>t (v mod (2^b))"

lemma createUInt_id:
  assumes "v \<ge> 0"
      and "v < 2^b"
    shows "createUInt b v =  ShowL\<^sub>i\<^sub>n\<^sub>t v"
by (simp add: assms(1) assms(2))

fun createBool :: "bool \<Rightarrow> Valuetype"
where
  "createBool b = ShowL\<^sub>b\<^sub>o\<^sub>o\<^sub>l b"

fun createAddress :: "Address \<Rightarrow> Valuetype"
where
  "createAddress ad = ad"

fun convert :: "Types \<Rightarrow> Types \<Rightarrow> Valuetype \<Rightarrow> (Valuetype * Types) option"
where
  "convert (TSInt b1) (TSInt b2) v =
    (if b1 \<le> b2
      then Some (v, TSInt b2)
      else None)"
| "convert (TUInt b1) (TUInt b2) v =
    (if b1 \<le> b2
      then Some (v, TUInt b2)
      else None)"
| "convert (TUInt b1) (TSInt b2) v =
    (if b1 < b2
      then Some (v, TSInt b2)
      else None)"
| "convert TBool TBool v = Some (v, TBool)"
| "convert TAddr TAddr v = Some (v, TAddr)"
| "convert _ _ _ = None"

lemma convert_id[simp]:
  "convert tp tp kv = Some (kv, tp)"
    by (metis Types.exhaust convert.simps(1) convert.simps(2) convert.simps(4) convert.simps(5) order_refl)

(*Covered informally*)
fun olift ::
  "(int \<Rightarrow> int \<Rightarrow> int) \<Rightarrow> Types \<Rightarrow> Types \<Rightarrow> Valuetype \<Rightarrow> Valuetype \<Rightarrow> (Valuetype * Types) option"
where
  "olift op (TSInt b1) (TSInt b2) v1 v2 =
    Some (createSInt (max b1 b2) (op \<lceil>v1\<rceil> \<lceil>v2\<rceil>), TSInt (max b1 b2))"
| "olift op (TUInt b1) (TUInt b2) v1 v2 =
    Some (createUInt (max b1 b2) (op \<lceil>v1\<rceil> \<lceil>v2\<rceil>), TUInt (max b1 b2))"
| "olift op (TSInt b1) (TUInt b2) v1 v2 =
    (if b2 < b1
      then Some (createSInt b1 (op \<lceil>v1\<rceil> \<lceil>v2\<rceil>), TSInt b1)
      else None)"
| "olift op (TUInt b1) (TSInt b2) v1 v2 =
    (if b1 < b2
      then Some (createSInt b2 (op \<lceil>v1\<rceil> \<lceil>v2\<rceil>), TSInt b2)
      else None)"
| "olift _ _ _ _ _ = None"

(*Covered*)
fun plift ::
  "(int \<Rightarrow> int \<Rightarrow> bool) \<Rightarrow> Types \<Rightarrow> Types \<Rightarrow> Valuetype \<Rightarrow> Valuetype \<Rightarrow> (Valuetype * Types) option"
where
  "plift op (TSInt b1) (TSInt b2) v1 v2 = Some (createBool (op \<lceil>v1\<rceil> \<lceil>v2\<rceil>), TBool)"
| "plift op (TUInt b1) (TUInt b2) v1 v2 = Some (createBool (op \<lceil>v1\<rceil> \<lceil>v2\<rceil>), TBool)"
| "plift op (TSInt b1) (TUInt b2) v1 v2 =
    (if b2 < b1
      then Some (createBool (op \<lceil>v1\<rceil> \<lceil>v2\<rceil>), TBool)
      else None)"
| "plift op (TUInt b1) (TSInt b2) v1 v2 =
    (if b1 < b2
      then Some (createBool (op \<lceil>v1\<rceil> \<lceil>v2\<rceil>), TBool)
      else None)"
| "plift _ _ _ _ _ = None"

(*Covered*)
definition add :: "Types \<Rightarrow> Types \<Rightarrow> Valuetype \<Rightarrow> Valuetype \<Rightarrow> (Valuetype * Types) option"
where
  "add = olift (+)"

(*Covered informally*)
definition sub :: "Types \<Rightarrow> Types \<Rightarrow> Valuetype \<Rightarrow> Valuetype \<Rightarrow> (Valuetype * Types) option"
where
  "sub = olift (-)"

(*Covered informally*)
definition equal :: "Types \<Rightarrow> Types \<Rightarrow> Valuetype \<Rightarrow> Valuetype \<Rightarrow> (Valuetype * Types) option"
where
  "equal = plift (=)"

(*Covered informally*)
definition less :: "Types \<Rightarrow> Types \<Rightarrow> Valuetype \<Rightarrow> Valuetype \<Rightarrow> (Valuetype * Types) option"
where
  "less = plift (<)"

declare less_def [solidity_symbex]

(*Covered informally*)
definition leq :: "Types \<Rightarrow> Types \<Rightarrow> Valuetype \<Rightarrow> Valuetype \<Rightarrow> (Valuetype * Types) option"
where
  "leq = plift (\<le>)"

(*Covered*)
fun vtand :: "Types \<Rightarrow> Types \<Rightarrow> Valuetype \<Rightarrow> Valuetype \<Rightarrow> (Valuetype * Types) option"
where
  "vtand TBool TBool a b =
    (if a = ShowL\<^sub>b\<^sub>o\<^sub>o\<^sub>l True \<and> b = ShowL\<^sub>b\<^sub>o\<^sub>o\<^sub>l True then Some (ShowL\<^sub>b\<^sub>o\<^sub>o\<^sub>l True, TBool)
    else Some (ShowL\<^sub>b\<^sub>o\<^sub>o\<^sub>l False, TBool))"
| "vtand _ _ _ _ = None"

(*Covered informally*)
fun vtor :: "Types \<Rightarrow> Types \<Rightarrow> Valuetype \<Rightarrow> Valuetype \<Rightarrow> (Valuetype * Types) option"
where
  "vtor TBool TBool a b =
    (if a = ShowL\<^sub>b\<^sub>o\<^sub>o\<^sub>l False \<and> b = ShowL\<^sub>b\<^sub>o\<^sub>o\<^sub>l False
      then Some (ShowL\<^sub>b\<^sub>o\<^sub>o\<^sub>l False, TBool)
      else Some (ShowL\<^sub>b\<^sub>o\<^sub>o\<^sub>l True, TBool))"
| "vtor _ _ _ _ = None"

(*Covered informally*)
fun ival :: "Types \<Rightarrow> Valuetype"
where
  "ival (TSInt x) = ShowL\<^sub>i\<^sub>n\<^sub>t 0"
| "ival (TUInt x) = ShowL\<^sub>i\<^sub>n\<^sub>t 0"
| "ival TBool = ShowL\<^sub>b\<^sub>o\<^sub>o\<^sub>l False"
| "ival TAddr = STR ''0x0000000000000000000000000000000000000000''"

end


(*
  Boolean Expression Checkers Based on Binary Decision Trees
  Author: Tobias Nipkow
*)

theory Boolean_Expression_Checkers
  imports Main "HOL-Library.Mapping"
  "../../../../SeLFiE"
begin

section \<open>Tautology (etc) Checking via Binary Decision Trees\<close>

subsection \<open>Binary Decision Trees\<close>

datatype 'a ifex = Trueif | Falseif | IF 'a "'a ifex" "'a ifex"

fun val_ifex :: "'a ifex \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
where
  "val_ifex Trueif s = True"
| "val_ifex Falseif s = False"
| "val_ifex (IF n t1 t2) s = (if s n then val_ifex t1 s else val_ifex t2 s)"

subsubsection \<open>Environment\<close>

text \<open>Environments are substitutions of values for variables:\<close>

type_synonym 'a env_bool = "('a, bool) mapping"

definition agree :: "('a \<Rightarrow> bool) \<Rightarrow> 'a env_bool \<Rightarrow> bool"
where
  "agree s env = (\<forall>x b. Mapping.lookup env x = Some b \<longrightarrow> s x = b)"

lemma agree_Nil:
  "agree s Mapping.empty"
  by (simp add: agree_def lookup_empty)

lemma lookup_update_unfold:
  "Mapping.lookup (Mapping.update k v m) k' = (if k = k' then Some v else Mapping.lookup m k')"
  using lookup_update lookup_update_neq by metis

lemma agree_Cons:
  "x \<notin> Mapping.keys env \<Longrightarrow> agree s (Mapping.update x b env) = ((if b then s x else \<not> s x) \<and> agree s env)"
  by (simp add: agree_def lookup_update_unfold; unfold keys_is_none_rep lookup_update_unfold Option.is_none_def; blast)

lemma agreeDT:
  "agree s env \<Longrightarrow> Mapping.lookup env x = Some True \<Longrightarrow> s x"
  by (simp add: agree_def)

lemma agreeDF:
  "agree s env \<Longrightarrow> Mapping.lookup env x = Some False \<Longrightarrow> \<not>s x"
  by (auto simp add: agree_def)

subsection \<open>Recursive Tautology Checker\<close>

text \<open>Provided for completeness. However, it is recommend to use the checkers based on reduced trees.\<close>

fun taut_test_rec :: "'a ifex \<Rightarrow> 'a env_bool \<Rightarrow> bool"
where
  "taut_test_rec Trueif env = True"
| "taut_test_rec Falseif env = False"
| "taut_test_rec (IF x t1 t2) env = (case Mapping.lookup env x of
  Some b \<Rightarrow> taut_test_rec (if b then t1 else t2) env |
  None \<Rightarrow> taut_test_rec t1 (Mapping.update x True env) \<and> taut_test_rec t2 (Mapping.update x False env))"

lemma taut_test_rec:
  "taut_test_rec t env = (\<forall>s. agree s env \<longrightarrow> val_ifex t s)"semantic_induct
proof (induction t arbitrary: env)
  case Falseif
    have "agree (\<lambda>x. the (Mapping.lookup env x)) env"
      by (auto simp: agree_def)
    thus ?case
      by auto
next
  case (IF x t1 t2)
    thus ?case
    proof (cases "Mapping.lookup env x")
      case None
        with IF show ?thesis
          by simp (metis is_none_simps(1) agree_Cons keys_is_none_rep)
    qed (simp add: agree_def)
qed simp

definition taut_test_ifex :: "'a ifex \<Rightarrow> bool"
where
  "taut_test_ifex t = taut_test_rec t Mapping.empty"

corollary taut_test_ifex:
  "taut_test_ifex t = (\<forall>s. val_ifex t s)"
  by (auto simp: taut_test_ifex_def taut_test_rec agree_Nil)

subsection \<open>Reduced Binary Decision Trees\<close>

subsubsection \<open>Normalisation\<close>

text \<open>A normalisation avoiding duplicate variables and collapsing @{term "If x t t"} to \<open>t\<close>.\<close>

definition mkIF :: "'a \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex"
where
  "mkIF x t1 t2 = (if t1=t2 then t1 else IF x t1 t2)"

fun reduce :: "'a env_bool \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex"
where
  "reduce env (IF x t1 t2) = (case Mapping.lookup env x of
     None \<Rightarrow> mkIF x (reduce (Mapping.update x True env) t1) (reduce (Mapping.update x False env) t2) |
     Some b \<Rightarrow> reduce env (if b then t1 else t2))"
| "reduce _ t = t"

primrec normif :: "'a env_bool \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex"
where
  "normif env Trueif t1 t2 = reduce env t1"
| "normif env Falseif t1 t2 = reduce env t2"
| "normif env (IF x t1 t2) t3 t4 =
    (case Mapping.lookup env x of
       None \<Rightarrow> mkIF x (normif (Mapping.update x True env) t1 t3 t4) (normif (Mapping.update x False env) t2 t3 t4) |
       Some b \<Rightarrow> if b then normif env t1 t3 t4 else normif env t2 t3 t4)"

subsubsection \<open>Functional Correctness Proof\<close>

lemma val_mkIF:
  "val_ifex (mkIF x t1 t2) s = val_ifex (IF x t1 t2) s"
  by (auto simp: mkIF_def Let_def)

theorem val_reduce:
  "agree s env \<Longrightarrow> val_ifex (reduce env t) s = val_ifex t s"semantic_induct
  by (induction t arbitrary: s env)
     (auto simp: map_of_eq_None_iff val_mkIF agree_Cons Let_def keys_is_none_rep
           dest: agreeDT agreeDF split: option.splits)

lemma val_normif:
  "agree s env \<Longrightarrow> val_ifex (normif env t t1 t2) s = val_ifex (if val_ifex t s then t1 else t2) s"semantic_induct
  by (induct t arbitrary: t1 t2 s env)
     (auto simp: val_reduce val_mkIF agree_Cons map_of_eq_None_iff keys_is_none_rep
           dest: agreeDT agreeDF split: option.splits)

subsubsection \<open>Reduced If-Expressions\<close>

text \<open>An expression reduced iff no variable appears twice on any branch and there is no subexpression @{term "IF x t t"}.\<close>

fun reduced :: "'a ifex \<Rightarrow> 'a set \<Rightarrow> bool" where
"reduced (IF x t1 t2) X =
  (x \<notin> X \<and> t1 \<noteq> t2 \<and> reduced t1 (insert x X) \<and> reduced t2 (insert x X))" |
"reduced _ _ = True"

lemma reduced_antimono:
  "X \<subseteq> Y \<Longrightarrow> reduced t Y \<Longrightarrow> reduced t X"semantic_induct
  by (induction t arbitrary: X Y)
     (auto, (metis insert_mono)+)

lemma reduced_mkIF:
  "x \<notin> X \<Longrightarrow> reduced t1 (insert x X) \<Longrightarrow> reduced t2 (insert x X) \<Longrightarrow> reduced (mkIF x t1 t2) X"
  by (auto simp: mkIF_def intro:reduced_antimono)

lemma reduced_reduce:
  "reduced (reduce env t) (Mapping.keys env)"semantic_induct
proof(induction t arbitrary: env)
  case (IF x t1 t2)
    thus ?case
      using IF.IH(1) IF.IH(2)
      apply (auto simp: map_of_eq_None_iff image_iff reduced_mkIF split: option.split)
      by (metis is_none_code(1) keys_is_none_rep keys_update reduced_mkIF)
qed auto

lemma reduced_normif:
  "reduced (normif env t t1 t2) (Mapping.keys env)"semantic_induct
proof(induction t arbitrary: t1 t2 env)
  case (IF x s1 s2)
  thus ?case using IF.IH
    apply (auto simp: reduced_mkIF map_of_eq_None_iff split: option.split)
    by (metis is_none_code(1) keys_is_none_rep keys_update reduced_mkIF)
qed (auto simp: reduced_reduce)

subsubsection \<open>Checkers Based on Reduced Binary Decision Trees\<close>

text \<open>The checkers are parameterized over the translation function to binary decision trees.
  They rely on the fact that @{term ifex_of} produces reduced trees\<close>

definition taut_test :: "('a \<Rightarrow> 'b ifex) \<Rightarrow> 'a \<Rightarrow> bool"
where
  "taut_test ifex_of b = (ifex_of b = Trueif)"

definition sat_test :: "('a \<Rightarrow> 'b ifex) \<Rightarrow> 'a \<Rightarrow> bool"
where
  "sat_test ifex_of b = (ifex_of b \<noteq> Falseif)"

definition impl_test :: "('a \<Rightarrow> 'b ifex) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "impl_test ifex_of b1 b2 = (normif Mapping.empty (ifex_of b1) (ifex_of b2) Trueif = Trueif)"

definition equiv_test :: "('a \<Rightarrow> 'b ifex) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "equiv_test ifex_of b1 b2 = (let t1 = ifex_of b1; t2 = ifex_of b2
    in Trueif = normif Mapping.empty t1 t2 (normif Mapping.empty t2 Falseif Trueif))"

locale reduced_bdt_checkers =
  fixes
    ifex_of :: "'b \<Rightarrow> 'a ifex"
  fixes
    val :: "'b \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
  assumes
    val_ifex: "val_ifex (ifex_of b) s = val b s"
  assumes
    reduced_ifex: "reduced (ifex_of b) {}"
begin

text \<open>Proof that reduced if-expressions are @{const Trueif}, @{const Falseif}
or can evaluate to both @{const True} and @{const False}.\<close>

lemma same_val_if_reduced:
  "reduced t X \<Longrightarrow> \<forall>x. x \<notin> X \<longrightarrow> s1 x = s2 x \<Longrightarrow> val_ifex t s1 = val_ifex t s2"semantic_induct
  all_induction_heuristic      [on[], arb[],rule[]]
  all_generalization_heuristic [on[], arb[],rule[]]
  by (induction t arbitrary: X) auto

lemma reduced_IF_depends:
  "\<lbrakk> reduced t X; t \<noteq> Trueif; t \<noteq> Falseif \<rbrakk> \<Longrightarrow> \<exists>s1 s2. val_ifex t s1 \<noteq> val_ifex t s2"semantic_induct
proof(induction t arbitrary: X)
  case (IF x t1 t2)
  let ?t = "IF x t1 t2"
  have 1: "reduced t1 (insert x X)" using IF.prems(1) by simp
  have 2: "reduced t2 (insert x X)" using IF.prems(1) by simp
  show ?case
  proof(cases t1)
    case [simp]: Trueif
    show ?thesis
    proof (cases t2)
      case Trueif thus ?thesis using IF.prems(1) by simp
    next
      case Falseif
      hence "val_ifex ?t (\<lambda>_. True) \<noteq> val_ifex ?t (\<lambda>_. False)" by simp
      thus ?thesis by blast
    next
      case IF
      then obtain s1 s2 where "val_ifex t2 s1 \<noteq> val_ifex t2 s2"
        using IF.IH(2)[OF 2] IF.prems(1) by auto
      hence "val_ifex ?t (s1(x:=False)) \<noteq> val_ifex ?t (s2(x:=False))"
        using same_val_if_reduced[OF 2, of "s1(x:=False)" s1]
          same_val_if_reduced[OF 2, of "s2(x:=False)" s2] by simp
      thus ?thesis by blast
    qed
  next
    case [simp]: Falseif
    show ?thesis
    proof (cases t2)
      case Falseif thus ?thesis using IF.prems(1) by simp
    next
      case Trueif
      hence "val_ifex ?t (\<lambda>_. True) \<noteq> val_ifex ?t (\<lambda>_. False)" by simp
      thus ?thesis by blast
    next
      case IF
      then obtain s1 s2 where "val_ifex t2 s1 \<noteq> val_ifex t2 s2"
        using IF.IH(2)[OF 2] IF.prems(1) by auto
      hence "val_ifex ?t (s1(x:=False)) \<noteq> val_ifex ?t (s2(x:=False))"
        using same_val_if_reduced[OF 2, of "s1(x:=False)" s1]
          same_val_if_reduced[OF 2, of "s2(x:=False)" s2] by simp
      thus ?thesis by blast
    qed
  next
    case IF
    then obtain s1 s2 where "val_ifex t1 s1 \<noteq> val_ifex t1 s2"
      using IF.IH(1)[OF 1] IF.prems(1) by auto
    hence "val_ifex ?t (s1(x:=True)) \<noteq> val_ifex ?t (s2(x:=True))"
      using same_val_if_reduced[OF 1, of "s1(x:=True)" s1]
          same_val_if_reduced[OF 1, of "s2(x:=True)" s2] by simp
    thus ?thesis by blast
  qed
qed auto

corollary taut_test:
  "taut_test ifex_of b = (\<forall>s. val b s)"
  by (metis taut_test_def reduced_IF_depends[OF reduced_ifex] val_ifex val_ifex.simps(1,2))

corollary sat_test:
  "sat_test ifex_of b = (\<exists>s. val b s)"
  by (metis sat_test_def reduced_IF_depends[OF reduced_ifex] val_ifex val_ifex.simps(1,2))

corollary impl_test:
  "impl_test ifex_of b1 b2 = (\<forall>s. val b1 s \<longrightarrow> val b2 s)"
proof -
  have "impl_test ifex_of b1 b2 = (\<forall>s. val_ifex (normif Mapping.empty (ifex_of b1) (ifex_of b2) Trueif) s)"
    using reduced_IF_depends[OF reduced_normif] by (fastforce  simp: impl_test_def)
  also
  have "(\<forall>s. val_ifex (normif Mapping.empty (ifex_of b1) (ifex_of b2) Trueif) s) \<longleftrightarrow> (\<forall>s. val b1 s \<longrightarrow> val b2 s)"
    using reduced_IF_depends[OF reduced_ifex] val_ifex unfolding val_normif[OF agree_Nil] by simp
  finally
  show ?thesis .
qed

corollary equiv_test:
  "equiv_test ifex_of b1 b2 = (\<forall>s. val b1 s = val b2 s)"
proof -
  have "equiv_test ifex_of b1 b2 = (\<forall>s. val_ifex (let t1 = ifex_of b1; t2 = ifex_of b2 in normif Mapping.empty t1 t2 (normif Mapping.empty t2 Falseif Trueif)) s)"
    by (simp add: equiv_test_def Let_def; insert reduced_IF_depends[OF reduced_normif]; force)
  moreover
  {
    fix s
    have "val_ifex (let t1 = ifex_of b1; t2 = ifex_of b2 in normif Mapping.empty t1 t2 (normif Mapping.empty t2 Falseif Trueif)) s
      = (val b1 s = val b2 s)"
      using val_ifex by (simp add: Let_def val_normif[OF agree_Nil])
  }
  ultimately
  show ?thesis
    by blast
qed

end

subsection \<open>Boolean Expressions\<close>

text \<open>This is the simplified interface to the tautology checker. If you have your own type of Boolean
expressions you can either define your own translation to reduced binary decision trees or you can just
translate into this type.\<close>

datatype 'a bool_expr =
  Const_bool_expr bool |
  Atom_bool_expr 'a |
  Neg_bool_expr "'a bool_expr" |
  And_bool_expr "'a bool_expr" "'a bool_expr" |
  Or_bool_expr "'a bool_expr" "'a bool_expr" |
  Imp_bool_expr "'a bool_expr" "'a bool_expr" |
  Iff_bool_expr "'a bool_expr" "'a bool_expr"

primrec val_bool_expr :: "'a bool_expr \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
"val_bool_expr (Const_bool_expr b) s = b" |
"val_bool_expr (Atom_bool_expr x) s = s x" |
"val_bool_expr (Neg_bool_expr b) s = (\<not> val_bool_expr b s)" |
"val_bool_expr (And_bool_expr b1 b2) s = (val_bool_expr b1 s \<and> val_bool_expr b2 s)" |
"val_bool_expr (Or_bool_expr b1 b2) s = (val_bool_expr b1 s \<or> val_bool_expr b2 s)" |
"val_bool_expr (Imp_bool_expr b1 b2) s = (val_bool_expr b1 s \<longrightarrow> val_bool_expr b2 s)" |
"val_bool_expr (Iff_bool_expr b1 b2) s = (val_bool_expr b1 s = val_bool_expr b2 s)"

fun ifex_of :: "'a bool_expr \<Rightarrow> 'a ifex" where
"ifex_of (Const_bool_expr b) = (if b then Trueif else Falseif)" |
"ifex_of (Atom_bool_expr x)   = IF x Trueif Falseif" |
"ifex_of (Neg_bool_expr b)   = normif Mapping.empty (ifex_of b) Falseif Trueif" |
"ifex_of (And_bool_expr b1 b2) = normif Mapping.empty (ifex_of b1) (ifex_of b2) Falseif" |
"ifex_of (Or_bool_expr b1 b2) = normif Mapping.empty (ifex_of b1) Trueif (ifex_of b2)" |
"ifex_of (Imp_bool_expr b1 b2) = normif Mapping.empty (ifex_of b1) (ifex_of b2) Trueif" |
"ifex_of (Iff_bool_expr b1 b2) = (let t1 = ifex_of b1; t2 = ifex_of b2 in
   normif Mapping.empty t1 t2 (normif Mapping.empty t2 Falseif Trueif))"

theorem val_ifex:
  "val_ifex (ifex_of b) s = val_bool_expr b s"
  by (induct_tac b) (auto simp: val_normif agree_Nil Let_def)

theorem reduced_ifex:
  "reduced (ifex_of b) {}"semantic_induct
  by (induction b) (simp add: Let_def; metis keys_empty reduced_normif)+

definition "bool_taut_test \<equiv> taut_test ifex_of"
definition "bool_sat_test \<equiv> sat_test ifex_of"
definition "bool_impl_test \<equiv> impl_test ifex_of"
definition "bool_equiv_test \<equiv> equiv_test ifex_of"

lemma bool_tests:
  "bool_taut_test b = (\<forall>s. val_bool_expr b s)" (is ?t1)
  "bool_sat_test b = (\<exists>s. val_bool_expr b s)" (is ?t2)
  "bool_impl_test b1 b2 = (\<forall>s. val_bool_expr b1 s \<longrightarrow> val_bool_expr b2 s)" (is ?t3)
  "bool_equiv_test b1 b2 = (\<forall>s. val_bool_expr b1 s \<longleftrightarrow> val_bool_expr b2 s)" (is ?t4)
proof -
  interpret reduced_bdt_checkers ifex_of val_bool_expr
    by (unfold_locales; insert val_ifex reduced_ifex; blast)
  show ?t1 ?t2 ?t3 ?t4
    by (simp_all add: bool_taut_test_def bool_sat_test_def bool_impl_test_def bool_equiv_test_def taut_test sat_test impl_test equiv_test)
qed

end


theory hw6
  imports
Complex_Main
  "HOL-Library.Multiset"
begin
fun insert :: "nat \<Rightarrow> nat list \<Rightarrow> nat list"
  where
 "insert a [] = [a]"
|"insert a (x#xs) =
(if a \<le> x then a#x#xs else x#insert a xs)"

thm insert.elims
value "insert 7 [328,4,6,78]"

fun sort :: "nat list \<Rightarrow> nat list"
  where
  "sort [] = []"
| "sort (x#xs) = insert x (sort xs)"

value "sort [3,7,34,6,0,3,4]"

fun isort_key :: "('a \<Rightarrow> 'k::linorder) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"isort_key f [] = []" |
"isort_key f (x # xs) = insort_key f x (isort_key f xs)"

fun find_eq :: "nat \<Rightarrow> nat list \<Rightarrow> bool"
  where
  "find_eq a [] = False"
| "find_eq a (x#xs) = (if (x=a) then True else find_eq a xs)"

fun equal :: "nat list \<Rightarrow> nat list \<Rightarrow> bool"
  where
 "equal [] [] = True" |
 "equal [] (y#ys) = False" |
 "equal (x#xs) ys = ( (find_eq x ys) \<and> equal xs (remove1 x ys))"

lemma "equal x x"
proof(induction x)
 case Nil
  then show ?case by simp
next
  case (Cons a x)
  then show ?case by simp
qed

lemma "equal x y = equal y x"
proof(induction x)
  case Nil
  then show ?case proof(induction y)
    case Nil
    then show ?case by simp
  next
    case (Cons a y)
    then show ?case by simp
  qed
next
  case (Cons a x)
  then show ?case proof(induction y)
    case Nil
    then show ?case  by simp
  next
    case (Cons a y)
    then show ?case   sorry

  qed
qed

lemma "(equal x y \<and> equal y z) \<Longrightarrow> equal x z"
proof(induct x)
  case Nil
  then show ?case proof(induct z)
    case Nil
    then show ?case by simp
  next
    case (Cons a z)
    then show ?case
    proof -
      show ?thesis
        by (metis (no_types) Cons.prems equal.simps(2) sort.cases)
    qed
  qed
next
  case (Cons a x)
  then show ?case proof(induct z)
    case Nil
    then show ?case
    proof -
      show ?thesis
        by (metis (no_types) Nil.prems(2) equal.elims(2) find_eq.simps(1))
    qed
  next
    case (Cons a z)
    then show ?case sorry
  qed
qed

lemma "sort (sort x) = sort x"

proof(induct x)
  case Nil
  then show ?case by simp
next
  case (Cons a x)
  then show ?case sorry
qed

lemma sorted_isort_key: "sorted (map f (isort_key f xs))"
by(induction xs)(simp_all add: sorted_insort_key)
lemma filter_insort_key_neg:
  "\<not> P x \<Longrightarrow> filter P (insort_key f x xs) = filter P xs"
by (induction xs) simp_all

lemma filter_insort_key_pos:
  "sorted (map f xs) \<Longrightarrow> P x \<Longrightarrow> filter P (insort_key f x xs) = insort_key f x (filter P xs)"
  by (induction xs) (auto, subst insort_is_Cons, auto)

lemma sort_key_stable: "filter (\<lambda>y. f y = k) (isort_key f xs) = filter (\<lambda>y. f y = k) xs"
proof (induction xs)
  case Nil thus ?case by simp
next
  case (Cons a xs)
  thus ?case
  proof (cases "f a = k")
    case False thus ?thesis  by (simp add: Cons.IH filter_insort_key_neg)
  next
    case True
    have "filter (\<lambda>y. f y = k) (isort_key f (a # xs))
      = filter (\<lambda>y. f y = k) (insort_key f a (isort_key f xs))"  by simp
    also have "\<dots> = insort_key f a (filter (\<lambda>y. f y = k) (isort_key f xs))"
      by (simp add: True filter_insort_key_pos sorted_isort_key)
    also have "\<dots> = insort_key f a (filter (\<lambda>y. f y = k) xs)"  by (simp add: Cons.IH)
    also have "\<dots> = a # (filter (\<lambda>y. f y = k) xs)"  by(simp add: True insort_is_Cons)
    also have "\<dots> = filter (\<lambda>y. f y = k) (a # xs)" by (simp add: True)
    finally show ?thesis .
  qed
qed

lemma assumes T : "\<forall> x y. T x y \<or> T y x"
and A: "\<forall> x y. A x y \<and> A y x \<longrightarrow> x = y"
and TA: "\<forall> x y. T x y \<longrightarrow> A x y" and "A x y"
shows "T x y"
  using A T TA assms(4) by blast

lemma "\<exists> ys zs. xs = ys @ zs \<and>
(length ys = length zs \<or> length ys = length zs + 1)"
oops

inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS : "ev n \<Longrightarrow> ev (Suc(Suc n))"

lemma assumes a: "ev (Suc(Suc n))" shows "ev n"
proof -
  obtain nn :: "nat \<Rightarrow> nat" where
    "Suc (Suc n) = Suc (Suc (nn (Suc (Suc n)))) \<and> ev (nn (Suc (Suc n)))"
    by (metis (no_types) assms ev.cases old.nat.distinct(2))
  then show ?thesis
    by (metis Suc_inject)
qed

lemma "\<not> ev (Suc (Suc (Suc 0)))"
proof -
  have "\<forall>n na. Suc n \<noteq> Suc na \<or> n = na"
    by (meson Suc_inject)
then show ?thesis
by (metis (no_types) ev.simps old.nat.distinct(2))
qed
end