(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory Eval_Bool

imports Try_Methods

begin

text \<open>The eval_bool method/simproc uses the code generator setup to
reduce terms of boolean type to True or False. Reducing booleans to
True or False is nearly always desirable, and is a fairly good heuristic
for when to make use of definitions/code-equations.

Additional simprocs exist to reduce other types.
\<close>

ML \<open>
structure Eval_Simproc = struct

exception Failure

fun mk_constname_tab ts = fold Term.add_const_names ts []
  |> Symtab.make_set

fun is_built_from tab t = case Term.strip_comb t of
    (Const (cn, _), ts) => Symtab.defined tab cn
        andalso forall (is_built_from tab) ts
  | _ => false

fun eval tab ctxt ct = let
    val t = Thm.term_of ct
    val _ = Term.fold_aterms (fn Free _ => raise Failure
      | Var _ => raise Failure | _ => ignore) t ()
    val _ = not (is_built_from tab t) orelse raise Failure
    val ev = the (try (Code_Simp.dynamic_conv ctxt) ct)
  in if is_built_from tab (Thm.term_of (Thm.rhs_of ev))
    then SOME ev else NONE end
  handle Failure => NONE | Option => NONE

val eval_bool = eval (mk_constname_tab [@{term "True"}, @{term "False"}])
val eval_nat = eval (mk_constname_tab [@{term "Suc 0"}, @{term "Suc 1"},
    @{term "Suc 9"}])
val eval_int = eval (mk_constname_tab [@{term "0 :: int"}, @{term "1 :: int"},
    @{term "18 :: int"}, @{term "(-9) :: int"}])

val eval_bool_simproc = Simplifier.make_simproc @{context} "eval_bool"
  { lhss = [@{term "b :: bool"}], proc = K eval_bool }
val eval_nat_simproc = Simplifier.make_simproc @{context} "eval_nat"
  { lhss = [@{term "n :: nat"}], proc = K eval_nat }
val eval_int_simproc = Simplifier.make_simproc @{context} "eval_int"
  { lhss = [@{term "i :: int"}], proc = K eval_int }

end
\<close>

method_setup eval_bool = \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD'
    (CHANGED o full_simp_tac (clear_simpset ctxt
        addsimprocs [Eval_Simproc.eval_bool_simproc])))\<close>
    "use code generator setup to simplify booleans in goals to True or False"

method_setup eval_int_nat = \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD'
    (CHANGED o full_simp_tac (clear_simpset ctxt
        addsimprocs [Eval_Simproc.eval_nat_simproc, Eval_Simproc.eval_int_simproc])))\<close>
    "use code generator setup to simplify nats and ints in goals to values"

add_try_method eval_bool

text \<open>Testing.\<close>
definition
  eval_bool_test_seq :: "int list"
where
  "eval_bool_test_seq = [2, 3, 4, 5, 6, 7, 8]"

lemma
  "eval_bool_test_seq ! 4 = 6 \<and> (3 :: nat) < 4
    \<and> sorted eval_bool_test_seq"
  by eval_bool

text \<open>
A related gadget for installing constant definitions from locales
as code equations. Useful where locales are being used to "hide"
constants from the global state rather than to do anything tricky
with interpretations.

Installing the global definitions in this way will allow eval_bool
etc to "see through" the hiding and decide questions about these
constants.
\<close>

ML \<open>
structure Add_Locale_Code_Defs = struct

fun get_const_defs thy nm = Sign.consts_of thy
  |> Consts.dest |> #constants
  |> map fst
  |> filter (fn s => case Long_Name.explode s of
        [_, nm', _] => nm' = nm | _ => false)
  |> map_filter (try (suffix "_def" #> Global_Theory.get_thm thy))
  |> filter (Thm.strip_shyps #> Thm.shyps_of #> null)
  |> tap (fn xs => tracing ("Installing " ^ string_of_int (length xs) ^ " code defs"))

fun setup nm thy = fold (fn t => Code.add_eqn_global (t, true))
    (get_const_defs thy nm) thy

end
\<close>

locale eval_bool_test_locale begin

definition
  "x == (12 :: int)"

definition
  "y == (13 :: int)"

definition
  "z = (x * y) + x + y"

end

setup \<open>Add_Locale_Code_Defs.setup "eval_bool_test_locale"\<close>

lemma "eval_bool_test_locale.z > 150"
  by eval_bool

end


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

This implements Rajeev Gore's sequent calculus for S43.
*)

theory S43
imports Modal0
begin

consts
  S43pi :: "[seq'\<Rightarrow>seq', seq'\<Rightarrow>seq', seq'\<Rightarrow>seq',
             seq'\<Rightarrow>seq', seq'\<Rightarrow>seq', seq'\<Rightarrow>seq'] \<Rightarrow> prop"
syntax
  "_S43pi" :: "[seq, seq, seq, seq, seq, seq] \<Rightarrow> prop"
                         ("S43pi((_);(_);(_);(_);(_);(_))" [] 5)

parse_translation \<open>
  let
    val tr  = seq_tr;
    fun s43pi_tr [s1, s2, s3, s4, s5, s6] =
      Const (@{const_syntax S43pi}, dummyT) $ tr s1 $ tr s2 $ tr s3 $ tr s4 $ tr s5 $ tr s6;
  in [(@{syntax_const "_S43pi"}, K s43pi_tr)] end
\<close>

print_translation \<open>
let
  val tr' = seq_tr';
  fun s43pi_tr' [s1, s2, s3, s4, s5, s6] =
    Const(@{syntax_const "_S43pi"}, dummyT) $ tr' s1 $ tr' s2 $ tr' s3 $ tr' s4 $ tr' s5 $ tr' s6;
in [(@{const_syntax S43pi}, K s43pi_tr')] end
\<close>

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

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

(* Set of Horn clauses to generate the antecedents for the S43 pi rule       *)
(* ie                                                                        *)
(*           S1...Sk,Sk+1...Sk+m                                             *)
(*     ----------------------------------                                    *)
(*     <>P1...<>Pk, $G \<turnstile> $H, []Q1...[]Qm                                    *)
(*                                                                           *)
(*  where Si == <>P1...<>Pi-1,<>Pi+1,..<>Pk,Pi, $G * \<turnstile> $H *, []Q1...[]Qm    *)
(*    and Sj == <>P1...<>Pk, $G * \<turnstile> $H *, []Q1...[]Qj-1,[]Qj+1...[]Qm,Qj    *)
(*    and 1<=i<=k and k<j<=k+m                                               *)

  S43pi0:         "S43pi $L;; $R;; $Lbox; $Rdia" and
  S43pi1:
   "\<lbrakk>(S43pi <>P,$L';     $L;; $R; $Lbox;$Rdia);   $L',P,$L,$Lbox \<turnstile> $R,$Rdia\<rbrakk> \<Longrightarrow>
       S43pi     $L'; <>P,$L;; $R; $Lbox;$Rdia" and
  S43pi2:
   "\<lbrakk>(S43pi $L';; []P,$R';     $R; $Lbox;$Rdia);  $L',$Lbox \<turnstile> $R',P,$R,$Rdia\<rbrakk> \<Longrightarrow>
       S43pi $L';;     $R'; []P,$R; $Lbox;$Rdia" and

(* Rules for [] and <> for S43 *)

  boxL:           "$E, P, $F, []P \<turnstile> $G \<Longrightarrow> $E, []P, $F \<turnstile> $G" and
  diaR:           "$E \<turnstile> $F, P, $G, <>P \<Longrightarrow> $E \<turnstile> $F, <>P, $G" and
  pi1:
   "\<lbrakk>$L1,<>P,$L2 |L> $Lbox;  $L1,<>P,$L2 |R> $Ldia;  $R |L> $Rbox;  $R |R> $Rdia;
      S43pi ; $Ldia;; $Rbox; $Lbox; $Rdia\<rbrakk> \<Longrightarrow>
   $L1, <>P, $L2 \<turnstile> $R" and
  pi2:
   "\<lbrakk>$L |L> $Lbox;  $L |R> $Ldia;  $R1,[]P,$R2 |L> $Rbox;  $R1,[]P,$R2 |R> $Rdia;
      S43pi ; $Ldia;; $Rbox; $Lbox; $Rdia\<rbrakk> \<Longrightarrow>
   $L \<turnstile> $R1, []P, $R2"

ML \<open>
structure S43_Prover = Modal_ProverFun
(
  val rewrite_rls = @{thms rewrite_rls}
  val safe_rls = @{thms safe_rls}
  val unsafe_rls = @{thms unsafe_rls} @ [@{thm pi1}, @{thm pi2}]
  val bound_rls = @{thms bound_rls} @ [@{thm boxL}, @{thm diaR}]
  val aside_rls = [@{thm lstar0}, @{thm lstar1}, @{thm lstar2}, @{thm rstar0},
    @{thm rstar1}, @{thm rstar2}, @{thm S43pi0}, @{thm S43pi1}, @{thm S43pi2}]
)
\<close>

method_setup S43_solve = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD
    (S43_Prover.solve_tac ctxt 2 ORELSE S43_Prover.solve_tac ctxt 3))
\<close>

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

lemma "\<turnstile> []P \<longrightarrow> P" by S43_solve
lemma "\<turnstile> [](P \<longrightarrow> Q) \<longrightarrow> ([]P \<longrightarrow> []Q)" by S43_solve   (* normality*)
lemma "\<turnstile> (P--<Q) \<longrightarrow> []P \<longrightarrow> []Q" by S43_solve
lemma "\<turnstile> P \<longrightarrow> <>P" by S43_solve

lemma "\<turnstile>  [](P \<and> Q) \<longleftrightarrow> []P \<and> []Q" by S43_solve
lemma "\<turnstile>  <>(P \<or> Q) \<longleftrightarrow> <>P \<or> <>Q" by S43_solve
lemma "\<turnstile>  [](P \<longleftrightarrow> Q) \<longleftrightarrow> (P>-<Q)" by S43_solve
lemma "\<turnstile>  <>(P \<longrightarrow> Q) \<longleftrightarrow> ([]P \<longrightarrow> <>Q)" by S43_solve
lemma "\<turnstile>        []P \<longleftrightarrow> \<not> <>(\<not> P)" by S43_solve
lemma "\<turnstile>     [](\<not>P) \<longleftrightarrow> \<not> <>P" by S43_solve
lemma "\<turnstile>       \<not> []P \<longleftrightarrow> <>(\<not> P)" by S43_solve
lemma "\<turnstile>      [][]P \<longleftrightarrow> \<not> <><>(\<not> P)" by S43_solve
lemma "\<turnstile> \<not> <>(P \<or> Q) \<longleftrightarrow> \<not> <>P \<and> \<not> <>Q" by S43_solve

lemma "\<turnstile> []P \<or> []Q \<longrightarrow> [](P \<or> Q)" by S43_solve
lemma "\<turnstile> <>(P \<and> Q) \<longrightarrow> <>P \<and> <>Q" by S43_solve
lemma "\<turnstile> [](P \<or> Q) \<longrightarrow> []P \<or> <>Q" by S43_solve
lemma "\<turnstile> <>P \<and> []Q \<longrightarrow> <>(P \<and> Q)" by S43_solve
lemma "\<turnstile> [](P \<or> Q) \<longrightarrow> <>P \<or> []Q" by S43_solve
lemma "\<turnstile> <>(P \<longrightarrow> (Q \<and> R)) \<longrightarrow> ([]P \<longrightarrow> <>Q) \<and> ([]P \<longrightarrow> <>R)" by S43_solve
lemma "\<turnstile> (P --< Q) \<and> (Q --<R ) \<longrightarrow> (P --< R)" by S43_solve
lemma "\<turnstile> []P \<longrightarrow> <>Q \<longrightarrow> <>(P \<and> Q)" by S43_solve

(* Theorems of system S4 from Hughes and Cresswell, p.46 *)

lemma "\<turnstile> []A \<longrightarrow> A" by S43_solve             (* refexivity *)
lemma "\<turnstile> []A \<longrightarrow> [][]A" by S43_solve         (* transitivity *)
lemma "\<turnstile> []A \<longrightarrow> <>A" by S43_solve           (* seriality *)
lemma "\<turnstile> <>[](<>A \<longrightarrow> []<>A)" by S43_solve
lemma "\<turnstile> <>[](<>[]A \<longrightarrow> []A)" by S43_solve
lemma "\<turnstile> []P \<longleftrightarrow> [][]P" by S43_solve
lemma "\<turnstile> <>P \<longleftrightarrow> <><>P" by S43_solve
lemma "\<turnstile> <>[]<>P \<longrightarrow> <>P" by S43_solve
lemma "\<turnstile> []<>P \<longleftrightarrow> []<>[]<>P" by S43_solve
lemma "\<turnstile> <>[]P \<longleftrightarrow> <>[]<>[]P" by S43_solve

(* Theorems for system S4 from Hughes and Cresswell, p.60 *)

lemma "\<turnstile> []P \<or> []Q \<longleftrightarrow> []([]P \<or> []Q)" by S43_solve
lemma "\<turnstile> ((P >-< Q) --< R) \<longrightarrow> ((P >-< Q) --< []R)" by S43_solve

(* These are from Hailpern, LNCS 129 *)

lemma "\<turnstile> [](P \<and> Q) \<longleftrightarrow> []P \<and> []Q" by S43_solve
lemma "\<turnstile> <>(P \<or> Q) \<longleftrightarrow> <>P \<or> <>Q" by S43_solve
lemma "\<turnstile> <>(P \<longrightarrow> Q) \<longleftrightarrow> ([]P \<longrightarrow> <>Q)" by S43_solve

lemma "\<turnstile> [](P \<longrightarrow> Q) \<longrightarrow> (<>P \<longrightarrow> <>Q)" by S43_solve
lemma "\<turnstile> []P \<longrightarrow> []<>P" by S43_solve
lemma "\<turnstile> <>[]P \<longrightarrow> <>P" by S43_solve

lemma "\<turnstile> []P \<or> []Q \<longrightarrow> [](P \<or> Q)" by S43_solve
lemma "\<turnstile> <>(P \<and> Q) \<longrightarrow> <>P \<and> <>Q" by S43_solve
lemma "\<turnstile> [](P \<or> Q) \<longrightarrow> []P \<or> <>Q" by S43_solve
lemma "\<turnstile> <>P \<and> []Q \<longrightarrow> <>(P \<and> Q)" by S43_solve
lemma "\<turnstile> [](P \<or> Q) \<longrightarrow> <>P \<or> []Q" by S43_solve

(* Theorems of system S43 *)

lemma "\<turnstile> <>[]P \<longrightarrow> []<>P" by S43_solve
lemma "\<turnstile> <>[]P \<longrightarrow> [][]<>P" by S43_solve
lemma "\<turnstile> [](<>P \<or> <>Q) \<longrightarrow> []<>P \<or> []<>Q" by S43_solve
lemma "\<turnstile> <>[]P \<and> <>[]Q \<longrightarrow> <>([]P \<and> []Q)" by S43_solve
lemma "\<turnstile> []([]P \<longrightarrow> []Q) \<or> []([]Q \<longrightarrow> []P)" by S43_solve
lemma "\<turnstile> [](<>P \<longrightarrow> <>Q) \<or> [](<>Q \<longrightarrow> <>P)" by S43_solve
lemma "\<turnstile> []([]P \<longrightarrow> Q) \<or> []([]Q \<longrightarrow> P)" by S43_solve
lemma "\<turnstile> [](P \<longrightarrow> <>Q) \<or> [](Q \<longrightarrow> <>P)" by S43_solve
lemma "\<turnstile> [](P \<longrightarrow> []Q \<longrightarrow> R) \<or> [](P \<or> ([]R \<longrightarrow> Q))" by S43_solve
lemma "\<turnstile> [](P \<or> (Q \<longrightarrow> <>C)) \<or> [](P \<longrightarrow> C \<longrightarrow> <>Q)" by S43_solve
lemma "\<turnstile> []([]P \<or> Q) \<and> [](P \<or> []Q) \<longrightarrow> []P \<or> []Q" by S43_solve
lemma "\<turnstile> <>P \<and> <>Q \<longrightarrow> <>(<>P \<and> Q) \<or> <>(P \<and> <>Q)" by S43_solve
lemma "\<turnstile> [](P \<or> Q) \<and> []([]P \<or> Q) \<and> [](P \<or> []Q) \<longrightarrow> []P \<or> []Q" by S43_solve
lemma "\<turnstile> <>P \<and> <>Q \<longrightarrow> <>(P \<and> Q) \<or> <>(<>P \<and> Q) \<or> <>(P \<and> <>Q)" by S43_solve
lemma "\<turnstile> <>[]<>P \<longleftrightarrow> []<>P" by S43_solve
lemma "\<turnstile> []<>[]P \<longleftrightarrow> <>[]P" by S43_solve

(* These are from Hailpern, LNCS 129 *)

lemma "\<turnstile> [](P \<and> Q) \<longleftrightarrow> []P \<and> []Q" by S43_solve
lemma "\<turnstile> <>(P \<or> Q) \<longleftrightarrow> <>P \<or> <>Q" by S43_solve
lemma "\<turnstile> <>(P \<longrightarrow> Q) \<longleftrightarrow> []P \<longrightarrow> <>Q" by S43_solve

lemma "\<turnstile> [](P \<longrightarrow> Q) \<longrightarrow> <>P \<longrightarrow> <>Q" by S43_solve
lemma "\<turnstile> []P \<longrightarrow> []<>P" by S43_solve
lemma "\<turnstile> <>[]P \<longrightarrow> <>P" by S43_solve
lemma "\<turnstile> []<>[]P \<longrightarrow> []<>P" by S43_solve
lemma "\<turnstile> <>[]P \<longrightarrow> <>[]<>P" by S43_solve
lemma "\<turnstile> <>[]P \<longrightarrow> []<>P" by S43_solve
lemma "\<turnstile> []<>[]P \<longleftrightarrow> <>[]P" by S43_solve
lemma "\<turnstile> <>[]<>P \<longleftrightarrow> []<>P" by S43_solve

lemma "\<turnstile> []P \<or> []Q \<longrightarrow> [](P \<or> Q)" by S43_solve
lemma "\<turnstile> <>(P \<and> Q) \<longrightarrow> <>P \<and> <>Q" by S43_solve
lemma "\<turnstile> [](P \<or> Q) \<longrightarrow> []P \<or> <>Q" by S43_solve
lemma "\<turnstile> <>P \<and> []Q \<longrightarrow> <>(P \<and> Q)" by S43_solve
lemma "\<turnstile> [](P \<or> Q) \<longrightarrow> <>P \<or> []Q" by S43_solve
lemma "\<turnstile> [](P \<or> Q) \<longrightarrow> []<>P \<or> []<>Q" by S43_solve
lemma "\<turnstile> <>[]P \<and> <>[]Q \<longrightarrow> <>(P \<and> Q)" by S43_solve
lemma "\<turnstile> <>[](P \<and> Q) \<longleftrightarrow> <>[]P \<and> <>[]Q" by S43_solve
lemma "\<turnstile> []<>(P \<or> Q) \<longleftrightarrow> []<>P \<or> []<>Q" by S43_solve

end


(*  Title:      Word_Misc.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter {* More about words *}

theory Word_Misc imports
  "HOL-Word.Word"
  More_Bits_Int
begin

text {*
  The separate code target @{text SML_word} collects setups for the
  code generator that PolyML does not provide.
*}

setup {* Code_Target.add_derived_target ("SML_word", [(Code_ML.target_SML, I)]) *}

code_identifier code_module Word_Misc \<rightharpoonup>
  (SML) Word and (Haskell) Word and (OCaml) Word and (Scala) Word

context
includes integer.lifting
begin
lift_definition word_of_integer :: "integer \<Rightarrow> 'a :: len0 word" is word_of_int .

lemma word_of_integer_code [code]: "word_of_integer n = word_of_int (int_of_integer n)"
by(simp add: word_of_integer.rep_eq)
end

lemma shiftr_zero_size: "size x \<le> n \<Longrightarrow> x >> n = (0 :: 'a :: len0 word)"
by(rule word_eqI)(auto simp add: nth_shiftr dest: test_bit_size)

lemma mask_full [simp]: "mask (len_of TYPE('a :: len)) = (-1 :: 'a word)"
by(simp add: mask_def word_pow_0)

lemma set_bit_beyond: fixes x :: "'a :: len0 word" shows
  "size x \<le> n \<Longrightarrow> set_bit x n b = x"
by(auto intro: word_eqI simp add: test_bit_set_gen word_size)

lemma word_of_int_code [code abstract]:
  "uint (word_of_int x :: 'a word) = x AND bin_mask (len_of TYPE('a :: len0))"
by(simp add: uint_word_of_int and_bin_mask_conv_mod)

lemma shiftl_transfer [transfer_rule]:
  includes lifting_syntax
  shows "(pcr_word ===> op = ===> pcr_word) op << op <<"
by(auto intro!: rel_funI word_eqI simp add: word.pcr_cr_eq cr_word_def word_size nth_shiftl)

lemma set_bits_K_False [simp]: "set_bits (\<lambda>_. False) = (0 :: 'a :: len0 word)"
by(rule word_eqI)(simp add: test_bit.eq_norm)

lemma test_bit_1' [simp]: "(1 :: 'a :: len0 word) !! n \<longleftrightarrow> 0 < len_of TYPE('a) \<and> n = 0"
by(cases n)(simp_all only: one_word_def test_bit_wi bin_nth.simps, simp_all)

lemma mask_0 [simp]: "mask 0 = 0"
by(simp add: Word.mask_def)

lemma shiftl0 [simp]: "x << 0 = (x :: 'a :: len0 word)"
by (metis shiftl_rev shiftr_x_0 word_rev_gal)

lemma mask_1: "mask 1 = 1"
by(simp add: mask_def)

lemma mask_Suc_0: "mask (Suc 0) = 1"
by(simp add: mask_def)

lemma mask_numeral: "mask (numeral n) = 2 * mask (pred_numeral n) + 1"
unfolding mask_def by transfer(simp, simp add: shiftl_int_def)

lemma bin_last_bintrunc: "bin_last (bintrunc l n) = (l > 0 \<and> bin_last n)"
by(cases l) simp_all

lemma word_and_1:
  fixes n :: "_ word"
  shows "n AND 1 = (if n !! 0 then 1 else 0)"
by transfer(rule bin_rl_eqI, simp_all add: bin_rest_trunc bin_last_bintrunc)

lemma bintrunc_shiftl: "bintrunc n (m << i) = bintrunc (n - i) m << i"
proof(induct i arbitrary: n)
  case (Suc i)
  thus ?case by(cases n) simp_all
qed simp

lemma uint_shiftl: "uint (n << i) = bintrunc (size n) (uint n << i)"
unfolding word_size by transfer(simp add: bintrunc_shiftl)

context fixes f :: "nat \<Rightarrow> bool" begin

fun set_bits_aux :: "'a word \<Rightarrow> nat \<Rightarrow> 'a :: len0 word"
where
  "set_bits_aux w 0 = w"
| "set_bits_aux w (Suc n) = set_bits_aux ((w << 1) OR (if f n then 1 else 0)) n"

lemma set_bits_aux_conv: "set_bits_aux w n = (w << n) OR (set_bits f AND mask n)"
apply(induct w n rule: set_bits_aux.induct)
apply(auto 4 3 intro: word_eqI simp add: word_ao_nth nth_shiftl test_bit.eq_norm word_size not_less less_Suc_eq)
done

corollary set_bits_conv_set_bits_aux:
  "set_bits f = (set_bits_aux 0 (len_of TYPE('a)) :: 'a :: len word)"
by(simp add: set_bits_aux_conv)

end

lemma word_test_bit_set_bits: "(BITS n. f n :: 'a :: len0 word) !! n \<longleftrightarrow> n < len_of TYPE('a) \<and> f n"
by(auto simp add: word_set_bits_def test_bit_bl word_bl.Abs_inverse word_size)

lemma word_of_int_conv_set_bits: "word_of_int i = (BITS n. i !! n)"
by(rule word_eqI)(simp add: word_test_bit_set_bits)

text {*
  Division on @{typ "'a word"} is unsigned, but Scala and OCaml only have signed division and modulus.
*}
definition word_sdiv :: "'a :: len word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixl "sdiv" 70)
where [code]:
  "x sdiv y =
   (let x' = sint x; y' = sint y;
        negative = (x' < 0) \<noteq> (y' < 0);
        result = abs x' div abs y'
    in word_of_int (if negative then -result else result))"

definition word_smod :: "'a :: len word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixl "smod" 70)
where [code]:
  "x smod y =
   (let x' = sint x; y' = sint y;
        negative = (x' < 0);
        result = abs x' mod abs y'
    in word_of_int (if negative then -result else result))"

lemma sdiv_smod_id: "(a sdiv b) * b + (a smod b) = a"
proof -
  note [simp] = word_sdiv_def word_smod_def
  have F5: "\<forall>u::'a word. - (- u) = u" by (metis word_sint.Rep_inverse' minus_minus wi_hom_neg)
  have F7: "\<forall>v u::'a word. u + v = v + u" by(metis add.left_commute add_0_right)
  have F8: "\<forall>(w::'a word) (v::int) u::int. word_of_int u + word_of_int v * w = word_of_int (u + v * sint w)"
    by (metis word_sint.Rep_inverse wi_hom_syms(1) wi_hom_syms(3))
  have "\<exists>u. u = - sint b \<and> word_of_int (sint a mod u + - (- u * (sint a div u))) = a"
    using F5 by (metis minus_minus word_sint.Rep_inverse' mult_minus_left add.commute mult_div_mod_eq [symmetric])
  hence "word_of_int (sint a mod - sint b + - (sint b * (sint a div - sint b))) = a" by (metis equation_minus_iff)
  hence "word_of_int (sint a mod - sint b) + word_of_int (- (sint a div - sint b)) * b = a"
    using F8 by(metis mult.commute mult_minus_left)
  hence eq: "word_of_int (- (sint a div - sint b)) * b + word_of_int (sint a mod - sint b) = a" using F7 by metis

  show ?thesis
  proof(cases "sint a < 0")
    case True note a = this
    show ?thesis
    proof(cases "sint b < 0")
      case True
      with a show ?thesis
        by simp (metis F7 F8 eq minus_equation_iff minus_mult_minus mod_div_mult_eq)
    next
      case False
      from eq have "word_of_int (- (- sint a div sint b)) * b + word_of_int (- (- sint a mod sint b)) = a"
        by (metis div_minus_right mod_minus_right)
      with a False show ?thesis by simp
    qed
  next
    case False note a = this
    show ?thesis
    proof(cases "sint b < 0")
      case True
      with a eq show ?thesis by simp
    next
      case False with a show ?thesis
        by simp (metis wi_hom_add wi_hom_mult add.commute mult.commute word_sint.Rep_inverse add.commute mult_div_mod_eq [symmetric])
    qed
  qed
qed

lemma nat_div_eq_Suc_0_iff: "n div m = Suc 0 \<longleftrightarrow> n \<ge> m \<and> n < 2 * (m :: nat)"
  apply (auto simp add: sdl)
  using not_less apply fastforce
  apply (metis One_nat_def Suc_1 div_eq_0_iff lessI neq0_conv td_gal_lt)
  done

lemma word_div_lt_eq_0:
  fixes x :: "'a :: len word"
  shows "x < y \<Longrightarrow> x div y = 0"
by(simp only: word_div_def zero_word_def uint_nat zdiv_int[symmetric] transfer_int_nat_numerals(1) word_less_def div_less)

lemma Suc_0_lt_2p_len_of: "Suc 0 < 2 ^ len_of TYPE('a :: len)"
by (metis One_nat_def len_gt_0 one_less_numeral_iff one_less_power semiring_norm(76))

lemma unat_p2: "n < len_of TYPE('a :: len) \<Longrightarrow> unat (2 ^ n :: 'a word) = 2 ^ n"
proof(induct n)
  case 0 thus ?case by simp
next
  case (Suc n)
  then obtain n' where "len_of TYPE('a) = Suc n'" by(cases "len_of TYPE('a)") simp_all
  with Suc show ?case by(simp add: unat_word_ariths bintrunc_mod2p int_mod_eq')
qed

lemma div_half_nat:
  fixes x y :: nat
  assumes "y \<noteq> 0"
  shows "(x div y, x mod y) = (let q = 2 * (x div 2 div y); r = x - q * y in if y \<le> r then (q + 1, r - y) else (q, r))"
proof -
  let ?q = "2 * (x div 2 div y)"
  have q: "?q = x div y - x div y mod 2"
    by(metis div_mult2_eq mult.commute minus_mod_eq_mult_div [symmetric])
  let ?r = "x - ?q * y"
  have r: "?r = x mod y + x div y mod 2 * y"
    by(simp add: q diff_mult_distrib minus_mod_eq_div_mult [symmetric])(metis diff_diff_cancel mod_less_eq_dividend mod_mult2_eq add.commute mult.commute)

  show ?thesis
  proof(cases "y \<le> x - ?q * y")
    case True
    with assms q have "x div y mod 2 \<noteq> 0" unfolding r
      by (metis Nat.add_0_right diff_0_eq_0 diff_Suc_1 le_div_geq mod2_gr_0 mod_div_trivial mult_0 neq0_conv numeral_1_eq_Suc_0 numerals(1))
    hence "x div y = ?q + 1" unfolding q
      by(metis le_add_diff_inverse mod_2_not_eq_zero_eq_one_nat mod_less_eq_dividend add.commute)
    moreover hence "x mod y = ?r - y"
      by simp(metis minus_div_mult_eq_mod [symmetric] diff_commute diff_diff_left mult_Suc)
    ultimately show ?thesis using True by(simp add: Let_def)
  next
    case False
    hence "x div y mod 2 = 0" unfolding r
      by(simp add: not_le)(metis Nat.add_0_right assms div_less div_mult_self2 mod_div_trivial mult.commute)
    hence "x div y = ?q" unfolding q by simp
    moreover hence "x mod y = ?r" by (metis minus_div_mult_eq_mod [symmetric])
    ultimately show ?thesis using False by(simp add: Let_def)
  qed
qed

lemma div_half_word:
  fixes x y :: "'a :: len word"
  assumes "y \<noteq> 0"
  shows "(x div y, x mod y) = (let q = (x >> 1) div y << 1; r = x - q * y in if y \<le> r then (q + 1, r - y) else (q, r))"
proof -
  obtain n where n: "x = of_nat n" "n < 2 ^ len_of TYPE('a)" by(cases x)
  obtain m where m: "y = of_nat m" "m < 2 ^ len_of TYPE('a)" by(cases y)
  let ?q = "(x >> 1) div y << 1"
  let ?q' = "2 * (n div 2 div m)"
  have "n div 2 div m < 2 ^ len_of TYPE('a)" using n by (metis of_nat_inverse unat_lt2p uno_simps(2))
  hence q: "?q = of_nat ?q'" using n m
    apply(simp add: shiftr_def shiftr1_def bin_rest_def uint_nat unat_of_nat shiftl_def shiftl1_def Bit_def word_div_def word_of_nat)
by (metis of_nat_inverse of_nat_numeral uno_simps(2) word_of_nat zdiv_int of_nat_mult)

  from assms have "m \<noteq> 0" using m by -(rule notI, simp)

  from n have "2 * (n div 2 div m) < 2 ^ len_of TYPE('a)"
    by(metis mult.commute div_mult2_eq minus_mod_eq_mult_div [symmetric] less_imp_diff_less of_nat_inverse unat_lt2p uno_simps(2))
  moreover
  have "2 * (n div 2 div m) * m < 2 ^ len_of TYPE('a)" using n unfolding div_mult2_eq[symmetric]
    by(subst (2) mult.commute)(simp add: minus_mod_eq_div_mult [symmetric] diff_mult_distrib minus_mod_eq_mult_div [symmetric] div_mult2_eq)
  moreover have "2 * (n div 2 div m) * m \<le> n"
    by(metis div_mult2_eq div_mult_le mult.assoc mult.commute)
  ultimately
  have r: "x - ?q * y = of_nat (n - ?q' * m)"
    and "y \<le> x - ?q * y \<Longrightarrow> of_nat (n - ?q' * m) - y = of_nat (n - ?q' * m - m)"
    using n m unfolding q
    by (simp_all add: word_sub_wi word_mult_def uint_nat unat_of_nat of_nat_mult [symmetric] word_of_nat[symmetric] of_nat_diff word_le_nat_alt del: of_nat_mult)
      (metis diff_diff_left less_imp_diff_less of_nat_diff of_nat_inverse word_of_nat)
  thus ?thesis using n m div_half_nat[OF `m \<noteq> 0`, of n] unfolding q
    by(simp add: word_le_nat_alt word_div_def word_mod_def uint_nat unat_of_nat zmod_int[symmetric] zdiv_int[symmetric] word_of_nat[symmetric])(simp add: Let_def split del: if_split split: if_split_asm)
qed

lemma word_div_eq_1_iff: "n div m = 1 \<longleftrightarrow> n \<ge> m \<and> unat n < 2 * unat (m :: 'a :: len word)"
apply(simp only: word_arith_nat_defs word_le_nat_alt nat_div_eq_Suc_0_iff[symmetric])
apply(rule word_unat.Abs_inject)
 apply(simp only: unat_div[symmetric] word_unat.Rep)
apply(simp add: unats_def Suc_0_lt_2p_len_of)
done

text {*
  This algorithm implements unsigned division in terms of signed division.
  Taken from Hacker's Delight.
*}

lemma divmod_via_sdivmod:
  fixes x y :: "'a :: len word"
  assumes "y \<noteq> 0"
  shows
  "(x div y, x mod y) =
  (if 1 << (len_of TYPE('a) - 1) \<le> y then if x < y then (0, x) else (1, x - y)
   else let q = ((x >> 1) sdiv y) << 1;
            r = x - q * y
        in if r \<ge> y then (q + 1, r - y) else (q, r))"
proof(cases "1 << (len_of TYPE('a) - 1) \<le> y")
  case True
  note y = this
  show ?thesis
  proof(cases "x < y")
    case True
    hence "x mod y = x"
      by(cases x)(cases y, simp add: word_mod_def uint_nat unat_of_nat zmod_int[symmetric] word_of_nat[symmetric] mod_less word_less_nat_alt)
    thus ?thesis using True y by(simp add: word_div_lt_eq_0)
  next
    case False
    obtain n where n: "y = of_nat n" "n < 2 ^ len_of TYPE('a)" by(cases y)
    have "unat x < 2 ^ len_of TYPE('a)" by(rule unat_lt2p)
    also have "\<dots> = 2 * 2 ^ (len_of TYPE('a) - 1)"
      by(metis Suc_pred len_gt_0 power_Suc One_nat_def)
    also have "\<dots> \<le> 2 * n" using y n
      by(simp add: word_le_nat_alt unat_of_nat unat_p2)
    finally have div: "x div of_nat n = 1" using False n
      by(simp add: word_div_eq_1_iff not_less word_le_nat_alt unat_of_nat)
    moreover have "x mod y = x - x div y * y"
      by (metis add_diff_cancel2 word_mod_div_equality)
    with div n have "x mod y = x - y" by simp
    ultimately show ?thesis using False y n by simp
  qed
next
  case False
  note y = this
  obtain n where n: "x = of_nat n" "n < 2 ^ len_of TYPE('a)" by(cases x)
  hence "int n div 2 + 2 ^ (len_of TYPE('a) - Suc 0) < 2 ^ len_of TYPE('a)"
    by (cases "len_of TYPE('a)")
      (simp_all, simp only: of_nat_numeral [where ?'a = int, symmetric]
      zdiv_int [symmetric] of_nat_power [symmetric])
  with y n have "sint (x >> 1) = uint (x >> 1)"
    by(simp add: sint_uint sbintrunc_mod2p shiftr_div_2n)(simp add: int_mod_eq' uint_nat unat_of_nat)
  moreover have "uint y + 2 ^ (len_of TYPE('a) - Suc 0) < 2 ^ len_of TYPE('a)" using y
    by(cases "len_of TYPE('a)")(simp_all add: not_le, metis lessI word_2p_lem word_less_def word_size)
  hence "sint y = uint y" by(simp add: sint_uint sbintrunc_mod2p int_mod_eq')
  ultimately show ?thesis using y
    by(subst div_half_word[OF assms])(simp add: word_sdiv_def uint_div[symmetric])
qed

lemma word_of_int_via_signed:
  fixes mask
  assumes mask_def: "mask = bin_mask (len_of TYPE('a))"
  and shift_def: "shift = 1 << len_of TYPE('a)"
  and index_def: "index = len_of TYPE('a) - 1"
  and overflow_def:"overflow = 1 << (len_of TYPE('a) - 1)"
  and least_def: "least = - overflow"
  shows
  "(word_of_int i :: 'a :: len word) =
   (let i' = i AND mask
    in if i' !! index then
         if i' - shift < least \<or> overflow \<le> i' - shift then arbitrary1 i' else word_of_int (i' - shift)
       else if i' < least \<or> overflow \<le> i' then arbitrary2 i' else word_of_int i')"
proof -
  def i' \<equiv> "i AND mask"
  have "shift = mask + 1" unfolding assms by(simp add: bin_mask_p1_conv_shift)
  hence "i' < shift" by(simp add: mask_def i'_def int_and_le)
  show ?thesis
  proof(cases "i' !! index")
    case True
    hence unf: "i' = overflow OR i'" unfolding assms i'_def
      by(auto intro!: bin_eqI simp add: bin_nth_ops)
    have "overflow \<le> i'" by(subst unf)(rule le_int_or, simp add: bin_sign_and assms i'_def)
    hence "i' - shift < least \<longleftrightarrow> False" unfolding assms
      by(cases "len_of TYPE('a)")(simp_all add: not_less Bit_def)
    moreover
    have "overflow \<le> i' - shift \<longleftrightarrow> False" using `i' < shift` unfolding assms
      by(cases "len_of TYPE('a)")(auto simp add: not_le Bit_def elim: less_le_trans)
    moreover
    have "word_of_int (i' - shift) = (word_of_int i :: 'a word)" using `i' < shift`
      by(auto intro!: word_eqI simp add: i'_def shift_def mask_def bin_nth_ops bin_nth_minus_p2 bin_sign_and)
    ultimately show ?thesis using True by(simp add: Let_def i'_def)
  next
    case False
    hence "i' = i AND bin_mask (len_of TYPE('a) - 1)" unfolding assms i'_def
      by(clarsimp simp add: i'_def bin_nth_ops intro!: bin_eqI)(cases "len_of TYPE('a)", auto simp add: less_Suc_eq)
    also have "\<dots> \<le> bin_mask (len_of TYPE('a) - 1)" by(rule int_and_le) simp
    also have "\<dots> < overflow" unfolding overflow_def
      by(simp add: bin_mask_p1_conv_shift[symmetric])
    also
    have "least \<le> 0" unfolding least_def overflow_def by simp
    have "0 \<le> i'" by(simp add: i'_def mask_def bin_mask_ge0)
    hence "least \<le> i'" using `least \<le> 0` by simp
    moreover
    have "word_of_int i' = (word_of_int i :: 'a word)"
      by(rule word_eqI)(auto simp add: i'_def bin_nth_ops mask_def)
    ultimately show ?thesis using False by(simp add: Let_def i'_def)
  qed
qed

lemma word_and_mask_or_conv_and_mask:
  "n !! index \<Longrightarrow> (n AND mask index) OR (1 << index) = n AND mask (index + 1)"
by(rule word_eqI)(auto simp add: word_ao_nth word_size nth_shiftl simp del: shiftl_1)

lemma uint_and_mask_or_full:
  fixes n :: "'a :: len word"
  assumes "n !! (len_of TYPE('a) - 1)"
  and "mask1 = mask (len_of TYPE('a) - 1)"
  and "mask2 = 1 << len_of TYPE('a) - 1"
  shows "uint (n AND mask1) OR mask2 = uint n"
proof -
  have "mask2 = uint (1 << len_of TYPE('a) - 1 :: 'a word)" using assms
    by(simp add: uint_shiftl word_size bintrunc_shiftl del: shiftl_1)(metis One_nat_def Suc_diff_Suc bintrunc_minus bintrunc_shiftl diff_self_eq_0 len_gt_0 len_num1 lessI uint_1 uint_word_arith_bintrs(8))
  hence "uint (n AND mask1) OR mask2 = uint (n AND mask1 OR (1 << len_of TYPE('a) - 1 :: 'a word))"
    by(simp add: uint_or)
  also have "\<dots> = uint (n AND mask (len_of TYPE('a) - 1 + 1))"
    using assms by(simp only: word_and_mask_or_conv_and_mask)
  also have "\<dots> = uint n" by simp
  finally show ?thesis .
qed

section {* Quickcheck conversion functions *}

notation scomp (infixl "\<circ>\<rightarrow>" 60)

definition qc_random_cnv ::
  "(natural \<Rightarrow> 'a::term_of) \<Rightarrow> natural \<Rightarrow> Random.seed
    \<Rightarrow> ('a \<times> (unit \<Rightarrow> Code_Evaluation.term)) \<times> Random.seed"
  where "qc_random_cnv a_of_natural i = Random.range (i + 1) \<circ>\<rightarrow> (\<lambda>k. Pair (
       let n = a_of_natural k
       in (n, \<lambda>_. Code_Evaluation.term_of n)))"

no_notation scomp (infixl "\<circ>\<rightarrow>" 60)

definition qc_exhaustive_cnv :: "(natural \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> (bool \<times> term list) option)
  \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
where
  "qc_exhaustive_cnv a_of_natural f d =
   Quickcheck_Exhaustive.exhaustive (%x. f (a_of_natural x)) d"

definition qc_full_exhaustive_cnv ::
  "(natural \<Rightarrow> ('a::term_of)) \<Rightarrow> ('a \<times> (unit \<Rightarrow> term) \<Rightarrow> (bool \<times> term list) option)
  \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
where
  "qc_full_exhaustive_cnv a_of_natural f d = Quickcheck_Exhaustive.full_exhaustive
  (%(x, xt). f (a_of_natural x, %_. Code_Evaluation.term_of (a_of_natural x))) d"

declare [[quickcheck_narrowing_ghc_options = "-XTypeSynonymInstances"]]

definition qc_narrowing_drawn_from :: "'a list \<Rightarrow> integer \<Rightarrow> _"
where
  "qc_narrowing_drawn_from xs =
   foldr Quickcheck_Narrowing.sum (map Quickcheck_Narrowing.cons (butlast xs)) (Quickcheck_Narrowing.cons (last xs))"

locale quickcheck_narrowing_samples =
  fixes a_of_integer :: "integer \<Rightarrow> 'a \<times> 'a :: {partial_term_of, term_of}"
  and zero :: "'a"
  and tr :: "typerep"
begin

function narrowing_samples :: "integer \<Rightarrow> 'a list"
where
  "narrowing_samples i =
   (if i > 0 then let (a, a') = a_of_integer i in narrowing_samples (i - 1) @ [a, a'] else [zero])"
by pat_completeness auto
termination including integer.lifting
proof(relation "measure nat_of_integer")
  fix i :: integer
  assume "0 < i"
  thus "(i - 1, i) \<in> measure nat_of_integer"
    by simp(transfer, simp)
qed simp

definition partial_term_of_sample :: "integer \<Rightarrow> 'a"
where
  "partial_term_of_sample i =
  (if i < 0 then undefined
   else if i = 0 then zero
   else if i mod 2 = 0 then snd (a_of_integer (i div 2))
   else fst (a_of_integer (i div 2 + 1)))"

lemma partial_term_of_code:
  "partial_term_of (ty :: 'a itself) (Quickcheck_Narrowing.Narrowing_variable p t) \<equiv>
    Code_Evaluation.Free (STR ''_'') tr"
  "partial_term_of (ty :: 'a itself) (Quickcheck_Narrowing.Narrowing_constructor i []) \<equiv>
   Code_Evaluation.term_of (partial_term_of_sample i)"
by (rule partial_term_of_anything)+

end

lemmas [code] =
  quickcheck_narrowing_samples.narrowing_samples.simps
  quickcheck_narrowing_samples.partial_term_of_sample_def

end


theory SKAT_Tactics
  imports SKAT
begin

lemma skat_star_elim:
  assumes "x \<notin> touches t"
  shows "(x := s \<cdot> \<lfloor>t\<rfloor>)\<^sup>\<star> \<cdot> x := null = \<lfloor>t\<rfloor>\<^sup>\<star> \<cdot> x := null"
  apply (subst ska.star_elim[symmetric,simplified])
  apply (metis skat_null_zero)
  apply skat_comm
  apply (metis assms set_mp touch_atoms)
  apply (metis skat_null_zero)
  by auto

definition seq :: "'a::ranked_alphabet skat list \<Rightarrow> 'a skat" where
  "seq xs \<equiv> foldl op \<cdot> \<one> xs"

definition SEQ :: "'a::ranked_alphabet skat list \<Rightarrow> 'a skat" where
  "SEQ \<equiv> seq"

definition qes :: "'a::ranked_alphabet skat list \<Rightarrow> 'a skat" where
  "qes xs \<equiv> seq (rev xs)"

definition QES :: "'a::ranked_alphabet skat list \<Rightarrow> 'a skat" where
  "QES \<equiv> qes"

lemma seq_to_qes: "seq xs = qes (rev xs)"
  by (simp add: qes_def)

ML {*
fun seq_select_tac s ctxt n =
  simp_tac (HOL_basic_ss addsimps @{thms SEQ_def[symmetric]}) n
  THEN EqSubst.eqsubst_tac ctxt [s] @{thms SEQ_def} n

fun seq_deselect_tac n =
  simp_tac (HOL_basic_ss addsimps @{thms SEQ_def QES_def}) n

fun qes_select_tac s ctxt n =
  simp_tac (HOL_basic_ss addsimps @{thms QES_def[symmetric]}) n
  THEN EqSubst.eqsubst_tac ctxt [s] @{thms QES_def} n

fun qes_deselect_tac n =
  simp_tac (HOL_basic_ss addsimps @{thms QES_def}) n

fun seq_reverse_tac s ctxt n =
  seq_select_tac s ctxt n
  THEN simp_tac (HOL_basic_ss addsimps @{thms seq_to_qes rev.simps append.simps}) n
  THEN seq_deselect_tac n

fun qes_reverse_tac s ctxt n =
  qes_select_tac s ctxt n
  THEN simp_tac (HOL_basic_ss addsimps @{thms qes_def rev.simps append.simps}) n
  THEN qes_deselect_tac n

*}

method_setup seq_select = {*
Scan.lift (Scan.optional Parse.nat 0) >>
  (fn s => fn ctxt => SIMPLE_METHOD (seq_select_tac s ctxt 1))
*}

method_setup seq_deselect = {*
Scan.succeed (fn _ => SIMPLE_METHOD (seq_deselect_tac 1))
*}

method_setup qes_select = {*
Scan.lift (Scan.optional Parse.nat 0) >>
  (fn s => fn ctxt => SIMPLE_METHOD (qes_select_tac s ctxt 1))
*}

method_setup qes_deselect = {*
Scan.succeed (fn _ => SIMPLE_METHOD (qes_deselect_tac 1))
*}

method_setup seq_rev = {*
Scan.lift (Scan.optional Parse.nat 0) >>
  (fn s => fn ctxt => seq_reverse_tac s ctxt |> SIMPLE_METHOD')
*}

method_setup qes_rev = {*
Scan.lift (Scan.optional Parse.nat 0) >>
  (fn s => fn ctxt => qes_reverse_tac s ctxt |> SIMPLE_METHOD')
*}

lemmas mult_oner = skd.mult_oner[simplified]
  and mult_onel = skd.mult_onel[simplified]

declare mult_oner [skat_simp]
  and mult_onel [skat_simp]
  and seq_def [skat_simp]
  and qes_def [skat_simp]
  and foldl.simps [skat_simp]
  and rev.simps [skat_simp]
  and append.simps [skat_simp]

lemma seq_singleton [simp]: "seq [x] = x" by skat_reduce
lemma qes_singleton [simp]: "qes [x] = x" by skat_reduce

lemma foldl_step: "foldl op \<cdot> \<one> (x#xs) = x \<cdot> foldl op \<cdot> \<one> xs"
  by (induct xs arbitrary: x, auto, skat_reduce, metis skd.mult_assoc)

lemma foldl_is_foldr: "foldl op \<cdot> \<one> xs = foldr op \<cdot> xs \<one>"
  by (induct xs, auto, metis foldl_Cons foldl_step)

lemma seq_foldr: "seq xs = foldr op \<cdot> xs \<one>"
  by (simp add: seq_def foldl_is_foldr)

lemma seq_mult: "seq (xs @ ys) = seq xs \<cdot> seq ys"
  apply (induct xs)
  apply (simp add: seq_foldr)
  apply (metis skd.mult_onel)
  apply (simp add: seq_foldr)
  by (metis skd.mult_assoc)

lemma seq_cut: "seq xs = seq (take n xs) \<cdot> seq (drop n xs)"
  by (subst seq_mult[symmetric], simp)

lemma seq_zip: "seq xs = qes (rev (take n xs)) \<cdot> seq (drop n xs)"
  by (metis seq_cut seq_to_qes)

method_setup cut = {*
Scan.lift Parse.nat  -- Scan.lift Parse.nat >>
  (fn (s, c) => fn ctxt =>
    let
      val ct = nat_cterm c
    in
      seq_select_tac s ctxt 1
      THEN EqSubst.eqsubst_tac ctxt [0] [Drule.instantiate' [] [NONE, SOME ct] @{thm seq_cut}] 1
      THEN simp_tac (HOL_basic_ss addsimps @{thms Nat.nat.cases take.simps drop.simps}) 1
      THEN seq_deselect_tac 1
      |> SIMPLE_METHOD
    end)
*}

ML {*
fun zip_tac s c ctxt n =
  let
    val ct = nat_cterm c
  in
    seq_select_tac s ctxt n
    THEN EqSubst.eqsubst_tac ctxt [0] [Drule.instantiate' [] [NONE, SOME ct] @{thm seq_zip}] n
    THEN simp_tac (HOL_basic_ss addsimps @{thms rev.simps append.simps Nat.nat.cases take.simps drop.simps}) n
  end
*}

method_setup zip = {*
Scan.lift Parse.nat  -- Scan.lift Parse.nat >>
  (fn (s, c) => fn ctxt => SIMPLE_METHOD (zip_tac s c ctxt 1))
*}

lemma zip_right: "qes (x#xs) \<cdot> seq ys = qes xs \<cdot> seq (x#ys)"
  by (metis (no_types) foldl_step qes_def rev.simps(2) seq_def seq_mult seq_singleton skd.mult_assoc)

lemmas zip_left = zip_right[symmetric]

lemma zip_comm: "x\<cdot>y = y\<cdot>x \<Longrightarrow> qes (x#xs) \<cdot> seq (y#ys) = qes (y#xs) \<cdot> seq (x#ys)"
  by (metis (no_types) qes_def rev.simps(2) seq_mult seq_singleton skd.mult_assoc zip_left)

lemma unzip: "qes xs \<cdot> seq ys = seq (rev xs @ ys)"
  by (metis qes_def seq_mult)

ML {*
fun unzip_tac ctxt n =
  EqSubst.eqsubst_tac ctxt [0] @{thms unzip} n
  THEN simp_tac (HOL_basic_ss addsimps @{thms rev.simps append.simps}) n
*}

method_setup unzip = {*
Scan.succeed (fn ctxt => unzip_tac ctxt |> SIMPLE_METHOD')
*}

ML {*
fun NTIMES 0 _ = all_tac
  | NTIMES n tac = tac THEN (NTIMES (n - 1) tac)

fun commr_tac s c m = Subgoal.FOCUS (fn {context, ...} =>
  let
    val move_right_tac = EVERY
      [ EqSubst.eqsubst_tac context [0] @{thms zip_comm} 1
      , skat_comm_tac simp_solver context 1
      , EqSubst.eqsubst_tac context [0] @{thms zip_left} 1
      ]
  in
    DETERM (zip_tac s c context 1)
    THEN (if m = 0
          then (CHANGED (REPEAT move_right_tac))
          else (NTIMES m move_right_tac))
    THEN unzip_tac context 1
    THEN seq_deselect_tac 1
  end)
*}

method_setup commr1 = {*
Scan.lift Parse.nat  -- Scan.lift Parse.nat -- Scan.lift (Scan.optional Parse.nat 0) >>
  (fn ((s, c), m) => fn ctxt => SIMPLE_METHOD' (commr_tac s c m ctxt))
*}

method_setup comml1 = {*
Scan.lift Parse.nat  -- Scan.lift Parse.nat -- Scan.lift (Scan.optional Parse.nat 0) >>
  (fn ((s, c), m) => fn ctxt =>
    let
      val move_left_tac = EVERY
        [ EqSubst.eqsubst_tac ctxt [0] @{thms zip_comm} 1
        , skat_comm_tac simp_solver ctxt 1
        , EqSubst.eqsubst_tac ctxt [0] @{thms zip_right} 1
        ]
    in
      DETERM (zip_tac s (c - 1) ctxt 1)
      THEN (if m = 0
            then (CHANGED (REPEAT move_left_tac))
            else (NTIMES m move_left_tac))
      THEN unzip_tac ctxt 1
      THEN seq_deselect_tac 1
      |> SIMPLE_METHOD
    end)
*}

inductive comms :: "'a::ranked_alphabet skat \<Rightarrow> 'a skat list \<Rightarrow> bool" where
  comms_nil: "comms x []"
| comms_cons: "\<lbrakk>x\<cdot>y = y\<cdot>x; comms x ys\<rbrakk> \<Longrightarrow> comms x (y#ys)"

lemma comms_comm: "comms x xs \<Longrightarrow> x \<cdot> seq xs = seq xs \<cdot> x"
  apply (induct xs)
  apply (metis foldl_step seq_def seq_singleton skd.mult_onel)
  by (metis (hide_lams, no_types) comms.simps foldl_step list.inject list.simps(3) seq_def skd.mult_assoc)

lemma break: "i < length xs \<Longrightarrow> xs = take i xs @ xs ! i # tl (drop i xs)"
  apply (induct xs arbitrary: i)
  apply simp
  apply auto
  by (metis add_0_right add_Suc_right append_take_drop_id list.size(4) nth_drop' tl.simps(2))

lemma comm_step:
  assumes
  "\<exists>i. nth ys i = x \<and> i < length ys \<and> comms x (take i ys) \<and> seq xs = seq (take i ys @ tl (drop i ys))"
  shows "seq (x#xs) = seq ys"
proof -
  obtain i where asm1: "ys ! i = x"
  and asm2: "i < length ys"
  and asm3: "comms x (take i ys)"
  and asm4: "seq xs = seq (take i ys @ tl (drop i ys))"
    by (metis assms)

  have "seq (x#xs) = x \<cdot> seq xs"
    by (metis append_Cons append_Nil seq_mult seq_singleton)
  also have "... = x \<cdot> seq (take i ys @ tl (drop i ys))"
    by (metis asm4)
  also have "... = x \<cdot> seq (take i ys) \<cdot> seq (tl (drop i ys))"
    by (metis append_Cons append_Nil seq_mult seq_singleton asm4)
  also have "... = seq (take i ys) \<cdot> x \<cdot> seq (tl (drop i ys))"
    by (metis comms_comm asm3)
  also have "... = seq (take i ys) \<cdot> ys ! i \<cdot> seq (tl (drop i ys))"
    by (metis asm1)
  also have "... = seq (take i ys @ [ys ! i] @ tl (drop i ys))"
    by (metis (lifting) append_assoc seq_mult seq_singleton)
  also have "... = seq ys"
    by (metis (lifting) append_Cons append_self_conv2 break asm2)
  finally show ?thesis .
qed

ML {*
fun seq_comm_step_tac ctxt n =
  rtac @{thm conjI} n THEN simp_tac (simpset_of ctxt) n
  THEN rtac @{thm conjI} n THEN simp_tac (simpset_of ctxt) n
  THEN REPEAT (rtac @{thm comms_cons} n THEN skat_comm_tac simp_solver ctxt n)
  THEN rtac @{thm comms_nil} n
  THEN simp_tac (simpset_of ctxt) n

fun destroy [] = (fn x => x)
  | destroy (f::fs) = f o Thm.dest_comb #> destroy fs

fun safe_dest_comb ctrm = SOME (Thm.dest_comb ctrm)
  handle CTERM _ => NONE

fun safe_destroy [] ctrm = SOME ctrm
  | safe_destroy (f::fs) ctrm =
    case (safe_dest_comb ctrm) of
      NONE => NONE
    | SOME x => safe_destroy fs (f x);

fun ml_list ctrm =
  case (safe_destroy [fst, snd] ctrm) of
    NONE => []
  | SOME x => x :: ml_list (destroy [snd] ctrm);

fun find_index _ [] = 0
  | find_index x (y::ys) =
    (if x aconvc y then 0 else 1 + find_index x ys)

fun seq_comm_get_index concl =
  let
    val ys = concl |> destroy [snd, snd, snd] |> ml_list
    val xs = concl |> destroy [snd, fst, snd, snd] |> ml_list
  in
    find_index (hd xs) ys
  end

val seq_comm1_tac = Subgoal.FOCUS (fn {concl, context, ...} =>
  let
    val index = nat_cterm (seq_comm_get_index concl)
    val exI_index = Drule.instantiate' [SOME @{ctyp "nat"}] [NONE, SOME index] @{thm exI}
  in
    EVERY [rtac @{thm comm_step} 1, rtac exI_index 1, seq_comm_step_tac context 1]
    ORELSE commr_tac 1 1 0 context 1
  end
  handle CTERM _ => no_tac)

val seq_comm_tac = Subgoal.FOCUS (fn {context, ...} =>
  REPEAT1 (seq_comm1_tac context 1))
*}

method_setup seq_comm = {* Scan.succeed (fn ctxt => SIMPLE_METHOD' (seq_comm_tac ctxt)) *}

lemma seq_cong: "seq xs = seq ys \<Longrightarrow> seq (x#xs) = seq (x#ys)"
  by (skat_simp, metis SKAT_Tactics.mult_onel foldl_Cons foldl_step)

lemma qes_cong: "qes xs = qes ys \<Longrightarrow> qes (x#xs) = qes (x#ys)"
  by skat_simp

method_setup cong = {*
Scan.succeed (fn ctxt =>
  REPEAT (rtac @{thm seq_cong} 1)
  THEN simp_tac (HOL_basic_ss addsimps @{thms seq_to_qes rev.simps append.simps}) 1
  THEN REPEAT (rtac @{thm qes_cong} 1)
  THEN simp_tac (HOL_basic_ss addsimps @{thms qes_def rev.simps append.simps}) 1
  |> CHANGED |> SIMPLE_METHOD)
*}

method_setup congl = {*
Scan.succeed (fn ctxt =>
  REPEAT (rtac @{thm seq_cong} 1) |> CHANGED |> SIMPLE_METHOD)
*}

method_setup congr = {*
Scan.succeed (fn ctxt =>
  simp_tac (HOL_basic_ss addsimps @{thms seq_to_qes rev.simps append.simps}) 1
  THEN (REPEAT (rtac @{thm qes_cong} 1))
  THEN simp_tac (HOL_basic_ss addsimps @{thms qes_def rev.simps append.simps}) 1
  |> CHANGED |> SIMPLE_METHOD)
*}

lemma seq_head_eq [intro]: "\<lbrakk>x = y; seq xs = seq ys\<rbrakk> \<Longrightarrow> seq (x#xs) = seq (y#ys)"
  by (metis seq_cong)

lemma seq_head_plus [intro]: "seq xs = seq ys + seq zs \<Longrightarrow> seq (x#xs) = seq (x#ys) + seq (x#zs)"
  by (metis append_Cons eq_Nil_appendI seq_mult skd.distl)

lemma seq_head_elim [simp,elim]: "x \<in> carrier tests \<Longrightarrow> seq (x#xs) + seq (!x#xs) = seq xs"
proof -
  assume "x \<in> carrier tests"
  hence "(x + !x) \<cdot> seq xs = seq xs"
    by (metis complement_one skd.mult_onel)
  hence "x \<cdot> seq xs + !x \<cdot> seq xs = seq xs"
    by (metis skd.distr)
  thus ?thesis
    by (metis append_Cons append_Nil seq_mult seq_singleton)
qed

lemma seq_head_elim_var [simp,elim]: "x \<in> carrier tests \<Longrightarrow> seq (!x#xs) + seq (x#xs) = seq xs"
  by (metis seq_head_elim skd.add_comm)

lemma zip_zero: "x\<cdot>y = \<zero> \<Longrightarrow> qes (x#xs) \<cdot> seq (y#ys) = \<zero>"
  by (metis fold_Cons_rev foldl_step seq_def skd.mult_assoc skd.mult_zerol skd.mult_zeror zip_left)

lemma zip_zero1: "x \<in> carrier tests \<Longrightarrow> qes (x#xs) \<cdot> seq (!x#ys) = \<zero>"
  by (metis complement_zero foldl_step seq_def skd.mult_assoc skd.mult_zerol skd.mult_zeror zip_left)

lemma zip_zero2: "x \<in> carrier tests \<Longrightarrow> qes (!x#xs) \<cdot> seq (x#ys) = \<zero>"
  by (metis not_closed skt.test_mult_comm zip_comm zip_zero1)

lemma zippify: "seq xs \<cdot> seq ys = qes (rev xs) \<cdot> seq ys"
  by (simp add: qes_def)

method_setup zero = {*
Scan.succeed (fn ctxt =>
  EqSubst.eqsubst_tac ctxt [0] @{thms zippify} 1
  THEN simp_tac (HOL_basic_ss addsimps @{thms rev.simps append.simps}) 1
  THEN EqSubst.eqsubst_tac ctxt [0] @{thms zip_zero1 zip_zero2} 1
  |> SIMPLE_METHOD)
*}

lemma seq_cons: "seq (x#xs) = x \<cdot> seq xs"
  by (metis foldl_step seq_def)

lemma qes_snoc: "qes (x#xs) = qes xs \<cdot> x"
  by (simp add: qes_def seq_mult)

lemma seq_empty [simp]: "seq [] = \<one>" by skat_reduce
lemma qes_empty [simp]: "qes [] = \<one>" by skat_reduce

end


theory CancelResults
imports "FreeGroupMain" "CancelLemmas" "HOL-Proofs-Lambda.Commutation"
begin

(*1. Diamond*)

lemma diamond_cancel:
  shows "diamond (\<lambda> x y. (cancels_to_1 x y) \<or> x = y)"
  unfolding  diamond_def cancels_to_1_def commute_def square_def
  apply (rule allI, rule allI, rule impI, rule allI, rule impI)
proof-
  fix x y z :: "('a,'b) word"
  assume 1:"(\<exists>i. cancels_to_1_at i x y) \<or> x = y"
  assume 2:"(\<exists>i. cancels_to_1_at i x z) \<or> x = z"
  show "\<exists>u. ((\<exists>i. cancels_to_1_at i y u) \<or> y = u) \<and> ((\<exists>i. cancels_to_1_at i z u) \<or> z = u)"
  proof(cases "x = y \<or> x = z")
    case True
    then have "(\<exists>i. cancels_to_1_at i y z) \<or> (\<exists>i. cancels_to_1_at i z y) \<or> y = z " using 1 2 by blast
  then show ?thesis by blast
  next
    case False
    have 3: "(\<exists>i. cancels_to_1_at i x y) \<and> (\<exists>j. cancels_to_1_at j x z)" using 1 2 False by blast
    obtain i where "cancels_to_1_at i x y" using 3 by auto
    obtain j where "cancels_to_1_at j x z" using 3 by auto
  then show ?thesis
    proof(cases "y = z")
      case True
    then show ?thesis by auto
    next
      case False
      then show ?thesis
      proof(cases "i \<in> {j, j + 1} \<or> j \<in> {i, i+1}")
        case True
        have a: "y \<noteq> z"  by (simp add: False)
      then show ?thesis
        proof(cases "i = j")
          case True
          have y: "y = cancel_at i x" using cancels_to_1_at_def using \<open>cancels_to_1_at i x y\<close> by auto
          have z: "z = cancel_at i x" using cancels_to_1_at_def True using \<open>cancels_to_1_at j x z\<close> by auto
          have cont: "y = z" using y z by simp
        then show ?thesis using a by auto
        next
          case False
          then have ij: "i = j + 1 \<or> j = i + 1" using True by blast
          have xi: "inverse (x!i) = (x!(1+i))" using cancels_to_1_at_def \<open>cancels_to_1_at i x y\<close> by auto
          have xj: "inverse (x!j) = (x!(1+j))" using cancels_to_1_at_def \<open>cancels_to_1_at j x z\<close> by auto
        then show ?thesis
          proof(cases "i = 1 + j")
            case True
            have xij: "((nth x j) = (nth x (2+j)))" using True xi xj inverse_of_inverse by (metis add_2_eq_Suc plus_1_eq_Suc)
            have y1: "y = cancel_at (j+1) x" by (metis True \<open>cancels_to_1_at i x y\<close> add.commute cancels_to_1_at_def)
            have z1: "z = cancel_at j x" using cancels_to_1_at_def \<open>cancels_to_1_at j x z\<close> by (simp add: cancels_to_1_at_def)
            have contr1: "y = z" using y1 z1 a1 z1 xij by (smt (z3) True \<open>cancels_to_1_at i x y\<close> a2 add.commute cancel_at_def cancels_to_1_at_def group_cancel.add1 nat_1_add_1 zero_le)
          show ?thesis using a contr1 by auto
          next
            case False
            have "j = i + 1" using False ij by auto
            then have xji: "((nth x i) = (nth x (2+i)))" by (metis Suc_1 add.commute add_Suc_right inverse_of_inverse plus_1_eq_Suc xi xj)
            have y2: "y = cancel_at i x" using cancels_to_1_at_def \<open>cancels_to_1_at i x y\<close> by auto
            have z2: "z = cancel_at (i+1) x" using xji cancels_to_1_at_def \<open>cancels_to_1_at j x z\<close> by (simp add: cancels_to_1_at_def \<open>j = i + 1\<close>)
            have contr2: "y = z" using y2 z2 a2 z2 xji  by (smt (verit) \<open>cancels_to_1_at j x z\<close> \<open>j = i + 1\<close> a1 add.left_commute cancel_at_def cancels_to_1_at_def le_add2 le_add_same_cancel2 nat_1_add_1)
          then show ?thesis using a contr2 by auto
          qed
        qed
      next
        case False
        then have ij: " \<not> (i \<in> {j, j + 1} \<or> j \<in> {i, i + 1})" by auto
        have xi: "inverse (x!i) = (x!(1+i))" using cancels_to_1_at_def \<open>cancels_to_1_at i x y\<close> by auto
        have xj: "inverse (x!j) = (x!(1+j))" using cancels_to_1_at_def \<open>cancels_to_1_at j x z\<close> by auto
        then show ?thesis
        proof(cases "i \<le> j")
          case True
           then have l: "i + 1 < j"  by (metis False discrete insert_iff le_neq_implies_less)
          then have j1: "i + 1 < j + 1" by linarith
          have i0: "i\<ge>0" by simp
          have j0: "j \<ge> 0"  by simp
          then have j20: "j - 2 \<ge> 0" by simp
          have z: "z = cancel_at j x" using \<open>cancels_to_1_at j x z\<close> cancels_to_1_at_def by auto
          have y: "y = cancel_at i x"  using \<open>cancels_to_1_at i x y\<close> cancels_to_1_at_def by auto
          have il: "1 + i < length x" using  \<open>cancels_to_1_at i x y\<close> by (simp add: cancels_to_1_at_def)
          have m: "1 + j  < length x" using \<open>cancels_to_1_at j x z\<close> cancels_to_1_at_def by (simp add: cancels_to_1_at_def)
          then have jl: "j + 1 < length x" by auto
          then have "i + 1 + 2 < length x" using l  by linarith
          then have zz: "i + 1 < length x - 2" by simp
          have "length x - 2 = length (cancel_at i x)" using cancel_at_length[of "i" "x"] il i0 by presburger
          then have "length x - 2 = length y" using y by simp
          then have "j + 1 < length y + 2" using jl  by linarith
          then have j2y: "(j - 2) + 1 < length y" using l by linarith
          have "length x - 2 = length (cancel_at j x)" using cancel_at_length[of "j" "x"]  jl j0 by metis
          then have "length x - 2 = length z" using z by simp
          then have iz: "i + 1 < length z" using zz  by simp
          have j: "j < length x" using m by linarith
          then have n: "cancel_at i (cancel_at j x) = cancel_at (j-2) (cancel_at i x)" using cancel_order l m by (metis add.commute)
          then have eq: "cancel_at i z = cancel_at (j-2) y" using \<open>cancels_to_1_at j x z\<close> \<open>cancels_to_1_at i x y\<close> cancels_to_1_at_def by (simp add: cancels_to_1_at_def)
          have take: "take j z = take j x" using take_assoc cancel_at_def l m by (metis \<open>cancels_to_1_at j x z\<close> add.commute cancels_to_1_at_def eq_imp_le)
          then have o: "(nth x i) = (nth z i)" using l i0 by (metis add_lessD1 nth_take)
          have p: "(nth x (i+1)) = (nth z (i+1))" using l i0 take takenth by (metis True order.trans)
          then have "inverse (nth z i) = (nth x (i+1))" using xi o by (smt (z3) add.commute)
          then have "inverse (nth z i) = (nth z (i+1))" using p by (smt (z3))
          then have inv1: "inverse (nth z i) = (nth z (1+i))" by simp
          have zeq: "(cancel_at i z) = cancel_at i z" by simp
          have zu: "cancels_to_1_at i z (cancel_at i z)"  using i0 iz inv1 zeq unfolding cancels_to_1_at_def by linarith
          have "y = cancel_at i x" using  \<open>cancels_to_1_at i x y\<close> cancels_to_1_at_def by (simp add: cancels_to_1_at_def)
          then have q: "(nth x j) = (nth y (j - 2))" using cancel_atnth l j by blast
          have r: "(nth x (j + 1)) = (nth y ((j - 2) + 1))"  using cancel_atnth j1 m by (smt (verit) \<open>y = cancel_at i x\<close> add.commute comm diff_add_inverse diff_diff_left diff_is_0_eq' l le_add2 nat_1_add_1 nat_less_le zero_less_diff)
          have s: "inverse (nth y (j - 2)) = (nth x (j + 1))" using xj q  by auto
          then have inv2:"inverse (nth y (j - 2)) = (nth y ((j - 2) + 1))" using r  by fastforce
          have yeq: "cancel_at (j - 2) y = cancel_at (j - 2) y" by simp
          have yu: "cancels_to_1_at (j - 2) y (cancel_at (j - 2) y)" using j20 j2y  inv2 yeq unfolding cancels_to_1_at_def by auto
          then show ?thesis using yu zu eq by auto
        next
          case False
          then have j1i: "j + 1 < i" using ij by (metis discrete insertCI leI le_neq_implies_less)
          then have j1i1: "j + 1 < i + 1" by linarith
          have i0: "i\<ge>0" by simp
          then have i20: "i - 2 \<ge> 0" by simp
          have j0: "j \<ge> 0"  by simp
          have z: "z = cancel_at j x" using \<open>cancels_to_1_at j x z\<close> cancels_to_1_at_def by auto
          have y: "y = cancel_at i x"  using \<open>cancels_to_1_at i x y\<close> cancels_to_1_at_def by auto
          have jl: "1 + j  < length x" using \<open>cancels_to_1_at j x z\<close> cancels_to_1_at_def by (simp add: cancels_to_1_at_def)
          have il: "1 + i < length x" using  \<open>cancels_to_1_at i x y\<close> by (simp add: cancels_to_1_at_def)
          have "length x - 2 = length (cancel_at j x)" using cancel_at_length[of "j" "x"] jl j0 by presburger
          then have  "length x = length (cancel_at j x) + 2" using jl by linarith
          then have "i + 1 < (length z) + 2" using il i0 z  by auto
          then have i2z: "(i - 2) + 1 < length z" using j1i by linarith
          have "length x - 2 = length (cancel_at i x)" using cancel_at_length[of "i" "x"] il i0 by presburger
          then have xy: "length x - 2 = length y" using y  by simp
          have "j + 1 + 2 < length x" using j1i il  by linarith
          then have "j + 1 < length x - 2" using jl  by linarith
          then have jy: "j + 1 < length y" using xy by simp
          have "cancel_at j (cancel_at i x) = cancel_at (i-2) (cancel_at j x)" using j1i il cancel_order by auto
          then have eq: "cancel_at j y = cancel_at (i-2) z" using y z by simp
          have take: "take i x = take i y" using take_assoc cancel_at_def j1i by (metis add_diff_inverse_nat diff_add_inverse diff_add_inverse2 diff_le_self less_imp_diff_less less_nat_zero_code y zero_less_diff)
          have nth: "(nth x j) = (nth y j)" using takenth i0 j1i1 add_less_imp_less_right take by blast
          have nth1: "(nth x (j+1)) = (nth y (j+1))" using takenth i0 j1i1 j1i take by auto
          have "inverse (nth y j) = (nth x (j+1))" using xj nth by fastforce
          then have invj: "inverse (nth y j) = (nth y (j+1))" using nth1 by (smt (z3))
          have yu:  "cancels_to_1_at j y (cancel_at j y)" using j0 jy invj cancels_to_1_at_def by fastforce
          have nthi: "(nth x i) = (nth z (i - 2))" using z j1i  il cancel_atnth by (metis trans_le_add2 verit_comp_simplify1(3))
          have nthi1: "(nth x (i+1)) = (nth z ((i - 2) + 1))"  using z j1i1 il by (metis Nat.add_diff_assoc2 add.commute add_lessD1 cancel_atnth discrete j1i nat_1_add_1)
          then have "inverse (nth z (i - 2)) = (nth x (i + 1))" using xi nthi by fastforce
          then have invi: "inverse (nth z (i - 2)) = (nth z ((i - 2) + 1))" using nthi1 by (smt (z3))
          have zu: "cancels_to_1_at (i - 2) z (cancel_at (i - 2) z)" using i20 i2z invi cancels_to_1_at_def by (metis add.commute)
          then show ?thesis using eq yu zu by auto
        qed
      qed
    qed
  qed
qed

lemma cancels_to_1_reduced :
  assumes "cancels_to_1 x y"  "cancels_to_1 x z" "reduced y" "reduced z"
  shows "y = z"
  using assms
  unfolding cancels_to_1_def
proof-
  have 1: "(\<exists>i. cancels_to_1_at i x y) \<or> x = y" using assms(1) cancels_to_1_def by blast
  have 2: "(\<exists>i. cancels_to_1_at i x z) \<or> x = z" using assms(2) cancels_to_1_def by blast
  have "diamond (\<lambda> x y . (cancels_to_1 x y) \<or> x = y)" using diamond_cancel by simp
  then have "commute  (\<lambda> x y . (cancels_to_1 x y) \<or> x = y)  (\<lambda> x y . (cancels_to_1 x y) \<or> x = y)" using diamond_def by auto
  then have "square  (\<lambda> x y . (cancels_to_1 x y) \<or> x = y)  (\<lambda> x y . (cancels_to_1 x y) \<or> x = y)  (\<lambda> x y . (cancels_to_1 x y) \<or> x = y)  (\<lambda> x y . (cancels_to_1 x y) \<or> x = y)" using commute_def by blast
  then have "(\<forall>x y. (\<lambda> x y . (cancels_to_1 x y) \<or> x = y) x y --> (\<forall>z. (\<lambda> x y . (cancels_to_1 x y) \<or> x = y) x z --> (\<exists>u. (\<lambda> x y . (cancels_to_1 x y) \<or> x = y) y u \<and> (\<lambda> x y . (cancels_to_1 x y) \<or> x = y) z u)))" using square_def[of "(\<lambda> x y . (cancels_to_1 x y) \<or> x = y)" "(\<lambda> x y . (cancels_to_1 x y) \<or> x = y)" "(\<lambda> x y . (cancels_to_1 x y) \<or> x = y)" "(\<lambda> x y . (cancels_to_1 x y) \<or> x = y)"] by blast
  then have "(\<exists>u. (\<lambda> x y . (cancels_to_1 x y) \<or> x = y) y u \<and> (\<lambda> x y . (cancels_to_1 x y) \<or> x = y) z u)" using 1 2  assms(1) assms(2) by blast
  then have "\<exists>u . (y = u \<and>  z = u)" using cancels_to_1_red assms(3) assms(4) by (simp add: cancels_to_1_red)
  then show ?thesis by simp
qed

lemma diamondlemmaapp:
  assumes  "(\<exists>i. cancels_to_1_at i x y) \<or> x = y" "(\<exists>i. cancels_to_1_at i x z) \<or> x = z"
  shows "\<exists>u. ((\<exists>i. cancels_to_1_at i y u) \<or> y = u) \<and> ((\<exists>i. cancels_to_1_at i z u) \<or> z = u)"
proof-
  have "diamond (\<lambda> x y . (cancels_to_1 x y) \<or> x = y)" using diamond_cancel by simp
  then have "commute  (\<lambda> x y . (cancels_to_1 x y) \<or> x = y)  (\<lambda> x y . (cancels_to_1 x y) \<or> x = y)" using diamond_def by auto
  then have "square  (\<lambda> x y . (cancels_to_1 x y) \<or> x = y)  (\<lambda> x y . (cancels_to_1 x y) \<or> x = y)  (\<lambda> x y . (cancels_to_1 x y) \<or> x = y)  (\<lambda> x y . (cancels_to_1 x y) \<or> x = y)" using commute_def by blast
  then have "(\<forall>x y. (\<lambda> x y . (cancels_to_1 x y) \<or> x = y) x y --> (\<forall>z. (\<lambda> x y . (cancels_to_1 x y) \<or> x = y) x z --> (\<exists>u. (\<lambda> x y . (cancels_to_1 x y) \<or> x = y) y u \<and> (\<lambda> x y . (cancels_to_1 x y) \<or> x = y) z u)))" using square_def[of "(\<lambda> x y . (cancels_to_1 x y) \<or> x = y)" "(\<lambda> x y . (cancels_to_1 x y) \<or> x = y)" "(\<lambda> x y . (cancels_to_1 x y) \<or> x = y)" "(\<lambda> x y . (cancels_to_1 x y) \<or> x = y)"] by blast
  then have "(\<exists>u. (\<lambda> x y . (cancels_to_1 x y) \<or> x = y) y u \<and> (\<lambda> x y . (cancels_to_1 x y) \<or> x = y) z u)" by (metis assms(1) assms(2) cancels_to_1_def)
  then show ?thesis by (simp add: cancels_to_1_def)
qed

lemma confluent_cancels_to_1: "confluent cancels_to_1"
proof(rule lconfluent_confluent)
  show "wfP cancels_to_1\<inverse>\<inverse>" by (rule canceling_terminates)
next
  fix a b c
  assume "cancels_to_1 a b"
  then have 1: "(\<exists>i. cancels_to_1_at i a b)" by (simp add: cancels_to_1_def)
  assume "cancels_to_1 a c"
  then have 2: "\<exists>j. cancels_to_1_at j a c" by (simp add: cancels_to_1_def)
  show "\<exists>d. cancels_to_1\<^sup>*\<^sup>* b d \<and> cancels_to_1\<^sup>*\<^sup>* c d"
  proof-
    have "\<exists>d. ((\<exists>i. cancels_to_1_at i b d) \<or> b = d) \<and> ((\<exists>i. cancels_to_1_at i c d) \<or> c = d)" using 1 2 diamondlemmaapp by blast
    then obtain d where "((\<exists>i. cancels_to_1_at i b d) \<or> b = d) \<and> ((\<exists>i. cancels_to_1_at i c d) \<or> c = d)" by force
    then have "((\<exists>i. cancels_to_1_at i b d) \<or> b = d) \<and> ((\<exists>i. cancels_to_1_at i c d) \<or> c = d)"  by simp
    then have "(cancels_to b d) \<and> (cancels_to c d)" by (simp add: rtrancancel)
    then have "cancels_to_1\<^sup>*\<^sup>* b d \<and> cancels_to_1\<^sup>*\<^sup>* c d" using cancels_to_def by metis
    then show ?thesis by auto
  qed
qed

(*2. Uniqueness of cancels_to*)

lemma unique_reduced_cancel:
  assumes "cancels_to x y" "cancels_to x z" "reduced y" "reduced z"
  shows "y = z"
proof(rule confluent_unique_normal_form)
  have "cancels_to_1^** = cancels_to" using cancels_to_def  by metis
  show "confluent cancels_to_1" using confluent_cancels_to_1 by simp
next
  show "cancels_to_1\<^sup>*\<^sup>* x y" using assms(1) cancels_to_def by metis
next
  show "cancels_to_1\<^sup>*\<^sup>* x z" using assms(2) cancels_to_def by metis
next
  show "\<not> Domainp cancels_to_1 y" using assms(3) reduced_normal by blast
next
  show "\<not> Domainp cancels_to_1 z" using assms(4) reduced_normal by blast
qed

(*3. Uniqueness of cancel_eq*)
lemma reduced_cancel_eq:
  assumes "cancels_eq x y" "reduced x" "reduced y"
  shows "x = y"
proof-
  have "confluent cancels_to_1" using confluent_cancels_to_1 by blast
  then have 1: "Church_Rosser cancels_to_1" using Church_Rosser_confluent by (simp add: Church_Rosser_confluent)
  have "(symclp cancels_to)^** x y" using assms(1) eq_symp by metis
  then have "(symclp cancels_to_1)^** x y" using sympstar by metis
  then have 2: "(sup cancels_to_1 cancels_to_1^--1)^** x y" using symclp_pointfree[of "cancels_to_1"] by metis
  have 3: "\<not> Domainp cancels_to_1 x" using assms(2) reduced_normal by blast
  have 4: "\<not> Domainp cancels_to_1 y" using assms(3) reduced_normal by blast
  show ?thesis using 1 2 3 4 Church_Rosser_unique_normal_form[of "cancels_to_1" "x" "y"] by blast
qed

end