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

chapter {* Bit operations for target language integers *}

theory Bits_Integer imports
  More_Bits_Int
begin

lemmas [transfer_rule] =
  identity_quotient
  fun_quotient
  Quotient_integer[folded integer.pcr_cr_eq]

lemma undefined_transfer:
  assumes "Quotient R Abs Rep T"
  shows "T (Rep undefined) undefined"
using assms unfolding Quotient_alt_def by blast

bundle undefined_transfer = undefined_transfer[transfer_rule]

section {* More lemmas about @{typ integer}s *}

context
includes integer.lifting
begin

lemma bitval_integer_transfer [transfer_rule]:
  "(rel_fun op = pcr_integer) of_bool of_bool"
by(auto simp add: of_bool_def integer.pcr_cr_eq cr_integer_def split: bit.split)

lemma integer_of_nat_less_0_conv [simp]: "\<not> integer_of_nat n < 0"
by(transfer) simp

lemma int_of_integer_pow: "int_of_integer (x ^ n) = int_of_integer x ^ n"
by(induct n) simp_all

lemma pow_integer_transfer [transfer_rule]:
  "(rel_fun pcr_integer (rel_fun op = pcr_integer)) op ^ op ^"
by(auto 4 3 simp add: integer.pcr_cr_eq cr_integer_def int_of_integer_pow)

lemma sub1_lt_0_iff [simp]: "Code_Numeral.sub n num.One < 0 \<longleftrightarrow> False"
by(cases n)(simp_all add: Code_Numeral.sub_code)

lemma nat_of_integer_numeral [simp]: "nat_of_integer (numeral n) = numeral n"
by transfer simp

lemma nat_of_integer_sub1_conv_pred_numeral [simp]:
  "nat_of_integer (Code_Numeral.sub n num.One) = pred_numeral n"
by(cases n)(simp_all add: Code_Numeral.sub_code)

lemma nat_of_integer_1 [simp]: "nat_of_integer 1 = 1"
by transfer simp

lemma dup_1 [simp]: "Code_Numeral.dup 1 = 2"
by transfer simp

section {* Bit operations on @{typ integer} *}

text {* Bit operations on @{typ integer} are the same as on @{typ int} *}

lift_definition bin_rest_integer :: "integer \<Rightarrow> integer" is bin_rest .
lift_definition bin_last_integer :: "integer \<Rightarrow> bool" is bin_last .
lift_definition Bit_integer :: "integer \<Rightarrow> bool \<Rightarrow> integer" is Bit .

end

instantiation integer :: bitss begin
context includes integer.lifting begin

lift_definition bitAND_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" is "bitAND" .
lift_definition bitOR_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" is "bitOR" .
lift_definition bitXOR_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" is "bitXOR" .
lift_definition bitNOT_integer :: "integer \<Rightarrow> integer" is "bitNOT" .

lift_definition test_bit_integer :: "integer \<Rightarrow> nat \<Rightarrow> bool" is test_bit .
lift_definition lsb_integer :: "integer \<Rightarrow> bool" is lsb .
lift_definition set_bit_integer :: "integer \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> integer" is set_bit .
lift_definition set_bits_integer :: "(nat \<Rightarrow> bool) \<Rightarrow> integer" is set_bits .
lift_definition shiftl_integer :: "integer \<Rightarrow> nat \<Rightarrow> integer" is shiftl .
lift_definition shiftr_integer :: "integer \<Rightarrow> nat \<Rightarrow> integer" is shiftr .

lift_definition msb_integer :: "integer \<Rightarrow> bool" is msb .
instance ..
end
end

abbreviation (input) wf_set_bits_integer
where "wf_set_bits_integer \<equiv> wf_set_bits_int"

section {* Target language implementations *}

text {*
  Unfortunately, this is not straightforward,
  because these API functions have different signatures and preconditions on the parameters:

  \begin{description}
  \item[Standard ML] Shifts in IntInf are given as word, but not IntInf.
  \item[Haskell] In the Data.Bits.Bits type class, shifts and bit indices are given as Int rather than Integer.
  \item[OCaml] AND, XOR and OR in Big\_int accept only positive integers.
  \end{description}

  Additional constants take only parameters of type @{typ integer} rather than @{typ nat}
  and check the preconditions as far as possible (e.g., being non-negative) in a portable way.
  Manual implementations inside code\_printing perform the remaining range checks and convert
  these @{typ integer}s into the right type.

  For normalisation by evaluation, we derive custom code equations, because NBE
  does not know these code\_printing serialisations and would otherwise loop.
*}

code_identifier code_module Bits_Integer \<rightharpoonup>
  (SML) Bit_Int and (OCaml) Bit_Int and (Haskell) Bit_Int and (Scala) Bit_Int

code_printing code_module Bits_Integer \<rightharpoonup> (SML)
{*structure Bits_Integer : sig
  val set_bit : IntInf.int -> IntInf.int -> bool -> IntInf.int
  val shiftl : IntInf.int -> IntInf.int -> IntInf.int
  val shiftr : IntInf.int -> IntInf.int -> IntInf.int
  val test_bit : IntInf.int -> IntInf.int -> bool
end = struct

val maxWord = IntInf.pow (2, Word.wordSize);

fun set_bit x n b =
  if n < maxWord then
    if b then IntInf.orb (x, IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n)))
    else IntInf.andb (x, IntInf.notb (IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n))))
  else raise (Fail ("Bit index too large: " ^ IntInf.toString n));

fun shiftl x n =
  if n < maxWord then IntInf.<< (x, Word.fromLargeInt (IntInf.toLarge n))
  else raise (Fail ("Shift operand too large: " ^ IntInf.toString n));

fun shiftr x n =
  if n < maxWord then IntInf.~>> (x, Word.fromLargeInt (IntInf.toLarge n))
  else raise (Fail ("Shift operand too large: " ^ IntInf.toString n));

fun test_bit x n =
  if n < maxWord then IntInf.andb (x, IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n))) <> 0
  else raise (Fail ("Bit index too large: " ^ IntInf.toString n));

end; (*struct Bits_Integer*)*}
code_reserved SML Bits_Integer

code_printing code_module Data_Bits \<rightharpoonup> (Haskell)
{*import qualified Data.Bits;

{-
  The ...Bounded functions assume that the Integer argument for the shift
  or bit index fits into an Int, is non-negative and (for types of fixed bit width)
  less than bitSize
-}

infixl 7 .&.;
infixl 6 `xor`;
infixl 5 .|.;

(.&.) :: Data.Bits.Bits a => a -> a -> a;
(.&.) = (Data.Bits..&.);

xor :: Data.Bits.Bits a => a -> a -> a;
xor = Data.Bits.xor;

(.|.) :: Data.Bits.Bits a => a -> a -> a;
(.|.) = (Data.Bits..|.);

complement :: Data.Bits.Bits a => a -> a;
complement = Data.Bits.complement;

testBitUnbounded :: Data.Bits.Bits a => a -> Integer -> Bool;
testBitUnbounded x b
  | b <= toInteger (Prelude.maxBound :: Int) = Data.Bits.testBit x (fromInteger b)
  | otherwise = error ("Bit index too large: " ++ show b)
;

testBitBounded :: Data.Bits.Bits a => a -> Integer -> Bool;
testBitBounded x b = Data.Bits.testBit x (fromInteger b);

setBitUnbounded :: Data.Bits.Bits a => a -> Integer -> Bool -> a;
setBitUnbounded x n b
  | n <= toInteger (Prelude.maxBound :: Int) =
    if b then Data.Bits.setBit x (fromInteger n) else Data.Bits.clearBit x (fromInteger n)
  | otherwise = error ("Bit index too large: " ++ show n)
;

setBitBounded :: Data.Bits.Bits a => a -> Integer -> Bool -> a;
setBitBounded x n True = Data.Bits.setBit x (fromInteger n);
setBitBounded x n False = Data.Bits.clearBit x (fromInteger n);

shiftlUnbounded :: Data.Bits.Bits a => a -> Integer -> a;
shiftlUnbounded x n
  | n <= toInteger (Prelude.maxBound :: Int) = Data.Bits.shiftL x (fromInteger n)
  | otherwise = error ("Shift operand too large: " ++ show n)
;

shiftlBounded :: Data.Bits.Bits a => a -> Integer -> a;
shiftlBounded x n = Data.Bits.shiftL x (fromInteger n);

shiftrUnbounded :: Data.Bits.Bits a => a -> Integer -> a;
shiftrUnbounded x n
  | n <= toInteger (Prelude.maxBound :: Int) = Data.Bits.shiftR x (fromInteger n)
  | otherwise = error ("Shift operand too large: " ++ show n)
;

shiftrBounded :: (Ord a, Data.Bits.Bits a) => a -> Integer -> a;
shiftrBounded x n = Data.Bits.shiftR x (fromInteger n);*}

  and -- {* @{theory Quickcheck_Narrowing} maps @{typ integer} to
            Haskell's Prelude.Int type instead of Integer. For compatibility
            with the Haskell target, we nevertheless provide bounded and
            unbounded functions. *}
  (Haskell_Quickcheck)
{*import qualified Data.Bits;

{-
  The functions assume that the Int argument for the shift or bit index is
  non-negative and (for types of fixed bit width) less than bitSize
-}

infixl 7 .&.;
infixl 6 `xor`;
infixl 5 .|.;

(.&.) :: Data.Bits.Bits a => a -> a -> a;
(.&.) = (Data.Bits..&.);

xor :: Data.Bits.Bits a => a -> a -> a;
xor = Data.Bits.xor;

(.|.) :: Data.Bits.Bits a => a -> a -> a;
(.|.) = (Data.Bits..|.);

complement :: Data.Bits.Bits a => a -> a;
complement = Data.Bits.complement;

testBitUnbounded :: Data.Bits.Bits a => a -> Prelude.Int -> Bool;
testBitUnbounded = Data.Bits.testBit;

testBitBounded :: Data.Bits.Bits a => a -> Prelude.Int -> Bool;
testBitBounded = Data.Bits.testBit;

setBitUnbounded :: Data.Bits.Bits a => a -> Prelude.Int -> Bool -> a;
setBitUnbounded x n True = Data.Bits.setBit x n;
setBitUnbounded x n False = Data.Bits.clearBit x n;

setBitBounded :: Data.Bits.Bits a => a -> Prelude.Int -> Bool -> a;
setBitBounded x n True = Data.Bits.setBit x n;
setBitBounded x n False = Data.Bits.clearBit x n;

shiftlUnbounded :: Data.Bits.Bits a => a -> Prelude.Int -> a;
shiftlUnbounded = Data.Bits.shiftL;

shiftlBounded :: Data.Bits.Bits a => a -> Prelude.Int -> a;
shiftlBounded = Data.Bits.shiftL;

shiftrUnbounded :: Data.Bits.Bits a => a -> Prelude.Int -> a;
shiftrUnbounded = Data.Bits.shiftR;

shiftrBounded :: (Ord a, Data.Bits.Bits a) => a -> Prelude.Int -> a;
shiftrBounded = Data.Bits.shiftR;*}
code_reserved Haskell Data_Bits

code_printing code_module Bits_Integer \<rightharpoonup> (OCaml)
{*module Bits_Integer : sig
  val and_pninteger : Big_int.big_int -> Big_int.big_int -> Big_int.big_int
  val or_pninteger : Big_int.big_int -> Big_int.big_int -> Big_int.big_int
  val shiftl : Big_int.big_int -> Big_int.big_int -> Big_int.big_int
  val shiftr : Big_int.big_int -> Big_int.big_int -> Big_int.big_int
  val test_bit : Big_int.big_int -> Big_int.big_int -> bool
end = struct

let and_pninteger bi1 bi2 =
  Big_int.and_big_int bi1
    (Big_int.xor_big_int
      (Big_int.pred_big_int
        (Big_int.shift_left_big_int Big_int.unit_big_int
           (max (Big_int.num_digits_big_int bi1 * Nat.length_of_digit)
                (Big_int.num_digits_big_int bi2 * Nat.length_of_digit))))
      (Big_int.pred_big_int (Big_int.minus_big_int bi2)));;

let or_pninteger bi1 bi2 =
  Big_int.pred_big_int (Big_int.minus_big_int
    (Big_int.and_big_int
      (Big_int.xor_big_int
         (Big_int.pred_big_int
           (Big_int.shift_left_big_int Big_int.unit_big_int
              (max (Big_int.num_digits_big_int bi1 * Nat.length_of_digit)
                   (Big_int.num_digits_big_int bi2 * Nat.length_of_digit))))
         bi1)
      (Big_int.pred_big_int (Big_int.minus_big_int bi2))));;

(* We do not need an explicit range checks here,
   because Big_int.int_of_big_int raises Failure
   if the argument does not fit into an int. *)
let shiftl x n = Big_int.shift_left_big_int x (Big_int.int_of_big_int n);;

let shiftr x n = Big_int.shift_right_big_int x (Big_int.int_of_big_int n);;

let test_bit x n =
  Big_int.eq_big_int
    (Big_int.extract_big_int x (Big_int.int_of_big_int n) 1)
    Big_int.unit_big_int

end;; (*struct Bits_Integer*)*}
code_reserved OCaml Bits_Integer

code_printing code_module Bits_Integer \<rightharpoonup> (Scala)
{*object Bits_Integer {

def setBit(x: BigInt, n: BigInt, b: Boolean) : BigInt =
  if (n.isValidInt)
    if (b)
      x.setBit(n.toInt)
    else
      x.clearBit(n.toInt)
  else
    sys.error("Bit index too large: " + n.toString)

def shiftl(x: BigInt, n: BigInt) : BigInt =
  if (n.isValidInt)
    x << n.toInt
  else
    sys.error("Shift index too large: " + n.toString)

def shiftr(x: BigInt, n: BigInt) : BigInt =
  if (n.isValidInt)
    x << n.toInt
  else
    sys.error("Shift index too large: " + n.toString)

def testBit(x: BigInt, n: BigInt) : Boolean =
  if (n.isValidInt)
    x.testBit(n.toInt)
  else
    sys.error("Bit index too large: " + n.toString)

} /* object Bits_Integer */*}

code_printing
  constant "bitAND :: integer \<Rightarrow> integer \<Rightarrow> integer" \<rightharpoonup>
  (SML) "IntInf.andb ((_),/ (_))" and
  (Haskell) "((Data'_Bits..&.) :: Integer -> Integer -> Integer)" and
  (Haskell_Quickcheck) "((Data'_Bits..&.) :: Prelude.Int -> Prelude.Int -> Prelude.Int)" and
  (Scala) infixl 3 "&"
| constant "bitOR :: integer \<Rightarrow> integer \<Rightarrow> integer" \<rightharpoonup>
  (SML) "IntInf.orb ((_),/ (_))" and
  (Haskell) "((Data'_Bits..|.) :: Integer -> Integer -> Integer)" and
  (Haskell_Quickcheck) "((Data'_Bits..|.) :: Prelude.Int -> Prelude.Int -> Prelude.Int)" and
  (Scala) infixl 1 "|"
| constant "bitXOR :: integer \<Rightarrow> integer \<Rightarrow> integer" \<rightharpoonup>
  (SML) "IntInf.xorb ((_),/ (_))" and
  (Haskell) "(Data'_Bits.xor :: Integer -> Integer -> Integer)" and
  (Haskell_Quickcheck) "(Data'_Bits.xor :: Prelude.Int -> Prelude.Int -> Prelude.Int)" and
  (Scala) infixl 2 "^"
| constant "bitNOT :: integer \<Rightarrow> integer" \<rightharpoonup>
  (SML) "IntInf.notb" and
  (Haskell) "(Data'_Bits.complement :: Integer -> Integer)" and
  (Haskell_Quickcheck) "(Data'_Bits.complement :: Prelude.Int -> Prelude.Int)" and
  (Scala) "_.unary'_~"

code_printing constant bin_rest_integer \<rightharpoonup>
  (SML) "IntInf.div ((_), 2)" and
  (Haskell) "(Data'_Bits.shiftrUnbounded _ 1 :: Integer)" and
  (Haskell_Quickcheck) "(Data'_Bits.shiftrUnbounded _ 1 :: Prelude.Int)" and
  (Scala) "_ >> 1" and
  (OCaml) "Big'_int.shift'_right'_big'_int _ 1"

context
includes integer.lifting
begin

lemma bitNOT_integer_code [code]:
  fixes i :: integer shows
  "NOT i = - i - 1"
by transfer(simp add: int_not_def)

lemma bin_rest_integer_code [code nbe]:
  "bin_rest_integer i = i div 2"
by transfer(simp add: bin_rest_def)

lemma bin_last_integer_code [code]:
  "bin_last_integer i \<longleftrightarrow> i AND 1 \<noteq> 0"
by transfer(rule bin_last_conv_AND)

lemma bin_last_integer_nbe [code nbe]:
  "bin_last_integer i \<longleftrightarrow> i mod 2 \<noteq> 0"
by transfer(simp add: bin_last_def)

lemma bitval_bin_last_integer [code_unfold]:
  "of_bool (bin_last_integer i) = i AND 1"
by transfer(rule bitval_bin_last)

end

definition integer_test_bit :: "integer \<Rightarrow> integer \<Rightarrow> bool"
where [code del]: "integer_test_bit x n = (if n < 0 then undefined x n else x !! nat_of_integer n)"

lemma test_bit_integer_code [code]:
  "x !! n \<longleftrightarrow> integer_test_bit x (integer_of_nat n)"
by(simp add: integer_test_bit_def)

lemma integer_test_bit_code [code]:
  "integer_test_bit x (Code_Numeral.Neg n) = undefined x (Code_Numeral.Neg n)"
  "integer_test_bit 0 0 = False"
  "integer_test_bit 0 (Code_Numeral.Pos n) = False"
  "integer_test_bit (Code_Numeral.Pos num.One)      0 = True"
  "integer_test_bit (Code_Numeral.Pos (num.Bit0 n)) 0 = False"
  "integer_test_bit (Code_Numeral.Pos (num.Bit1 n)) 0 = True"
  "integer_test_bit (Code_Numeral.Pos num.One)      (Code_Numeral.Pos n') = False"
  "integer_test_bit (Code_Numeral.Pos (num.Bit0 n)) (Code_Numeral.Pos n') =
   integer_test_bit (Code_Numeral.Pos n) (Code_Numeral.sub n' num.One)"
  "integer_test_bit (Code_Numeral.Pos (num.Bit1 n)) (Code_Numeral.Pos n') =
   integer_test_bit (Code_Numeral.Pos n) (Code_Numeral.sub n' num.One)"
  "integer_test_bit (Code_Numeral.Neg num.One)      0 = True"
  "integer_test_bit (Code_Numeral.Neg (num.Bit0 n)) 0 = False"
  "integer_test_bit (Code_Numeral.Neg (num.Bit1 n)) 0 = True"
  "integer_test_bit (Code_Numeral.Neg num.One)      (Code_Numeral.Pos n') = True"
  "integer_test_bit (Code_Numeral.Neg (num.Bit0 n)) (Code_Numeral.Pos n') =
   integer_test_bit (Code_Numeral.Neg n) (Code_Numeral.sub n' num.One)"
  "integer_test_bit (Code_Numeral.Neg (num.Bit1 n)) (Code_Numeral.Pos n') =
   integer_test_bit (Code_Numeral.Neg (n + num.One)) (Code_Numeral.sub n' num.One)"
by(simp_all add: integer_test_bit_def test_bit_integer_def)

code_printing constant integer_test_bit \<rightharpoonup>
  (SML) "Bits'_Integer.test'_bit" and
  (Haskell) "(Data'_Bits.testBitUnbounded :: Integer -> Integer -> Bool)" and
  (Haskell_Quickcheck) "(Data'_Bits.testBitUnbounded :: Prelude.Int -> Prelude.Int -> Bool)" and
  (OCaml) "Bits'_Integer.test'_bit" and
  (Scala) "Bits'_Integer.testBit"

context
includes integer.lifting
begin

lemma lsb_integer_code [code]:
  fixes x :: integer shows
  "lsb x = x !! 0"
by transfer(simp add: lsb_int_def)

definition integer_set_bit :: "integer \<Rightarrow> integer \<Rightarrow> bool \<Rightarrow> integer"
where [code del]: "integer_set_bit x n b = (if n < 0 then undefined x n b else set_bit x (nat_of_integer n) b)"

lemma set_bit_integer_code [code]:
  "set_bit x i b = integer_set_bit x (integer_of_nat i) b"
by(simp add: integer_set_bit_def)

lemma set_bit_integer_conv_masks:
  fixes x :: integer shows
  "set_bit x i b = (if b then x OR (1 << i) else x AND NOT (1 << i))"
by transfer(simp add: int_set_bit_conv_ops)

end

code_printing constant integer_set_bit \<rightharpoonup>
  (SML) "Bits'_Integer.set'_bit" and
  (Haskell) "(Data'_Bits.setBitUnbounded :: Integer -> Integer -> Bool -> Integer)" and
  (Haskell_Quickcheck) "(Data'_Bits.setBitUnbounded :: Prelude.Int -> Prelude.Int -> Bool -> Prelude.Int)" and
  (Scala) "Bits'_Integer.setBit"

text {*
  OCaml.Big\_int does not have a method for changing an individual bit, so we emulate that with masks.
  We prefer an Isabelle implementation, because this then takes care of the signs for AND and OR.
*}
lemma integer_set_bit_code [code]:
  "integer_set_bit x n b =
  (if n < 0 then undefined x n b else
   if b then x OR (1 << nat_of_integer n)
   else x AND NOT (1 << nat_of_integer n))"
by(auto simp add: integer_set_bit_def set_bit_integer_conv_masks)

lemma set_bits_code [code]:
  "set_bits = Code.abort (STR ''set_bits is unsupported on type integer'') (\<lambda>_. set_bits :: _ \<Rightarrow> integer)"
by simp

definition integer_shiftl :: "integer \<Rightarrow> integer \<Rightarrow> integer"
where [code del]: "integer_shiftl x n = (if n < 0 then undefined x n else x << nat_of_integer n)"

lemma shiftl_integer_code [code]:
  fixes x :: integer shows
  "x << n = integer_shiftl x (integer_of_nat n)"
by(auto simp add: integer_shiftl_def)

context
includes integer.lifting
begin

lemma shiftl_integer_conv_mult_pow2:
  fixes x :: integer shows
  "x << n = x * 2 ^ n"
by transfer(simp add: shiftl_int_def)

lemma integer_shiftl_code [code]:
  "integer_shiftl x (Code_Numeral.Neg n) = undefined x (Code_Numeral.Neg n)"
  "integer_shiftl x 0 = x"
  "integer_shiftl x (Code_Numeral.Pos n) = integer_shiftl (Code_Numeral.dup x) (Code_Numeral.sub n num.One)"
  "integer_shiftl 0 (Code_Numeral.Pos n) = 0"
  by (simp_all add: integer_shiftl_def shiftl_integer_def shiftl_int_def numeral_eq_Suc)
    (transfer, simp)

end

code_printing constant integer_shiftl \<rightharpoonup>
  (SML) "Bits'_Integer.shiftl" and
  (Haskell) "(Data'_Bits.shiftlUnbounded :: Integer -> Integer -> Integer)" and
  (Haskell_Quickcheck) "(Data'_Bits.shiftlUnbounded :: Prelude.Int -> Prelude.Int -> Prelude.Int)" and
  (OCaml) "Bits'_Integer.shiftl" and
  (Scala) "Bits'_Integer.shiftl"

definition integer_shiftr :: "integer \<Rightarrow> integer \<Rightarrow> integer"
where [code del]: "integer_shiftr x n = (if n < 0 then undefined x n else x >> nat_of_integer n)"

lemma shiftr_integer_conv_div_pow2:
  includes integer.lifting fixes x :: integer shows
  "x >> n = x div 2 ^ n"
by transfer(simp add: shiftr_int_def)

lemma shiftr_integer_code [code]:
  fixes x :: integer shows
  "x >> n = integer_shiftr x (integer_of_nat n)"
by(auto simp add: integer_shiftr_def)

code_printing constant integer_shiftr \<rightharpoonup>
  (SML) "Bits'_Integer.shiftr" and
  (Haskell) "(Data'_Bits.shiftrUnbounded :: Integer -> Integer -> Integer)" and
  (Haskell_Quickcheck) "(Data'_Bits.shiftrUnbounded :: Prelude.Int -> Prelude.Int -> Prelude.Int)" and
  (OCaml) "Bits'_Integer.shiftr" and
  (Scala) "Bits'_Integer.shiftr"

lemma integer_shiftr_code [code]:
  "integer_shiftr x (Code_Numeral.Neg n) = undefined x (Code_Numeral.Neg n)"
  "integer_shiftr x 0 = x"
  "integer_shiftr 0 (Code_Numeral.Pos n) = 0"
  "integer_shiftr (Code_Numeral.Pos num.One) (Code_Numeral.Pos n) = 0"
  "integer_shiftr (Code_Numeral.Pos (num.Bit0 n')) (Code_Numeral.Pos n) =
   integer_shiftr (Code_Numeral.Pos n') (Code_Numeral.sub n num.One)"
  "integer_shiftr (Code_Numeral.Pos (num.Bit1 n')) (Code_Numeral.Pos n) =
   integer_shiftr (Code_Numeral.Pos n') (Code_Numeral.sub n num.One)"
  "integer_shiftr (Code_Numeral.Neg num.One) (Code_Numeral.Pos n) = -1"
  "integer_shiftr (Code_Numeral.Neg (num.Bit0 n')) (Code_Numeral.Pos n) =
   integer_shiftr (Code_Numeral.Neg n') (Code_Numeral.sub n num.One)"
  "integer_shiftr (Code_Numeral.Neg (num.Bit1 n')) (Code_Numeral.Pos n) =
   integer_shiftr (Code_Numeral.Neg (Num.inc n')) (Code_Numeral.sub n num.One)"
by(simp_all add: integer_shiftr_def shiftr_integer_def)

context
includes integer.lifting
begin

lemma Bit_integer_code [code]:
  "Bit_integer i False = i << 1"
  "Bit_integer i True = (i << 1) + 1"
by(transfer, simp add: Bit_def shiftl_int_def)+

lemma msb_integer_code [code]:
  "msb (x :: integer) \<longleftrightarrow> x < 0"
by transfer(simp add: msb_int_def)

subsection {* OCaml implementation for @{text "AND"}, @{text "OR"}, and @{text "XOR"} *}

definition and_pint :: "int \<Rightarrow> int \<Rightarrow> int" where
  "and_pint i j =
  (if i < 0 \<or> j < 0 then int_of_integer (undefined (integer_of_int i) (integer_of_int j))
   else i AND j)"

definition or_pint :: "int \<Rightarrow> int \<Rightarrow> int" where
  "or_pint i j =
   (if i < 0 \<or> j < 0 then int_of_integer (undefined (integer_of_int i) (integer_of_int j))
    else i OR j)"

definition xor_pint :: "int \<Rightarrow> int \<Rightarrow> int" where
  "xor_pint i j =
  (if i < 0 \<or> j < 0 then int_of_integer (undefined (integer_of_int i) (integer_of_int j))
   else i XOR j)"

lift_definition and_pinteger :: "integer \<Rightarrow> integer \<Rightarrow> integer" is and_pint .
lift_definition or_pinteger :: "integer \<Rightarrow> integer \<Rightarrow> integer" is or_pint .
lift_definition xor_pinteger :: "integer \<Rightarrow> integer \<Rightarrow> integer" is xor_pint .

end

code_printing
  constant and_pinteger \<rightharpoonup> (OCaml) "Big'_int.and'_big'_int"
| constant or_pinteger  \<rightharpoonup> (OCaml) "Big'_int.or'_big'_int"
| constant xor_pinteger \<rightharpoonup> (OCaml) "Big'_int.xor'_big'_int"

context
includes integer.lifting natural.lifting
begin

lemma and_pinteger_unfold:
  "and_pinteger i j = (if i < 0 \<or> j < 0 then undefined i j else i AND j)"
including undefined_transfer by transfer(simp add: and_pint_def)

lemma or_pinteger_unfold:
  "or_pinteger i j = (if i < 0 \<or> j < 0 then undefined i j else i OR j)"
including undefined_transfer by transfer(simp add: or_pint_def)

lemma xor_pinteger_unfold:
  "xor_pinteger i j = (if i < 0 \<or> j < 0 then undefined i j else i XOR j)"
including undefined_transfer by transfer(simp add: xor_pint_def)

lemma xor_OCaml_code [code]:
  fixes i :: integer shows
  "i XOR j =
  (if i < 0 then
     if j < 0 then
        xor_pinteger (NOT i) (NOT j)
     else
        NOT (xor_pinteger (NOT i) j)
   else if j < 0 then
     NOT (xor_pinteger i (NOT j))
   else xor_pinteger i j)"
by transfer(simp add: int_xor_not xor_pint_def)

lemma and_pinteger_code [code]:
  "and_pinteger (Code_Numeral.Neg n) j = undefined (Code_Numeral.Neg n) j"
  "and_pinteger i (Code_Numeral.Neg n) = undefined i (Code_Numeral.Neg n)"
  "and_pinteger 0 0 = 0"
  "and_pinteger (Code_Numeral.Pos n) 0 = 0"
  "and_pinteger 0 (Code_Numeral.Pos n) = 0"
  "and_pinteger (Code_Numeral.Pos m) (Code_Numeral.Pos n) = (case bitAND_num m n of None \<Rightarrow> 0 | Some n' \<Rightarrow> Code_Numeral.Pos n')"
including undefined_transfer by(transfer, simp add: and_pint_def Bit_def int_and_code[unfolded Int.Pos_def])+

lemma or_pinteger_code [code]:
  "or_pinteger (Code_Numeral.Neg n) j = undefined (Code_Numeral.Neg n) j"
  "or_pinteger i (Code_Numeral.Neg n) = undefined i (Code_Numeral.Neg n)"
  "or_pinteger 0 0 = 0"
  "or_pinteger (Code_Numeral.Pos n) 0 = (Code_Numeral.Pos n)"
  "or_pinteger 0 (Code_Numeral.Pos n) = (Code_Numeral.Pos n)"
  "or_pinteger (Code_Numeral.Pos m) (Code_Numeral.Pos n) = Code_Numeral.Pos (bitOR_num m n)"
including undefined_transfer by(transfer, simp add: or_pint_def Bit_def int_or_code[unfolded Int.Pos_def])+

lemma xor_pinteger_code [code]:
  "xor_pinteger (Code_Numeral.Neg n) j = undefined (Code_Numeral.Neg n) j"
  "xor_pinteger i (Code_Numeral.Neg n) = undefined i (Code_Numeral.Neg n)"
  "xor_pinteger 0 0 = 0"
  "xor_pinteger (Code_Numeral.Pos n) 0 = (Code_Numeral.Pos n)"
  "xor_pinteger 0 (Code_Numeral.Pos n) = (Code_Numeral.Pos n)"
  "xor_pinteger (Code_Numeral.Pos n) (Code_Numeral.Pos m) = (case bitXOR_num n m of None \<Rightarrow> 0 | Some n' \<Rightarrow> Code_Numeral.Pos n')"
including undefined_transfer by(transfer, simp add: xor_pint_def Bit_def int_xor_code[unfolded Int.Pos_def])+

text {*
  If one argument is positive and the other negative, AND and OR
  cannot be expressed with XOR/NOT and only positive arguments.
  To handle this case, we define @{term "and_pninteger"} and @{term "or_pninteger"}
  and implement them manually in the code\_include Bits\_Integer.
  The following proves that the implementation is correct.
*}

definition and_pnint :: "int \<Rightarrow> int \<Rightarrow> int" where
  "and_pnint i j =
   (if i \<ge> 0 \<and> j < 0 then i AND j
    else int_of_integer (undefined (integer_of_int i) (integer_of_int j)))"

definition or_pnint :: "int \<Rightarrow> int \<Rightarrow> int" where
  "or_pnint i j =
   (if i \<ge> 0 \<and> j < 0 then i OR j
    else int_of_integer (undefined (integer_of_int i) (integer_of_int j)))"

fun log2 :: "int => nat" where
  "log2 i = (if i < 0 then undefined else if i = 0 then 0 else log2 (i div 2) + 1)"

lift_definition and_pninteger :: "integer \<Rightarrow> integer \<Rightarrow> integer" is and_pnint .
lift_definition or_pninteger :: "integer \<Rightarrow> integer \<Rightarrow> integer" is or_pnint .
lift_definition log2_integer :: "integer \<Rightarrow> natural" is log2 .
lift_definition bin_mask_integer :: "natural \<Rightarrow> integer" is bin_mask .

end

code_printing
  constant and_pninteger \<rightharpoonup> (OCaml) "Bits'_Integer.and'_pninteger"
| constant or_pninteger  \<rightharpoonup> (OCaml) "Bits'_Integer.or'_pninteger"

context
includes integer.lifting natural.lifting
begin

lemma and_pninteger_unfold:
  "and_pninteger i j = (if i \<ge> 0 \<and> j < 0 then i AND j else undefined i j)"
including undefined_transfer by transfer(simp add: and_pnint_def)

lemma and_pninteger_code [code]:
  "and_pninteger (Code_Numeral.Neg n) j = undefined (Code_Numeral.Neg n) j"
  "and_pninteger i 0 = undefined i (0 :: integer)"
  "and_pninteger i (Code_Numeral.Pos n) = undefined i (Code_Numeral.Pos n)"
  "and_pninteger 0 (Code_Numeral.Neg n) = 0"
  "and_pninteger (Code_Numeral.Pos n) (Code_Numeral.Neg num.One) = Code_Numeral.Pos n"
  "and_pninteger (Code_Numeral.Pos n) (Code_Numeral.Neg (num.Bit0 m)) = Code_Numeral.sub (bitORN_num (Num.BitM m) n) num.One"
  "and_pninteger (Code_Numeral.Pos n) (Code_Numeral.Neg (num.Bit1 m)) = Code_Numeral.sub (bitORN_num (num.Bit0 m) n) num.One"
including undefined_transfer by(transfer, simp add: and_pnint_def Bit_def int_and_code[unfolded Int.Pos_def Int.Neg_def])+

lemma or_pninteger_unfold:
  "or_pninteger i j = (if i \<ge> 0 \<and> j < 0 then i OR j else undefined i j)"
including undefined_transfer by transfer(simp add: or_pnint_def)

lemma or_pninteger_code [code]:
  "or_pninteger (Code_Numeral.Neg n) j = undefined (Code_Numeral.Neg n) j"
  "or_pninteger i 0 = undefined i (0 :: integer)"
  "or_pninteger i (Code_Numeral.Pos n) = undefined i (Code_Numeral.Pos n)"
  "or_pninteger 0 (Code_Numeral.Neg n) = Code_Numeral.Neg n"

  "or_pninteger (Code_Numeral.Pos n) (Code_Numeral.Neg num.One) = -1"
  "or_pninteger (Code_Numeral.Pos n) (Code_Numeral.Neg (num.Bit0 m)) = (case bitANDN_num (Num.BitM m) n of None \<Rightarrow> -1 | Some n' \<Rightarrow> Code_Numeral.Neg (Num.inc n'))"
  "or_pninteger (Code_Numeral.Pos n) (Code_Numeral.Neg (num.Bit1 m)) = (case bitANDN_num (num.Bit0 m) n of None \<Rightarrow> -1 | Some n' \<Rightarrow> Code_Numeral.Neg (Num.inc n'))"
including undefined_transfer by(transfer, simp add: or_pnint_def Bit_def int_or_code[unfolded Int.Pos_def Int.Neg_def])+

lemma integer_and_OCaml_code [code]:
  "i AND j =
  (if i \<ge> 0 then
     if j \<ge> 0 then
       and_pinteger i j
     else and_pninteger i j
   else if j < 0 then
     NOT (or_pinteger (NOT i) (NOT j))
   else and_pninteger j i)"
by transfer(simp add: and_pnint_def and_pint_def or_pint_def bbw_not_dist int_and_comm)

lemma integer_or_OCaml_code [code]:
  "i OR j =
  (if i \<ge> 0 then
     if j \<ge> 0 then
       or_pinteger i j
     else or_pninteger i j
   else if j < 0 then
     NOT (and_pinteger (NOT i) (NOT j))
   else or_pninteger j i)"
by transfer(simp add: or_pnint_def and_pint_def or_pint_def bbw_not_dist int_or_comm)

lemma integer_or_unfold:
  fixes x y :: integer shows
  "x OR y = NOT (NOT x AND NOT y)"
by(transfer)(simp add: int_or_def)

lemma bitAND_integer_unfold:
  "x AND y =
   (if x = 0 then 0
    else if x = -1 then y
    else Bit_integer (bin_rest_integer x AND bin_rest_integer y) (bin_last_integer x \<and> bin_last_integer y))"
by transfer(rule bitAND_int.simps)

lemma log2_simps [simp]:
  "log2 0 = 0"
  "log2 1 = 1"
  "n < 0 \<Longrightarrow> log2 n = undefined"
by(simp_all)

declare log2.simps [simp del]

lemma log2_le_plus1: "0 \<le> i \<Longrightarrow> log2 i \<le> log2 (i + 1)"
proof(induct i rule: log2.induct)
  case (1 i)
  moreover have "i mod 2 = 0 \<or> i mod 2 = 1" by arith
  ultimately show ?case by(subst (1 2) log2.simps)(auto, simp_all add: zdiv_zadd1_eq)
qed

lemma log2_mono:
  assumes x: "0 \<le> x" and xy: "x \<le> y"
  shows "log2 x \<le> log2 y"
using xy
proof(induct n\<equiv>"nat (y - x)" arbitrary: y)
  case 0 thus ?case by simp
next
  case (Suc n)
  from `Suc n = nat (y - x)` Suc.prems
  have "n = nat (y - 1 - x)" "x \<le> y - 1" by simp_all
  hence "log2 x \<le> log2 (y - 1)" by(rule Suc)
  also have "\<dots> \<le> log2 y" using log2_le_plus1[of "y - 1"] x `x \<le> y - 1` by simp
  finally show ?case .
qed

lemma log2_eq_0 [simp]:
  "i \<ge> 0 \<Longrightarrow> log2 i = 0 \<longleftrightarrow> i = 0"
by(subst log2.simps) force

lemma pow2_log2_gt: "i \<ge> 0 \<Longrightarrow> i < 2 ^ log2 i"
proof(induct i rule: log2.induct)
  case (1 i)
  hence IH: "i div 2 < 2 ^ log2 (i div 2)"
    by (metis (full_types) div_pos_pos_trivial order_less_imp_not_less order_less_le_trans pos_imp_zdiv_nonneg_iff zero_less_numeral zero_less_power)
  show ?case
  proof(cases "i = 0")
    case True thus ?thesis by simp
  next
    case False with `0 \<le> i` have "i > 0" by simp
    thus ?thesis using IH by(subst log2.simps)(simp add: nat_add_distrib)
  qed
qed

lemma log2_bin_rest [simp]: "i > 0 \<Longrightarrow> log2 (bin_rest i) = log2 i - 1"
by(subst (2) log2.simps)(simp add: bin_rest_def)

lemma bin_mask_XOR_conv_and_not: "\<lbrakk> n \<ge> log2 i; i \<ge> 0 \<rbrakk> \<Longrightarrow> bin_mask n XOR i = bin_mask n AND NOT i"
proof(induct n arbitrary: i)
  case 0 thus ?case by simp
next
  case (Suc n)
  from Suc(1)[of "bin_rest i"] `0 \<le> i` Suc(2)
  show ?case by(cases "i = 0")(auto intro: bin_rl_eqI)
qed

lemma int_and_mask: "\<lbrakk> n \<ge> log2 i; i \<ge> 0 \<rbrakk> \<Longrightarrow> i AND bin_mask n = i"
proof(induct n arbitrary: i)
  case 0 thus ?case by simp
next
  case (Suc n)
  from Suc(1)[of "bin_rest i"] `0 \<le> i` Suc(2)
  show ?case by(cases "i = 0")(auto intro: bin_rl_eqI)
qed

lemma and_pnint:
  assumes x: "x \<ge> 0" and y: "y < 0"
  and kx: "k \<ge> log2 x" and ky: "k \<ge> log2 (- y)"
  shows "and_pnint x y = and_pint x (xor_pint (bin_mask k) (- y - 1))"
proof -
  from y have "log2 (- y - 1) \<le> log2 (- y)" by(auto intro: log2_mono)
  with ky have "log2 (NOT y) \<le> k" by(simp add: int_not_def)
  moreover from y have "0 \<le> NOT y" by(simp add: int_not_def)
  ultimately have "bin_mask k XOR NOT y = bin_mask k AND NOT NOT y"
    by(rule bin_mask_XOR_conv_and_not)
  moreover
  have "x AND y = (x AND bin_mask k) AND y" using kx x
    by(rule arg_cong[OF int_and_mask, symmetric])
  ultimately show ?thesis using x y bin_mask_ge0[of "k"]
    unfolding and_pnint_def and_pint_def
    by(simp add: int_and_assoc int_not_def xor_pint_def)
qed

lemma and_pninteger:  -- {* justification for OCaml implementation of @{term andpnint} *}
  "\<lbrakk> x \<ge> 0; y < 0; k \<ge> log2_integer x; k \<ge> log2_integer (- y) \<rbrakk>
  \<Longrightarrow> and_pninteger x y = and_pinteger x (xor_pinteger (bin_mask_integer k) (- y - 1))"
by transfer(rule and_pnint)

lemma or_pnint:
  assumes x: "x \<ge> 0" and y: "y < 0"
  and kx: "k \<ge> log2 x" and ky: "k \<ge> log2 (- y)"
  shows "or_pnint x y = - (and_pint (xor_pint (bin_mask k) x) (- y - 1)) - 1"
proof -
  from y have "log2 (- y - 1) \<le> log2 (- y)" by(auto intro: log2_mono)
  with ky have "log2 (NOT y) \<le> k" by(simp add: int_not_def)
  moreover from y have "0 \<le> NOT y" by(simp add: int_not_def)
  ultimately have "bin_mask k XOR NOT y = bin_mask k AND NOT NOT y"
    by(rule bin_mask_XOR_conv_and_not)
  moreover have "bin_mask k XOR x \<ge> 0" using x bin_mask_ge0[of k] by simp
  ultimately show ?thesis using x y kx `log2 (NOT y) \<le> k` `0 \<le> NOT y`
    by(simp add: or_pnint_def int_or_def and_pint_def int_not_def xor_pint_def bin_mask_XOR_conv_and_not int_and_assoc)
      (subst bbw_lcs(1), subst (3) int_and_comm, simp add: int_and_mask)
qed

lemma or_pinteger: -- {* justification for OCaml implementation of @{term or_pnint} *}
  "\<lbrakk>  x \<ge> 0; y < 0; k \<ge> log2_integer x; k \<ge> log2_integer (- y) \<rbrakk>
  \<Longrightarrow> or_pninteger x y = - (and_pinteger (xor_pinteger (bin_mask_integer k) x) (- y - 1)) - 1"
by(transfer)(rule or_pnint)

end

hide_const (open)
  log2 and_pint and_pnint or_pint or_pnint xor_pint
  log2_integer bin_mask_integer and_pinteger and_pninteger or_pinteger or_pninteger xor_pinteger

section {* Test code generator setup *}

definition bit_integer_test :: "bool" where
  "bit_integer_test =
  (([ -1 AND 3, 1 AND -3, 3 AND 5, -3 AND (- 5)
    , -3 OR 1, 1 OR -3, 3 OR 5, -3 OR (- 5)
    , NOT 1, NOT (- 3)
    , -1 XOR 3, 1 XOR (- 3), 3 XOR 5, -5 XOR (- 3)
    , set_bit 5 4 True, set_bit (- 5) 2 True, set_bit 5 0 False, set_bit (- 5) 1 False
    , 1 << 2, -1 << 3
    , 100 >> 3, -100 >> 3] :: integer list)
  = [ 3, 1, 1, -7
    , -3, -3, 7, -1
    , -2, 2
    , -4, -4, 6, 6
    , 21, -1, 4, -7
    , 4, -8
    , 12, -13] \<and>
    [ (5 :: integer) !! 4, (5 :: integer) !! 2, (-5 :: integer) !! 4, (-5 :: integer) !! 2
    , lsb (5 :: integer), lsb (4 :: integer), lsb (-1 :: integer), lsb (-2 :: integer),
      msb (5 :: integer), msb (0 :: integer), msb (-1 :: integer), msb (-2 :: integer)]
  = [ False, True, True, False,
      True, False, True, False,
      False, False, True, True])"

export_code bit_integer_test checking SML Haskell? Haskell_Quickcheck? OCaml? Scala

notepad begin
have bit_integer_test by eval
have bit_integer_test by normalization
have bit_integer_test by code_simp
end
ML_val {* val true = @{code bit_integer_test} *}

lemma "x AND y = x OR (y :: integer)"
quickcheck[random, expect=counterexample]
quickcheck[exhaustive, expect=counterexample]
oops

lemma "(x :: integer) AND x = x OR x"
quickcheck[narrowing, expect=no_counterexample]
oops

lemma "(f :: integer \<Rightarrow> unit) = g"
quickcheck[narrowing, size=3, expect=no_counterexample]
by(simp add: fun_eq_iff)

hide_const bit_integer_test
hide_fact bit_integer_test_def

end


header {* \isaheader{Specification of Sequences} *}
theory ListSpec
imports ICF_Spec_Base
begin

(*@intf List
  @abstype 'a list
  This interface specifies sequences.
*)

subsection "Definition"
locale list =
  -- "Abstraction to HOL-lists"
  fixes \<alpha> :: "'s \<Rightarrow> 'x list"
  -- "Invariant"
  fixes invar :: "'s \<Rightarrow> bool"

locale list_no_invar = list +
  assumes invar[simp, intro!]: "\<And>l. invar l"

subsection "Functions"

locale list_empty = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes empty :: "unit \<Rightarrow> 's"
  assumes empty_correct:
    "\<alpha> (empty ()) = []"
    "invar (empty ())"

locale list_isEmpty = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes isEmpty :: "'s \<Rightarrow> bool"
  assumes isEmpty_correct:
    "invar s \<Longrightarrow> isEmpty s \<longleftrightarrow> \<alpha> s = []"

locale poly_list_iteratei = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
begin
  definition iteratei where
    iteratei_correct[code_unfold]: "iteratei s \<equiv> foldli (\<alpha> s)"
  definition iterate where
    iterate_correct[code_unfold]: "iterate s \<equiv> foldli (\<alpha> s) (\<lambda>_. True)"
end

locale poly_list_rev_iteratei = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
begin
  definition rev_iteratei where
    rev_iteratei_correct[code_unfold]: "rev_iteratei s \<equiv> foldri (\<alpha> s)"
  definition rev_iterate where
    rev_iterate_correct[code_unfold]: "rev_iterate s \<equiv> foldri (\<alpha> s) (\<lambda>_. True)"
end

(*
locale list_iteratei = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes iteratei :: "'s \<Rightarrow> ('x,'\<sigma>) set_iterator"
  assumes iteratei_correct:
    "invar s \<Longrightarrow> iteratei s = foldli (\<alpha> s)"
begin
  lemma iteratei_no_sel_rule:
    "invar s \<Longrightarrow> distinct (\<alpha> s) \<Longrightarrow> set_iterator (iteratei s) (set (\<alpha> s))"
    by (simp add: iteratei_correct set_iterator_foldli_correct)
end

lemma list_iteratei_iteratei_linord_rule:
  "list_iteratei \<alpha> invar iteratei \<Longrightarrow> invar s \<Longrightarrow> distinct (\<alpha> s) \<Longrightarrow> sorted (\<alpha> s) \<Longrightarrow>
   set_iterator_linord (iteratei s) (set (\<alpha> s))"
  by (simp add: list_iteratei_def set_iterator_linord_foldli_correct)

lemma list_iteratei_iteratei_rev_linord_rule:
  "list_iteratei \<alpha> invar iteratei \<Longrightarrow> invar s \<Longrightarrow> distinct (\<alpha> s) \<Longrightarrow> sorted (rev (\<alpha> s)) \<Longrightarrow>
   set_iterator_rev_linord (iteratei s) (set (\<alpha> s))"
  by (simp add: list_iteratei_def set_iterator_rev_linord_foldli_correct)

locale list_reverse_iteratei = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes reverse_iteratei :: "'s \<Rightarrow> ('x,'\<sigma>) set_iterator"
  assumes reverse_iteratei_correct:
    "invar s \<Longrightarrow> reverse_iteratei s = foldri (\<alpha> s)"
begin
  lemma reverse_iteratei_no_sel_rule:
    "invar s \<Longrightarrow> distinct (\<alpha> s) \<Longrightarrow> set_iterator (reverse_iteratei s) (set (\<alpha> s))"
    by (simp add: reverse_iteratei_correct set_iterator_foldri_correct)
end

lemma list_reverse_iteratei_iteratei_linord_rule:
  "list_reverse_iteratei \<alpha> invar iteratei \<Longrightarrow> invar s \<Longrightarrow> distinct (\<alpha> s) \<Longrightarrow> sorted (rev (\<alpha> s)) \<Longrightarrow>
   set_iterator_linord (iteratei s) (set (\<alpha> s))"
  by (simp add: list_reverse_iteratei_def set_iterator_linord_foldri_correct)

lemma list_reverse_iteratei_iteratei_rev_linord_rule:
  "list_reverse_iteratei \<alpha> invar iteratei \<Longrightarrow> invar s \<Longrightarrow> distinct (\<alpha> s) \<Longrightarrow> sorted (\<alpha> s) \<Longrightarrow>
   set_iterator_rev_linord (iteratei s) (set (\<alpha> s))"
  by (simp add: list_reverse_iteratei_def set_iterator_rev_linord_foldri_correct)
*)

locale list_size = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes size :: "'s \<Rightarrow> nat"
  assumes size_correct:
    "invar s \<Longrightarrow> size s = length (\<alpha> s)"

locale list_appendl = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes appendl :: "'x \<Rightarrow> 's \<Rightarrow> 's"
  assumes appendl_correct:
    "invar s \<Longrightarrow> \<alpha> (appendl x s) = x#\<alpha> s"
    "invar s \<Longrightarrow> invar (appendl x s)"
begin
  abbreviation (input) "push \<equiv> appendl"
  lemmas push_correct = appendl_correct
end

locale list_removel = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes removel :: "'s \<Rightarrow> ('x \<times> 's)"
  assumes removel_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> fst (removel s) = hd (\<alpha> s)"
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> \<alpha> (snd (removel s)) = tl (\<alpha> s)"
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> invar (snd (removel s))"
begin
  lemma removelE:
    assumes I: "invar s" "\<alpha> s \<noteq> []"
    obtains s' where "removel s = (hd (\<alpha> s), s')" "invar s'" "\<alpha> s' = tl (\<alpha> s)"
  proof -
    from removel_correct(1,2,3)[OF I] have
      C: "fst (removel s) = hd (\<alpha> s)"
         "\<alpha> (snd (removel s)) = tl (\<alpha> s)"
         "invar (snd (removel s))" .
    from that[of "snd (removel s)", OF _ C(3,2), folded C(1)] show thesis
      by simp
  qed

  text {* The following shortcut notations are not meant for generating efficient code,
    but solely to simplify reasoning *}
  (* TODO: Is this actually used somewhere ? *)
  (*
  definition "head s == fst (removef s)"
  definition "tail s == snd (removef s)"

  lemma tail_correct: "\<lbrakk>invar F; \<alpha> F \<noteq> []\<rbrakk> \<Longrightarrow> \<alpha> (tail F) = tl (\<alpha> F)"
    by (simp add: tail_def removef_correct)

  lemma removef_split: "removef F = (head F, tail F)"
    apply (cases "removef F")
    apply (simp add: head_def tail_def)
    done
    *)

  abbreviation (input) "pop \<equiv> removel"
  lemmas pop_correct = removel_correct

  abbreviation (input) "dequeue \<equiv> removel"
  lemmas dequeue_correct = removel_correct
end

locale list_leftmost = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes leftmost :: "'s \<Rightarrow> 'x"
  assumes leftmost_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> leftmost s = hd (\<alpha> s)"
begin
  abbreviation (input) top where "top \<equiv> leftmost"
  lemmas top_correct = leftmost_correct
end

locale list_appendr = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes appendr :: "'x \<Rightarrow> 's \<Rightarrow> 's"
  assumes appendr_correct:
    "invar s \<Longrightarrow> \<alpha> (appendr x s) = \<alpha> s @ [x]"
    "invar s \<Longrightarrow> invar (appendr x s)"
begin
  abbreviation (input) "enqueue \<equiv> appendr"
  lemmas enqueue_correct = appendr_correct
end

locale list_remover = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes remover :: "'s \<Rightarrow> 's \<times> 'x"
  assumes remover_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> \<alpha> (fst (remover s)) = butlast (\<alpha> s)"
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> snd (remover s) = last (\<alpha> s)"
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> invar (fst (remover s))"

locale list_rightmost = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes rightmost :: "'s \<Rightarrow> 'x"
  assumes rightmost_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> []\<rbrakk> \<Longrightarrow> rightmost s = List.last (\<alpha> s)"
begin
  abbreviation (input) bot where "bot \<equiv> rightmost"
  lemmas bot_correct = rightmost_correct
end

subsubsection "Indexing"
locale list_get = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes get :: "'s \<Rightarrow> nat \<Rightarrow> 'x"
  assumes get_correct:
    "\<lbrakk>invar s; i<length (\<alpha> s)\<rbrakk> \<Longrightarrow> get s i = \<alpha> s ! i"

locale list_set = list +
  constrains \<alpha> :: "'s \<Rightarrow> 'x list"
  fixes set :: "'s \<Rightarrow> nat \<Rightarrow> 'x \<Rightarrow> 's"
  assumes set_correct:
    "\<lbrakk>invar s; i<length (\<alpha> s)\<rbrakk> \<Longrightarrow> \<alpha> (set s i x) = \<alpha> s [i := x]"
    "\<lbrakk>invar s; i<length (\<alpha> s)\<rbrakk> \<Longrightarrow> invar (set s i x)"

record ('a,'s) list_ops =
  list_op_\<alpha> :: "'s \<Rightarrow> 'a list"
  list_op_invar :: "'s \<Rightarrow> bool"
  list_op_empty :: "unit \<Rightarrow> 's"
  list_op_isEmpty :: "'s \<Rightarrow> bool"
  list_op_size :: "'s \<Rightarrow> nat"
  list_op_appendl :: "'a \<Rightarrow> 's \<Rightarrow> 's"
  list_op_removel :: "'s \<Rightarrow> 'a \<times> 's"
  list_op_leftmost :: "'s \<Rightarrow> 'a"
  list_op_appendr :: "'a \<Rightarrow> 's \<Rightarrow> 's"
  list_op_remover :: "'s \<Rightarrow> 's \<times> 'a"
  list_op_rightmost :: "'s \<Rightarrow> 'a"
  list_op_get :: "'s \<Rightarrow> nat \<Rightarrow> 'a"
  list_op_set :: "'s \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 's"

locale StdListDefs =
  poly_list_iteratei "list_op_\<alpha> ops" "list_op_invar ops"
  + poly_list_rev_iteratei "list_op_\<alpha> ops" "list_op_invar ops"
  for ops :: "('a,'s,'more) list_ops_scheme"
begin
  abbreviation \<alpha> where "\<alpha> \<equiv> list_op_\<alpha> ops"
  abbreviation invar where "invar \<equiv> list_op_invar ops"
  abbreviation empty where "empty \<equiv> list_op_empty ops"
  abbreviation isEmpty where "isEmpty \<equiv> list_op_isEmpty ops"
  abbreviation size where "size \<equiv> list_op_size ops"
  abbreviation appendl where "appendl \<equiv> list_op_appendl ops"
  abbreviation removel where "removel \<equiv> list_op_removel ops"
  abbreviation leftmost where "leftmost \<equiv> list_op_leftmost ops"
  abbreviation appendr where "appendr \<equiv> list_op_appendr ops"
  abbreviation remover where "remover \<equiv> list_op_remover ops"
  abbreviation rightmost where "rightmost \<equiv> list_op_rightmost ops"
  abbreviation get where "get \<equiv> list_op_get ops"
  abbreviation set where "set \<equiv> list_op_set ops"
end

locale StdList = StdListDefs ops
  + list \<alpha> invar
  + list_empty \<alpha> invar empty
  + list_isEmpty \<alpha> invar isEmpty
  + list_size \<alpha> invar size
  + list_appendl \<alpha> invar appendl
  + list_removel \<alpha> invar removel
  + list_leftmost \<alpha> invar leftmost
  + list_appendr \<alpha> invar appendr
  + list_remover \<alpha> invar remover
  + list_rightmost \<alpha> invar rightmost
  + list_get \<alpha> invar get
  + list_set \<alpha> invar set
  for ops :: "('a,'s,'more) list_ops_scheme"
begin
  lemmas correct =
    empty_correct
    isEmpty_correct
    size_correct
    appendl_correct
    removel_correct
    leftmost_correct
    appendr_correct
    remover_correct
    rightmost_correct
    get_correct
    set_correct

end

locale StdList_no_invar = StdList + list_no_invar \<alpha> invar

end


header {* Miscellaneous Lemmas *}
theory Sep_Misc
imports Main "../../Automatic_Refinement/Lib/Misc"
begin
  text {* These lemmas are candidates to be pushed into the Isabelle/HOL
    standard libraries *}

lemma imp_mp_iff[simp]: "a \<and> (a \<longrightarrow> b) \<longleftrightarrow> a \<and> b"
  by metis

lemma Un_empty'[simp]:
  "{} = a\<union>b \<longleftrightarrow> a={} \<and> b={}"
  by auto

text {* The following lemma is useful to split non-empty lists. *}
lemma list_not_emptyE:
  assumes "l\<noteq>[]"
  obtains x xs where "l=x#xs"
  using assms by (metis list.exhaust)

lemma map_of_eq_empty_iff [simp]:
  "map_of xs = Map.empty \<longleftrightarrow> xs=[]"
proof
  assume "map_of xs = Map.empty"
  thus "xs = []" by (induct xs) simp_all
qed auto

end


section {* More on Terms *}

theory Terms imports Transition_QuasiTerms_Terms
begin

text{* In this section, we continue the study of terms, with stating and proving
properties specific to terms (while in the previous section we dealt with
lifting properties from quasi-terms).
Consequently, in this theory, not only the theorems, but neither the proofs
should mention quasi-items at all.
Among the properties specific to terms will
be the compositionality properties of substitution (while, by contrast, similar properties
of swapping also held for quasi-tems).
 *}

context FixVars (* scope all throughout the file *)
begin

declare qItem_simps[simp del]
declare qItem_versus_item_simps[simp del]

subsection {* Identity environment versus other operators *}

(* Recall theorem getEnv_idEnv. *)

theorem getEnv_updEnv_idEnv[simp]:
"(idEnv [x \<leftarrow> X]_xs) ys y = (if (ys = xs \<and> y = x) then Some X else None)"
unfolding idEnv_def updEnv_def by simp

theorem subst_psubst_idEnv:
"(X #[Y / y]_ys) = (X #[idEnv [y \<leftarrow> Y]_ys])"
unfolding subst_def idEnv_def updEnv_def psubst_def by simp

theorem vsubst_psubst_idEnv:
"(X #[z // y]_ys) = (X #[idEnv [y \<leftarrow> Var ys z]_ys])"
unfolding vsubst_def by(simp add: subst_psubst_idEnv)

theorem substEnv_psubstEnv_idEnv:
"(rho &[Y / y]_ys) = (rho &[idEnv [y \<leftarrow> Y]_ys])"
unfolding substEnv_def idEnv_def updEnv_def psubstEnv_def by simp

theorem vsubstEnv_psubstEnv_idEnv:
"(rho &[z // y]_ys) = (rho &[idEnv [y \<leftarrow> Var ys z]_ys])"
unfolding vsubstEnv_def by (simp add: substEnv_psubstEnv_idEnv)

theorem freshEnv_idEnv: "freshEnv xs x idEnv"
unfolding idEnv_def freshEnv_def liftAll_def by simp

theorem swapEnv_idEnv[simp]: "(idEnv &[x \<and> y]_xs) = idEnv"
unfolding idEnv_def swapEnv_def comp_def swapEnvDom_def swapEnvIm_def lift_def by simp

theorem psubstEnv_idEnv[simp]: "(idEnv &[rho]) = rho"
unfolding idEnv_def psubstEnv_def lift_def by simp

theorem substEnv_idEnv: "(idEnv &[X / x]_xs) = (idEnv [x \<leftarrow> X]_xs)"
unfolding substEnv_def using psubstEnv_idEnv by auto

theorem vsubstEnv_idEnv: "(idEnv &[y // x]_xs) = (idEnv [x \<leftarrow> (Var xs y)]_xs)"
unfolding vsubstEnv_def using substEnv_idEnv .

lemma psubstAll_idEnv:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs"
shows
"(good X  \<longrightarrow> (X #[idEnv]) = X) \<and>
 (goodAbs A  \<longrightarrow> (A $[idEnv]) = A)"
apply(induct rule: term_rawInduct)
unfolding psubstInp_def psubstBinp_def
using idEnv_preserves_good psubst_Var_simp1
by (simp_all del: getEnv_idEnv add:
liftAll_lift_ext lift_ident freshEnv_idEnv psubstBinp_def psubstInp_def)
  fastforce+

lemma psubst_idEnv[simp]:
"good X \<Longrightarrow> (X #[idEnv]) = X"
by(simp add: psubstAll_idEnv)

lemma psubstEnv_idEnv_id[simp]:
assumes "goodEnv rho"
shows "(rho &[idEnv]) = rho"
using assms unfolding psubstEnv_def lift_def goodEnv_def liftAll_def
apply(intro ext) subgoal for xs x by(cases "rho xs x") auto .

subsection {* Environment update versus other operators *}

(* Recall theorem getEnv_updEnv. *)

theorem updEnv_overwrite[simp]: "((rho [x \<leftarrow> X]_xs) [x \<leftarrow> X']_xs) = (rho [x \<leftarrow> X']_xs)"
unfolding updEnv_def by fastforce

theorem updEnv_commute:
assumes "xs \<noteq> ys \<or> x \<noteq> y"
shows "((rho [x \<leftarrow> X]_xs) [y \<leftarrow> Y]_ys) = ((rho [y \<leftarrow> Y]_ys) [x \<leftarrow> X]_xs)"
using assms unfolding updEnv_def by fastforce

theorem freshEnv_updEnv_E1:
assumes "freshEnv xs y (rho [x \<leftarrow> X]_xs)"
shows "y \<noteq> x"
using assms unfolding freshEnv_def liftAll_def updEnv_def by auto

theorem freshEnv_updEnv_E2:
assumes "freshEnv ys y (rho [x \<leftarrow> X]_xs)"
shows "fresh ys y X"
using assms unfolding freshEnv_def liftAll_def updEnv_def
by (auto split: if_splits)

theorem freshEnv_updEnv_E3:
assumes "freshEnv ys y (rho [x \<leftarrow> X]_xs)"
shows "rho ys y = None"
using assms freshEnv_updEnv_E1[of ys y] unfolding freshEnv_def
by (metis getEnv_updEnv option.simps(3))

theorem freshEnv_updEnv_E4:
assumes "freshEnv ys y (rho [x \<leftarrow> X]_xs)"
and "zs \<noteq> xs \<or> z \<noteq> x" and "rho zs z = Some Z"
shows "fresh ys y Z"
using assms unfolding freshEnv_def liftAll_def
by (metis getEnv_updEnv1)

theorem freshEnv_updEnv_I:
assumes "ys \<noteq> xs \<or> y \<noteq> x" and "fresh ys y X" and "rho ys y = None"
and "\<And> zs z Z. \<lbrakk>zs \<noteq> xs \<or> z \<noteq> x; rho zs z = Some Z\<rbrakk> \<Longrightarrow> fresh ys y Z"
shows "freshEnv ys y (rho [x \<leftarrow> X]_xs)"
unfolding freshEnv_def liftAll_def
using assms by auto

theorem swapEnv_updEnv:
"((rho [x \<leftarrow> X]_xs) &[y1 \<and> y2]_ys) =
 ((rho &[y1 \<and> y2]_ys) [(x @xs[y1 \<and> y2]_ys) \<leftarrow> (X #[y1 \<and> y2]_ys)]_xs)"
unfolding swapEnv_defs sw_def lift_def
by(cases "xs = ys") fastforce+

lemma swapEnv_updEnv_fresh:
assumes "ys \<noteq> xs \<or> x \<notin> {y1,y2}" and "good X"
and "fresh ys y1 X" and "fresh ys y2 X"
shows "((rho [x \<leftarrow> X]_xs) &[y1 \<and> y2]_ys) =
       ((rho &[y1 \<and> y2]_ys) [x \<leftarrow> X]_xs)"
using assms by(simp add: swapEnv_updEnv)

theorem psubstEnv_updEnv:
"((rho [x \<leftarrow> X]_xs) &[rho']) = ((rho &[rho']) [x \<leftarrow> (X #[rho'])]_xs)"
unfolding psubstEnv_def by fastforce

theorem psubstEnv_updEnv_idEnv:
"((idEnv [x \<leftarrow> X]_xs) &[rho]) = (rho [x \<leftarrow> (X #[rho])]_xs)"
by(simp add: psubstEnv_updEnv)

theorem substEnv_updEnv:
"((rho [x \<leftarrow> X]_xs) &[Y / y]_ys) = ((rho &[Y / y]_ys) [x \<leftarrow> (X #[Y / y]_ys)]_xs)"
unfolding substEnv_def subst_def by(rule psubstEnv_updEnv)

theorem vsubstEnv_updEnv:
"((rho [x \<leftarrow> X]_xs) &[y1 // y]_ys) = ((rho &[y1 // y]_ys) [x \<leftarrow> (X #[y1 // y]_ys)]_xs)"
unfolding vsubstEnv_def vsubst_def using substEnv_updEnv .

subsection {* Environment ``get" versus other operators *}

text{* Currently, ``get" is just function application.  While the next
properties are immediate consequences of the definitions, it is worth stating
them because of their abstract character (since later, concrete terms
inferred from abstract terms by a presumptive package, ``get" will no longer
be function application). *}

theorem getEnv_ext:
assumes "\<And> xs x. rho xs x = rho' xs x"
shows "rho = rho'"
using assms by(simp add: ext)

theorem freshEnv_getEnv1[simp]:
"\<lbrakk>freshEnv ys y rho; rho xs x = Some X\<rbrakk> \<Longrightarrow> ys \<noteq> xs \<or> y \<noteq> x"
unfolding freshEnv_def by auto

theorem freshEnv_getEnv2[simp]:
"\<lbrakk>freshEnv ys y rho; rho xs x = Some X\<rbrakk> \<Longrightarrow> fresh ys y X"
unfolding freshEnv_def liftAll_def by simp

theorem freshEnv_getEnv[simp]:
"freshEnv ys y rho \<Longrightarrow> rho ys y = None"
unfolding freshEnv_def by simp

theorem getEnv_swapEnv1[simp]:
assumes "rho xs (x @xs [z1 \<and> z2]_zs) = None"
shows "(rho &[z1 \<and> z2]_zs) xs x = None"
using assms unfolding swapEnv_defs lift_def by simp

theorem getEnv_swapEnv2[simp]:
assumes "rho xs (x @xs [z1 \<and> z2]_zs) = Some X"
shows "(rho &[z1 \<and> z2]_zs) xs x = Some (X #[z1 \<and> z2]_zs)"
using assms unfolding swapEnv_defs lift_def by simp

theorem getEnv_psubstEnv_None[simp]:
assumes "rho xs x = None"
shows "(rho &[rho']) xs x = rho' xs x"
using assms unfolding psubstEnv_def by simp

theorem getEnv_psubstEnv_Some[simp]:
assumes "rho xs x = Some X"
shows "(rho &[rho']) xs x = Some (X #[rho'])"
using assms unfolding psubstEnv_def by simp

theorem getEnv_substEnv1[simp]:
assumes "ys \<noteq> xs \<or> y \<noteq> x" and "rho xs x = None"
shows "(rho &[Y / y]_ys) xs x = None"
using assms unfolding substEnv_def2 by auto

theorem getEnv_substEnv2[simp]:
assumes "ys \<noteq> xs \<or> y \<noteq> x" and "rho xs x = Some X"
shows "(rho &[Y / y]_ys) xs x = Some (X #[Y / y]_ys)"
using assms unfolding substEnv_def2 by auto

theorem getEnv_substEnv3[simp]:
"\<lbrakk>ys \<noteq> xs \<or> y \<noteq> x; freshEnv xs x rho\<rbrakk>
 \<Longrightarrow> (rho &[Y / y]_ys) xs x = None"
using getEnv_substEnv1 by auto

theorem getEnv_substEnv4[simp]:
"freshEnv ys y rho \<Longrightarrow> (rho &[Y / y]_ys) ys y = Some Y"
unfolding substEnv_psubstEnv_idEnv by simp

theorem getEnv_vsubstEnv2[simp]:
assumes "ys \<noteq> xs \<or> y \<noteq> x" and "rho xs x = Some X"
shows "(rho &[y1 // y]_ys) xs x = Some (X #[y1 // y]_ys)"
using assms unfolding vsubstEnv_def vsubst_def by auto

theorem getEnv_vsubstEnv3[simp]:
"\<lbrakk>ys \<noteq> xs \<or> y \<noteq> x; freshEnv xs x rho\<rbrakk>
 \<Longrightarrow> (rho &[z // y]_ys) xs x = None"
using getEnv_vsubstEnv1 by auto

theorem getEnv_vsubstEnv4[simp]:
"freshEnv ys y rho \<Longrightarrow> (rho &[z // y]_ys) ys y = Some (Var ys z)"
unfolding vsubstEnv_psubstEnv_idEnv by simp

subsection {* Substitution versus other operators  *}

definition freshImEnvAt ::
"'varSort \<Rightarrow> 'var \<Rightarrow> ('index,'bindex,'varSort,'var,'opSym)env \<Rightarrow> 'varSort \<Rightarrow> 'var \<Rightarrow> bool"
where
"freshImEnvAt xs x rho ys y ==
 rho ys y = None \<and> (ys \<noteq> xs \<or> y \<noteq> x) \<or>
 (\<exists> Y. rho ys y = Some Y \<and> fresh xs x Y)"

lemma freshAll_psubstAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param" and x
assumes goodP: "goodPar P"
shows
"(good X \<longrightarrow> z \<in> varsOf P \<longrightarrow>
  (\<forall> rho \<in> envsOf P.
     fresh zs z (X #[rho]) =
     (\<forall> ys. \<forall> y. fresh ys y X \<or> freshImEnvAt zs z rho ys y)))
 \<and>
 (goodAbs A \<longrightarrow> z \<in> varsOf P \<longrightarrow>
  (\<forall> rho \<in> envsOf P.
     freshAbs zs z (A $[rho]) =
     (\<forall> ys. \<forall> y. freshAbs ys y A \<or> freshImEnvAt zs z rho ys y)))"
proof(induction rule: term_induct_fresh[of P])
  case Par
  then show ?case using goodP by simp
next
  case (Var ys y)
  thus ?case proof clarify
    fix rho
    assume r: "rho \<in> envsOf P"
    hence g: "goodEnv rho" using goodP by simp
    thus "fresh zs z (psubst rho (Var ys y)) =
     (\<forall>ysa ya. fresh ysa ya (Var ys y) \<or> freshImEnvAt zs z rho ysa ya)"
    unfolding freshImEnvAt_def
    by(cases "ys = zs \<and> y = z", (cases "rho ys y", auto)+)
  qed
next
  case (Op delta inp binp)
  show ?case proof clarify
    fix rho
    assume P: "z \<in> varsOf P" "rho \<in> envsOf P"
    let ?L1 = "liftAll (fresh zs z \<circ> psubst rho) inp"
    let ?L2 = "liftAll (freshAbs zs z \<circ> psubstAbs rho) binp"
    let ?R1 = "%ys y. liftAll (fresh ys y) inp"
    let ?R2 = "%ys y. liftAll (freshAbs ys y) binp"
    let ?R3 = "%ys y. freshImEnvAt zs z rho ys y"
    have "(?L1 \<and> ?L2) = (\<forall>ys y. ?R1 ys y \<and> ?R2 ys y \<or> ?R3 ys y)"
    using Op.IH P unfolding liftAll_def by simp blast
    thus "fresh zs z ((Op delta inp binp) #[rho]) =
           (\<forall>ys y. fresh ys y (Op delta inp binp) \<or> freshImEnvAt zs z rho ys y)"
    by (metis (no_types, lifting) Op.hyps(1) Op.hyps(2) P(2) envsOf_preserves_good freshBinp_def freshInp_def fresh_Op_simp goodP liftAll_lift_comp psubstBinp_def psubstBinp_preserves_good
     psubstInp_def psubstInp_preserves_good psubst_Op_simp)
  qed
next
  case (Abs xs x X)
  thus ?case
  using goodP by simp (metis (full_types) freshEnv_def freshImEnvAt_def)
qed

corollary fresh_psubst:
assumes "good X" and "goodEnv rho"
shows
"fresh zs z (X #[rho]) =
 (\<forall> ys y. fresh ys y X \<or> freshImEnvAt zs z rho ys y)"
using assms freshAll_psubstAll[of "Par [z] [] [] [rho]"]
unfolding goodPar_def by simp

corollary fresh_psubst_E1:
assumes "good X" and "goodEnv rho"
and "rho ys y = None" and "fresh zs z (X #[rho])"
shows "fresh ys y X \<or> (ys \<noteq> zs \<or> y \<noteq> z)"
using assms fresh_psubst unfolding freshImEnvAt_def by fastforce

corollary fresh_psubst_E2:
assumes "good X" and "goodEnv rho"
and "rho ys y = Some Y" and "fresh zs z (X #[rho])"
shows "fresh ys y X \<or> fresh zs z Y"
using assms fresh_psubst[of X rho] unfolding freshImEnvAt_def by fastforce

corollary fresh_psubst_I1:
assumes "good X" and "goodEnv rho"
and "fresh zs z X" and "freshEnv zs z rho"
shows "fresh zs z (X #[rho])"
using assms apply(simp add: fresh_psubst)
unfolding freshEnv_def liftAll_def freshImEnvAt_def by auto

corollary psubstEnv_preserves_freshEnv:
assumes good: "goodEnv rho"  "goodEnv rho'"
and fresh: "freshEnv zs z rho"  "freshEnv zs z rho'"
shows "freshEnv zs z (rho &[rho'])"
using assms unfolding freshEnv_def liftAll_def
by simp (smt Var_preserves_good fresh(2) fresh_psubst_I1 option.case_eq_if
option.exhaust_sel option.sel psubstEnv_def psubst_Var_simp2 psubst_preserves_good)

corollary fresh_psubst_I:
assumes "good X" and "goodEnv rho"
and "rho zs z = None \<Longrightarrow> fresh zs z X" and
    "\<And> ys y Y. rho ys y = Some Y \<Longrightarrow> fresh ys y X \<or> fresh zs z Y"
shows "fresh zs z (X #[rho])"
using assms unfolding freshImEnvAt_def
by (simp add: fresh_psubst) (metis freshImEnvAt_def not_None_eq)

lemma fresh_subst:
assumes "good X" and "good Y"
shows "fresh zs z (X #[Y / y]_ys) =
       (((zs = ys \<and> z = y) \<or> fresh zs z X) \<and> (fresh ys y X \<or> fresh zs z Y))"
using assms unfolding subst_def freshImEnvAt_def
by (simp add: fresh_psubst)
(metis (no_types, lifting) freshImEnvAt_def fresh_psubst fresh_psubst_E2
getEnv_updEnv_idEnv idEnv_preserves_good option.simps(3) updEnv_preserves_good)

lemma fresh_vsubst:
assumes "good X"
shows "fresh zs z (X #[y1 // y]_ys) =
       (((zs = ys \<and> z = y) \<or> fresh zs z X) \<and> (fresh ys y X \<or> (zs \<noteq> ys \<or> z \<noteq> y1)))"
unfolding vsubst_def using assms by(auto simp: fresh_subst)

lemma subst_preserves_fresh:
assumes "good X" and "good Y"
and "fresh zs z X" and "fresh zs z Y"
shows "fresh zs z (X #[Y / y]_ys)"
using assms by(simp add: fresh_subst)

lemma substEnv_preserves_freshEnv_aux:
assumes rho: "goodEnv rho" and Y: "good Y"
and fresh_rho: "freshEnv zs z rho" and fresh_Y: "fresh zs z Y" and diff: "zs \<noteq> ys \<or> z \<noteq> y"
shows "freshEnv zs z (rho &[Y / y]_ys)"
using assms unfolding freshEnv_def liftAll_def
by (simp add: option.case_eq_if substEnv_def2 subst_preserves_fresh)

lemma substEnv_preserves_freshEnv:
assumes rho: "goodEnv rho" and Y: "good Y"
and fresh_rho: "freshEnv zs z rho" and fresh_Y: "fresh zs z Y" and diff: "zs \<noteq> ys \<or> z \<noteq> y"
shows "freshEnv zs z (rho &[Y / y]_ys)"
using assms by(simp add: substEnv_preserves_freshEnv_aux)

lemma vsubst_preserves_fresh:
assumes "good X"
and "fresh zs z X" and "zs \<noteq> ys \<or> z \<noteq> y1"
shows "fresh zs z (X #[y1 // y]_ys)"
using assms by(simp add: fresh_vsubst)

lemma vsubstEnv_preserves_freshEnv:
assumes rho: "goodEnv rho"
and fresh_rho: "freshEnv zs z rho" and diff: "zs \<noteq> ys \<or> z \<notin> {y,y1}"
shows "freshEnv zs z (rho &[y1 // y]_ys)"
using assms unfolding vsubstEnv_def
by(simp add: substEnv_preserves_freshEnv)

lemma fresh_fresh_subst[simp]:
assumes "good Y" and "good X"
and "fresh ys y Y"
shows "fresh ys y (X #[Y / y]_ys)"
using assms by(simp add: fresh_subst)

lemma diff_fresh_vsubst[simp]:
assumes "good X"
and "y \<noteq> y1"
shows "fresh ys y (X #[y1 // y]_ys)"
using assms by(simp add: fresh_vsubst)

lemma fresh_subst_E1:
assumes "good X" and "good Y"
and "fresh zs z (X #[Y / y]_ys)" and "zs \<noteq> ys \<or> z \<noteq> y"
shows "fresh zs z X"
using assms by(auto simp add: fresh_subst)

lemma fresh_vsubst_E1:
assumes "good X"
and "fresh zs z (X #[y1 // y]_ys)" and "zs \<noteq> ys \<or> z \<noteq> y"
shows "fresh zs z X"
using assms by(auto simp add: fresh_vsubst)

lemma fresh_subst_E2:
assumes "good X" and "good Y"
and "fresh zs z (X #[Y / y]_ys)"
shows "fresh ys y X \<or> fresh zs z Y"
using assms by(simp add: fresh_subst)

lemma fresh_vsubst_E2:
assumes "good X"
and "fresh zs z (X #[y1 // y]_ys)"
shows "fresh ys y X \<or> zs \<noteq> ys \<or> z \<noteq> y1"
using assms by(simp add: fresh_vsubst)

lemma psubstAll_cong:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param"
assumes goodP: "goodPar P"
shows
"(good X \<longrightarrow>
  (\<forall> rho rho'. {rho, rho'} \<subseteq> envsOf P \<longrightarrow>
   (\<forall> ys. \<forall> y. fresh ys y X \<or> rho ys y = rho' ys y) \<longrightarrow>
               (X #[rho]) = (X #[rho'])))
\<and>
 (goodAbs A \<longrightarrow>
  (\<forall> rho rho'. {rho, rho'} \<subseteq> envsOf P \<longrightarrow>
   (\<forall> ys. \<forall> y. freshAbs ys y A \<or> rho ys y = rho' ys y) \<longrightarrow>
               (A $[rho]) = (A $[rho'])))"
proof(induction rule: term_induct_fresh[of P])
  case Par
  then show ?case using assms .
next
  case (Var xs x)
  then show ?case using goodP by (auto simp: psubst_Var)
next
  case (Op delta inp binp)
  show ?case proof clarify
    fix rho rho'
    assume envs: "{rho, rho'} \<subseteq> envsOf P"
    hence goodEnv: "goodEnv rho \<and> goodEnv rho'" using goodP by simp
    assume "\<forall>ys y. fresh ys y (Op delta inp binp) \<or> rho ys y = rho' ys y"
    hence 1: "liftAll (\<lambda> X. \<forall>ys y. fresh ys y X \<or> rho ys y = rho' ys y) inp \<and>
            liftAll (\<lambda> A. \<forall>ys y. freshAbs ys y A \<or> rho ys y = rho' ys y) binp"
    using Op by simp (smt freshBinp_def freshInp_def liftAll_def)
    have "liftAll (\<lambda> X. (X #[rho]) = (X #[rho'])) inp \<and>
          liftAll (\<lambda> A. (A $[rho]) = (A $[rho'])) binp"
    using Op.IH 1 envs by (auto simp: liftAll_def)
    thus "(Op delta inp binp) #[rho] = (Op delta inp binp) #[rho']"
    using Op.IH 1
    by (simp add: Op.hyps goodEnv psubstBinp_def psubstInp_def liftAll_lift_ext)
  qed
next
  case (Abs xs x X)
  thus ?case
  using Abs goodP unfolding freshEnv_def liftAll_def
  by simp (metis Abs.hyps(5) envsOf_preserves_good psubstAbs_simp)
qed

corollary psubst_cong[fundef_cong]:
assumes "good X" and "goodEnv rho" and "goodEnv rho'"
and "\<And> ys y. fresh ys y X \<or> rho ys y = rho' ys y"
shows "(X #[rho]) = (X #[rho'])"
using assms psubstAll_cong[of "Par [] [] [] [rho,rho']"]
unfolding goodPar_def by simp

(* Note: A congruence principle for ``psubstEnv" would not hold w.r.t. ``freshEnv",
and the one that would hold w.r.t. ``fresh" would be a mere rephrasing of the
definition of ``psubstEnv", not worth stating. *)

lemma fresh_psubst_updEnv:
assumes "good X" and "good Y" and "goodEnv rho"
and "fresh xs x Y"
shows "(Y #[rho [x \<leftarrow> X]_xs]) = (Y #[rho])"
using assms by (auto cong: psubst_cong)

lemma psubstAll_ident:
fixes X :: "('index,'bindex,'varSort,'var,'opSym)term" and
      A :: "('index,'bindex,'varSort,'var,'opSym)abs" and
      P :: "('index,'bindex,'varSort,'var,'opSym) Transition_QuasiTerms_Terms.param"
assumes P: "goodPar P"
shows
"(good X \<longrightarrow>
  (\<forall> rho \<in> envsOf P.
   (\<forall> zs z. freshEnv zs z rho \<or> fresh zs z X)
   \<longrightarrow> (X #[rho]) = X))
 \<and>
 (goodAbs A \<longrightarrow>
  (\<forall> rho \<in> envsOf P.
   (\<forall> zs z. freshEnv zs z rho \<or> freshAbs zs z A)
   \<longrightarrow> (A $[rho]) = A))"
proof(induction rule: term_induct_fresh)
  case (Var xs x)
  then show ?case
  by (meson assms freshEnv_def fresh_Var_simp goodPar_def psubst_Var_simp1)
next
  case (Op delta inp binp)
  then show ?case
  by (metis (no_types,lifting) Op_preserves_good assms envsOf_preserves_good
   freshEnv_getEnv idEnv_def idEnv_preserves_good psubst_cong psubst_idEnv)
qed(insert P, fastforce+)

corollary freshEnv_psubst_ident[simp]:
fixes X :: "('index,'bindex,'varSort,'var,'opSym)term"
assumes "good X" and "goodEnv rho"
and "\<And> zs z. freshEnv zs z rho \<or> fresh zs z X"
shows "(X #[rho]) = X"
using assms psubstAll_ident[of "Par [] [] [] [rho]"]
unfolding goodPar_def by simp

lemma fresh_subst_ident[simp]:
assumes "good X" and "good Y" and "fresh xs x Y"
shows "(Y #[X / x]_xs) = Y"
by (simp add: assms fresh_psubst_updEnv subst_def)

corollary substEnv_updEnv_fresh:
assumes "good X" and "good Y" and "fresh ys y X"
shows "((rho [x \<leftarrow> X]_xs) &[Y / y]_ys) = ((rho &[Y / y]_ys) [x \<leftarrow> X]_xs)"
using assms by(simp add: substEnv_updEnv)

lemma fresh_substEnv_updEnv[simp]:
assumes rho: "goodEnv rho" and Y: "good Y"
and *: "freshEnv ys y rho"
shows "(rho &[Y / y]_ys) = (rho [y \<leftarrow> Y]_ys)"
apply (rule getEnv_ext)
subgoal for xs x using assms by (cases "rho xs x") auto .

lemma fresh_vsubst_ident[simp]:
assumes "good Y" and "fresh xs x Y"
shows "(Y #[x1 // x]_xs) = Y"
using assms unfolding vsubst_def by simp

corollary vsubstEnv_updEnv_fresh:
assumes "good X" and "fresh ys y X"
shows "((rho [x \<leftarrow> X]_xs) &[y1 // y]_ys) = ((rho &[y1 // y]_ys) [x \<leftarrow> X]_xs)"
using assms by(simp add: vsubstEnv_updEnv)

lemma fresh_vsubstEnv_updEnv[simp]:
assumes rho: "goodEnv rho"
and *: "freshEnv ys y rho"
shows "(rho &[y1 // y]_ys) = (rho [y \<leftarrow> Var ys y1]_ys)"
using assms unfolding vsubstEnv_def by simp

lemma swapAll_psubstAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param"
assumes P: "goodPar P"
shows
"(good X \<longrightarrow>
  (\<forall> rho z1 z2. rho \<in> envsOf P \<and> {z1,z2} \<subseteq> varsOf P \<longrightarrow>
                ((X #[rho]) #[z1 \<and> z2]_zs) = ((X #[z1 \<and> z2]_zs) #[rho &[z1 \<and> z2]_zs])))
 \<and>
 (goodAbs A \<longrightarrow>
  (\<forall> rho z1 z2. rho \<in> envsOf P \<and> {z1,z2} \<subseteq> varsOf P \<longrightarrow>
                ((A $[rho]) $[z1 \<and> z2]_zs) = ((A $[z1 \<and> z2]_zs) $[rho &[z1 \<and> z2]_zs])))"
proof(induction rule: term_induct_fresh[of P])
  case (Var xs x)
  then show ?case using assms
  by simp (smt Var_preserves_good envsOf_preserves_good getEnv_swapEnv1 getEnv_swapEnv2 option.case_eq_if option.exhaust_sel psubst_Var psubst_Var_simp2 swapEnv_preserves_good
 swap_Var_simp swap_involutive2 swap_sym)
next
  case (Op delta inp binp)
  then show ?case
  using assms
  unfolding psubstInp_def swapInp_def psubstBinp_def swapBinp_def lift_comp
  unfolding liftAll_def lift_def
  by simp (auto simp: lift_def psubstInp_def swapInp_def
  psubstBinp_def swapBinp_def split: option.splits)
qed(insert assms, auto)

lemma swap_psubst:
assumes "good X" and "goodEnv rho"
shows "((X #[rho]) #[z1 \<and> z2]_zs) = ((X #[z1 \<and> z2]_zs) #[rho &[z1 \<and> z2]_zs])"
using assms swapAll_psubstAll[of "Par [z1,z2] [] [] [rho]"]
unfolding goodPar_def by auto

lemma swap_subst:
assumes "good X" and "good Y"
shows "((X #[Y / y]_ys) #[z1 \<and> z2]_zs) =
       ((X #[z1 \<and> z2]_zs) #[(Y #[z1 \<and> z2]_zs) / (y @ys[z1 \<and> z2]_zs)]_ys)"
proof-
  have 1: "(idEnv [(y @ys[z1 \<and> z2]_zs) \<leftarrow> (Y #[z1 \<and> z2]_zs)]_ys) =
           ((idEnv [y \<leftarrow> Y]_ys) &[z1 \<and> z2]_zs)"
  by(simp add: swapEnv_updEnv)
  show ?thesis
  using assms unfolding subst_def 1 by (intro swap_psubst) auto
qed

lemma swap_vsubst:
assumes "good X"
shows "((X #[y1 // y]_ys) #[z1 \<and> z2]_zs) =
       ((X #[z1 \<and> z2]_zs) #[(y1 @ys[z1 \<and> z2]_zs) // (y @ys[z1 \<and> z2]_zs)]_ys)"
using assms unfolding vsubst_def
by(simp add: swap_subst)

lemma swapEnv_psubstEnv:
assumes "goodEnv rho" and "goodEnv rho'"
shows "((rho &[rho']) &[z1 \<and> z2]_zs) = ((rho &[z1 \<and> z2]_zs) &[rho' &[z1 \<and> z2]_zs])"
using assms apply(intro ext)
subgoal for xs x
by (cases "rho xs (x @xs[z1 \<and> z2]_zs)")
   (auto simp: lift_def swapEnv_defs swap_psubst) .

lemma swapEnv_substEnv:
assumes "good Y" and "goodEnv rho"
shows "((rho &[Y / y]_ys) &[z1 \<and> z2]_zs) =
       ((rho &[z1 \<and> z2]_zs) &[(Y #[z1 \<and> z2]_zs) / (y @ys[z1 \<and> z2]_zs)]_ys)"
proof-
  have 1: "(idEnv [(y @ys[z1 \<and> z2]_zs) \<leftarrow> (Y #[z1 \<and> z2]_zs)]_ys) =
           ((idEnv [y \<leftarrow> Y]_ys) &[z1 \<and> z2]_zs)"
  by(simp add: swapEnv_updEnv)
  show ?thesis
  unfolding substEnv_def 1
  using assms by (intro swapEnv_psubstEnv) auto
qed

lemma swapEnv_vsubstEnv:
assumes "goodEnv rho"
shows "((rho &[y1 // y]_ys) &[z1 \<and> z2]_zs) =
       ((rho &[z1 \<and> z2]_zs) &[(y1 @ys[z1 \<and> z2]_zs) // (y @ys[z1 \<and> z2]_zs)]_ys)"
using assms unfolding vsubstEnv_def by(simp add: swapEnv_substEnv)

lemma psubstAll_compose:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param"
assumes P: "goodPar P"
shows
"(good X \<longrightarrow>
  (\<forall> rho rho'. {rho,rho'} \<subseteq> envsOf P \<longrightarrow> ((X #[rho]) #[rho']) = (X #[(rho &[rho'])])))
\<and>
 (goodAbs A \<longrightarrow>
  (\<forall> rho rho'. {rho,rho'} \<subseteq> envsOf P \<longrightarrow> ((A $[rho]) $[rho']) = (A $[(rho &[rho'])])))"
proof(induction rule: term_induct_fresh[of P])
  case (Var xs x)
  then show ?case using assms
  by simp (smt envsOf_preserves_good option.case_eq_if option.sel psubstEnv_def
  psubstEnv_idEnv_id psubstEnv_preserves_good psubst_Var_simp1 psubst_Var_simp2)
next
  case (Op delta inp binp)
  then show ?case
  using assms
  unfolding psubstInp_def swapInp_def psubstBinp_def swapBinp_def lift_comp
  unfolding liftAll_def lift_def
  by simp (auto simp: lift_def psubstInp_def swapInp_def
  psubstBinp_def swapBinp_def split: option.splits)
qed(insert assms, simp_all add: psubstEnv_preserves_freshEnv)

corollary psubst_compose:
assumes "good X" and "goodEnv rho" and "goodEnv rho'"
shows "((X #[rho]) #[rho']) = (X #[(rho &[rho'])])"
using assms psubstAll_compose[of "Par [] [] [] [rho, rho']"]
unfolding goodPar_def by auto

lemma psubstEnv_compose:
assumes "goodEnv rho" and "goodEnv rho'" and "goodEnv rho''"
shows "((rho &[rho']) &[rho'']) = (rho &[(rho' &[rho''])])"
using assms apply(intro ext)
subgoal for xs x
by (cases "rho xs x") (auto simp: lift_def psubstEnv_def  psubst_compose) .

lemma psubst_subst_compose:
assumes "good X" and "good Y" and "goodEnv rho"
shows "((X #[Y / y]_ys) #[rho]) = (X #[(rho [y \<leftarrow> (Y #[rho])]_ys)])"
by (simp add: assms psubstEnv_updEnv_idEnv psubst_compose subst_psubst_idEnv)

lemma psubstEnv_substEnv_compose:
assumes "goodEnv rho" and "good Y" and "goodEnv rho'"
shows "((rho &[Y / y]_ys) &[rho']) = (rho &[(rho' [y \<leftarrow> (Y #[rho'])]_ys)])"
by (simp add: assms psubstEnv_compose psubstEnv_updEnv_idEnv substEnv_def)

lemma psubst_vsubst_compose:
assumes "good X" and "goodEnv rho"
shows "((X #[y1 // y]_ys) #[rho]) = (X #[(rho [y \<leftarrow> ((Var ys y1) #[rho])]_ys)])"
using assms unfolding vsubst_def by(simp add: psubst_subst_compose)

lemma psubstEnv_vsubstEnv_compose:
assumes "goodEnv rho" and "goodEnv rho'"
shows "((rho &[y1 // y]_ys) &[rho']) = (rho &[(rho' [y \<leftarrow> ((Var ys y1) #[rho'])]_ys)])"
using assms unfolding vsubstEnv_def by(simp add: psubstEnv_substEnv_compose)

lemma subst_psubst_compose:
assumes "good X" and "good Y" and "goodEnv rho"
shows "((X #[rho]) #[Y / y]_ys) = (X #[(rho &[Y / y]_ys)])"
unfolding subst_def substEnv_def using assms by(simp add: psubst_compose)

lemma substEnv_psubstEnv_compose:
assumes "goodEnv rho" and "good Y" and "goodEnv rho'"
shows "((rho &[rho']) &[Y / y]_ys) = (rho &[(rho' &[Y / y]_ys)])"
unfolding substEnv_def using assms by(simp add: psubstEnv_compose)

lemma psubst_subst_compose_freshEnv:
assumes "goodEnv rho" and "good X" and "good Y"
assumes "freshEnv ys y rho"
shows "((X #[Y / y]_ys) #[rho]) = ((X #[rho]) #[(Y #[rho]) / y]_ys)"
using assms by (simp add: subst_psubst_compose psubst_subst_compose)

lemma psubstEnv_substEnv_compose_freshEnv:
assumes "goodEnv rho" and "goodEnv rho'" and "good Y"
assumes "freshEnv ys y rho'"
shows "((rho &[Y / y]_ys) &[rho']) = ((rho &[rho']) &[(Y #[rho']) / y]_ys)"
using assms by (simp add: substEnv_psubstEnv_compose psubstEnv_substEnv_compose)

lemma vsubst_psubst_compose:
assumes "good X" and "goodEnv rho"
shows "((X #[rho]) #[y1 // y]_ys) = (X #[(rho &[y1 // y]_ys)])"
unfolding vsubst_def vsubstEnv_def using assms by(simp add: subst_psubst_compose)

lemma vsubstEnv_psubstEnv_compose:
assumes "goodEnv rho" and "goodEnv rho'"
shows "((rho &[rho']) &[y1 // y]_ys) = (rho &[(rho' &[y1 // y]_ys)])"
unfolding vsubstEnv_def using assms by(simp add: substEnv_psubstEnv_compose)

lemma subst_compose1:
assumes "good X" and "good Y1" and "good Y2"
shows "((X #[Y1 / y]_ys) #[Y2 / y]_ys) = (X #[(Y1 #[Y2 / y]_ys) / y]_ys)"
proof-
  have "goodEnv (idEnv [y \<leftarrow> Y1]_ys) \<and> goodEnv (idEnv [y \<leftarrow> Y2]_ys)" using assms by simp
  thus ?thesis using `good X` unfolding subst_def substEnv_def
  by(simp add: psubst_compose psubstEnv_updEnv)
qed

lemma substEnv_compose1:
assumes "goodEnv rho" and "good Y1" and "good Y2"
shows "((rho &[Y1 / y]_ys) &[Y2 / y]_ys) = (rho &[(Y1 #[Y2 / y]_ys) / y]_ys)"
by (simp add: assms psubstEnv_compose psubstEnv_updEnv_idEnv substEnv_def subst_psubst_idEnv)

lemma subst_vsubst_compose1:
assumes "good X" and "good Y" and "y \<noteq> y1"
shows "((X #[y1 // y]_ys) #[Y / y]_ys) = (X #[y1 // y]_ys)"
using assms unfolding vsubst_def by(simp add: subst_compose1)

lemma substEnv_vsubstEnv_compose1:
assumes "goodEnv rho" and "good Y" and "y \<noteq> y1"
shows "((rho &[y1 // y]_ys) &[Y / y]_ys) = (rho &[y1 // y]_ys)"
using assms unfolding vsubst_def vsubstEnv_def by(simp add: substEnv_compose1)

lemma vsubst_subst_compose1:
assumes "good X" and "good Y"
shows "((X #[Y / y]_ys) #[y1 // y]_ys) = (X #[(Y #[y1 // y]_ys) / y]_ys)"
using assms unfolding vsubst_def by(simp add: subst_compose1)

lemma vsubstEnv_substEnv_compose1:
assumes "goodEnv rho" and "good Y"
shows "((rho &[Y / y]_ys) &[y1 // y]_ys) = (rho &[(Y #[y1 // y]_ys) / y]_ys)"
using assms unfolding vsubst_def vsubstEnv_def by(simp add: substEnv_compose1)

lemma vsubst_compose1:
assumes "good X"
shows "((X #[y1 // y]_ys) #[y2 // y]_ys) = (X #[(y1 @ys[y2 / y]_ys) // y]_ys)"
using assms unfolding vsubst_def
by(cases "y = y1") (auto simp: subst_compose1)

lemma vsubstEnv_compose1:
assumes "goodEnv rho"
shows "((rho &[y1 // y]_ys) &[y2 // y]_ys) = (rho &[(y1 @ys[y2 / y]_ys) // y]_ys)"
using assms unfolding vsubstEnv_def
by(cases "y = y1") (auto simp: substEnv_compose1)

lemma subst_compose2:
assumes  "good X" and "good Y" and "good Z"
and "ys \<noteq> zs \<or> y \<noteq> z" and fresh: "fresh ys y Z"
shows "((X #[Y / y]_ys) #[Z / z]_zs) = ((X #[Z / z]_zs) #[(Y #[Z / z]_zs) / y]_ys)"
by (metis assms fresh freshEnv_getEnv freshEnv_getEnv2 freshEnv_idEnv freshEnv_updEnv_I idEnv_preserves_good psubst_subst_compose_freshEnv
 subst_psubst_idEnv updEnv_preserves_good)

lemma substEnv_compose2:
assumes  "goodEnv rho" and "good Y" and "good Z"
and "ys \<noteq> zs \<or> y \<noteq> z" and fresh: "fresh ys y Z"
shows "((rho &[Y / y]_ys) &[Z / z]_zs) = ((rho &[Z / z]_zs) &[(Y #[Z / z]_zs) / y]_ys)"
  by (metis assms fresh freshEnv_updEnv_I getEnv_idEnv idEnv_preserves_good
   option.discI psubstEnv_substEnv_compose_freshEnv substEnv_def
  subst_psubst_idEnv updEnv_preserves_good)

lemma subst_vsubst_compose2:
assumes  "good X" and "good Z"
and "ys \<noteq> zs \<or> y \<noteq> z" and fresh: "fresh ys y Z"
shows "((X #[y1 // y]_ys) #[Z / z]_zs) = ((X #[Z / z]_zs) #[((Var ys y1) #[Z / z]_zs) / y]_ys)"
using assms unfolding vsubst_def by(simp add: subst_compose2)

lemma substEnv_vsubstEnv_compose2:
assumes  "goodEnv rho" and "good Z"
and "ys \<noteq> zs \<or> y \<noteq> z" and fresh: "fresh ys y Z"
shows "((rho &[y1 // y]_ys) &[Z / z]_zs) = ((rho &[Z / z]_zs) &[((Var ys y1) #[Z / z]_zs) / y]_ys)"
using assms unfolding vsubstEnv_def by(simp add: substEnv_compose2)

lemma vsubst_subst_compose2:
assumes  "good X" and "good Y"
and "ys \<noteq> zs \<or> y \<notin> {z,z1}"
shows "((X #[Y / y]_ys) #[z1 // z]_zs) = ((X #[z1 // z]_zs) #[(Y #[z1 // z]_zs) / y]_ys)"
using assms unfolding vsubst_def by(simp add: subst_compose2)

lemma vsubstEnv_substEnv_compose2:
assumes  "goodEnv rho" and "good Y"
and "ys \<noteq> zs \<or> y \<notin> {z,z1}"
shows "((rho &[Y / y]_ys) &[z1 // z]_zs) = ((rho &[z1 // z]_zs) &[(Y #[z1 // z]_zs) / y]_ys)"
using assms unfolding vsubst_def vsubstEnv_def by(simp add: substEnv_compose2)

lemma vsubst_compose2:
assumes  "good X"
and "ys \<noteq> zs \<or> y \<notin> {z,z1}"
shows "((X #[y1 // y]_ys) #[z1 // z]_zs) =
       ((X #[z1 // z]_zs) #[(y1 @ys[z1 / z]_zs) // y]_ys)"
by (metis vsubst_def Var_preserves_good assms vsubst_Var_simp vsubst_def
    vsubst_subst_compose2)

lemma vsubstEnv_compose2:
assumes "goodEnv rho"
and "ys \<noteq> zs \<or> y \<notin> {z,z1}"
shows "((rho &[y1 // y]_ys) &[z1 // z]_zs) =
       ((rho &[z1 // z]_zs) &[(y1 @ys[z1 / z]_zs) // y]_ys)"
by (metis Var_preserves_good assms
vsubstEnv_def vsubstEnv_substEnv_compose2 vsubst_Var_simp)

subsection {* Properties specific to variable-for-variable substitution *}

(* Note: The results in this section cannot be lifted to environments, and therefore
we don't have ``environment versions" of these.  *)

lemma vsubstAll_ident:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param" and zs
assumes P: "goodPar P"
shows
"(good X \<longrightarrow>
  (\<forall> z. z \<in> varsOf P \<longrightarrow> (X #[z // z]_zs) = X))
\<and>
 (goodAbs A \<longrightarrow>
  (\<forall> z. z \<in> varsOf P \<longrightarrow> (A $[z // z]_zs) = A))"
proof(induct rule: term_induct_fresh[of P])
  case (Op delta inp binp)
  then show ?case
  using assms
  unfolding vsubst_def vsubstAbs_def liftAll_def lift_def
  by simp (auto simp: lift_def substInp_def2 substBinp_def2 vsubstInp_def2
        split: option.splits)
next
  case (Abs xs x X)
  then show ?case
  by (metis empty_iff insert_iff vsubstAbs_simp)
qed(insert assms, simp_all)

corollary vsubst_ident[simp]:
assumes "good X"
shows "(X #[z // z]_zs) = X"
using assms vsubstAll_ident[of "Par [z] [] [] []" X]
unfolding goodPar_def by simp

corollary subst_ident[simp]:
assumes "good X"
shows "(X #[(Var zs z) / z]_zs) = X"
using assms vsubst_ident unfolding vsubst_def by auto

lemma vsubstAll_swapAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param" and ys
assumes P: "goodPar P"
shows
"(good X \<longrightarrow>
  (\<forall> y1 y2. {y1,y2} \<subseteq> varsOf P \<and> fresh ys y1 X \<longrightarrow>
            (X #[y1 // y2]_ys) = (X #[y1 \<and> y2]_ys)))
\<and>
 (goodAbs A \<longrightarrow>
  (\<forall> y1 y2. {y1,y2} \<subseteq> varsOf P \<and> freshAbs ys y1 A  \<longrightarrow>
            (A $[y1 // y2]_ys) = (A $[y1 \<and> y2]_ys)))"
apply(induction rule: term_induct_fresh[OF P])
subgoal by (force simp add: sw_def)
subgoal by simp (auto
  simp: vsubstInp_def substInp_def2 vsubst_def swapInp_def
              vsubstBinp_def substBinp_def2 vsubstAbs_def swapBinp_def
              freshInp_def  freshBinp_def lift_def liftAll_def
  split: option.splits)
subgoal by simp (metis Var_preserves_good fresh_Var_simp substAbs_simp sw_def
  vsubstAbs_def vsubst_def) .

corollary vsubst_eq_swap:
assumes "good X" and "y1 = y2 \<or> fresh ys y1 X"
shows "(X #[y1 // y2]_ys) = (X #[y1 \<and> y2]_ys)"
apply(cases "y1 = y2")
using assms vsubstAll_swapAll[of "Par [y1, y2] [] [] []" X]
unfolding goodPar_def by auto

lemma skelAll_vsubstAll:
fixes X::"('index,'bindex,'varSort,'var,'opSym)term" and
      A::"('index,'bindex,'varSort,'var,'opSym)abs" and
      P::"('index,'bindex,'varSort,'var,'opSym)param" and ys
assumes P: "goodPar P"
shows
"(good X \<longrightarrow>
  (\<forall> y1 y2. {y1,y2} \<subseteq> varsOf P \<longrightarrow>
            skel (X #[y1 // y2]_ys) = skel X))
\<and>
 (goodAbs A \<longrightarrow>
  (\<forall> y1 y2. {y1,y2} \<subseteq> varsOf P \<longrightarrow>
            skelAbs (A $[y1 // y2]_ys) = skelAbs A))"
proof(induction rule: term_induct_fresh[of P])
  case (Op delta inp binp)
  then show ?case
  by (simp add: skelInp_def2 skelBinp_def2)
   (auto simp: vsubst_def vsubstInp_def substInp_def2
       vsubstAbs_def vsubstBinp_def substBinp_def2 lift_def liftAll_def
       split: option.splits)
next
  case (Abs xs x X)
  then show ?case using assms
  by simp (metis not_equals_and_not_equals_not_in
     skelAbs_simp vsubstAbs_simp vsubst_preserves_good)
qed(insert assms, simp_all)

corollary skel_vsubst:
assumes "good X"
shows "skel (X #[y1 // y2]_ys) = skel X"
using assms skelAll_vsubstAll[of "Par [y1, y2] [] [] []" X]
unfolding goodPar_def by simp

lemma subst_vsubst_trans:
assumes  "good X" and "good Y" and "fresh ys y1 X"
shows "((X #[y1 // y]_ys) #[Y / y1]_ys) = (X #[Y / y]_ys)"
using assms unfolding subst_def vsubst_def
by (cases "y1 = y") (simp_all add: fresh_psubst_updEnv psubstEnv_updEnv_idEnv
  psubst_compose updEnv_commute)

lemma vsubst_trans:
assumes  "good X" and "fresh ys y1 X"
shows "((X #[y1 // y]_ys) #[y2 // y1]_ys) = (X #[y2 // y]_ys)"
unfolding vsubst_def[of _ y2 y1] vsubst_def[of _ y2 y]
using assms by(simp add: subst_vsubst_trans)

lemma vsubst_commute:
assumes X: "good X"
and "xs \<noteq> xs' \<or> {x,y} \<inter> {x',y'} = {}" and "fresh xs x X" and "fresh xs' x' X"
shows "((X #[x // y]_xs) #[x' // y']_xs') = ((X #[x' // y']_xs') #[x // y]_xs)"
proof-
  have "fresh xs' x' (X #[x // y]_xs)"
  using assms by (intro vsubst_preserves_fresh) auto
  moreover have "fresh xs x (X #[x' // y']_xs')"
  using assms by (intro vsubst_preserves_fresh) auto
  ultimately show ?thesis using assms
  by (auto simp: vsubst_eq_swap intro!: swap_commute)
qed

subsection {* Abstraction versions of the properties *}

text{* Environment identity and update versus other operators: *}

lemma psubstAbs_idEnv[simp]:
"goodAbs A \<Longrightarrow> (A $[idEnv]) = A"
by(simp add: psubstAll_idEnv)

text{* Substitution versus other operators:  *}

corollary freshAbs_psubstAbs:
assumes "goodAbs A" and "goodEnv rho"
shows
"freshAbs zs z (A $[rho]) =
 (\<forall> ys y. freshAbs ys y A \<or> freshImEnvAt zs z rho ys y)"
using assms freshAll_psubstAll[of "Par [z] [] [] [rho]"]
unfolding goodPar_def by simp

corollary freshAbs_psubstAbs_E1:
assumes "goodAbs A" and "goodEnv rho"
and "rho ys y = None" and "freshAbs zs z (A $[rho])"
shows "freshAbs ys y A \<or> (ys \<noteq> zs \<or> y \<noteq> z)"
using assms freshAbs_psubstAbs unfolding freshImEnvAt_def by fastforce

corollary freshAbs_psubstAbs_E2:
assumes "goodAbs A" and "goodEnv rho"
and "rho ys y = Some Y" and "freshAbs zs z (A $[rho])"
shows "freshAbs ys y A \<or> fresh zs z Y"
using assms freshAbs_psubstAbs[of A rho] unfolding freshImEnvAt_def by fastforce

corollary freshAbs_psubstAbs_I1:
assumes "goodAbs A" and "goodEnv rho"
and "freshAbs zs z A" and "freshEnv zs z rho"
shows "freshAbs zs z (A $[rho])"
using assms apply(simp add: freshAbs_psubstAbs)
unfolding freshEnv_def liftAll_def freshImEnvAt_def by auto

corollary freshAbs_psubstAbs_I:
assumes "goodAbs A" and "goodEnv rho"
and "rho zs z = None \<Longrightarrow> freshAbs zs z A" and
    "\<And> ys y Y. rho ys y = Some Y \<Longrightarrow> freshAbs ys y A \<or> fresh zs z Y"
shows "freshAbs zs z (A $[rho])"
using assms using option.exhaust_sel
by (simp add: freshAbs_psubstAbs freshImEnvAt_def) blast

lemma freshAbs_substAbs:
assumes "goodAbs A" and "good Y"
shows "freshAbs zs z (A $[Y / y]_ys) =
       (((zs = ys \<and> z = y) \<or> freshAbs zs z A) \<and> (freshAbs ys y A \<or> fresh zs z Y))"
unfolding substAbs_def using assms
by (auto simp: freshAbs_psubstAbs freshImEnvAt_def)

lemma freshAbs_vsubstAbs:
assumes "goodAbs A"
shows "freshAbs zs z (A $[y1 // y]_ys) =
       (((zs = ys \<and> z = y) \<or> freshAbs zs z A) \<and>
        (freshAbs ys y A \<or> (zs \<noteq> ys \<or> z \<noteq> y1)))"
unfolding vsubstAbs_def using assms by(auto simp: freshAbs_substAbs)

lemma substAbs_preserves_freshAbs:
assumes "goodAbs A" and "good Y"
and "freshAbs zs z A" and "fresh zs z Y"
shows "freshAbs zs z (A $[Y / y]_ys)"
using assms by(simp add: freshAbs_substAbs)

lemma vsubstAbs_preserves_freshAbs:
assumes "goodAbs A"
and "freshAbs zs z A" and "zs \<noteq> ys \<or> z \<noteq> y1"
shows "freshAbs zs z (A $[y1 // y]_ys)"
using assms by(simp add: freshAbs_vsubstAbs)

lemma fresh_freshAbs_substAbs[simp]:
assumes "good Y" and "goodAbs A"
and "fresh ys y Y"
shows "freshAbs ys y (A $[Y / y]_ys)"
using assms by(simp add: freshAbs_substAbs)

lemma diff_freshAbs_vsubstAbs[simp]:
assumes "goodAbs A"
and "y \<noteq> y1"
shows "freshAbs ys y (A $[y1 // y]_ys)"
using assms by(simp add: freshAbs_vsubstAbs)

lemma freshAbs_substAbs_E1:
assumes "goodAbs A" and "good Y"
and "freshAbs zs z (A $[Y / y]_ys)" and "zs \<noteq> ys \<or> z \<noteq> y"
shows "freshAbs zs z A"
using assms by(auto simp: freshAbs_substAbs)

lemma freshAbs_vsubstAbs_E1:
assumes "goodAbs A"
and "freshAbs zs z (A $[y1 // y]_ys)" and "zs \<noteq> ys \<or> z \<noteq> y"
shows "freshAbs zs z A"
using assms by(auto simp: freshAbs_vsubstAbs)

lemma freshAbs_substAbs_E2:
assumes "goodAbs A" and "good Y"
and "freshAbs zs z (A $[Y / y]_ys)"
shows "freshAbs ys y A \<or> fresh zs z Y"
using assms by(simp add: freshAbs_substAbs)

lemma freshAbs_vsubstAbs_E2:
assumes "goodAbs A"
and "freshAbs zs z (A $[y1 // y]_ys)"
shows "freshAbs ys y A \<or> zs \<noteq> ys \<or> z \<noteq> y1"
using assms by(simp add: freshAbs_vsubstAbs)

corollary psubstAbs_cong[fundef_cong]:
assumes "goodAbs A" and "goodEnv rho" and "goodEnv rho'"
and "\<And> ys y. freshAbs ys y A \<or> rho ys y = rho' ys y"
shows "(A $[rho]) = (A $[rho'])"
using assms psubstAll_cong[of "Par [] [] [] [rho,rho']"]
unfolding goodPar_def by simp

lemma freshAbs_psubstAbs_updEnv:
assumes "good X" and "goodAbs A" and "goodEnv rho"
and "freshAbs xs x A"
shows "(A $[rho [x \<leftarrow> X]_xs]) = (A $[rho])"
using assms by (intro psubstAbs_cong) auto

corollary freshEnv_psubstAbs_ident[simp]:
fixes A :: "('index,'bindex,'varSort,'var,'opSym)abs"
assumes "goodAbs A" and "goodEnv rho"
and "\<And> zs z. freshEnv zs z rho \<or> freshAbs zs z A"
shows "(A $[rho]) = A"
using assms psubstAll_ident[of "Par [] [] [] [rho]"]
unfolding goodPar_def by simp

lemma freshAbs_substAbs_ident[simp]:
assumes "good X" and "goodAbs A" and "freshAbs xs x A"
shows "(A $[X / x]_xs) = A"
by (simp add: assms freshAbs_psubstAbs_updEnv substAbs_def)

corollary substAbs_Abs[simp]:
assumes "good X" and "good Y"
shows "((Abs xs x X) $[Y / x]_xs) = Abs xs x X"
using assms by simp

lemma freshAbs_vsubstAbs_ident[simp]:
assumes "goodAbs A" and "freshAbs xs x A"
shows "(A $[x1 // x]_xs) = A"
using assms unfolding vsubstAbs_def by(auto simp: freshAbs_substAbs_ident)

lemma swapAbs_psubstAbs:
assumes "goodAbs A" and "goodEnv rho"
shows "((A $[rho]) $[z1 \<and> z2]_zs) = ((A $[z1 \<and> z2]_zs) $[rho &[z1 \<and> z2]_zs])"
using assms swapAll_psubstAll[of "Par [z1,z2] [] [] [rho]"]
unfolding goodPar_def by auto

lemma swapAbs_substAbs:
assumes "goodAbs A" and "good Y"
shows "((A $[Y / y]_ys) $[z1 \<and> z2]_zs) =
       ((A $[z1 \<and> z2]_zs) $[(Y #[z1 \<and> z2]_zs) / (y @ys[z1 \<and> z2]_zs)]_ys)"
proof-
  have 1: "(idEnv [(y @ys[z1 \<and> z2]_zs) \<leftarrow> (Y #[z1 \<and> z2]_zs)]_ys) =
           ((idEnv [y \<leftarrow> Y]_ys) &[z1 \<and> z2]_zs)"
  by(simp add: swapEnv_updEnv)
  show ?thesis
  unfolding substAbs_def 1 using assms by (intro swapAbs_psubstAbs) auto
qed

lemma swapAbs_vsubstAbs:
assumes "goodAbs A"
shows "((A $[y1 // y]_ys) $[z1 \<and> z2]_zs) =
       ((A $[z1 \<and> z2]_zs) $[(y1 @ys[z1 \<and> z2]_zs) // (y @ys[z1 \<and> z2]_zs)]_ys)"
using assms unfolding vsubstAbs_def
by(simp add: swapAbs_substAbs)

lemma psubstAbs_compose:
assumes "goodAbs A" and "goodEnv rho" and "goodEnv rho'"
shows "((A $[rho]) $[rho']) = (A $[(rho &[rho'])])"
using assms psubstAll_compose[of "Par [] [] [] [rho, rho']"]
unfolding goodPar_def by auto

lemma psubstAbs_substAbs_compose:
assumes "goodAbs A" and "good Y" and "goodEnv rho"
shows "((A $[Y / y]_ys) $[rho]) = (A $[(rho [y \<leftarrow> (Y #[rho])]_ys)])"
by (simp add: assms psubstAbs_compose psubstEnv_updEnv_idEnv substAbs_def)

lemma psubstAbs_vsubstAbs_compose:
assumes "goodAbs A" and "goodEnv rho"
shows "((A $[y1 // y]_ys) $[rho]) = (A $[(rho [y \<leftarrow> ((Var ys y1) #[rho])]_ys)])"
using assms unfolding vsubstAbs_def by(simp add: psubstAbs_substAbs_compose)

lemma substAbs_psubstAbs_compose:
assumes "goodAbs A" and "good Y" and "goodEnv rho"
shows "((A $[rho]) $[Y / y]_ys) = (A $[(rho &[Y / y]_ys)])"
unfolding substAbs_def substEnv_def using assms by(simp add: psubstAbs_compose)

lemma psubstAbs_substAbs_compose_freshEnv:
assumes "goodAbs A" and "goodEnv rho" and "good Y"
assumes "freshEnv ys y rho"
shows "((A $[Y / y]_ys) $[rho]) = ((A $[rho]) $[(Y #[rho]) / y]_ys)"
using assms by (simp add: substAbs_psubstAbs_compose psubstAbs_substAbs_compose)

lemma vsubstAbs_psubstAbs_compose:
assumes "goodAbs A" and "goodEnv rho"
shows "((A $[rho]) $[y1 // y]_ys) = (A $[(rho &[y1 // y]_ys)])"
unfolding vsubstAbs_def vsubstEnv_def using assms
by(simp add: substAbs_psubstAbs_compose)

lemma substAbs_compose1:
assumes "goodAbs A" and "good Y1" and "good Y2"
shows "((A $[Y1 / y]_ys) $[Y2 / y]_ys) = (A $[(Y1 #[Y2 / y]_ys) / y]_ys)"
by (metis assms idEnv_preserves_good psubstAbs_substAbs_compose substAbs_def
  subst_psubst_idEnv updEnv_overwrite updEnv_preserves_good)

lemma substAbs_vsubstAbs_compose1:
assumes "goodAbs A" and "good Y" and "y \<noteq> y1"
shows "((A $[y1 // y]_ys) $[Y / y]_ys) = (A $[y1 // y]_ys)"
using assms unfolding vsubstAbs_def by(simp add: substAbs_compose1)

lemma vsubstAbs_substAbs_compose1:
assumes "goodAbs A" and "good Y"
shows "((A $[Y / y]_ys) $[y1 // y]_ys) = (A $[(Y #[y1 // y]_ys) / y]_ys)"
using assms unfolding vsubstAbs_def vsubst_def by(simp add: substAbs_compose1)

lemma vsubstAbs_compose1:
assumes "goodAbs A"
shows "((A $[y1 // y]_ys) $[y2 // y]_ys) = (A $[(y1 @ys[y2 / y]_ys) // y]_ys)"
using assms unfolding vsubstAbs_def
by(cases "y = y1") (auto simp: substAbs_compose1)

lemma substAbs_vsubstAbs_compose2:
assumes "goodAbs A" and "good Z"
and "ys \<noteq> zs \<or> y \<noteq> z" and fresh: "fresh ys y Z"
shows "((A $[y1 // y]_ys) $[Z / z]_zs) = ((A $[Z / z]_zs) $[((Var ys y1) #[Z / z]_zs) / y]_ys)"
using assms unfolding vsubstAbs_def by(simp add: substAbs_compose2)

lemma vsubstAbs_substAbs_compose2:
assumes  "goodAbs A" and "good Y"
and "ys \<noteq> zs \<or> y \<notin> {z,z1}"
shows "((A $[Y / y]_ys) $[z1 // z]_zs) = ((A $[z1 // z]_zs) $[(Y #[z1 // z]_zs) / y]_ys)"
using assms unfolding vsubstAbs_def vsubst_def by(simp add: substAbs_compose2)

lemma vsubstAbs_compose2:
assumes  "goodAbs A"
and "ys \<noteq> zs \<or> y \<notin> {z,z1}"
shows "((A $[y1 // y]_ys) $[z1 // z]_zs) =
       ((A $[z1 // z]_zs) $[(y1 @ys[z1 / z]_zs) // y]_ys)"
unfolding vsubstAbs_def
by (smt Var_preserves_good assms fresh_Var_simp insertCI
   substAbs_compose2 vsubst_Var_simp vsubst_def)

text{* Properties specific to variable-for-variable substitution: *}

corollary vsubstAbs_ident[simp]:
assumes "goodAbs A"
shows "(A $[z // z]_zs) = A"
using assms vsubstAll_ident[of "Par [z] [] [] []" _ _ A]
unfolding goodPar_def by simp

corollary substAbs_ident[simp]:
assumes "goodAbs A"
shows "(A $[(Var zs z) / z]_zs) = A"
using assms vsubstAbs_ident unfolding vsubstAbs_def by auto

corollary vsubstAbs_eq_swapAbs:
assumes "goodAbs A" and "freshAbs ys y1 A"
shows "(A $[y1 // y2]_ys) = (A $[y1 \<and> y2]_ys)"
using assms vsubstAll_swapAll[of "Par [y1, y2] [] [] []" _ _ A]
unfolding goodPar_def by simp

corollary skelAbs_vsubstAbs:
assumes "goodAbs A"
shows "skelAbs (A $[y1 // y2]_ys) = skelAbs A"
using assms skelAll_vsubstAll[of "Par [y1, y2] [] [] []" _ _ A]
unfolding goodPar_def by simp

lemma substAbs_vsubstAbs_trans:
assumes  "goodAbs A" and "good Y" and "freshAbs ys y1 A"
shows "((A $[y1 // y]_ys) $[Y / y1]_ys) = (A $[Y / y]_ys)"
using assms unfolding substAbs_def vsubstAbs_def
by (cases "y1 = y") (auto simp: freshAbs_psubstAbs_updEnv psubstAbs_compose
  psubstEnv_updEnv_idEnv updEnv_commute)

lemma vsubstAbs_trans:
assumes  "goodAbs A" and "freshAbs ys y1 A"
shows "((A $[y1 // y]_ys) $[y2 // y1]_ys) = (A $[y2 // y]_ys)"
unfolding vsubstAbs_def[of _ y2 y1] vsubstAbs_def[of _ y2 y]
using assms by(simp add: substAbs_vsubstAbs_trans)

lemmas good_psubstAll_freshAll_otherSimps =
psubst_idEnv psubstEnv_idEnv_id psubstAbs_idEnv
freshEnv_psubst_ident freshEnv_psubstAbs_ident

lemmas good_substAll_freshAll_otherSimps =
fresh_fresh_subst fresh_subst_ident fresh_substEnv_updEnv subst_ident
fresh_freshAbs_substAbs freshAbs_substAbs_ident substAbs_ident

lemmas good_vsubstAll_freshAll_otherSimps =
diff_fresh_vsubst fresh_vsubst_ident fresh_vsubstEnv_updEnv vsubst_ident
diff_freshAbs_vsubstAbs freshAbs_vsubstAbs_ident vsubstAbs_ident

lemmas good_allOpers_otherSimps =
good_swapAll_freshAll_otherSimps
good_psubstAll_freshAll_otherSimps
good_substAll_freshAll_otherSimps
good_vsubstAll_freshAll_otherSimps

lemmas good_item_simps =
param_simps
all_preserve_good
good_freeCons
good_allOpers_simps
good_allOpers_otherSimps

end  (* context FixVars *)

end