theory Semantics
imports Main Util.MList Util.SList ListTools "HOL-Library.Product_Lexorder" SemanticsTypes SemanticsGuarantees OptBoundTimeInterval
begin

(* EVALUATION *)

fun fixInterval :: "TimeInterval \<Rightarrow> State \<Rightarrow> IntervalResult" where
"fixInterval (low, high) state =
   (let curMinTime = minTime state in
    let newLow = max low curMinTime in
    let curInterval = (newLow, high) in
    let env = \<lparr> timeInterval = curInterval \<rparr> in
    let newState = state \<lparr> minTime := newLow \<rparr> in
    (if (high < low)
     then IntervalError (InvalidInterval (low, high))
     else (if (high < curMinTime)
           then IntervalError (IntervalInPastError curMinTime (low, high))
           else IntervalTrimmed env newState)))"

fun signum :: "int \<Rightarrow> int" where
"signum x = (if x > 0 then 1 else if x = 0 then 0 else -1)"

fun quot :: "int \<Rightarrow> int \<Rightarrow> int" (infixl "quot" 70) where
"x quot y = (if ((x < 0) = (y < 0)) then x div y else -(abs x div abs y))"

fun rem :: "int \<Rightarrow> int \<Rightarrow> int" (infixl "rem" 70) where
"x rem y = x - (x quot y) * y"

fun quotRem :: "int \<Rightarrow> int \<Rightarrow> int \<times> int" (infixl "quotRem" 70) where
"x quotRem y = (x quot y, x rem y)"

fun evalValue :: "Environment \<Rightarrow> State \<Rightarrow> Value \<Rightarrow> int" and evalObservation :: "Environment \<Rightarrow> State \<Rightarrow> Observation \<Rightarrow> bool" where
evalValue_AvailableMoney: "evalValue env state (AvailableMoney accId token) =
    findWithDefault 0 (accId, token) (accounts state)" |
evalValue_Constant: "evalValue env state (Constant integer) = integer" |
evalValue_NegValue: "evalValue env state (NegValue val) = uminus (evalValue env state val)" |
evalValue_AddValue: "evalValue env state (AddValue lhs rhs) =
    evalValue env state lhs + evalValue env state rhs" |
evalValue_SubValue: "evalValue env state (SubValue lhs rhs) =
    evalValue env state lhs - evalValue env state rhs" |
evalValue_MulValue: "evalValue env state (MulValue lhs rhs) =
    evalValue env state lhs * evalValue env state rhs" |
evalValue_DivValue: "evalValue env state (DivValue lhs rhs) =
   (let n = evalValue env state lhs;
        d = evalValue env state rhs
    in if d = 0 then 0
       else n quot d)" |
evalValue_ChoiceValue: "evalValue env state (ChoiceValue choId) =
    findWithDefault 0 choId (choices state)" |
evalValue_TimeIntervalStart: "evalValue env state TimeIntervalStart = fst (timeInterval env)" |
evalValue_TimeIntervalEnd: "evalValue env state TimeIntervalEnd = snd (timeInterval env)" |
evalValue_UseValue: "evalValue env state (UseValue valId) =
    findWithDefault 0 valId (boundValues state)" |
evalValue_Cond: "evalValue env state (Cond cond thn els) =
    (if evalObservation env state cond then evalValue env state thn else evalValue env state els)" |
evalObservation_AndObs: "evalObservation env state (AndObs lhs rhs) =
    (evalObservation env state lhs \<and> evalObservation env state rhs)" |
evalObservation_OrObs: "evalObservation env state (OrObs lhs rhs) =
    (evalObservation env state lhs \<or> evalObservation env state rhs)" |
evalObservation_NotObs: "evalObservation env state (NotObs subObs) =
    (\<not> evalObservation env state subObs)" |
evalObservation_ChoseSomething: "evalObservation env state (ChoseSomething choId) =
    (member choId (choices state))" |
evalObservation_ValueGE: "evalObservation env state (ValueGE lhs rhs) =
    (evalValue env state lhs \<ge> evalValue env state rhs)" |
evalObservation_ValueGT: "evalObservation env state (ValueGT lhs rhs) =
    (evalValue env state lhs > evalValue env state rhs)" |
evalObservation_ValueLT: "evalObservation env state (ValueLT lhs rhs) =
    (evalValue env state lhs < evalValue env state rhs)" |
evalObservation_ValueLE: "evalObservation env state (ValueLE lhs rhs) =
    (evalValue env state lhs \<le> evalValue env state rhs)" |
evalObservation_ValueEQ: "evalObservation env state (ValueEQ lhs rhs) =
    (evalValue env state lhs = evalValue env state rhs)" |
evalObservation_TrueObs: "evalObservation env state TrueObs = True" |
evalObservation_FalseObs: "evalObservation env state FalseObs = False"

lemma evalDoubleNegValue :
  "evalValue env sta (NegValue (NegValue x)) = evalValue env sta x"
  by auto

lemma evalNegValue :
  "evalValue env sta (AddValue x (NegValue x)) = 0"
  by auto

lemma evalAddCommutative :
  "evalValue env sta (AddValue x y) = evalValue env sta (AddValue y x)"
  by auto

lemma evalAddAssoc :
  "evalValue env sta (AddValue x (AddValue y z)) = evalValue env sta (AddValue (AddValue x y) z)"
  by auto

lemma evalMulValue :
  "evalValue env sta (MulValue x (Constant 0)) = 0"
  by auto

lemma evalSubValue :
  "evalValue env sta (SubValue (AddValue x y) y) = evalValue env sta x"
  by auto

lemma evalDivByZeroIsZero :
  "evalValue env sta y = 0 \<Longrightarrow> evalValue env sta (DivValue x y) = 0"
  by simp

lemma evalDivByItSelf : "a \<noteq> 0 \<Longrightarrow> evalValue env sta x = a \<Longrightarrow> evalValue env sta y = a \<Longrightarrow> evalValue env sta (DivValue x y) = 1"
  by simp

lemma evalDivByOneIsX : "evalValue env sta y = 1 \<Longrightarrow> evalValue env sta (DivValue x y) = evalValue env sta x"
  by (simp add:Let_def)

lemma evalDivRoundToZero :
  assumes "\<bar>(evalValue env sta n)\<bar> < \<bar>(evalValue env sta d)\<bar>"
  shows "evalValue env sta (DivValue n d) = 0"
  using assms
  by (auto simp add: Let_def)

lemma quotMultiplyEquivalence : "c \<noteq> 0 \<Longrightarrow> (c * a) quot (c * b) = a quot b"
  apply auto
  apply (simp_all add: mult_less_0_iff)
  apply (metis div_mult_mult1 less_irrefl mult_minus_right)
  apply (smt div_minus_minus mult_minus_right nonzero_mult_div_cancel_left zdiv_zmult2_eq)
  apply (metis div_minus_right div_mult_mult1 mult_minus_right)
  by (metis div_mult_mult1 less_irrefl mult_minus_right)

lemma remMultiplyEquivalence : "c \<noteq> 0 \<Longrightarrow> (c * a) rem (c * b) = c * (a rem b)"
proof -
  assume "c \<noteq> 0"
  then have "\<And>i ia. c * i quot (c * ia) = i quot ia"
    using quotMultiplyEquivalence by presburger
  then show ?thesis
    by (simp add: right_diff_distrib')
qed

lemma signEqualityPreservation : "(a :: int) \<noteq> 0 \<Longrightarrow> (b :: int) \<noteq> 0 \<Longrightarrow> (c :: int) \<noteq> 0 \<Longrightarrow> ((c * a < 0) = (c * b < 0)) = ((a < 0) = (b < 0))"
  by (smt mult_neg_pos mult_nonneg_nonneg mult_nonpos_nonpos mult_pos_neg)

lemma divMultiply : "(c :: int) \<noteq> 0 \<Longrightarrow> (c * a) div (c * b) = a div b"
  by simp

lemma divAbsMultiply : "(c :: int) \<noteq> 0 \<Longrightarrow> \<bar>c * a\<bar> div \<bar>c * b\<bar> = \<bar>a\<bar> div \<bar>b\<bar>"
  by (simp add: abs_mult)

lemma addMultiply : "\<bar>(c :: int) * a + x * (c * b)\<bar> = \<bar>c * (a + x * b)\<bar>"
  by (simp add: distrib_left mult.left_commute)

lemma addAbsMultiply : "\<bar>(c :: int) * a + x * (c * b)\<bar> = \<bar>c * (a + x * b)\<bar>"
  by (simp add: distrib_left mult.left_commute)

lemma subMultiply : "\<bar>(c :: int) * a - x * (c * b)\<bar> = \<bar>c * (a - x * b)\<bar>"
  by (simp add: mult.left_commute right_diff_distrib')

lemma ltMultiply : "(c :: int) \<noteq> 0 \<Longrightarrow> (\<bar>x\<bar> * 2 < \<bar>b\<bar>) = (\<bar>c * x\<bar> * 2 < \<bar>c * b\<bar>)"
  by (simp add: abs_mult)

lemma remMultiplySmalle_aux : "(a :: int) \<noteq> 0 \<Longrightarrow> (b :: int) \<noteq> 0 \<Longrightarrow> (c :: int) \<noteq> 0 \<Longrightarrow> (\<bar>a - a div b * b\<bar> * 2 < \<bar>b\<bar>) = (\<bar>c * a - c * a div (c * b) * (c * b)\<bar> * 2 < \<bar>c * b\<bar>)"
  apply (subst divMultiply)
  apply simp
  apply (subst subMultiply)
  using ltMultiply by blast

lemma remMultiplySmalle_aux2 : "(a :: int) \<noteq> 0 \<Longrightarrow> (b :: int) \<noteq> 0 \<Longrightarrow> (c :: int) \<noteq> 0 \<Longrightarrow> (\<bar>a + \<bar>a\<bar> div \<bar>b\<bar> * b\<bar> * 2 < \<bar>b\<bar>) = (\<bar>c * a + \<bar>c * a\<bar> div \<bar>c * b\<bar> * (c * b)\<bar> * 2 < \<bar>c * b\<bar>)"
  apply (subst divAbsMultiply)
  apply simp
  apply (subst addMultiply)
  using ltMultiply by blast

lemma remMultiplySmaller : "c \<noteq> 0 \<Longrightarrow> (\<bar>a rem b\<bar> * 2 < \<bar>b\<bar>) = (\<bar>(c * a) rem (c * b)\<bar> * 2 < \<bar>c * b\<bar>)"
  apply (cases "b = 0")
  apply simp
  apply (cases "a = 0")
  apply (simp add: mult_less_0_iff)
  apply (simp only:quot.simps rem.simps)
  apply (subst signEqualityPreservation[of a b c])
  apply simp
  apply simp
  apply simp
  apply (cases "(a < 0) = (b < 0)")
  apply (simp only:if_True refl)
  using remMultiplySmalle_aux apply blast
  apply (simp only:if_False refl)
  by (metis (no_types, opaque_lifting) diff_minus_eq_add mult_minus_left remMultiplySmalle_aux2)

lemma evalDivMultiplyFractByConstant :
  "evalValue env sta c \<noteq> 0 \<Longrightarrow> evalValue env sta (DivValue (MulValue c a) (MulValue c b)) = evalValue env sta (DivValue a b)"
  using quotMultiplyEquivalence by force

fun absValue :: "Value \<Rightarrow> Value" where
  "absValue x = Cond (ValueGT (Constant 0) x) (NegValue x) x"

lemma absValueMatchesAbs : "evalValue env sta x = y \<Longrightarrow> evalValue env sta (absValue x) = \<bar>y\<bar>"
  apply (cases "0 > y")
  by simp_all

lemma evalDivAbsMultiplyFractByConstant :
  "evalValue env sta c \<noteq> 0 \<Longrightarrow> evalValue env sta (DivValue (absValue (MulValue c a)) (absValue (MulValue c b))) = evalValue env sta (DivValue (absValue a) (absValue b))"
  apply simp
  by (smt (verit, best) div_minus_right div_mult_mult1_if minus_mult_right mult_neg_neg mult_pos_neg)

lemma evalDivCancelsMul :
  "evalValue env sta c \<noteq> 0 \<Longrightarrow> evalValue env sta (DivValue (MulValue a c) c) = evalValue env sta a"
  apply simp
  by (smt (verit, best) minus_mult_minus mult_minus_left nonzero_mult_div_cancel_right)

lemma evalDivCancelsMulPlusRem :
  "evalValue env sta b \<noteq> 0 \<Longrightarrow> evalValue env sta (MulValue (DivValue a b) b) = evalValue env sta a - (evalValue env sta a rem evalValue env sta b)"
  by simp

lemma evalDivCommutesWithNeg1 :
  "evalValue env sta (NegValue (DivValue a b)) = evalValue env sta (DivValue (NegValue a) b)"
  apply (simp add:Let_def)
  using div_minus_right by fastforce

lemma evalDivCommutesWithNeg2 :
  "evalValue env sta (NegValue (DivValue a b)) = evalValue env sta (DivValue a (NegValue b))"
  apply (simp add:Let_def)
  by (smt (verit) div_minus_right)

fun refundOne :: "Accounts \<Rightarrow>
                  ((Party \<times> Token \<times> int) \<times> Accounts) option" where
"refundOne (((accId, tok), money)#rest) =
   (if money > 0 then Some ((accId, tok, money), rest) else refundOne rest)" |
"refundOne [] = None"

lemma refundOneShortens : "refundOne acc = Some (c, nacc) \<Longrightarrow>
                           length nacc < length acc"
  apply (induction acc)
  apply simp
  by (metis Pair_inject length_Cons less_Suc_eq list.distinct(1)
            list.inject option.inject refundOne.elims)

datatype Payment = Payment AccountId Payee Token int

datatype ReduceEffect = ReduceNoPayment
                      | ReduceWithPayment Payment

fun moneyInAccount :: "AccountId \<Rightarrow> Token \<Rightarrow> Accounts \<Rightarrow> int" where
"moneyInAccount accId token accountsV = findWithDefault 0 (accId, token) accountsV"

fun updateMoneyInAccount :: "AccountId \<Rightarrow> Token \<Rightarrow> int \<Rightarrow>
                             Accounts \<Rightarrow>
                             Accounts" where
"updateMoneyInAccount accId token money accountsV =
  (if money \<le> 0
   then MList.delete (accId, token) accountsV
   else MList.insert (accId, token) money accountsV)"

fun addMoneyToAccount :: "AccountId \<Rightarrow> Token \<Rightarrow> int \<Rightarrow>
                          Accounts \<Rightarrow>
                          Accounts" where
"addMoneyToAccount accId token money accountsV =
  (let balance = moneyInAccount accId token accountsV in
   let newBalance = balance + money in
   if money \<le> 0
   then accountsV
   else updateMoneyInAccount accId token newBalance accountsV)"

fun giveMoney :: "AccountId \<Rightarrow> Payee \<Rightarrow> Token \<Rightarrow> int \<Rightarrow> Accounts \<Rightarrow>
                  (ReduceEffect \<times> Accounts)" where
"giveMoney accountId payee token money accountsV =
  (let newAccounts = case payee of
                        Party _ \<Rightarrow> accountsV
                      | Account accId \<Rightarrow> addMoneyToAccount accId token money accountsV
   in (ReduceWithPayment (Payment accountId payee token money), newAccounts))"

lemma giveMoneyIncOne : "giveMoney sa p t m a = (e, na) \<Longrightarrow> length na \<le> length a + 1"
  apply (cases p)
  apply (cases "m \<le> 0")
  apply auto
  by (smt Suc_eq_plus1 delete_length insert_length le_Suc_eq)

(* REDUCE *)

datatype ReduceWarning = ReduceNoWarning
                       | ReduceNonPositivePay AccountId Payee Token int
                       | ReducePartialPay AccountId Payee Token int int
                       | ReduceShadowing ValueId int int
                       | ReduceAssertionFailed

datatype ReduceStepResult = Reduced ReduceWarning ReduceEffect State Contract
                          | NotReduced
                          | AmbiguousTimeIntervalReductionError

fun reduceContractStep :: "Environment \<Rightarrow> State \<Rightarrow> Contract \<Rightarrow> ReduceStepResult" where
"reduceContractStep _ state Close =
  (case refundOne (accounts state) of
     Some ((party, token, money), newAccount) \<Rightarrow>
       let newState = state \<lparr> accounts := newAccount \<rparr> in
       Reduced ReduceNoWarning (ReduceWithPayment (Payment party (Party party) token money)) newState Close
   | None \<Rightarrow> NotReduced)" |
"reduceContractStep env state (Pay accId payee token val cont) =
  (let moneyToPay = evalValue env state val in
   if moneyToPay \<le> 0
   then (let warning = ReduceNonPositivePay accId payee token moneyToPay in
         Reduced warning ReduceNoPayment state cont)
   else (let balance = moneyInAccount accId token (accounts state) in
        (let paidMoney = min balance moneyToPay in
         let newBalance = balance - paidMoney in
         let newAccs = updateMoneyInAccount accId token newBalance (accounts state) in
         let warning = (if paidMoney < moneyToPay
                        then ReducePartialPay accId payee token paidMoney moneyToPay
                        else ReduceNoWarning) in
         let (payment, finalAccs) = giveMoney accId payee token paidMoney newAccs in
         Reduced warning payment (state \<lparr> accounts := finalAccs \<rparr>) cont)))" |
"reduceContractStep env state (If obs cont1 cont2) =
  (let cont = (if evalObservation env state obs
               then cont1
               else cont2) in
   Reduced ReduceNoWarning ReduceNoPayment state cont)" |
"reduceContractStep env state (When _ timeout cont) =
  (let (startTime, endTime) = timeInterval env in
   if endTime < timeout
   then NotReduced
   else (if timeout \<le> startTime
         then Reduced ReduceNoWarning ReduceNoPayment state cont
         else AmbiguousTimeIntervalReductionError))" |
"reduceContractStep env state (Let valId val cont) =
  (let evaluatedValue = evalValue env state val in
   let boundVals = boundValues state in
   let newState = state \<lparr> boundValues := MList.insert valId evaluatedValue boundVals \<rparr> in
   let warn = case lookup valId boundVals of
                Some oldVal \<Rightarrow> ReduceShadowing valId oldVal evaluatedValue
              | None \<Rightarrow> ReduceNoWarning in
   Reduced warn ReduceNoPayment newState cont)" |
"reduceContractStep env state (Assert obs cont) =
  (let warning = if evalObservation env state obs
                 then ReduceNoWarning
                 else ReduceAssertionFailed
   in Reduced warning ReduceNoPayment state cont)"

datatype ReduceResult = ContractQuiescent bool "ReduceWarning list" "Payment list"
                                          State Contract
                      | RRAmbiguousTimeIntervalError

fun evalBound :: "State \<Rightarrow> Contract \<Rightarrow> nat" where
"evalBound sta cont = length (accounts sta) + 2 * (size cont)"

lemma reduceContractStepReducesSize_Refund_aux :
  "refundOne (accounts sta) = Some ((party, money), newAccount) \<Longrightarrow>
   length (accounts (sta\<lparr>accounts := newAccount\<rparr>)) < length (accounts sta)"
  by (simp add: refundOneShortens)

lemma reduceContractStepReducesSize_Refund_aux2 :
  "Reduced ReduceNoWarning (ReduceWithPayment (Payment accId (Party party) token money))
          (sta\<lparr>accounts := newAccount\<rparr>) Close =
   Reduced twa tef nsta nc \<Longrightarrow>
   c = Close \<Longrightarrow>
   refundOne (accounts sta) = Some ((party, token, money), newAccount) \<Longrightarrow>
   length (accounts nsta) + 2 * size nc < length (accounts sta)"
  apply simp
  using reduceContractStepReducesSize_Refund_aux by blast

lemma reduceContractStepReducesSize_Refund :
  "(case a of
          ((party, token, money), newAccount) \<Rightarrow>
            Reduced ReduceNoWarning (ReduceWithPayment (Payment accId (Party party) token money))
             (sta\<lparr>accounts := newAccount\<rparr>) Close) =
         Reduced twa tef nsta nc \<Longrightarrow>
         c = Close \<Longrightarrow>
         refundOne (accounts sta) = Some a \<Longrightarrow>
         length (accounts nsta) + 2 * size nc < length (accounts sta)"
  apply (cases a)
  apply simp
  using reduceContractStepReducesSize_Refund_aux2 by fastforce

lemma zeroMinIfGT : "x > 0 \<Longrightarrow> min 0 x = (0 :: int)"
  by simp

lemma reduceContractStepReducesSize_Pay_aux :
  "length z \<le> length x \<Longrightarrow>
   giveMoney accId x22 tok a z = (tef, y) \<Longrightarrow>
   length y < Suc (Suc (length x))"
  by (metis (no_types, lifting) Suc_eq_plus1 giveMoneyIncOne leI le_trans not_less_eq_eq)

lemma reduceContractStepReducesSize_Pay_aux2 :
  "giveMoney accId dst tok a (MList.delete (src, tok) x) = (tef, y) \<Longrightarrow>
   length y < Suc (Suc (length x))"
  using delete_length reduceContractStepReducesSize_Pay_aux by blast

lemma reduceContractStepReducesSize_Pay_aux3 :
  "sta\<lparr>accounts := b\<rparr> = nsta \<Longrightarrow>
   giveMoney accId dst tok a (MList.delete (src, tok) (accounts sta)) = (tef, b) \<Longrightarrow>
   length (accounts nsta) < Suc (Suc (length (accounts sta)))"
  using reduceContractStepReducesSize_Pay_aux2 by fastforce

lemma reduceContractStepReducesSize_Pay_aux4 :
  "lookup (k, tok) x = Some w \<Longrightarrow>
   giveMoney accId dst tok a (MList.insert (k, tok) v x) = (tef, y) \<Longrightarrow>
   length y < Suc (Suc (length x))"
  by (metis One_nat_def add.right_neutral add_Suc_right giveMoneyIncOne insert_existing_length le_imp_less_Suc)

lemma reduceContractStepReducesSize_Pay_aux5 :
"sta\<lparr>accounts := ba\<rparr> = nsta \<Longrightarrow>
 lookup (src, tok) (accounts sta) = Some a \<Longrightarrow>
 giveMoney accId dst tok (evalValue env sta am) (MList.insert (src, tok) (a - evalValue env sta am) (accounts sta)) = (tef, ba) \<Longrightarrow>
 length (accounts nsta) < Suc (Suc (length (accounts sta)))"
  using reduceContractStepReducesSize_Pay_aux4 by fastforce

lemma reduceContractStepReducesSize_Pay_aux6 :
  "reduceContractStep env sta c = Reduced twa tef nsta nc \<Longrightarrow>
   c = Pay src dst tok am y \<Longrightarrow>
   evalValue env sta am > 0 \<Longrightarrow>
   lookup (src, tok) (accounts sta) = Some a \<Longrightarrow>
   evalBound nsta nc < evalBound sta c"
  apply (cases "a < evalValue env sta am")
  apply (simp add:min_absorb1)
  apply (cases "giveMoney src dst tok a (MList.delete (src, tok) (accounts sta))")
  using reduceContractStepReducesSize_Pay_aux3 apply fastforce
  apply (cases "a = evalValue env sta am")
  apply (cases "giveMoney src dst tok (evalValue env sta am) (MList.delete (src, tok) (accounts sta))")
  apply (simp add:min_absorb2)
  using reduceContractStepReducesSize_Pay_aux3 apply fastforce
  apply (cases "giveMoney src dst tok (evalValue env sta am) (MList.insert (src, tok) (a - evalValue env sta am) (accounts sta))")
  apply (simp add:min_absorb2)
  using reduceContractStepReducesSize_Pay_aux5 by fastforce

lemma reduceContractStepReducesSize_Pay :
  "reduceContractStep env sta c = Reduced twa tef nsta nc \<Longrightarrow>
   c = Pay src dst tok am y \<Longrightarrow> evalBound nsta nc < evalBound sta c"
  apply (cases "evalValue env sta am \<le> 0")
  apply auto[1]
  apply (cases "lookup (src, tok) (accounts sta)")
  apply (cases "evalValue env sta am > 0")
  apply (cases "giveMoney src dst tok 0 (MList.delete (src, tok) (accounts sta))")
  apply (simp add:zeroMinIfGT)
  using reduceContractStepReducesSize_Pay_aux3 apply fastforce
  apply simp
  using reduceContractStepReducesSize_Pay_aux6 by auto

lemma reduceContractStepReducesSize_When :
  "reduceContractStep env sta c = Reduced twa tef nsta nc \<Longrightarrow>
   c = When cases timeout cont \<Longrightarrow>
   timeInterval env = (startTime, endTime) \<Longrightarrow>
   evalBound nsta nc < evalBound sta c"
  apply simp
  apply (cases "endTime < timeout")
  apply simp
  apply (cases "timeout \<le> startTime")
  by simp_all

lemma reduceContractStepReducesSize_Let_aux :
  "Reduced (ReduceShadowing vId a (evalValue env sta val)) ReduceNoPayment
         (sta\<lparr>boundValues := MList.insert vId (evalValue env sta val) (boundValues sta)\<rparr>) cont =
    Reduced twa tef nsta nc \<Longrightarrow>
   c = Contract.Let vId val cont \<Longrightarrow>
   lookup vId (boundValues sta) = Some a \<Longrightarrow>
   evalBound nsta nc < evalBound sta c"
  by auto

lemma reduceContractStepReducesSize_Let :
  "reduceContractStep env sta c = Reduced twa tef nsta nc \<Longrightarrow>
   c = Contract.Let vId val cont \<Longrightarrow> evalBound nsta nc < evalBound sta c"
  apply (cases "lookup vId (boundValues sta)")
  apply auto[1]
  by (metis ReduceStepResult.inject reduceContractStep.simps(5) reduceContractStepReducesSize_Let_aux)

lemma reduceContractStepReducesSize :
  "reduceContractStep env sta c = Reduced twa tef nsta nc \<Longrightarrow>
     (evalBound nsta nc) < (evalBound sta c)"
  apply (cases c)
  apply (cases "refundOne (accounts sta)")
  apply simp
  apply simp
  using reduceContractStepReducesSize_Refund apply fastforce
  using reduceContractStepReducesSize_Pay apply blast
  apply auto[1]
  apply (meson eq_fst_iff reduceContractStepReducesSize_When)
  using reduceContractStepReducesSize_Let apply blast
  by simp

function (sequential) reductionLoop :: "bool \<Rightarrow> Environment \<Rightarrow> State \<Rightarrow> Contract \<Rightarrow> ReduceWarning list \<Rightarrow>
                                        Payment list \<Rightarrow> ReduceResult" where
"reductionLoop reduced env state contract warnings payments =
  (case reduceContractStep env state contract of
     Reduced warning effect newState ncontract \<Rightarrow>
       let newWarnings = (if warning = ReduceNoWarning
                          then warnings
                          else warning # warnings) in
       let newPayments = (case effect of
                            ReduceWithPayment payment \<Rightarrow> payment # payments
                          | ReduceNoPayment \<Rightarrow> payments) in
       reductionLoop True env newState ncontract newWarnings newPayments
   | AmbiguousTimeIntervalReductionError \<Rightarrow> RRAmbiguousTimeIntervalError
   | NotReduced \<Rightarrow> ContractQuiescent reduced (rev warnings) (rev payments) state contract)"
  by pat_completeness auto
termination reductionLoop
  apply (relation "measure (\<lambda>(_, (_, (state, (contract, _)))) . evalBound state contract)")
  apply blast
  using reduceContractStepReducesSize by auto

(* This lemma allows to work with the reductionLoop.induct theorem with a new name for the induction
   case.*)
lemmas reductionLoop_induct = reductionLoop.induct[case_names "reductionLoopInduction"]

fun reduceContractUntilQuiescent :: "Environment \<Rightarrow> State \<Rightarrow> Contract \<Rightarrow> ReduceResult" where
"reduceContractUntilQuiescent env state contract = reductionLoop False env state contract [] []"

datatype ApplyWarning = ApplyNoWarning
                      | ApplyNonPositiveDeposit Party AccountId Token int

datatype ApplyResult = Applied ApplyWarning State Contract
                     | ApplyNoMatchError

fun inBounds :: "ChosenNum \<Rightarrow> Bound list \<Rightarrow> bool" where
"inBounds num = any (\<lambda> (Bound l u) \<Rightarrow> num \<ge> l \<and> num \<le> u)"

fun applyCases :: "Environment \<Rightarrow> State \<Rightarrow> Input \<Rightarrow> Case list \<Rightarrow> ApplyResult" where
"applyCases env state (IDeposit accId1 party1 tok1 amount)
            (Cons (Case (Deposit accId2 party2 tok2 val) cont) rest) =
  (if (accId1 = accId2 \<and> party1 = party2 \<and> tok1 = tok2
        \<and> amount = evalValue env state val)
   then let warning = if amount > 0
                      then ApplyNoWarning
                      else ApplyNonPositiveDeposit party1 accId2 tok2 amount in
        let newState = state \<lparr> accounts := addMoneyToAccount accId1 tok1 amount (accounts state) \<rparr> in
        Applied warning newState cont
   else applyCases env state (IDeposit accId1 party1 tok1 amount) rest)" |
"applyCases env state (IChoice choId1 choice)
            (Cons (Case (Choice choId2 bounds) cont) rest) =
  (if (choId1 = choId2 \<and> inBounds choice bounds)
   then let newState = state \<lparr> choices := MList.insert choId1 choice (choices state) \<rparr> in
        Applied ApplyNoWarning newState cont
   else applyCases env state (IChoice choId1 choice) rest)" |
"applyCases env state INotify (Cons (Case (Notify obs) cont) rest) =
  (if evalObservation env state obs
   then Applied ApplyNoWarning state cont
   else applyCases env state INotify rest)" |
"applyCases env state (IDeposit accId1 party1 tok1 amount) (Cons _ rest) =
  applyCases env state (IDeposit accId1 party1 tok1 amount) rest" |
"applyCases env state (IChoice choId1 choice) (Cons _ rest) =
  applyCases env state (IChoice choId1 choice) rest" |
"applyCases env state INotify (Cons _ rest) =
  applyCases env state INotify rest" |
"applyCases env state acc Nil = ApplyNoMatchError"

fun applyInput :: "Environment \<Rightarrow> State \<Rightarrow> Input \<Rightarrow> Contract \<Rightarrow> ApplyResult" where
"applyInput env state input (When cases t cont) = applyCases env state input cases" |
"applyInput env state input c = ApplyNoMatchError"

datatype TransactionWarning = TransactionNonPositiveDeposit Party AccountId Token int
                            | TransactionNonPositivePay AccountId Payee Token int
                            | TransactionPartialPay AccountId Payee Token int int
                            | TransactionShadowing ValueId int int
                            | TransactionAssertionFailed

fun convertReduceWarnings :: "ReduceWarning list \<Rightarrow> TransactionWarning list" where
"convertReduceWarnings Nil = Nil" |
"convertReduceWarnings (Cons ReduceNoWarning rest) =
   convertReduceWarnings rest" |
"convertReduceWarnings (Cons (ReduceNonPositivePay accId payee tok amount) rest) =
   Cons (TransactionNonPositivePay accId payee tok amount)
        (convertReduceWarnings rest)" |
"convertReduceWarnings (Cons (ReducePartialPay accId payee tok paid expected) rest) =
   Cons (TransactionPartialPay accId payee tok paid expected)
        (convertReduceWarnings rest)" |
"convertReduceWarnings (Cons (ReduceShadowing valId oldVal newVal) rest) =
   Cons (TransactionShadowing valId oldVal newVal)
        (convertReduceWarnings rest)" |
"convertReduceWarnings (Cons ReduceAssertionFailed rest) =
   Cons TransactionAssertionFailed (convertReduceWarnings rest)"

fun convertApplyWarning :: "ApplyWarning \<Rightarrow> TransactionWarning list" where
"convertApplyWarning ApplyNoWarning = Nil" |
"convertApplyWarning (ApplyNonPositiveDeposit party accId tok amount) =
   Cons (TransactionNonPositiveDeposit party accId tok amount) Nil"

datatype ApplyAllResult = ApplyAllSuccess bool "TransactionWarning list" "Payment list"
                                     State Contract
                        | ApplyAllNoMatchError
                        | ApplyAllAmbiguousTimeIntervalError

fun applyAllLoop :: "bool \<Rightarrow> Environment \<Rightarrow> State \<Rightarrow> Contract \<Rightarrow> Input list \<Rightarrow>
                    TransactionWarning list \<Rightarrow> Payment list \<Rightarrow>
                    ApplyAllResult" where
"applyAllLoop contractChanged env state contract inputs warnings payments =
   (case reduceContractUntilQuiescent env state contract of
      RRAmbiguousTimeIntervalError \<Rightarrow> ApplyAllAmbiguousTimeIntervalError
    | ContractQuiescent reduced reduceWarns pays curState cont \<Rightarrow>
       (case inputs of
          Nil \<Rightarrow> ApplyAllSuccess (contractChanged \<or> reduced) (warnings @ (convertReduceWarnings reduceWarns))
                                 (payments @ pays) curState cont
        | Cons input rest \<Rightarrow>
           (case applyInput env curState input cont of
              Applied applyWarn newState cont \<Rightarrow>
                  applyAllLoop True env newState cont rest
                               (warnings @ (convertReduceWarnings reduceWarns)
                                         @ (convertApplyWarning applyWarn))
                               (payments @ pays)
            | ApplyNoMatchError \<Rightarrow> ApplyAllNoMatchError)))"

(* This lemma allows to work with the applyAllLoop.induct theorem with a new name for the induction
   case.*)
lemmas applyAllLoop_induct = applyAllLoop.induct[case_names applyAllLoopInduction]

fun applyAllInputs :: "Environment \<Rightarrow> State \<Rightarrow> Contract \<Rightarrow> Input list \<Rightarrow>
                 ApplyAllResult" where
"applyAllInputs env state contract inputs = applyAllLoop False env state contract inputs Nil Nil"

type_synonym TransactionSignatures = "Party list"

datatype TransactionError = TEAmbiguousTimeIntervalError
                          | TEApplyNoMatchError
                          | TEIntervalError IntervalError
                          | TEUselessTransaction

record TransactionOutputRecord = txOutWarnings :: "TransactionWarning list"
                                 txOutPayments :: "Payment list"
                                 txOutState :: State
                                 txOutContract :: Contract

datatype TransactionOutput = TransactionOutput TransactionOutputRecord
                           | TransactionError TransactionError

record Transaction = interval :: TimeInterval
                     inputs :: "Input list"

fun computeTransaction :: "Transaction \<Rightarrow> State \<Rightarrow> Contract \<Rightarrow> TransactionOutput" where
"computeTransaction tx state contract =
  (let inps = inputs tx in
   case fixInterval (interval tx) state of
     IntervalTrimmed env fixSta \<Rightarrow>
       (case applyAllInputs env fixSta contract inps of
          ApplyAllSuccess reduced warnings payments newState cont \<Rightarrow>
            if ((\<not> reduced) \<and> ((contract \<noteq> Close) \<or> (accounts state = [])))
            then TransactionError TEUselessTransaction
            else TransactionOutput \<lparr> txOutWarnings = warnings
                                   , txOutPayments = payments
                                   , txOutState = newState
                                   , txOutContract = cont \<rparr>
        | ApplyAllNoMatchError \<Rightarrow> TransactionError TEApplyNoMatchError
        | ApplyAllAmbiguousTimeIntervalError \<Rightarrow> TransactionError TEAmbiguousTimeIntervalError)
     | IntervalError error \<Rightarrow> TransactionError (TEIntervalError error))"

fun playTraceAux :: "TransactionOutputRecord \<Rightarrow> Transaction list \<Rightarrow> TransactionOutput" where
"playTraceAux res Nil = TransactionOutput res" |
"playTraceAux \<lparr> txOutWarnings = warnings
              , txOutPayments = payments
              , txOutState = state
              , txOutContract = cont \<rparr> (Cons h t) =
   (let transRes = computeTransaction h state cont in
    case transRes of
      TransactionOutput transResRec \<Rightarrow> playTraceAux (transResRec \<lparr> txOutPayments := payments @ (txOutPayments transResRec)
                                                                 , txOutWarnings := warnings @ (txOutWarnings transResRec) \<rparr>) t
    | TransactionError _ \<Rightarrow> transRes)"

fun emptyState :: "POSIXTime \<Rightarrow> State" where
"emptyState sl = \<lparr> accounts = MList.empty
                 , choices = MList.empty
                 , boundValues = MList.empty
                 , minTime = sl \<rparr>"

fun playTrace :: "POSIXTime \<Rightarrow> Contract \<Rightarrow> Transaction list \<Rightarrow> TransactionOutput" where
"playTrace sl c t = playTraceAux \<lparr> txOutWarnings = Nil
                                 , txOutPayments = Nil
                                 , txOutState = emptyState sl
                                 , txOutContract = c \<rparr> t"

(* Extra functions *)

type_synonym TransactionOutcomes = "(Party \<times> int) list"

definition "emptyOutcome = (MList.empty :: TransactionOutcomes)"

lemma emptyOutcomeValid : "valid_map emptyOutcome"
  using MList.valid_empty emptyOutcome_def by auto

fun isEmptyOutcome :: "TransactionOutcomes \<Rightarrow> bool" where
"isEmptyOutcome trOut = all (\<lambda> (x, y) \<Rightarrow> y = 0) trOut"

fun addOutcome :: "Party \<Rightarrow> int \<Rightarrow> TransactionOutcomes \<Rightarrow> TransactionOutcomes" where
"addOutcome party diffValue trOut =
   (let newValue = case MList.lookup party trOut of
                     Some value \<Rightarrow> value + diffValue
                   | None \<Rightarrow> diffValue in
    MList.insert party newValue trOut)"

fun combineOutcomes :: "TransactionOutcomes \<Rightarrow> TransactionOutcomes \<Rightarrow> TransactionOutcomes" where
"combineOutcomes x y = MList.unionWith plus x y"

fun getPartiesFromReduceEffect :: "ReduceEffect list \<Rightarrow> (Party \<times> Token \<times> int) list" where
"getPartiesFromReduceEffect (Cons (ReduceWithPayment (Payment src (Party p) tok m)) t) =
   Cons (p, tok, -m) (getPartiesFromReduceEffect t)" |
"getPartiesFromReduceEffect (Cons x t) = getPartiesFromReduceEffect t" |
"getPartiesFromReduceEffect Nil = Nil"

fun getPartiesFromInput :: "Input list \<Rightarrow> (Party \<times> Token \<times> int) list" where
"getPartiesFromInput (Cons (IDeposit _ p tok m) t) =
   Cons (p, tok, m) (getPartiesFromInput t)" |
"getPartiesFromInput (Cons x t) = getPartiesFromInput t" |
"getPartiesFromInput Nil = Nil"

fun getOutcomes :: "ReduceEffect list \<Rightarrow> Input list \<Rightarrow> TransactionOutcomes" where
"getOutcomes eff inp =
   foldl (\<lambda> acc (p, t, m) . addOutcome p m acc) emptyOutcome
         ((getPartiesFromReduceEffect eff) @ (getPartiesFromInput inp))"

fun addSig :: "Party list \<Rightarrow> Input \<Rightarrow> Party list" where
"addSig acc (IDeposit _ p _ _) = SList.insert p acc" |
"addSig acc (IChoice (ChoiceId _ p) _) = SList.insert p acc" |
"addSig acc INotify = acc"

fun getSignatures :: "Input list \<Rightarrow> TransactionSignatures" where
"getSignatures l = foldl addSig SList.empty l"

fun isQuiescent :: "Contract \<Rightarrow> State \<Rightarrow> bool" where
"isQuiescent Close state = (accounts state = [])" |
"isQuiescent (When _ _ _) _ = True" |
"isQuiescent _ _ = False"

fun maxTimeContract :: "Contract \<Rightarrow> int"
and maxTimeCase :: "Case \<Rightarrow> int" where
"maxTimeContract Close = 0" |
"maxTimeContract (Pay _ _ _ _ contract) = maxTimeContract contract" |
"maxTimeContract (If _ contractTrue contractFalse) = max (maxTimeContract contractTrue) (maxTimeContract contractFalse)" |
"maxTimeContract (When Nil timeout contract) = max timeout (maxTimeContract contract)" |
"maxTimeContract (When (Cons head tail) timeout contract) = max (maxTimeCase head) (maxTimeContract (When tail timeout contract))" |
"maxTimeContract (Let _ _ contract) = maxTimeContract contract" |
"maxTimeContract (Assert _ contract) = maxTimeContract contract" |
"maxTimeCase (Case _ contract) = maxTimeContract contract"

subsection "calculateNonAmbiguousInterval"

fun gtIfNone :: "int option \<Rightarrow> int \<Rightarrow> bool" where
"gtIfNone None _ = True" |
"gtIfNone (Some x) y = (x > y)"

fun geIfNone :: "int option \<Rightarrow> int \<Rightarrow> bool" where
"geIfNone None _ = True" |
"geIfNone (Some x) y = (x \<ge> y)"

fun subIfSome :: "int option \<Rightarrow> int \<Rightarrow> int option" where
"subIfSome None _ = None" |
"subIfSome (Some x) y = Some (x - y)"

fun calculateNonAmbiguousInterval :: "int option \<Rightarrow> POSIXTime \<Rightarrow> Contract \<Rightarrow> OptBoundTimeInterval"
where
"calculateNonAmbiguousInterval _ _ Close = (Unbounded, Unbounded)" |
"calculateNonAmbiguousInterval n t (Pay _ _ _ _ c) = calculateNonAmbiguousInterval n t c" |
"calculateNonAmbiguousInterval n t (If _ ct cf) = intersectInterval (calculateNonAmbiguousInterval n t ct)
                                                           (calculateNonAmbiguousInterval n t cf)" |
"calculateNonAmbiguousInterval n t (When Nil timeout tcont) =
  (if t < timeout
   then (Unbounded, Bounded (timeout - 1))
   else intersectInterval (Bounded timeout, Unbounded) (calculateNonAmbiguousInterval n t tcont))" |
"calculateNonAmbiguousInterval n t (When (Cons (Case _ cont ) tail) timeout tcont) =
  (if gtIfNone n 0
   then intersectInterval (calculateNonAmbiguousInterval (subIfSome n 1) t cont)
                         (calculateNonAmbiguousInterval n t (When tail timeout tcont))
   else calculateNonAmbiguousInterval n t (When tail timeout tcont))" |
"calculateNonAmbiguousInterval n t (Let _ _ c) = calculateNonAmbiguousInterval n t c" |
"calculateNonAmbiguousInterval n t (Assert _ c) = calculateNonAmbiguousInterval n t c"

end


theory prop_59
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun last :: "Nat list => Nat" where
  "last (Nil2) = Z"
  | "last (Cons2 y (Nil2)) = y"
  | "last (Cons2 y (Cons2 x2 x3)) = last (Cons2 x2 x3)"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster last append *)

  theorem x0 :
    "(ys = (Nil2)) ==> ((last (append xs ys)) = (last xs))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory Proof_3_3
  imports HandDryer VCTheoryLemmas Extra
begin

theorem proof_3_3:
"VC3 inv3 s0 hands_value"
  apply(simp only: VC3_def inv3_def  R3_def
  dryer_def)
  apply(rule impI)
  apply(rule conjI)
   apply(rule conjI)
    apply(simp)
proof -
  define s:: state where
"s = (toEnv
          (setVarBool (setVarAny s0 hands_value)
            (Suc (Suc 0)) OFF))"
  assume VC: " ((toEnvP s0 \<and>
      (\<forall>s1 s2.
          substate s1 s2 \<and>
          substate s2 s0 \<and>
          toEnvP s1 \<and>
          toEnvP s2 \<and>
          toEnvNum s1 s2 = hands \<and>
          10 \<le> toEnvNum s2 s0 \<and>
          getVarBool s1 hands = ON \<and>
          getVarBool s1 (Suc (Suc 0)) = ON \<and>
          getVarBool s2 hands = OFF \<longrightarrow>
          (\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> 10 \<and>
                (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
                 getVarBool s4 hands = ON) \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 (Suc (Suc 0)) =
                      ON \<and>
                      getVarBool s3 hands =
                      OFF)))) \<and>
     extraInv s0) \<and>
    env (setVarAny s0 hands_value) hands_value \<and>
    getPstate (setVarAny s0 hands_value) Ctrl =
    waiting \<and>
    getVarBool (setVarAny s0 hands_value) hands \<noteq>
    ON"
  show " \<forall>s1 s2.
       substate s1 s2 \<and>
       substate s2
        (toEnv
          (setVarBool (setVarAny s0 hands_value)
            (Suc (Suc 0)) OFF)) \<and>
       toEnvP s1 \<and>
       toEnvP s2 \<and>
       toEnvNum s1 s2 = hands \<and>
       10 \<le> toEnvNum s2
              (toEnv
                (setVarBool
                  (setVarAny s0 hands_value)
                  (Suc (Suc 0)) OFF)) \<and>
       getVarBool s1 hands = ON \<and>
       getVarBool s1 (Suc (Suc 0)) = ON \<and>
       getVarBool s2 hands = OFF \<longrightarrow>
       (\<exists>s4. toEnvP s4 \<and>
             substate s2 s4 \<and>
             substate s4
              (toEnv
                (setVarBool
                  (setVarAny s0 hands_value)
                  (Suc (Suc 0)) OFF)) \<and>
             toEnvNum s2 s4 \<le> 10 \<and>
             (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
              getVarBool s4 hands = ON) \<and>
             (\<forall>s3. toEnvP s3 \<and>
                   substate s2 s3 \<and>
                   substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                   getVarBool s3 (Suc (Suc 0)) =
                   ON \<and>
                   getVarBool s3 hands = OFF)) "
    apply(simp only: s_def[symmetric])
  proof(rule allI; rule allI; rule impI)
    fix s1 s2
    print_state
    assume req_prems: "substate s1 s2 \<and>
       substate s2 s \<and>
       toEnvP s1 \<and>
       toEnvP s2 \<and>
       toEnvNum s1 s2 = hands \<and>
       10 \<le> toEnvNum s2 s \<and>
       getVarBool s1 hands = ON \<and>
       getVarBool s1 (Suc (Suc 0)) = ON \<and>
       getVarBool s2 hands = OFF"
    then obtain "10 \<le> toEnvNum s2 s" by auto
    from le_imp_less_or_eq[OF this]
    show " \<exists>s4. toEnvP s4 \<and>
            substate s2 s4 \<and>
            substate s4 s \<and>
            toEnvNum s2 s4 \<le> 10 \<and>
            (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
             getVarBool s4 hands = ON) \<and>
            (\<forall>s3. toEnvP s3 \<and>
                  substate s2 s3 \<and>
                  substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                  getVarBool s3 (Suc (Suc 0)) = ON \<and>
                  getVarBool s3 hands = OFF)"
    proof
      assume 1: "10 < toEnvNum s2 s"
      with req_prems substate_eq_or_predEnv
 toEnvNum_id s_def  have 2: "substate s2 s0"
        by (simp add: s_def split: if_splits)
      from VC obtain "\<forall>s1 s2.
          substate s1 s2 \<and>
          substate s2 s0 \<and>
          toEnvP s1 \<and>
          toEnvP s2 \<and>
          toEnvNum s1 s2 = hands \<and>
          10 \<le> toEnvNum s2 s0 \<and>
          getVarBool s1 hands = ON \<and>
          getVarBool s1 (Suc (Suc 0)) = ON \<and>
          getVarBool s2 hands = OFF \<longrightarrow>
          (\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> 10 \<and>
                (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
                 getVarBool s4 hands = ON) \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 (Suc (Suc 0)) =
                      ON \<and>
                      getVarBool s3 hands =
                      OFF))"
        by auto
      with req_prems 1 2 have "\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> 10 \<and>
                (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
                 getVarBool s4 hands = ON) \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 (Suc (Suc 0)) =
                      ON \<and>
                      getVarBool s3 hands =
                      OFF)"
        by (auto simp add: s_def split: if_splits)
      then obtain s4 where 3: " toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> 10 \<and>
                (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
                 getVarBool s4 hands = ON) \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 (Suc (Suc 0)) =
                      ON \<and>
                      getVarBool s3 hands =
                      OFF)" ..
      have  "(toEnvP s4 \<and>
      substate s2 s4 \<and>
      substate s4 s \<and>
      toEnvNum s2 s4 \<le> 10 \<and>
      (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
       getVarBool s4 hands = ON)) \<and>
      (\<forall>s3. toEnvP s3 \<and>
            substate s2 s3 \<and>
            substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
            getVarBool s3 (Suc (Suc 0)) = ON \<and>
            getVarBool s3 hands = OFF)"
      proof
        from 3 show "toEnvP s4 \<and>
      substate s2 s4 \<and>
      substate s4 s \<and>
      toEnvNum s2 s4 \<le> 10 \<and>
      (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
       getVarBool s4 hands = ON)"
          by (simp add: s_def)
      next
        from 3 show "\<forall>s3. toEnvP s3 \<and>
         substate s2 s3 \<and>
         substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
         getVarBool s3 (Suc (Suc 0)) = ON \<and>
         getVarBool s3 hands = OFF"
          by simp
      qed
      thus ?thesis by auto
    next
      assume 4: "10 = toEnvNum s2 s"
      from substate_asym have 5:
"\<forall>s3. toEnvP s3 \<and>
               substate s2 s3 \<and>
               substate s3 s2 \<and> s3 \<noteq> s2 \<longrightarrow>
               getVarBool s3 (Suc (Suc 0)) = ON \<and>
               getVarBool s3 hands = OFF"
        by auto
      show ?thesis
      proof -
        define s5:: state where "s5=s2"
        have "toEnvP s5 \<and> substate s2 s5 \<and>
substate s5 s \<longrightarrow>pred3 s2 s s5"
        proof(induction rule: state_down_ind)
          case 1
          then show ?case
            using req_prems s_def by auto
        next
          case 2
          then show ?case
            apply(simp only: pred3_def)
          proof
            assume 6: " \<forall>s3. toEnvP s3 \<and>
         substate s2 s3 \<and>
         substate s3 s \<and> s3 \<noteq> s \<longrightarrow>
         getVarBool s3 (Suc (Suc 0)) = ON \<and>
         getVarBool s3 hands = OFF"
            have " (toEnvP s \<and>
         substate s s \<and>
         substate s s \<and>
         toEnvNum s2 s \<le> 10) \<and>
         (getVarBool s (Suc (Suc 0)) = OFF \<or>
          getVarBool s hands = ON) \<and>
         (\<forall>s3. toEnvP s3 \<and>
               substate s s3 \<and>
               substate s3 s \<and> s3 \<noteq> s \<longrightarrow>
               getVarBool s3 (Suc (Suc 0)) = ON \<and>
               getVarBool s3 hands = OFF)"
            proof
              from 4 substate_refl s_def  req_prems
              show "(toEnvP s \<and>
         substate s s \<and>
         substate s s \<and>
         toEnvNum s2 s \<le> 10 )"
                by auto
            next
              from VC have " (getVarBool s (Suc (Suc 0)) = OFF \<or>
     getVarBool s hands = ON)"
                by (simp add: s_def)
              moreover from substate_asym have
             "\<forall>s3. toEnvP s3 \<and>
          substate s s3 \<and>
          substate s3 s \<and> s3 \<noteq> s \<longrightarrow>
          getVarBool s3 (Suc (Suc 0)) = ON \<and>
          getVarBool s3 hands = OFF" by auto
              ultimately show
"(getVarBool s (Suc (Suc 0)) = OFF \<or>
     getVarBool s hands = ON) \<and>
    (\<forall>s3. toEnvP s3 \<and>
          substate s s3 \<and>
          substate s3 s \<and> s3 \<noteq> s \<longrightarrow>
          getVarBool s3 (Suc (Suc 0)) = ON \<and>
          getVarBool s3 hands = OFF)" ..
            qed
            thus "\<exists>s4. toEnvP s4 \<and>
         substate s s4 \<and>
         substate s4 s \<and>
         toEnvNum s2 s4 \<le> 10 \<and>
         (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
          getVarBool s4 hands = ON) \<and>
         (\<forall>s3. toEnvP s3 \<and>
               substate s s3 \<and>
               substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
               getVarBool s3 (Suc (Suc 0)) = ON \<and>
               getVarBool s3 hands = OFF)"
              by auto
          qed
        next
          case (3 s5)
          then show ?case
            apply(simp only: pred3_def)
          proof
            from 3(3) have  6: " (\<forall>s3. toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s5 \<and> s3 \<noteq> s5 \<longrightarrow>
          getVarBool s3 (Suc (Suc 0)) = ON \<and>
          getVarBool s3 hands = OFF) \<Longrightarrow>
    (\<exists>s4. toEnvP s4 \<and>
          substate s5 s4 \<and>
          substate s4 s \<and>
          toEnvNum s2 s4 \<le> 10 \<and>
          (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
           getVarBool s4 hands = ON) \<and>
          (\<forall>s3. toEnvP s3 \<and>
                substate s5 s3 \<and>
                substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                getVarBool s3 (Suc (Suc 0)) = ON \<and>
                getVarBool s3 hands = OFF)) "
              by (auto simp add: pred3_def)
            assume 7: " \<forall>s3. toEnvP s3 \<and>
         substate s2 s3 \<and>
         substate s3 (predEnv s5) \<and>
         s3 \<noteq> predEnv s5 \<longrightarrow>
         getVarBool s3 (Suc (Suc 0)) = ON \<and>
         getVarBool s3 hands = OFF"
            show "\<exists>s4. toEnvP s4 \<and>
         substate (predEnv s5) s4 \<and>
         substate s4 s \<and>
         toEnvNum s2 s4 \<le> 10 \<and>
         (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
          getVarBool s4 hands = ON) \<and>
         (\<forall>s3. toEnvP s3 \<and>
               substate (predEnv s5) s3 \<and>
               substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
               getVarBool s3 (Suc (Suc 0)) = ON \<and>
               getVarBool s3 hands = OFF)"
            proof cases
              assume 10: "(getVarBool (predEnv s5) (Suc (Suc 0)) = OFF \<or>
          getVarBool (predEnv s5) hands = ON)"
              from predEnv_substate 3
substate_trans have 8:  "substate (predEnv s5) s"
                by blast
              from 3(2) substate_eq_or_predEnv req_prems
              have 9: "substate s2 (predEnv s5)"
                by auto
              have "toEnvP (predEnv s5) \<and>
         substate (predEnv s5) (predEnv s5) \<and>
         substate (predEnv s5) s \<and>
         toEnvNum s2 (predEnv s5) \<le> 10 \<and>
         (getVarBool (predEnv s5) (Suc (Suc 0)) = OFF \<or>
          getVarBool (predEnv s5) hands = ON) \<and>
         (\<forall>s3. toEnvP s3 \<and>
               substate (predEnv s5) s3 \<and>
               substate s3 (predEnv s5) \<and>
 s3 \<noteq> (predEnv s5) \<longrightarrow>
               getVarBool s3 (Suc (Suc 0)) = ON \<and>
               getVarBool s3 hands = OFF)"
              proof -
                from predEnvP_or_emptyState[of s5]
                have "toEnvP (predEnv s5)"
                proof
                  assume "toEnvP (predEnv s5)"
                  thus ?thesis by assumption
                next
                  assume   "predEnv s5 = emptyState"
                  with 9 req_prems show ?thesis
                    by (cases s2; auto)
                qed
                moreover from substate_refl have
" substate (predEnv s5) (predEnv s5)" by auto
                moreover from 8
                have "substate (predEnv s5) s"
                  by assumption
                moreover from 4 8 9 toEnvNum3
                have "toEnvNum s2 (predEnv s5) \<le> 10"
                  by auto
                moreover from 10
                have "(getVarBool (predEnv s5) (Suc (Suc 0)) = OFF \<or>
     getVarBool (predEnv s5) hands = ON)"
                  by assumption
                moreover from substate_asym
                have "\<forall>s3. toEnvP s3 \<and>
          substate (predEnv s5) s3 \<and>
          substate s3 (predEnv s5) \<and>
          s3 \<noteq> predEnv s5 \<longrightarrow>
          getVarBool s3 (Suc (Suc 0)) = ON \<and>
          getVarBool s3 hands = OFF" by auto
                ultimately show ?thesis by auto
              qed
              thus ?thesis by auto
            next
              assume 10: "\<not> (getVarBool (predEnv s5) (Suc (Suc 0)) = OFF \<or>
        getVarBool (predEnv s5) hands = ON)"
              with substate_eq_or_predEnv 7
              have " \<forall>s3. toEnvP s3 \<and>
         substate s2 s3 \<and>
         substate s3  s5 \<and>
         s3 \<noteq> s5 \<longrightarrow>
         getVarBool s3 (Suc (Suc 0)) = ON \<and>
         getVarBool s3 hands = OFF"
                by auto
              from 6[OF this] obtain s4 where 11:
"toEnvP s4 \<and>
       substate s5 s4 \<and>
       substate s4 s \<and>
       toEnvNum s2 s4 \<le> 10 \<and>
       (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
        getVarBool s4 hands = ON) \<and>
       (\<forall>s3. toEnvP s3 \<and>
             substate s5 s3 \<and>
             substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
             getVarBool s3 (Suc (Suc 0)) = ON \<and>
             getVarBool s3 hands = OFF)" ..
              have "(toEnvP s4 \<and>
      substate (predEnv s5) s4 \<and>
      substate s4 s \<and>
      toEnvNum s2 s4 \<le> 10 \<and>
      (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
       getVarBool s4 hands = ON)) \<and>
      (\<forall>s3. toEnvP s3 \<and>
            substate (predEnv s5) s3 \<and>
            substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
            getVarBool s3 (Suc (Suc 0)) = ON \<and>
            getVarBool s3 hands = OFF)"
              proof
                from 11 predEnv_substate substate_trans
                show "toEnvP s4 \<and>
      substate (predEnv s5) s4 \<and>
      substate s4 s \<and>
      toEnvNum s2 s4 \<le> 10 \<and>
      (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
       getVarBool s4 hands = ON)" by blast
              next
                show "\<forall>s3. toEnvP s3 \<and>
            substate (predEnv s5) s3 \<and>
            substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
            getVarBool s3 (Suc (Suc 0)) = ON \<and>
            getVarBool s3 hands = OFF"
                proof(rule allI; rule impI)
                  fix s3
                  assume 12: "toEnvP s3 \<and>
            substate (predEnv s5) s3 \<and>
            substate s3 s4 \<and> s3 \<noteq> s4"
                  with  11 3(1) predEnv_substate_imp_eq_or_substate
                  have "s3 = predEnv s5 \<or> substate s5 s3"
                    by auto
                  with 10 11 12 show "getVarBool s3 (Suc (Suc 0)) = ON \<and>
            getVarBool s3 hands = OFF"
                    by auto

                qed
              qed
              thus ?thesis by auto
            qed
          qed
        qed
        with s5_def req_prems substate_refl
 pred3_def 5 show ?thesis by auto
      qed
    qed
  qed
next
  assume "((toEnvP s0 \<and>
      (\<forall>s1 s2.
          substate s1 s2 \<and>
          substate s2 s0 \<and>
          toEnvP s1 \<and>
          toEnvP s2 \<and>
          toEnvNum s1 s2 = hands \<and>
          10 \<le> toEnvNum s2 s0 \<and>
          getVarBool s1 hands = ON \<and>
          getVarBool s1 (Suc (Suc 0)) = ON \<and>
          getVarBool s2 hands = OFF \<longrightarrow>
          (\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> 10 \<and>
                (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
                 getVarBool s4 hands = ON) \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 (Suc (Suc 0)) =
                      ON \<and>
                      getVarBool s3 hands =
                      OFF)))) \<and>
     extraInv s0) \<and>
    env (setVarAny s0 hands_value) hands_value \<and>
    getPstate (setVarAny s0 hands_value) Ctrl =
    waiting \<and>
    getVarBool (setVarAny s0 hands_value) hands \<noteq>
    ON"
  with extra3 show " extraInv
     (toEnv
       (setVarBool (setVarAny s0 hands_value)
         (Suc (Suc 0)) OFF))"
    by (auto simp add: VC3_def dryer_def)
qed

end


theory MainHC_Complex
imports Complex_Main
begin

constdefs

flip :: "('a => 'b => 'c) => 'b => 'a => 'c"
"flip f a b == f b a"

ifImplOp :: "bool * bool => bool"
"ifImplOp p == snd p --> fst p"

exEqualOp :: "'a option * 'a option => bool"
"exEqualOp p == case fst p of
    None => False
  | Some a => (case snd p of
      None => False
    | Some b => a = b)"

whenElseOp :: "('a option * bool) * 'a option => 'a option"
"whenElseOp t == case t of
    (p, e) => if snd p then fst p else e"

unpackOption :: "(('a => 'b option) => 'c => 'd option)
            => ('a => 'b option) option => 'c => 'd option"
"unpackOption c s a == case s of
    None => None
  | Some f => c f a"

unpackBool :: "(('a => bool) => 'c => bool)
            => ('a => bool) option => 'c => bool"
"unpackBool c s a == case s of
    None => False
  | Some f => c f a"

unpack2option :: "(('a => 'b) => 'c => 'd)
            => ('a => 'b) option => 'c => 'd option"
"unpack2option c s a == case s of
    None => None
  | Some f => Some (c f a)"

option2bool :: "'a option => bool"
"option2bool s == case s of
    None => False
  | Some a => True"

unpack2bool :: "(('a => unit) => 'c => unit)
            => ('a => unit) option => 'c => bool"
"unpack2bool c s a == option2bool s"

uncurryOp :: "('a => 'b => 'c) => 'a * 'b => 'c"
"uncurryOp f p == f (fst p) (snd p)"

curryOp :: "('a * 'b => 'c) => 'a => 'b => 'c"
"curryOp f a b == f (a, b)"

bool2option :: "bool => unit option"
"bool2option b == if b then Some () else None"

liftUnit2unit :: "('a => 'b) => bool => bool"
"liftUnit2unit f b == b"

liftUnit2bool :: "(unit => bool) => bool => bool"
"liftUnit2bool f b == if b then f () else False"

liftUnit2option :: "(unit => 'a option) => bool => 'a option"
"liftUnit2option f b == if b then f () else None"

liftUnit :: "(unit => 'a) => bool => 'a option"
"liftUnit f b == if b then Some (f ()) else None"

lift2unit :: "('b => 'c) => ('a option => bool)"
"lift2unit f == option2bool"

lift2bool :: "('a => bool) => 'a option => bool"
"lift2bool f s == case s of
    None => False
  | Some a => f a"

lift2option :: "('a => 'b option) => 'a option => 'b option"
"lift2option f s == case s of
    None => None
  | Some a => f a"

mapSome :: "('a => 'b) => 'a option => 'b option"
"mapSome f s == case s of
    None => None
  | Some a => Some (f a)"

mapFst :: "('a => 'b) => 'a * 'c => 'b * 'c"
"mapFst f p == (f (fst p), snd p)"

mapSnd :: "('b => 'c) => 'a * 'b => 'a * 'c"
"mapSnd f p == (fst p, f (snd p))"

consts defOp :: "'a option => bool"
primrec
"defOp None = False"
"defOp (Some x) = True"

consts app :: "('a => 'b option) option => 'a option => 'b option"
primrec
  "app None a = None"
  "app (Some f) x = (case x of
                            None => None
                          | Some x' => f x')"

consts apt :: "('a => 'b) option => 'a option => 'b option"
primrec
  "apt None a = None"
  "apt (Some f) x = (case x of
                            None => None
                          | Some x' => Some (f x'))"

consts pApp :: "('a => bool) option => 'a option => bool"
primrec
  "pApp None a = False"
  "pApp (Some f) x = (case x of
                             None => False
                           | Some y => f y)"

consts pair :: "'a option => 'b option => ('a * 'b) option"
primrec
  "pair None a = None"
  "pair (Some x) z = (case z of
                             None => None
                           | Some y => Some (x,y))"

lemma some_inj : "Some x = Some y ==> x = y"
apply (auto)
done

lemma real_mult_ldistrib : "w * ((z1::real) + z2) = (w * z1) + (w * z2)"
apply (subst real_mult_commute)
apply (rule sym)
apply (subst real_mult_commute)
apply (subst real_mult_commute [where w="z2"])
apply (rule sym)
apply (cases z1, cases z2, cases w)
apply (simp add: real_add real_mult preal_add_mult_distrib2
                 preal_add_ac preal_mult_ac)
done

lemma ladd_zero_real : "(0 :: real) + a = a"
  by (auto)

lemma radd_zero_real : "a + (0 :: real) = a"
  by (auto)

lemma lmult_zero_real : "(0 :: real) * a = 0"
  by (auto)

lemma rmult_zero_real : "a * (0 :: real) = 0"
  by (auto)

lemma plus_minus : "a + - (b :: real) = a - b"
  by (auto)

lemma lmult_one_real : "(1 :: real) * a = a"
  by (auto)

lemma rmult_one_real : "(1 :: real) * a = a"
  by (auto)

end


text_raw \<open>\section[Anchoring Classes and Identification Dependence]{Anchoring Classes and Identification Dependence\isalabel{subsec:identification-dependence}}\<close>

text \<^marker>\<open>tag bodyonly\<close> \<open>
  In this section, we propose a classification of the anchors
  of particulars of a particular structure and a definition
  of some relations that express various degrees of
  \emph{identity dependence}.
\<close>

text_raw \<open>\subsection[Anchoring Classes]{Anchoring Classes\isalabel{subsec:anchoring-classes}}\<close>

theory AnchoringClasses
  imports "../Identity/Anchoring"
begin

context ufo_particular_theory
begin

text \<^marker>\<open>tag bodyonly\<close> \<open>
  The anchors of particulars of a structure can be classified into
  several classes. The first is a \emph{minimal anchor}: we say
  that an anchor \<open>\<Gamma>\<^sub>x\<close> for \<open>x\<close> in \<open>\<Gamma>\<close> is \emph{minimal} if and only the
  only other anchors for \<open>x\<close> in \<open>\<Gamma>\<close> that are substructures of \<open>\<Gamma>\<^sub>x\<close>,
  i.e. that have an injective morphism to \<open>\<Gamma>\<^sub>x\<close>, are those that are
  isomorphical to \<open>\<Gamma>\<^sub>x\<close>. In other words, a minimal anchor represents
  a minimal context for the identification of a particular. Formally:
\<close>

definition minimallyAnchors ::
  \<open>'p\<^sub>2 \<Rightarrow>  ('p\<^sub>2,'q) particular_struct \<Rightarrow>
  ('p\<^sub>2 \<Rightarrow> 'p) \<Rightarrow> 'p \<Rightarrow> bool\<close>
  (\<open>_ \<midarrow>_,_\<rightarrow>\<^sub>\<bottom> _\<close> [74,1,1,74] 75)
  where
  \<open>y \<midarrow>\<Gamma>\<^sub>x,\<phi>\<rightarrow>\<^sub>\<bottom> x \<equiv>
    y \<midarrow>\<Gamma>\<^sub>x,\<phi>\<rightarrow>\<^sub>1 x \<and>
    (\<forall>\<Gamma>' z \<sigma>\<^sub>1 \<sigma>\<^sub>2.
        \<Gamma>' \<lless>\<^bsub>\<sigma>\<^sub>1\<^esub> \<Gamma>\<^sub>x \<and> z \<midarrow>\<Gamma>',\<sigma>\<^sub>2\<rightarrow>\<^sub>1 x \<longrightarrow>
        \<Gamma>' \<in> IsoModels\<^bsub>\<Gamma>\<^sub>x,TYPE(ZF)\<^esub>)\<close>

lemma \<^marker>\<open>tag (proof) aponly\<close> minimallyAnchorsI[intro!]:
  assumes \<open>y \<midarrow>\<Gamma>\<^sub>x,\<phi>\<rightarrow>\<^sub>1 x\<close> \<open>\<And>\<Gamma>' z \<sigma>\<^sub>1 \<sigma>\<^sub>2. \<lbrakk> \<Gamma>' \<lless>\<^bsub>\<sigma>\<^sub>1\<^esub> \<Gamma>\<^sub>x ; z \<midarrow>\<Gamma>',\<sigma>\<^sub>2\<rightarrow>\<^sub>1 x \<rbrakk> \<Longrightarrow> \<Gamma>' \<in> IsoModels\<^bsub>\<Gamma>\<^sub>x,TYPE(ZF)\<^esub>\<close>
  shows \<open>y \<midarrow>\<Gamma>\<^sub>x,\<phi>\<rightarrow>\<^sub>\<bottom> x\<close>
  using assms by (simp only: minimallyAnchors_def ; metis)

lemma \<^marker>\<open>tag (proof) aponly\<close> minimallyAnchorsE[elim!]:
  assumes \<open>y \<midarrow>\<Gamma>\<^sub>x,\<phi>\<rightarrow>\<^sub>\<bottom> x\<close>
  obtains \<open>y \<midarrow>\<Gamma>\<^sub>x,\<phi>\<rightarrow>\<^sub>1 x\<close> \<open>\<And>\<Gamma>' z \<sigma>\<^sub>1 \<sigma>\<^sub>2. \<lbrakk> \<Gamma>' \<lless>\<^bsub>\<sigma>\<^sub>1\<^esub> \<Gamma>\<^sub>x ; z \<midarrow>\<Gamma>',\<sigma>\<^sub>2\<rightarrow>\<^sub>1 x \<rbrakk> \<Longrightarrow> \<Gamma>' \<in> IsoModels\<^bsub>\<Gamma>\<^sub>x,TYPE(ZF)\<^esub>\<close>
  using assms by (simp only: minimallyAnchors_def ; metis)

lemma \<^marker>\<open>tag (proof) aponly\<close> minimallyAnchorsD:
  assumes \<open>y \<midarrow>\<Gamma>\<^sub>x,\<phi>\<rightarrow>\<^sub>\<bottom> x\<close>
  shows \<open>y \<midarrow>\<Gamma>\<^sub>x,\<phi>\<rightarrow>\<^sub>1 x\<close> \<open>\<And>\<Gamma>' z \<sigma>\<^sub>1 \<sigma>\<^sub>2. \<lbrakk> \<Gamma>' \<lless>\<^bsub>\<sigma>\<^sub>1\<^esub> \<Gamma>\<^sub>x ; z \<midarrow>\<Gamma>',\<sigma>\<^sub>2\<rightarrow>\<^sub>1 x \<rbrakk> \<Longrightarrow> \<Gamma>' \<in> IsoModels\<^bsub>\<Gamma>\<^sub>x,TYPE(ZF)\<^esub>\<close>
  using assms by (simp only: minimallyAnchors_def ; metis)+

text \<^marker>\<open>tag bodyonly\<close> \<open>
  We say that a particular is minimally anchored just in case
  there is at least one minimal anchor for it:
\<close>

definition minimallyAnchored :: \<open>'p set\<close> (\<open>\<P>\<^sub>\<Down>\<close>)
  where
  \<open>\<P>\<^sub>\<Down> \<equiv> { x | x (y :: ZF) \<Gamma>\<^sub>x \<phi> . y \<midarrow>\<Gamma>\<^sub>x,\<phi>\<rightarrow>\<^sub>\<bottom> x }\<close>

lemma \<^marker>\<open>tag (proof) aponly\<close> minimallyAnchored_I[intro]: \<open>(y :: ZF) \<midarrow>\<Gamma>\<^sub>x,\<phi>\<rightarrow>\<^sub>\<bottom> x \<Longrightarrow> x \<in> \<P>\<^sub>\<Down>\<close>
  by (simp only: minimallyAnchored_def mem_Collect_eq ; metis)

lemma \<^marker>\<open>tag (proof) aponly\<close> minimallyAnchored_E[elim!]:
  assumes \<open>x \<in> \<P>\<^sub>\<Down>\<close>
  obtains y :: ZF and \<Gamma>\<^sub>x \<phi> where  \<open>y \<midarrow>\<Gamma>\<^sub>x,\<phi>\<rightarrow>\<^sub>\<bottom> x\<close>
  using assms by (simp only: minimallyAnchored_def mem_Collect_eq ; metis)

lemma \<^marker>\<open>tag (proof) aponly\<close> minimallyAnchored_are_anchored: \<open>\<P>\<^sub>\<Down> \<subseteq> \<P>\<^sub>\<down>\<close>
  using minimallyAnchored_E
  by (metis minimallyAnchorsD(1) subsetI ufo_particular_theory_sig.anchored_particulars_I1)

text \<^marker>\<open>tag bodyonly\<close> \<open>
  Similarly, we say that a particular is finitely anchored if there is
  at least one finite anchor for it, i.e., an anchor that has a finite
  set of particulars. In other words, the existence of a finite anchor
  for a particular is the evidence that it's possible to identify finitely,
  e.g. using a finite predicate in first-order logic.
\<close>

definition finitelyAnchored :: \<open>'p set\<close> (\<open>\<P>\<^sup>f\<^sup>i\<^sup>n\<^sub>\<down>\<close>) where
  \<open>\<P>\<^sup>f\<^sup>i\<^sup>n\<^sub>\<down> \<equiv> { x | x (y :: ZF) \<Gamma>\<^sub>x \<phi>. y \<midarrow>\<Gamma>\<^sub>x,\<phi>\<rightarrow>\<^sub>1 x \<and>
                finite (particulars \<Gamma>\<^sub>x) }\<close>

lemma \<^marker>\<open>tag (proof) aponly\<close> finitelyAnchored_I[intro]:
  assumes \<open>(y :: ZF) \<midarrow>\<Gamma>\<^sub>x,\<phi>\<rightarrow>\<^sub>1 x\<close> \<open>finite (particulars \<Gamma>\<^sub>x)\<close>
  shows \<open>x \<in> \<P>\<^sup>f\<^sup>i\<^sup>n\<^sub>\<down>\<close>
  using assms by (simp only: finitelyAnchored_def mem_Collect_eq ; metis)

lemma \<^marker>\<open>tag (proof) aponly\<close> finitelyAnchored_E[elim!]:
  assumes  \<open>x \<in> \<P>\<^sup>f\<^sup>i\<^sup>n\<^sub>\<down>\<close>
  obtains y \<Gamma>\<^sub>x \<phi> where \<open>(y :: ZF) \<midarrow>\<Gamma>\<^sub>x,\<phi>\<rightarrow>\<^sub>1 x\<close> \<open>finite (particulars \<Gamma>\<^sub>x)\<close>
  using assms by (simp only: finitelyAnchored_def mem_Collect_eq ; metis)

text \<^marker>\<open>tag bodyonly\<close> \<open>
  We say that a particular is intrinsically anchored if and only
  if it is anchored by at least one anchor that only has a single
  substantial (but which may have many moments directly or indirectly
  inherent to the single substantial). The existence of such an
  anchor is the evidence that the particular can be identified without
  referring to other substantials, i.e., by referring only to its
  intrinsic properties. Formally, we have:
\<close>

definition intrinsicallyAnchored :: \<open>'p set\<close> (\<open>\<P>\<^sup>i\<^sup>n\<^sup>t\<^sub>\<down>\<close>)
  where
  \<open>\<P>\<^sup>i\<^sup>n\<^sup>t\<^sub>\<down> \<equiv> { x | x (y :: ZF) \<Gamma>\<^sub>x \<phi>. y \<midarrow>\<Gamma>\<^sub>x,\<phi>\<rightarrow>\<^sub>\<bottom> x \<and>
    (\<forall>z \<in> particulars \<Gamma>\<^sub>x. (ps_inheres_in \<Gamma>\<^sub>x)\<^sup>*\<^sup>* z y) }\<close>

lemma \<^marker>\<open>tag (proof) aponly\<close> intrinsicallyAnchored_I[intro]:
  assumes \<open>(y :: ZF) \<midarrow>\<Gamma>\<^sub>x,\<phi>\<rightarrow>\<^sub>\<bottom> x\<close>
        \<open>\<And>z. z \<in> particulars \<Gamma>\<^sub>x \<Longrightarrow> (ps_inheres_in \<Gamma>\<^sub>x)\<^sup>*\<^sup>* z y\<close>
  shows \<open>x \<in> \<P>\<^sup>i\<^sup>n\<^sup>t\<^sub>\<down>\<close>
  using assms by (simp only: intrinsicallyAnchored_def mem_Collect_eq ; metis)

lemma \<^marker>\<open>tag (proof) aponly\<close> intrinsicallyAnchored_E[elim!]:
  assumes  \<open>x \<in> \<P>\<^sup>i\<^sup>n\<^sup>t\<^sub>\<down>\<close>
  obtains y \<Gamma>\<^sub>x \<phi> where \<open>(y :: ZF) \<midarrow>\<Gamma>\<^sub>x,\<phi>\<rightarrow>\<^sub>\<bottom> x\<close>
        \<open>\<And>z. z \<in> particulars \<Gamma>\<^sub>x \<Longrightarrow> (ps_inheres_in \<Gamma>\<^sub>x)\<^sup>*\<^sup>* z y\<close>
  using assms by (simp only: intrinsicallyAnchored_def mem_Collect_eq ; metis)

lemma \<^marker>\<open>tag (proof) aponly\<close> intrinsicallyAnchored_are_Anchored: \<open>\<P>\<^sup>i\<^sup>n\<^sup>t\<^sub>\<down> \<subseteq> \<P>\<^sub>\<Down>\<close>
  using intrinsicallyAnchored_E
  by (meson minimallyAnchored_I subsetI)

end

context ufo_particular_theory
begin

lemma \<^marker>\<open>tag (proof) aponly\<close> finite_anchors_imp_min_anchor_ex:
  fixes x and y :: ZF and \<Gamma>\<^sub>x \<phi>\<^sub>x
  assumes \<open>y \<midarrow>\<Gamma>\<^sub>x,\<phi>\<^sub>x\<rightarrow>\<^sub>1 x\<close> \<open>finite (particulars \<Gamma>\<^sub>x)\<close>
  shows \<open>\<exists>(y\<^sub>2 :: ZF) \<Gamma>\<^sub>2 \<sigma>. y\<^sub>2 \<midarrow>\<Gamma>\<^sub>2,\<phi>\<^sub>x \<circ> \<sigma>\<rightarrow>\<^sub>\<bottom> x \<and> \<Gamma>\<^sub>2 \<lless>\<^bsub>\<sigma>\<^esub> \<Gamma>\<^sub>x\<close>
proof -
  obtain gamma_x: \<open>x \<in> \<P>\<close> \<open>\<Gamma>\<^sub>x \<lless>\<^bsub>\<phi>\<^sub>x\<^esub> \<Gamma>\<close> \<open>y \<in> particulars \<Gamma>\<^sub>x\<close>
         \<open>\<And>\<phi> z. \<lbrakk> z \<in> particulars \<Gamma>\<^sub>x ; \<phi> \<in> Morphs\<^bsub>\<Gamma>\<^sub>x,\<Gamma>\<^esub> \<rbrakk> \<Longrightarrow> \<phi> z = x \<longleftrightarrow> z = y\<close>
    using anchorsE[OF assms(1)] by metis
  then interpret phi_x: particular_struct_injection \<Gamma>\<^sub>x \<Gamma> \<phi>\<^sub>x \<open>TYPE(ZF)\<close> \<open>TYPE('p)\<close> \<open>TYPE('q)\<close> by simp
  have \<open>\<exists>(z :: ZF) \<Gamma>' \<phi>. z \<midarrow>\<Gamma>',\<phi>\<^sub>x \<circ> \<phi>\<rightarrow>\<^sub>\<bottom> x \<and> \<Gamma>' \<lless>\<^bsub>\<phi>\<^esub> \<Gamma>\<^sub>x\<close>
  proof (rule ccontr; simp)
    assume AA: \<open>\<forall>(z :: ZF) \<Gamma>' \<phi>. z \<midarrow>\<Gamma>',\<phi>\<^sub>x \<circ> \<phi>\<rightarrow>\<^sub>\<bottom> x \<longrightarrow> \<not> \<Gamma>' \<lless>\<^bsub>\<phi>\<^esub> \<Gamma>\<^sub>x \<close>
    have no_min_anchor: \<open>False\<close> if \<open>z \<midarrow>\<Gamma>',\<phi>\<^sub>x \<circ> \<phi>\<rightarrow>\<^sub>\<bottom> x \<close> \<open>\<Gamma>' \<lless>\<^bsub>\<phi>\<^esub> \<Gamma>\<^sub>x\<close> for z :: ZF and \<Gamma>' \<phi>
      using AA[rule_format] that by simp
    define N where \<open>N \<equiv> { card (particulars \<Gamma>') | \<Gamma>' (z :: ZF) \<phi>\<^sub>1 . z \<midarrow>\<Gamma>',\<phi>\<^sub>x \<circ> \<phi>\<^sub>1\<rightarrow>\<^sub>1 x \<and> \<Gamma>'\<lless>\<^bsub>\<phi>\<^sub>1\<^esub> \<Gamma>\<^sub>x \<and> finite (particulars \<Gamma>')}\<close>
    have \<open>N \<noteq> \<emptyset>\<close>
      apply (auto simp: N_def)
      apply (rule exI[of _ \<Gamma>\<^sub>x] ; rule exI[of _ y]
              ; rule exI[of _ id] ; intro conjI
              ; (simp only: o_id)?)
      subgoal by (simp add: phi_x.src.particular_struct_axioms sub_structure_by_refl)
      subgoal using assms(1) by blast
      by (simp add: assms(2))

    then obtain n where N: \<open>n \<in> N\<close> \<open>\<And>i. i \<in> N \<Longrightarrow> n \<le> i\<close>
      by (meson Inf_nat_def1 bdd_below_def bot.extremum cInf_less_iff leI less_imp_neq)
    then obtain \<Gamma>' and z :: ZF and \<phi>'
      where gamma_z: \<open>z \<midarrow>\<Gamma>',\<phi>\<^sub>x \<circ> \<phi>'\<rightarrow>\<^sub>1 x\<close> \<open>\<Gamma>'\<lless>\<^bsub>\<phi>'\<^esub> \<Gamma>\<^sub>x\<close> \<open>finite (particulars \<Gamma>')\<close>
            \<open>n = card (particulars \<Gamma>')\<close>
      using N apply (simp add: N_def)
      by blast
    interpret phi_x': particular_struct_injection \<Gamma>' \<Gamma> \<open>\<phi>\<^sub>x \<circ> \<phi>'\<close> using gamma_z(1) by blast
    interpret phi': particular_struct_injection \<Gamma>' \<Gamma>\<^sub>x \<phi>' using gamma_z(2) by blast

    have gamma'': \<open>\<not> z' \<midarrow>\<Gamma>'',\<phi>\<^sub>1\<rightarrow>\<^sub>1 x\<close> if \<open>\<Gamma>'' \<lless>\<^bsub>\<phi>\<^sub>2\<^esub> \<Gamma>'\<close> \<open>\<forall>\<phi>. \<not> \<Gamma>' \<lless>\<^bsub>\<phi>\<^esub> \<Gamma>''\<close> for \<Gamma>'' and z' :: ZF and \<phi>\<^sub>1 \<phi>\<^sub>2
    proof (rule ccontr ; simp)
      assume as3: \<open>z' \<midarrow>\<Gamma>'',\<phi>\<^sub>1\<rightarrow>\<^sub>1 x\<close>
      have C1: \<open>\<Gamma>'' \<lless>\<^bsub>\<phi>' \<circ> \<phi>\<^sub>2\<^esub> \<Gamma>\<^sub>x\<close> using that(1) gamma_z(2) sub_structure_by_trans
        by metis
      then have C2: \<open>finite (particulars \<Gamma>'')\<close>
        using assms(2) finite_card_sub_structure_by_finite by metis
      have C3: \<open>card (particulars \<Gamma>'') < card (particulars \<Gamma>')\<close>
        using that(1,2) by (simp add: finite_card_substruct_lt gamma_z(3))
      have C3_1: \<open>\<exists>z \<phi>\<^sub>1. z \<midarrow>\<Gamma>'',\<phi>\<^sub>x \<circ> \<phi>\<^sub>1\<rightarrow>\<^sub>1 x \<and> \<Gamma>'' \<lless>\<^bsub>\<phi>\<^sub>1\<^esub> \<Gamma>\<^sub>x \<and> finite (particulars \<Gamma>'')\<close>
      proof -
        have "\<forall>f p. \<Gamma>'' \<lless>\<^bsub>(f::ZF \<Rightarrow> 'p) \<circ> (\<phi>' \<circ> \<phi>\<^sub>2)\<^esub> p \<or> \<not> \<Gamma>\<^sub>x \<lless>\<^bsub>f\<^esub> p"
          using C1 sub_structure_by_trans by blast
        then have "z' \<midarrow>\<Gamma>'',\<phi>\<^sub>x \<circ> (\<phi>' \<circ> \<phi>\<^sub>2)\<rightarrow>\<^sub>1 x"
          using as3 phi_x.particular_struct_injection_axioms by blast
        then show ?thesis
          by (meson C1 C2)
      qed

      have C4: \<open>card (particulars \<Gamma>'') \<in> N\<close>
        apply (simp add: N_def)
        apply (intro exI[of _ \<Gamma>''] conjI C1 C2 ; simp?)
        using C3_1 by metis

      then have \<open>card (particulars \<Gamma>') \<le> card (particulars \<Gamma>'')\<close>
        using N(2) gamma_z(4) by simp
      then show False using C3 by auto
    qed
    have gamma_1: \<open>\<Gamma>'' \<in> IsoModels\<^bsub>\<Gamma>',TYPE(ZF)\<^esub>\<close> if as3: \<open>\<Gamma>'' \<lless>\<^bsub>\<phi>\<^sub>1\<^esub> \<Gamma>'\<close> \<open>z' \<midarrow>\<Gamma>'',\<phi>\<^sub>2\<rightarrow>\<^sub>1 x\<close> for \<Gamma>'' and z' :: ZF and \<phi>\<^sub>1 \<phi>\<^sub>2
    proof -
      have A1: \<open>finite (particulars \<Gamma>'')\<close>
        using finite_card_sub_structure_by_finite gamma_z that by metis
      obtain \<phi>\<^sub>3 where A2: \<open>\<Gamma>' \<lless>\<^bsub>\<phi>\<^sub>3\<^esub> \<Gamma>''\<close>
        using gamma''[OF as3(1),of z' \<phi>\<^sub>2] as3(2) by metis
      have A3: \<open>\<Gamma>'' \<sim>\<^bsub>\<phi>\<^sub>1\<^esub> \<Gamma>'\<close>
        using sub_structure_by_finite_weak_antisym that(1) A2 A1 by metis
      then show ?thesis
      proof -
        have "MorphImg \<phi>\<^sub>1 \<Gamma>'' = \<Gamma>'"
          by (metis A3 particular_struct_bijection_iff_particular_struct_bijection_1)
        then have "\<Gamma>' \<in> {MorphImg f \<Gamma>'' |f. f \<in> Collect (particular_struct_bijection_1 \<Gamma>'')}"
          using A3 particular_struct_bijection_iff_particular_struct_bijection_1 by auto
        then show ?thesis
          by (metis (no_types) isomorphic_models_def isomorphic_models_sym bijections1_def)
      qed
    qed

    have ZZ: \<open>z \<midarrow>\<Gamma>',\<phi>\<^sub>x \<circ> \<phi>'\<rightarrow>\<^sub>\<bottom> x\<close>
      apply (intro minimallyAnchorsI gamma_z(1))
      subgoal for \<Gamma>'' z' \<sigma>\<^sub>1 \<sigma>\<^sub>2
        using gamma_1 by metis
      done

    show False using AA[rule_format,of z \<Gamma>'] ZZ
        gamma_z(2) by simp
  qed
  then obtain  z :: ZF and  \<Gamma>' \<phi>
    where \<open>z \<midarrow>\<Gamma>',\<phi>\<^sub>x \<circ> \<phi>\<rightarrow>\<^sub>\<bottom> x\<close> \<open>\<Gamma>' \<lless>\<^bsub>\<phi>\<^esub> \<Gamma>\<^sub>x\<close>
    using that by metis
  then show \<open>?thesis\<close> by metis
qed

text \<^marker>\<open>tag bodyonly\<close> \<open>
  Finite anchors imply the existence of minimal anchors, i.e, finitely
  anchored particulars are also minimally anchored ones:
\<close>

lemma finitely_anchored_are_minimally_anchored: \<open>\<P>\<^sup>f\<^sup>i\<^sup>n\<^sub>\<down> \<subseteq> \<P>\<^sub>\<Down>\<close>
proof (intro subsetI ; elim finitelyAnchored_E)
  fix x and y :: ZF and \<Gamma>\<^sub>x \<phi>\<^sub>x
  assume assms: \<open>y \<midarrow>\<Gamma>\<^sub>x,\<phi>\<^sub>x\<rightarrow>\<^sub>1 x\<close> \<open>finite (particulars \<Gamma>\<^sub>x)\<close>
  then obtain  z :: ZF and  \<Gamma>' \<phi> where \<open>z \<midarrow>\<Gamma>',\<phi>\<rightarrow>\<^sub>\<bottom> x\<close>
    using assms finite_anchors_imp_min_anchor_ex   by metis
  then show \<open>x \<in> \<P>\<^sub>\<Down>\<close>
    using  minimallyAnchored_I[of z \<Gamma>'] by simp
qed

lemma \<^marker>\<open>tag (proof) aponly\<close> min_anchor_to_zf_I:
  fixes y :: 'a
  assumes \<open>y \<midarrow>\<Gamma>\<^sub>x,\<sigma>\<rightarrow>\<^sub>\<bottom> x\<close>
  shows \<open>\<exists>(y\<^sub>1 :: ZF) \<Gamma>\<^sub>1 \<phi>\<^sub>z. y\<^sub>1 \<midarrow>\<Gamma>\<^sub>1,\<phi>\<^sub>z\<rightarrow>\<^sub>\<bottom> x \<and> \<Gamma>\<^sub>1 \<in> IsoModels\<^bsub>\<Gamma>\<^sub>x,TYPE(ZF)\<^esub>\<close>
proof -
  obtain A: \<open>y \<midarrow>\<Gamma>\<^sub>x,\<sigma>\<rightarrow>\<^sub>1 x\<close> \<open>\<And>\<Gamma>' z \<sigma>\<^sub>1 \<sigma>\<^sub>2. \<lbrakk> \<Gamma>' \<lless>\<^bsub>\<sigma>\<^sub>1\<^esub> \<Gamma>\<^sub>x ; z \<midarrow>\<Gamma>',\<sigma>\<^sub>2\<rightarrow>\<^sub>1 x \<rbrakk> \<Longrightarrow> \<Gamma>' \<in> IsoModels\<^bsub>\<Gamma>\<^sub>x,TYPE(ZF)\<^esub>\<close>
    using minimallyAnchorsE[OF assms] by metis
  obtain y\<^sub>z :: ZF and \<Gamma>\<^sub>z \<phi>\<^sub>z where B: \<open>y\<^sub>z \<midarrow>\<Gamma>\<^sub>z,\<phi>\<^sub>z\<rightarrow>\<^sub>1 x\<close> \<open>\<Gamma>\<^sub>z \<in> IsoModels\<^bsub>\<Gamma>\<^sub>x,TYPE(ZF)\<^esub>\<close>
    using anchor_to_zf_I[OF A(1)] by blast
  obtain \<phi> where C: \<open>particular_struct_bijection_1 \<Gamma>\<^sub>x \<phi>\<close> \<open>\<Gamma>\<^sub>z = MorphImg \<phi> \<Gamma>\<^sub>x\<close>
    using B(2) by blast
  then interpret phi: particular_struct_bijection_1 \<Gamma>\<^sub>x \<phi> by simp
  have \<open>\<Gamma>\<^sub>x \<sim>\<^bsub>\<phi>\<^esub> \<Gamma>\<^sub>z\<close>
    by (simp add: C(2) phi.particular_struct_bijection_axioms)
  have D: \<open>\<Gamma>\<^sub>z \<lless>\<^bsub>phi.inv_morph\<^esub> \<Gamma>\<^sub>x\<close>
    using C(2) phi.inv_is_bijective_morphism by blast
  obtain E: \<open>x \<in> \<E>\<close>
   \<open>\<Gamma>\<^sub>x \<lless>\<^bsub>\<sigma>\<^esub> \<Gamma>\<close>
   \<open>y \<in> phi.src.\<P>\<close>
   \<open>\<And>\<phi> z. \<lbrakk> z \<in> phi.src.endurants; \<phi> \<in> Morphs\<^bsub>\<Gamma>\<^sub>x,\<Gamma>\<^esub> \<rbrakk> \<Longrightarrow> \<phi> z = x \<longleftrightarrow> z = y\<close>
    using A(1)[THEN anchorsE] by metis
  obtain F: \<open>\<Gamma>\<^sub>z \<lless>\<^bsub>\<phi>\<^sub>z\<^esub> \<Gamma>\<close>
   \<open>y\<^sub>z \<in> particulars \<Gamma>\<^sub>z\<close>
   \<open>\<And>\<phi> z. \<lbrakk> z \<in> particulars \<Gamma>\<^sub>z ; \<phi> \<in> Morphs\<^bsub>\<Gamma>\<^sub>z,\<Gamma>\<^esub> \<rbrakk> \<Longrightarrow> \<phi> z = x \<longleftrightarrow> z = y\<^sub>z\<close>
    using B(1)[THEN anchorsE] by metis
  have G: \<open>\<Gamma>\<^sub>z \<lless>\<^bsub>\<sigma> \<circ> phi.inv_morph\<^esub> \<Gamma>\<close>
    by (intro particular_struct_injection_comp[of _ \<Gamma>\<^sub>x] D E(2))
  have \<open>y\<^sub>z \<midarrow>\<Gamma>\<^sub>z,\<sigma> \<circ> phi.inv_morph\<rightarrow>\<^sub>\<bottom> x\<close>
    apply (intro minimallyAnchorsI anchorsI B E(1) F(2) G F(3) ; assumption?)
    subgoal premises P for \<Gamma>' z \<sigma>\<^sub>1 \<sigma>\<^sub>2
      supply R = A(2)[OF particular_struct_injection_comp[OF P(1) D] P(2)]
      by (metis (no_types, hide_lams) R C isomorphic_models_iff isomorphic_models_sym
          bijections_iff morph_img_comp particular_struct_bijection_1_comp)
    done
  then show ?thesis using B(2) by metis
qed

end

end


(*  Title:      Containers/Collection_Eq.thy
    Author:     Andreas Lochbihler, KIT
                René Thiemann, UIBK *)
theory Collection_Eq imports
  Containers_Auxiliary
  Containers_Generator
  Deriving.Equality_Instances
begin

section \<open>A type class for optional equality testing\<close>

class ceq =
  fixes ceq :: "('a \<Rightarrow> 'a \<Rightarrow> bool) option"
  assumes ceq: "ceq = Some eq \<Longrightarrow> eq = (=)"
begin

lemma ceq_equality: "ceq = Some eq \<Longrightarrow> equality eq"
  by (drule ceq, rule Equality_Generator.equalityI, simp)

lemma ID_ceq: "ID ceq = Some eq \<Longrightarrow> eq = (=)"
unfolding ID_def id_apply by(rule ceq)

abbreviation ceq' :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where "ceq' \<equiv> the (ID ceq)"

end

syntax "_CEQ" :: "type => logic"  ("(1CEQ/(1'(_')))")

parse_translation \<open>
let
  fun ceq_tr [ty] =
     (Syntax.const @{syntax_const "_constrain"} $ Syntax.const @{const_syntax "ceq"} $
       (Syntax.const @{type_syntax option} $
         (Syntax.const @{type_syntax fun} $ ty $
           (Syntax.const @{type_syntax fun} $ ty $ Syntax.const @{type_syntax bool}))))
    | ceq_tr ts = raise TERM ("ceq_tr", ts);
in [(@{syntax_const "_CEQ"}, K ceq_tr)] end
\<close>

typed_print_translation \<open>
let
  fun ceq_tr' ctxt
    (Type (@{type_name option}, [Type (@{type_name fun}, [T, _])])) ts =
    Term.list_comb (Syntax.const @{syntax_const "_CEQ"} $ Syntax_Phases.term_of_typ ctxt T, ts)
  | ceq_tr' _ _ _ = raise Match;
in [(@{const_syntax ceq}, ceq_tr')]
end
\<close>

definition is_ceq :: "'a :: ceq itself \<Rightarrow> bool"
where "is_ceq _ \<longleftrightarrow> ID CEQ('a) \<noteq> None"

subsection \<open>Generator for the @{class ceq}-class\<close>

text \<open>
This generator registers itself at the derive-manager for the class @{class ceq}.
To be more precise, one can choose whether one wants to take @{term "(=)"} as function
for @{term ceq} by passing "eq" as parameter,
whether equality should not be supported by passing "no" as parameter,
or whether an own definition for equality should be derived by not passing
any parameters. The last possibility only works for datatypes.

\begin{itemize}
\item \texttt{instantiation type :: (type,\ldots,type) (eq) ceq}
\item \texttt{instantiation type :: (type,\ldots,type) (no) ceq}
\item \texttt{instantiation datatype :: (ceq,\ldots,ceq) ceq}
\end{itemize}

If the parameter "no" is not used, then the corresponding
@{term is_ceq}-theorem is also automatically generated and attributed with
\texttt{[simp, code-post]}.
\<close>

text \<open>
This generator can be used for arbitrary types, not just datatypes.
\<close>

lemma equality_subst: "c1 = c2 \<Longrightarrow> equality c1 \<Longrightarrow> equality c2" by blast

ML_file \<open>ceq_generator.ML\<close>

subsection \<open>Type class instances for HOL types\<close>

derive (eq) ceq unit

lemma is_ceq_fun [simp]: "\<not> is_ceq TYPE('a \<Rightarrow> 'b)"
  by(simp add: is_ceq_def ceq_fun_def ID_None)

definition set_eq :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool"
where [code del]: "set_eq = (=)"

lemma set_eq_code:
  shows [code]: "set_eq A B \<longleftrightarrow> A \<subseteq> B \<and> B \<subseteq> A"
  and [code_unfold]: "(=) = set_eq"
unfolding set_eq_def by blast+

instantiation set :: (ceq) ceq begin
definition "CEQ('a set) = (case ID CEQ('a) of None \<Rightarrow> None | Some _ \<Rightarrow> Some set_eq)"
instance by(intro_classes)(simp add: ceq_set_def set_eq_def split: option.splits)
end

lemma is_ceq_set [simp, code_post]: "is_ceq TYPE('a set) \<longleftrightarrow> is_ceq TYPE('a :: ceq)"
by(simp add: is_ceq_def ceq_set_def ID_None ID_Some split: option.split)

lemma ID_ceq_set_not_None_iff [simp]: "ID CEQ('a set) \<noteq> None \<longleftrightarrow> ID CEQ('a :: ceq) \<noteq> None"
by(simp add: ceq_set_def ID_def split: option.splits)

text \<open>Instantiation for @{typ "'a Predicate.pred"}\<close>

context fixes eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" begin

definition member_pred :: "'a Predicate.pred \<Rightarrow> 'a \<Rightarrow> bool"
where "member_pred P x \<longleftrightarrow> (\<exists>y. eq x y \<and> Predicate.eval P y)"

definition member_seq :: "'a Predicate.seq \<Rightarrow> 'a \<Rightarrow> bool"
where "member_seq xp = member_pred (Predicate.pred_of_seq xp)"

lemma member_seq_code [code]:
  "member_seq seq.Empty x \<longleftrightarrow> False"
  "member_seq (seq.Insert y P) x \<longleftrightarrow> eq x y \<or> member_pred P x"
  "member_seq (seq.Join Q xq) x \<longleftrightarrow> member_pred Q x \<or> member_seq xq x"
by(auto simp add: member_seq_def member_pred_def)

lemma member_pred_code [code]:
  "member_pred (Predicate.Seq f) = member_seq (f ())"
by(simp add: member_seq_def Seq_def)

definition leq_pred :: "'a Predicate.pred \<Rightarrow> 'a Predicate.pred \<Rightarrow> bool"
where "leq_pred P Q \<longleftrightarrow> (\<forall>x. Predicate.eval P x \<longrightarrow> (\<exists>y. eq x y \<and> Predicate.eval Q y))"

definition leq_seq :: "'a Predicate.seq \<Rightarrow> 'a Predicate.pred \<Rightarrow> bool"
where "leq_seq xp Q \<longleftrightarrow> leq_pred (Predicate.pred_of_seq xp) Q"

lemma leq_seq_code [code]:
  "leq_seq seq.Empty Q \<longleftrightarrow> True"
  "leq_seq (seq.Insert x P) Q \<longleftrightarrow> member_pred Q x \<and> leq_pred P Q"
  "leq_seq (seq.Join P xp) Q \<longleftrightarrow> leq_pred P Q \<and> leq_seq xp Q"
by(auto simp add: leq_seq_def leq_pred_def member_pred_def)

lemma leq_pred_code [code]:
  "leq_pred (Predicate.Seq f) Q \<longleftrightarrow> leq_seq (f ()) Q"
by(simp add: leq_seq_def Seq_def)

definition predicate_eq :: "'a Predicate.pred \<Rightarrow> 'a Predicate.pred \<Rightarrow> bool"
where "predicate_eq P Q \<longleftrightarrow> leq_pred P Q \<and> leq_pred Q P"

context assumes eq: "eq = (=)" begin

lemma member_pred_eq: "member_pred = Predicate.eval"
unfolding fun_eq_iff member_pred_def by(simp add: eq)

lemma member_seq_eq: "member_seq = Predicate.member"
by(simp add: member_seq_def fun_eq_iff eval_member member_pred_eq)

lemma leq_pred_eq: "leq_pred = (\<le>)"
unfolding fun_eq_iff leq_pred_def by(auto simp add: eq less_eq_pred_def)

lemma predicate_eq_eq: "predicate_eq = (=)"
unfolding predicate_eq_def fun_eq_iff by(auto simp add: leq_pred_eq)

end
end

instantiation Predicate.pred :: (ceq) ceq begin
definition "CEQ('a Predicate.pred) = map_option predicate_eq (ID CEQ('a))"
instance by(intro_classes)(auto simp add: ceq_pred_def predicate_eq_eq dest: ID_ceq)
end

end