(*    Title:              SatSolverVerification/NieuwenhuisOliverasTinelli.thy
      Author:             Filip Maric
      Maintainer:         Filip Maric <filip at matf.bg.ac.yu>
*)

section\<open>Transition system of Nieuwenhuis, Oliveras and Tinelli.\<close>
theory NieuwenhuisOliverasTinelli
imports SatSolverVerification
begin

text\<open>This theory formalizes the transition rule system given by
Nieuwenhuis et al. in \cite{NieuwenhuisOliverasTinelli}\<close>

(******************************************************************************)
subsection\<open>Specification\<close>
(******************************************************************************)

record State =
"getF" :: Formula
"getM" :: LiteralTrail

definition
appliedDecide:: "State \<Rightarrow> State \<Rightarrow> Variable set \<Rightarrow> bool"
where
"appliedDecide stateA stateB decisionVars ==
  \<exists> l.
        (var l) \<in> decisionVars \<and>
        \<not> l el (elements (getM stateA)) \<and>
        \<not> opposite l el (elements (getM stateA)) \<and>

        getF stateB = getF stateA \<and>
        getM stateB = getM stateA @ [(l, True)]
"
definition
applicableDecide :: "State \<Rightarrow> Variable set \<Rightarrow> bool"
where
"applicableDecide state decisionVars == \<exists> state'. appliedDecide state state' decisionVars"

definition
appliedUnitPropagate :: "State \<Rightarrow> State \<Rightarrow> bool"
where
"appliedUnitPropagate stateA stateB ==
  \<exists> (uc::Clause) (ul::Literal).
       uc el (getF stateA) \<and>
       isUnitClause uc ul (elements (getM stateA)) \<and>

       getF stateB = getF stateA \<and>
       getM stateB = getM stateA @ [(ul, False)]
"
definition
applicableUnitPropagate :: "State \<Rightarrow> bool"
where
"applicableUnitPropagate state == \<exists> state'. appliedUnitPropagate state state'"

definition
appliedBackjump :: "State \<Rightarrow> State \<Rightarrow> bool"
where
"appliedBackjump stateA stateB ==
  \<exists> bc bl level.
       isUnitClause bc bl (elements (prefixToLevel level (getM stateA))) \<and>
       formulaEntailsClause (getF stateA) bc \<and>
       var bl \<in> vars (getF stateA) \<union> vars (elements (getM stateA)) \<and>
       0 \<le> level \<and> level < (currentLevel (getM stateA)) \<and>

       getF stateB = getF stateA \<and>
       getM stateB = prefixToLevel level (getM stateA) @ [(bl, False)]
"
definition
applicableBackjump :: "State \<Rightarrow> bool"
where
"applicableBackjump state ==  \<exists> state'. appliedBackjump state state'"

definition
appliedLearn :: "State \<Rightarrow> State \<Rightarrow> bool"
where
"appliedLearn stateA stateB ==
  \<exists> c.
       (formulaEntailsClause (getF stateA) c) \<and>
       (vars c) \<subseteq> vars (getF stateA) \<union> vars (elements (getM stateA)) \<and>
       getF stateB = getF stateA @ [c] \<and>
       getM stateB = getM stateA
"
definition
applicableLearn :: "State \<Rightarrow> bool"
where
"applicableLearn state == (\<exists> state'. appliedLearn state state')"

text\<open>Solving starts with the initial formula and the empty trail.\<close>
definition
isInitialState :: "State \<Rightarrow> Formula \<Rightarrow> bool"
where
"isInitialState state F0 ==
      getF state = F0 \<and>
      getM state = []
"

text\<open>Transitions are preformed only by using given rules.\<close>
definition
"transition stateA stateB decisionVars ==
     appliedDecide        stateA stateB decisionVars \<or>
     appliedUnitPropagate stateA stateB \<or>
     appliedLearn         stateA stateB \<or>
     appliedBackjump      stateA stateB
"

text\<open>Transition relation is obtained by applying transition rules
iteratively. It is defined using a reflexive-transitive closure.\<close>
definition
"transitionRelation decisionVars == ({(stateA, stateB). transition stateA stateB decisionVars})^*"

text\<open>Final state is one in which no rules apply\<close>
definition
isFinalState :: "State \<Rightarrow> Variable set \<Rightarrow> bool"
where
"isFinalState state decisionVars == \<not> (\<exists> state'. transition state state' decisionVars)"

text\<open>The following several lemmas establish conditions for applicability of different rules.\<close>
lemma applicableDecideCharacterization:
  fixes stateA::State
  shows "applicableDecide stateA decisionVars =
  (\<exists> l.
        (var l) \<in> decisionVars \<and>
        \<not> l el (elements (getM stateA)) \<and>
        \<not> opposite l el (elements (getM stateA)))
  " (is "?lhs = ?rhs")
proof
  assume ?rhs
  then obtain l where
    *: "(var l) \<in> decisionVars" "\<not> l el (elements (getM stateA))" "\<not> opposite l el (elements (getM stateA))"
    unfolding applicableDecide_def
    by auto
  let ?stateB = "stateA\<lparr> getM := (getM stateA) @ [(l, True)] \<rparr>"
  from * have "appliedDecide stateA ?stateB decisionVars"
    unfolding appliedDecide_def
    by auto
  thus ?lhs
    unfolding applicableDecide_def
    by auto
next
  assume ?lhs
  then obtain stateB l
    where "(var l) \<in> decisionVars" "\<not> l el (elements (getM stateA))"
    "\<not> opposite l el (elements (getM stateA))"
    unfolding applicableDecide_def
    unfolding appliedDecide_def
    by auto
  thus ?rhs
    by auto
qed

lemma applicableUnitPropagateCharacterization:
  fixes stateA::State and F0::Formula
  shows "applicableUnitPropagate stateA =
  (\<exists> (uc::Clause) (ul::Literal).
       uc el (getF stateA) \<and>
       isUnitClause uc ul (elements (getM stateA)))
  " (is "?lhs = ?rhs")
proof
  assume "?rhs"
  then obtain ul uc
    where *: "uc el (getF stateA)" "isUnitClause uc ul (elements (getM stateA))"
    unfolding applicableUnitPropagate_def
    by auto
  let ?stateB = "stateA\<lparr> getM := getM stateA @ [(ul, False)] \<rparr>"
  from * have "appliedUnitPropagate stateA ?stateB"
    unfolding appliedUnitPropagate_def
    by auto
  thus ?lhs
    unfolding applicableUnitPropagate_def
    by auto
next
  assume ?lhs
  then obtain stateB uc ul
    where "uc el (getF stateA)" "isUnitClause uc ul (elements (getM stateA))"
    unfolding applicableUnitPropagate_def
    unfolding appliedUnitPropagate_def
    by auto
  thus ?rhs
    by auto
qed

lemma applicableLearnCharacterization:
  fixes stateA::State
  shows "applicableLearn stateA =
    (\<exists> c. formulaEntailsClause (getF stateA) c \<and>
          vars c \<subseteq> vars (getF stateA) \<union>  vars (elements (getM stateA)))" (is "?lhs = ?rhs")
proof
  assume "?rhs"
  then obtain c where
  *: "formulaEntailsClause (getF stateA) c"
     "vars c \<subseteq> vars (getF stateA) \<union>  vars (elements (getM stateA))"
    unfolding applicableLearn_def
    by auto
  let ?stateB = "stateA\<lparr> getF := getF stateA @ [c]\<rparr>"
  from * have "appliedLearn stateA ?stateB"
    unfolding appliedLearn_def
    by auto
  thus "?lhs"
    unfolding applicableLearn_def
    by auto
next
  assume "?lhs"
  then obtain c stateB
    where
    "formulaEntailsClause (getF stateA) c"
    "vars c \<subseteq> vars (getF stateA) \<union> vars (elements (getM stateA))"
    unfolding applicableLearn_def
    unfolding appliedLearn_def
    by auto
  thus "?rhs"
    by auto
qed

text\<open>Final states are the ones where no rule is applicable.\<close>
lemma finalStateNonApplicable:
  fixes state::State
  shows "isFinalState state decisionVars =
          (\<not> applicableDecide state decisionVars \<and>
           \<not> applicableUnitPropagate state \<and>
           \<not> applicableBackjump state \<and>
           \<not> applicableLearn state)"
unfolding isFinalState_def
unfolding transition_def
unfolding applicableDecide_def
unfolding applicableUnitPropagate_def
unfolding applicableBackjump_def
unfolding applicableLearn_def
by auto

(******************************************************************************)
subsection\<open>Invariants\<close>
(******************************************************************************)
text\<open>Invariants that are relevant for the rest of correctness proof.\<close>
definition
invariantsHoldInState :: "State \<Rightarrow> Formula \<Rightarrow> Variable set \<Rightarrow> bool"
where
"invariantsHoldInState state F0 decisionVars ==
    InvariantImpliedLiterals (getF state) (getM state) \<and>
    InvariantVarsM (getM state) F0 decisionVars \<and>
    InvariantVarsF (getF state) F0 decisionVars \<and>
    InvariantConsistent (getM state) \<and>
    InvariantUniq (getM state) \<and>
    InvariantEquivalent F0 (getF state)
"

text\<open>Invariants hold in initial states.\<close>
lemma invariantsHoldInInitialState:
  fixes state :: State and F0 :: Formula
  assumes "isInitialState state F0"
  shows "invariantsHoldInState state F0 decisionVars"
using assms
by (auto simp add:
  isInitialState_def
  invariantsHoldInState_def
  InvariantImpliedLiterals_def
  InvariantVarsM_def
  InvariantVarsF_def
  InvariantConsistent_def
  InvariantUniq_def
  InvariantEquivalent_def equivalentFormulae_def
)

text\<open>Valid transitions preserve invariants.\<close>
lemma transitionsPreserveInvariants:
  fixes stateA::State and stateB::State
  assumes "transition stateA stateB decisionVars" and
  "invariantsHoldInState stateA F0 decisionVars"
  shows "invariantsHoldInState stateB F0 decisionVars"
proof-
    from \<open>invariantsHoldInState stateA F0 decisionVars\<close>
    have
      "InvariantImpliedLiterals (getF stateA) (getM stateA)" and
      "InvariantVarsM (getM stateA) F0 decisionVars" and
      "InvariantVarsF (getF stateA) F0 decisionVars" and
      "InvariantConsistent (getM stateA)" and
      "InvariantUniq (getM stateA)" and
      "InvariantEquivalent F0 (getF stateA)"
      unfolding invariantsHoldInState_def
      by auto
  {
    assume "appliedDecide stateA stateB decisionVars"
    then obtain l::Literal where
      "(var l) \<in> decisionVars"
      "\<not> literalTrue l (elements (getM stateA))"
      "\<not> literalFalse l (elements (getM stateA))"
      "getM stateB = getM stateA @ [(l, True)]"
      "getF stateB = getF stateA"
      unfolding appliedDecide_def
      by auto

    from \<open>\<not> literalTrue l (elements (getM stateA))\<close> \<open>\<not> literalFalse l (elements (getM stateA))\<close>
    have *: "var l \<notin> vars (elements (getM stateA))"
      using variableDefinedImpliesLiteralDefined[of "l" "elements (getM stateA)"]
      by simp

    have "InvariantImpliedLiterals (getF stateB) (getM stateB)"
      using \<open>getF stateB = getF stateA\<close>
        \<open>getM stateB = getM stateA @ [(l, True)]\<close>
        \<open>InvariantImpliedLiterals (getF stateA) (getM stateA)\<close>
        \<open>InvariantUniq (getM stateA)\<close>
        \<open>var l \<notin> vars (elements (getM stateA))\<close>
        InvariantImpliedLiteralsAfterDecide[of "getF stateA" "getM stateA" "l" "getM stateB"]
      by simp
    moreover
    have "InvariantVarsM (getM stateB) F0 decisionVars"
      using \<open>getM stateB = getM stateA @ [(l, True)]\<close>
        \<open>InvariantVarsM (getM stateA) F0 decisionVars\<close>
        \<open>var l \<in> decisionVars\<close>
        InvariantVarsMAfterDecide[of "getM stateA" "F0" "decisionVars" "l" "getM stateB"]
      by simp
    moreover
    have "InvariantVarsF (getF stateB) F0 decisionVars"
      using \<open>getF stateB = getF stateA\<close>
      \<open>InvariantVarsF (getF stateA) F0 decisionVars\<close>
      by simp
    moreover
    have "InvariantConsistent (getM stateB)"
      using \<open>getM stateB = getM stateA @ [(l, True)]\<close>
        \<open>InvariantConsistent (getM stateA)\<close>
        \<open>var l \<notin> vars (elements (getM stateA))\<close>
        InvariantConsistentAfterDecide[of "getM stateA" "l" "getM stateB"]
      by simp
    moreover
    have "InvariantUniq (getM stateB)"
      using \<open>getM stateB = getM stateA @ [(l, True)]\<close>
        \<open>InvariantUniq (getM stateA)\<close>
        \<open>var l \<notin> vars (elements (getM stateA))\<close>
        InvariantUniqAfterDecide[of "getM stateA" "l" "getM stateB"]
      by simp
    moreover
    have "InvariantEquivalent F0 (getF stateB)"
      using \<open>getF stateB = getF stateA\<close>
      \<open>InvariantEquivalent F0 (getF stateA)\<close>
      by simp
    ultimately
    have ?thesis
      unfolding invariantsHoldInState_def
      by auto
  }
  moreover
  {
    assume "appliedUnitPropagate stateA stateB"
    then obtain uc::Clause and ul::Literal where
      "uc el (getF stateA)"
      "isUnitClause uc ul (elements (getM stateA))"
      "getF stateB = getF stateA"
      "getM stateB = getM stateA @ [(ul, False)]"
      unfolding appliedUnitPropagate_def
      by auto

    from \<open>isUnitClause uc ul (elements (getM stateA))\<close>
    have "ul el uc"
      unfolding isUnitClause_def
      by simp

    from \<open>uc el (getF stateA)\<close>
    have "formulaEntailsClause (getF stateA) uc"
      by (simp add: formulaEntailsItsClauses)

    have "InvariantImpliedLiterals (getF stateB) (getM stateB)"
      using \<open>getF stateB = getF stateA\<close>
        \<open>InvariantImpliedLiterals (getF stateA) (getM stateA)\<close>
        \<open>formulaEntailsClause (getF stateA) uc\<close>
        \<open>isUnitClause uc ul (elements (getM stateA))\<close>
        \<open>getM stateB = getM stateA @ [(ul, False)]\<close>
        InvariantImpliedLiteralsAfterUnitPropagate[of "getF stateA" "getM stateA" "uc" "ul" "getM stateB"]
      by simp
    moreover
    from \<open>ul el uc\<close> \<open>uc el (getF stateA)\<close>
    have "ul el (getF stateA)"
      by (auto simp add: literalElFormulaCharacterization)
    with \<open>InvariantVarsF (getF stateA) F0 decisionVars\<close>
    have "var ul \<in> vars F0 \<union> decisionVars"
      using "formulaContainsItsLiteralsVariable" [of "ul" "getF stateA"]
      unfolding InvariantVarsF_def
      by auto

    have "InvariantVarsM (getM stateB) F0 decisionVars"
      using \<open>InvariantVarsM (getM stateA) F0 decisionVars\<close>
        \<open>var ul \<in> vars F0 \<union> decisionVars\<close>
        \<open>getM stateB = getM stateA @ [(ul, False)]\<close>
        InvariantVarsMAfterUnitPropagate[of "getM stateA" "F0" "decisionVars" "ul" "getM stateB"]
      by simp
    moreover
    have "InvariantVarsF (getF stateB) F0 decisionVars"
      using \<open>getF stateB = getF stateA\<close>
      \<open>InvariantVarsF (getF stateA) F0 decisionVars\<close>
      by simp
    moreover
    have "InvariantConsistent (getM stateB)"
      using \<open>InvariantConsistent (getM stateA)\<close>
        \<open>isUnitClause uc ul (elements (getM stateA))\<close>
        \<open>getM stateB = getM stateA @ [(ul, False)]\<close>
        InvariantConsistentAfterUnitPropagate [of "getM stateA" "uc" "ul" "getM stateB"]
      by simp
    moreover
    have "InvariantUniq (getM stateB)"
      using \<open>InvariantUniq (getM stateA)\<close>
        \<open>isUnitClause uc ul (elements (getM stateA))\<close>
        \<open>getM stateB = getM stateA @ [(ul, False)]\<close>
        InvariantUniqAfterUnitPropagate [of "getM stateA" "uc" "ul" "getM stateB"]
      by simp
    moreover
    have "InvariantEquivalent F0 (getF stateB)"
      using \<open>getF stateB = getF stateA\<close>
      \<open>InvariantEquivalent F0 (getF stateA)\<close>
      by simp
    ultimately
    have ?thesis
      unfolding invariantsHoldInState_def
      by auto
  }
  moreover
  {
    assume "appliedLearn stateA stateB"
    then obtain c::Clause where
      "formulaEntailsClause (getF stateA) c"
      "vars c \<subseteq> vars (getF stateA) \<union> vars (elements (getM stateA))"
      "getF stateB = getF stateA @ [c]"
      "getM stateB = getM stateA"
      unfolding appliedLearn_def
      by auto

    have "InvariantImpliedLiterals (getF stateB) (getM stateB)"
      using
        \<open>InvariantImpliedLiterals (getF stateA) (getM stateA)\<close>
        \<open>getF stateB = getF stateA @ [c]\<close>
        \<open>getM stateB = getM stateA\<close>
        InvariantImpliedLiteralsAfterLearn[of "getF stateA" "getM stateA" "getF stateB"]
      by simp
    moreover
    have "InvariantVarsM (getM stateB) F0 decisionVars"
      using
        \<open>InvariantVarsM (getM stateA) F0 decisionVars\<close>
        \<open>getM stateB = getM stateA\<close>
      by simp
    moreover
    from \<open>vars c \<subseteq> vars (getF stateA) \<union> vars (elements (getM stateA))\<close>
      \<open>InvariantVarsM (getM stateA) F0 decisionVars\<close>
        \<open>InvariantVarsF (getF stateA) F0 decisionVars\<close>
    have "vars c \<subseteq> vars F0 \<union> decisionVars"
      unfolding InvariantVarsM_def
      unfolding InvariantVarsF_def
      by auto
    hence "InvariantVarsF (getF stateB) F0 decisionVars"
      using \<open>InvariantVarsF (getF stateA) F0 decisionVars\<close>
        \<open>getF stateB = getF stateA @ [c]\<close>
      using varsAppendFormulae [of "getF stateA" "[c]"]
      unfolding InvariantVarsF_def
      by simp
    moreover
    have "InvariantConsistent (getM stateB)"
      using \<open>InvariantConsistent (getM stateA)\<close>
        \<open>getM stateB = getM stateA\<close>
      by simp
    moreover
    have "InvariantUniq (getM stateB)"
      using \<open>InvariantUniq (getM stateA)\<close>
        \<open>getM stateB = getM stateA\<close>
      by simp
    moreover
    have "InvariantEquivalent F0 (getF stateB)"
      using
        \<open>InvariantEquivalent F0 (getF stateA)\<close>
        \<open>formulaEntailsClause (getF stateA) c\<close>
        \<open>getF stateB = getF stateA @ [c]\<close>
        InvariantEquivalentAfterLearn[of "F0" "getF stateA" "c" "getF stateB"]
      by simp
    ultimately
    have ?thesis
      unfolding invariantsHoldInState_def
      by simp
  }
  moreover
  {
    assume "appliedBackjump stateA stateB"
    then obtain bc::Clause and bl::Literal and level::nat
      where
      "isUnitClause bc bl (elements (prefixToLevel level (getM stateA)))"
      "formulaEntailsClause (getF stateA) bc"
      "var bl \<in> vars (getF stateA) \<union> vars (elements (getM stateA))"
      "getF stateB = getF stateA"
      "getM stateB = prefixToLevel level (getM stateA) @ [(bl, False)]"
      unfolding appliedBackjump_def
      by auto

    have "isPrefix (prefixToLevel level (getM stateA)) (getM stateA)"
      by (simp add:isPrefixPrefixToLevel)

    have "InvariantImpliedLiterals (getF stateB) (getM stateB)"
      using \<open>InvariantImpliedLiterals (getF stateA) (getM stateA)\<close>
        \<open>isPrefix (prefixToLevel level (getM stateA)) (getM stateA)\<close>
        \<open>isUnitClause bc bl (elements (prefixToLevel level (getM stateA)))\<close>
        \<open>formulaEntailsClause (getF stateA) bc\<close>
        \<open>getF stateB = getF stateA\<close>
        \<open>getM stateB = prefixToLevel level (getM stateA) @ [(bl, False)]\<close>
        InvariantImpliedLiteralsAfterBackjump[of "getF stateA" "getM stateA" "prefixToLevel level (getM stateA)" "bc" "bl" "getM stateB"]
      by simp
    moreover

    from \<open>InvariantVarsF (getF stateA) F0 decisionVars\<close>
      \<open>InvariantVarsM (getM stateA) F0 decisionVars\<close>
      \<open>var bl \<in> vars (getF stateA) \<union> vars (elements (getM stateA))\<close>
    have "var bl \<in> vars F0 \<union> decisionVars"
      unfolding InvariantVarsM_def
      unfolding InvariantVarsF_def
      by auto

    have "InvariantVarsM (getM stateB) F0 decisionVars"
      using \<open>InvariantVarsM (getM stateA) F0 decisionVars\<close>
        \<open>isPrefix (prefixToLevel level (getM stateA)) (getM stateA)\<close>
        \<open>getM stateB = prefixToLevel level (getM stateA) @ [(bl, False)]\<close>
        \<open>var bl \<in> vars F0 \<union> decisionVars\<close>
        InvariantVarsMAfterBackjump[of "getM stateA" "F0" "decisionVars" "prefixToLevel level (getM stateA)" "bl" "getM stateB"]
      by simp
    moreover
    have "InvariantVarsF (getF stateB) F0 decisionVars"
      using \<open>getF stateB = getF stateA\<close>
      \<open>InvariantVarsF (getF stateA) F0 decisionVars\<close>
      by simp
    moreover
    have "InvariantConsistent (getM stateB)"
      using \<open>InvariantConsistent (getM stateA)\<close>
        \<open>isPrefix (prefixToLevel level (getM stateA)) (getM stateA)\<close>
        \<open>isUnitClause bc bl (elements (prefixToLevel level (getM stateA)))\<close>
        \<open>getM stateB = prefixToLevel level (getM stateA) @ [(bl, False)]\<close>
        InvariantConsistentAfterBackjump[of "getM stateA" "prefixToLevel level (getM stateA)" "bc" "bl" "getM stateB"]
      by simp
    moreover
    have "InvariantUniq (getM stateB)"
      using \<open>InvariantUniq (getM stateA)\<close>
        \<open>isPrefix (prefixToLevel level (getM stateA)) (getM stateA)\<close>
        \<open>isUnitClause bc bl (elements (prefixToLevel level (getM stateA)))\<close>
        \<open>getM stateB = prefixToLevel level (getM stateA) @ [(bl, False)]\<close>
        InvariantUniqAfterBackjump[of "getM stateA" "prefixToLevel level (getM stateA)" "bc" "bl" "getM stateB"]
      by simp
    moreover
    have "InvariantEquivalent F0 (getF stateB)"
      using
      \<open>InvariantEquivalent F0 (getF stateA)\<close>
      \<open>getF stateB = getF stateA\<close>
      by simp
    ultimately
    have ?thesis
      unfolding invariantsHoldInState_def
      by auto
  }
  ultimately
  show ?thesis
    using \<open>transition stateA stateB decisionVars\<close>
    unfolding transition_def
    by auto
qed

text\<open>The consequence is that invariants hold in all valid runs.\<close>
lemma invariantsHoldInValidRuns:
  fixes F0 :: Formula and decisionVars :: "Variable set"
  assumes "invariantsHoldInState stateA F0 decisionVars" and
  "(stateA, stateB) \<in> transitionRelation decisionVars"
  shows "invariantsHoldInState stateB F0 decisionVars"
using assms
using transitionsPreserveInvariants
using rtrancl_induct[of "stateA" "stateB"
  "{(stateA, stateB). transition stateA stateB decisionVars}" "\<lambda> x. invariantsHoldInState x F0 decisionVars"]
unfolding transitionRelation_def
by auto

lemma invariantsHoldInValidRunsFromInitialState:
  fixes F0 :: Formula and decisionVars :: "Variable set"
  assumes "isInitialState state0 F0"
  and "(state0, state) \<in> transitionRelation decisionVars"
  shows "invariantsHoldInState state F0 decisionVars"
proof-
  from \<open>isInitialState state0 F0\<close>
  have "invariantsHoldInState state0 F0 decisionVars"
    by (simp add:invariantsHoldInInitialState)
  with assms
  show ?thesis
    using invariantsHoldInValidRuns [of "state0"  "F0" "decisionVars" "state"]
    by simp
qed

text\<open>
 In the following text we will show that there are two kinds of states:
 \begin{enumerate}
  \item \textit{UNSAT} states where @{term "formulaFalse F0 (elements (getM state))"}
  and @{term "decisions (getM state) = []"}.
  \item \textit{SAT} states where @{term "\<not> formulaFalse F0 (elements (getM state))"}
  and @{term "vars (elements (getM state)) \<supseteq> decisionVars"}
 \end{enumerate}

 The soundness theorems claim that if \textit{UNSAT} state is reached
 the formula is unsatisfiable and if \textit{SAT} state is reached,
 the formula is satisfiable.

 Completeness theorems claim that every final state is either
 \textit{UNSAT} or \textit{SAT}. A consequence of this and soundness
 theorems, is that if formula is unsatisfiable the solver will finish
 in an \textit{UNSAT} state, and if the formula is satisfiable the
 solver will finish in a \textit{SAT} state.\<close>

(******************************************************************************)
subsection\<open>Soundness\<close>
(******************************************************************************)
(*----------------------------------------------------------------------------*)
theorem soundnessForUNSAT:
  fixes F0 :: Formula and decisionVars :: "Variable set" and state0 :: State and state :: State
  assumes
  "isInitialState state0 F0" and
  "(state0, state) \<in> transitionRelation decisionVars"

  "formulaFalse (getF state) (elements (getM state))"
  "decisions (getM state) = []"

  shows "\<not> satisfiable F0"
(*----------------------------------------------------------------------------*)
proof-
  from \<open>isInitialState state0 F0\<close> \<open>(state0, state) \<in> transitionRelation decisionVars\<close>
  have "invariantsHoldInState state F0 decisionVars"
    using invariantsHoldInValidRunsFromInitialState
    by simp
  hence "InvariantImpliedLiterals (getF state) (getM state)" "InvariantEquivalent F0 (getF state)"
    unfolding invariantsHoldInState_def
    by auto
  with \<open>formulaFalse (getF state) (elements (getM state))\<close>
    \<open>decisions (getM state) = []\<close>
  show ?thesis
    using unsatReport[of "getF state" "getM state" "F0"]
    by simp
qed

(*----------------------------------------------------------------------------*)
theorem soundnessForSAT:
  fixes F0 :: Formula and decisionVars :: "Variable set" and state0 :: State and state :: State
  assumes
  "vars F0 \<subseteq> decisionVars" and

  "isInitialState state0 F0" and
  "(state0, state) \<in> transitionRelation decisionVars"

  "\<not> formulaFalse (getF state) (elements (getM state))"
  "vars (elements (getM state)) \<supseteq> decisionVars"
  shows
  "model (elements (getM state)) F0"
(*----------------------------------------------------------------------------*)
proof-
  from \<open>isInitialState state0 F0\<close> \<open>(state0, state) \<in> transitionRelation decisionVars\<close>
  have "invariantsHoldInState state F0 decisionVars"
    using invariantsHoldInValidRunsFromInitialState
    by simp
  hence
    "InvariantConsistent (getM state)"
    "InvariantEquivalent F0 (getF state)"
    "InvariantVarsF (getF state) F0 decisionVars"
    unfolding invariantsHoldInState_def
    by auto
  with assms
  show ?thesis
  using satReport[of "F0" "decisionVars" "getF state" "getM state"]
  by simp
qed

(******************************************************************************)
subsection\<open>Termination\<close>
(******************************************************************************)
text\<open>This system is terminating, but only under assumption that
there is no infinite derivation consisting only of applications of
rule $Learn$. We will formalize this condition by requiring that there
there exists an ordering @{term learnL} on the formulae that is
well-founded such that the state is decreased with each application
of the $Learn$ rule. If such ordering exists, the termination
ordering is built as a lexicographic combination of @{term lexLessRestricted}
trail ordering and the @{term learnL} ordering.
\<close>

definition "lexLessState F0 decisionVars == {((stateA::State), (stateB::State)).
                       (getM stateA, getM stateB) \<in> lexLessRestricted (vars F0 \<union> decisionVars)}"
definition "learnLessState learnL == {((stateA::State), (stateB::State)).
                        getM stateA = getM stateB \<and> (getF stateA, getF stateB) \<in> learnL}"
definition "terminationLess F0 decisionVars learnL ==
  {((stateA::State), (stateB::State)).
      (stateA,stateB) \<in> lexLessState F0 decisionVars \<or>
      (stateA,stateB) \<in> learnLessState learnL}"

text\<open>We want to show that every valid transition decreases a state
  with respect to the constructed termination ordering. Therefore, we
  show that $Decide$, $UnitPropagate$ and $Backjump$ rule decrease the
  trail with respect to the restricted trail ordering @{term
  lexLessRestricted}.  Invariants ensure that trails are indeed uniq,
  consistent and with finite variable sets. By assumption, $Learn$
  rule will decrease the formula component of the state with respect
  to the @{term learnL} ordering.\<close>

lemma trailIsDecreasedByDeciedUnitPropagateAndBackjump:
  fixes stateA::State and stateB::State
  assumes "invariantsHoldInState stateA F0 decisionVars" and
  "appliedDecide stateA stateB decisionVars \<or> appliedUnitPropagate stateA stateB \<or> appliedBackjump stateA stateB"
  shows "(getM stateB, getM stateA) \<in> lexLessRestricted (vars F0 \<union> decisionVars)"
proof-
  from \<open>appliedDecide stateA stateB decisionVars \<or> appliedUnitPropagate stateA stateB \<or> appliedBackjump stateA stateB\<close>
    \<open>invariantsHoldInState stateA F0 decisionVars\<close>
  have "invariantsHoldInState stateB F0 decisionVars"
      using transitionsPreserveInvariants
      unfolding transition_def
      by auto
    from \<open>invariantsHoldInState stateA F0 decisionVars\<close>
    have *: "uniq (elements (getM stateA))" "consistent (elements (getM stateA))" "vars (elements (getM stateA)) \<subseteq> vars F0 \<union> decisionVars"
      unfolding invariantsHoldInState_def
      unfolding InvariantVarsM_def
      unfolding InvariantConsistent_def
      unfolding InvariantUniq_def
      by auto
    from \<open>invariantsHoldInState stateB F0 decisionVars\<close>
    have **: "uniq (elements (getM stateB))" "consistent (elements (getM stateB))" "vars (elements (getM stateB)) \<subseteq> vars F0 \<union> decisionVars"
      unfolding invariantsHoldInState_def
      unfolding InvariantVarsM_def
      unfolding InvariantConsistent_def
      unfolding InvariantUniq_def
      by auto
  {
    assume "appliedDecide stateA stateB decisionVars"
    hence "(getM stateB, getM stateA) \<in> lexLess"
      unfolding appliedDecide_def
      by (auto simp add:lexLessAppend)
    with * **
    have "((getM stateB), (getM stateA)) \<in> lexLessRestricted (vars F0 \<union> decisionVars)"
      unfolding lexLessRestricted_def
      by auto
  }
  moreover
  {
    assume "appliedUnitPropagate stateA stateB"
    hence "(getM stateB, getM stateA) \<in> lexLess"
      unfolding appliedUnitPropagate_def
      by (auto simp add:lexLessAppend)
    with * **
    have "(getM stateB, getM stateA) \<in> lexLessRestricted (vars F0 \<union> decisionVars)"
      unfolding lexLessRestricted_def
      by auto
  }
  moreover
  {
    assume "appliedBackjump stateA stateB"
    then obtain bc::Clause and bl::Literal and level::nat
      where
      "isUnitClause bc bl (elements (prefixToLevel level (getM stateA)))"
      "formulaEntailsClause (getF stateA) bc"
      "var bl \<in> vars (getF stateA) \<union> vars (elements (getM stateA))"
      "0 \<le> level" "level < currentLevel (getM stateA)"
      "getF stateB = getF stateA"
      "getM stateB = prefixToLevel level (getM stateA) @ [(bl, False)]"
      unfolding appliedBackjump_def
      by auto

    with \<open>getM stateB = prefixToLevel level (getM stateA) @ [(bl, False)]\<close>
    have "(getM stateB, getM stateA) \<in> lexLess"
      by (simp add:lexLessBackjump)
    with * **
    have "(getM stateB, getM stateA) \<in> lexLessRestricted (vars F0 \<union> decisionVars)"
      unfolding lexLessRestricted_def
      by auto
  }
  ultimately
  show ?thesis
    using assms
    by auto
qed

text\<open>Now we can show that, under the assumption for $Learn$ rule,
  every rule application decreases a state with respect to the
  constructed termination ordering.\<close>
theorem stateIsDecreasedByValidTransitions:
  fixes stateA::State and stateB::State
  assumes "invariantsHoldInState stateA F0 decisionVars" and "transition stateA stateB decisionVars"
  "appliedLearn stateA stateB  \<longrightarrow> (getF stateB, getF stateA) \<in> learnL"
  shows "(stateB, stateA) \<in> terminationLess F0 decisionVars learnL"
proof-
  {
    assume "appliedDecide stateA stateB decisionVars \<or> appliedUnitPropagate stateA stateB \<or> appliedBackjump stateA stateB"
    with \<open>invariantsHoldInState stateA F0 decisionVars\<close>
    have "(getM stateB, getM stateA) \<in> lexLessRestricted (vars F0 \<union> decisionVars)"
      using trailIsDecreasedByDeciedUnitPropagateAndBackjump
      by simp
    hence "(stateB, stateA) \<in> lexLessState F0 decisionVars"
      unfolding lexLessState_def
      by simp
    hence "(stateB, stateA) \<in> terminationLess F0 decisionVars learnL"
      unfolding terminationLess_def
      by simp
  }
  moreover
  {
    assume "appliedLearn stateA stateB"
    with \<open>appliedLearn stateA stateB \<longrightarrow> (getF stateB, getF stateA) \<in> learnL\<close>
    have "(getF stateB, getF stateA) \<in> learnL"
      by simp
    moreover
    from \<open>appliedLearn stateA stateB\<close>
    have "(getM stateB) = (getM stateA)"
      unfolding appliedLearn_def
      by auto
   ultimately
   have "(stateB, stateA) \<in> learnLessState learnL"
      unfolding learnLessState_def
      by simp
    hence "(stateB, stateA) \<in> terminationLess F0 decisionVars learnL"
      unfolding terminationLess_def
      by simp
  }
  ultimately
  show ?thesis
    using \<open>transition stateA stateB decisionVars\<close>
    unfolding transition_def
    by auto
qed

text\<open>The minimal states with respect to the termination ordering are
  final i.e., no further transition rules are applicable.\<close>
definition
"isMinimalState stateMin F0 decisionVars learnL == (\<forall> state::State. (state, stateMin) \<notin> terminationLess F0 decisionVars learnL)"

lemma minimalStatesAreFinal:
  fixes stateA::State
  assumes *: "\<forall> (stateA::State) (stateB::State). appliedLearn stateA stateB  \<longrightarrow> (getF stateB, getF stateA) \<in> learnL" and
  "invariantsHoldInState state F0 decisionVars" and "isMinimalState state F0 decisionVars learnL"
  shows "isFinalState state decisionVars"
proof-
  {
    assume "\<not> ?thesis"
    then obtain state'::State
      where "transition state state' decisionVars"
      unfolding isFinalState_def
      by auto
    with \<open>invariantsHoldInState state F0 decisionVars\<close> *
    have "(state', state) \<in> terminationLess F0 decisionVars learnL"
      using stateIsDecreasedByValidTransitions[of "state" "F0" "decisionVars" "state'" "learnL"]
      unfolding transition_def
      by auto
    with \<open>isMinimalState state F0 decisionVars learnL\<close>
    have False
      unfolding isMinimalState_def
      by auto
  }
  thus ?thesis
    by auto
qed

text\<open>We now prove that termination ordering is well founded. We
start with two auxiliary lemmas.\<close>
lemma wfLexLessState:
  fixes decisionVars :: "Variable set" and F0 :: "Formula"
  assumes "finite decisionVars"
  shows "wf (lexLessState F0 decisionVars)"
unfolding wf_eq_minimal
proof-
  show "\<forall>Q state. state \<in> Q \<longrightarrow> (\<exists>stateMin\<in>Q. \<forall>state'. (state', stateMin) \<in> lexLessState F0 decisionVars \<longrightarrow> state' \<notin> Q)"
  proof-
    {
      fix Q :: "State set" and state :: State
      assume "state \<in> Q"
      let ?Q1 = "{M::LiteralTrail. \<exists> state. state \<in> Q \<and> (getM state) = M}"
      from \<open>state \<in> Q\<close>
      have "getM state \<in> ?Q1"
        by auto
      from \<open>finite decisionVars\<close>
      have "finite (vars F0 \<union> decisionVars)"
        using finiteVarsFormula[of "F0"]
        by simp
      hence "wf (lexLessRestricted (vars F0 \<union> decisionVars))"
      using  wfLexLessRestricted[of "vars F0 \<union> decisionVars"]
      by simp
    with \<open>getM state \<in> ?Q1\<close>
      obtain Mmin where "Mmin \<in> ?Q1" "\<forall>M'. (M', Mmin) \<in> lexLessRestricted (vars F0 \<union> decisionVars) \<longrightarrow> M' \<notin> ?Q1"
        unfolding wf_eq_minimal
        apply (erule_tac x="?Q1" in allE)
        apply (erule_tac x="getM state" in allE)
        by auto
      from \<open>Mmin \<in> ?Q1\<close> obtain stateMin
        where "stateMin \<in> Q" "(getM stateMin) = Mmin"
        by auto
      have "\<forall>state'. (state', stateMin) \<in> lexLessState F0 decisionVars \<longrightarrow> state' \<notin> Q"
      proof
        fix state'
        show "(state', stateMin) \<in> lexLessState F0 decisionVars \<longrightarrow> state' \<notin> Q"
        proof
          assume "(state', stateMin) \<in> lexLessState F0 decisionVars"
          hence "(getM state', getM stateMin) \<in> lexLessRestricted (vars F0 \<union> decisionVars)"
            unfolding lexLessState_def
            by auto
          from \<open>\<forall>M'. (M', Mmin) \<in> lexLessRestricted (vars F0 \<union> decisionVars) \<longrightarrow> M' \<notin> ?Q1\<close>
            \<open>(getM state', getM stateMin) \<in> lexLessRestricted (vars F0 \<union> decisionVars)\<close> \<open>getM stateMin = Mmin\<close>
          have "getM state' \<notin> ?Q1"
            by simp
          with \<open>getM stateMin = Mmin\<close>
          show "state' \<notin> Q"
            by auto
        qed
      qed
      with \<open>stateMin \<in> Q\<close>
      have "\<exists> stateMin \<in> Q. (\<forall>state'. (state', stateMin) \<in> lexLessState F0 decisionVars \<longrightarrow> state' \<notin> Q)"
        by auto
    }
    thus ?thesis
      by auto
  qed
qed

lemma wfLearnLessState:
  assumes "wf learnL"
  shows "wf (learnLessState learnL)"
unfolding wf_eq_minimal
proof-
  show "\<forall>Q state. state \<in> Q \<longrightarrow> (\<exists>stateMin\<in>Q. \<forall>state'. (state', stateMin) \<in> learnLessState learnL \<longrightarrow> state' \<notin> Q)"
  proof-
    {
      fix Q :: "State set" and state :: State
      assume "state \<in> Q"
      let ?M = "(getM state)"
      let ?Q1 = "{f::Formula. \<exists> state. state \<in> Q \<and> (getM state) = ?M \<and> (getF state) = f}"
      from \<open>state \<in> Q\<close>
      have "getF state \<in> ?Q1"
        by auto
      with \<open>wf learnL\<close>
      obtain FMin where "FMin \<in> ?Q1" "\<forall>F'. (F', FMin) \<in> learnL \<longrightarrow> F' \<notin> ?Q1"
        unfolding wf_eq_minimal
        apply (erule_tac x="?Q1" in allE)
        apply (erule_tac x="getF state" in allE)
        by auto
      from \<open>FMin \<in> ?Q1\<close> obtain stateMin
        where "stateMin \<in> Q" "(getM stateMin) = ?M" "getF stateMin = FMin"
        by auto
      have "\<forall>state'. (state', stateMin) \<in> learnLessState learnL \<longrightarrow> state' \<notin> Q"
      proof
        fix state'
        show "(state', stateMin) \<in> learnLessState learnL \<longrightarrow> state' \<notin> Q"
        proof
          assume "(state', stateMin) \<in> learnLessState learnL"
          with \<open>getM stateMin = ?M\<close>
          have "getM state' = getM stateMin" "(getF state', getF stateMin) \<in> learnL"
            unfolding learnLessState_def
            by auto
          from \<open>\<forall>F'. (F', FMin) \<in> learnL \<longrightarrow> F' \<notin> ?Q1\<close>
            \<open>(getF state', getF stateMin) \<in> learnL\<close> \<open>getF stateMin = FMin\<close>
          have "getF state' \<notin> ?Q1"
            by simp
          with \<open>getM state' = getM stateMin\<close> \<open>getM stateMin = ?M\<close>
          show "state' \<notin> Q"
            by auto
        qed
      qed
      with \<open>stateMin \<in> Q\<close>
      have "\<exists> stateMin \<in> Q. (\<forall>state'. (state', stateMin) \<in> learnLessState learnL \<longrightarrow> state' \<notin> Q)"
        by auto
    }
    thus ?thesis
      by auto
  qed
qed

text\<open>Now we can prove the following key lemma which shows that the
termination ordering is well founded.\<close>
lemma wfTerminationLess:
  fixes F0 :: Formula and decisionVars :: "Variable set"
  assumes "finite decisionVars" "wf learnL"
  shows "wf (terminationLess F0 decisionVars learnL)"
  unfolding wf_eq_minimal
proof-
  show "\<forall>Q state. state \<in> Q \<longrightarrow> (\<exists> stateMin \<in> Q. \<forall>state'. (state', stateMin) \<in> terminationLess F0 decisionVars learnL \<longrightarrow> state' \<notin> Q)"
  proof-
    {
      fix Q::"State set"
      fix state::State
      assume "state \<in> Q"
      have "wf (lexLessState F0 decisionVars)"
        using wfLexLessState[of "decisionVars" "F0"]
        using \<open>finite decisionVars\<close>
        by simp
      with \<open>state \<in> Q\<close> obtain state0
        where "state0 \<in> Q" "\<forall>state'. (state', state0) \<in> lexLessState F0 decisionVars \<longrightarrow> state' \<notin> Q"
        unfolding wf_eq_minimal
        by auto
      let ?Q0 = "{state. state \<in> Q \<and> (getM state) = (getM state0)}"
      from \<open>state0 \<in> Q\<close>
      have "state0 \<in> ?Q0"
        by simp
      from \<open>wf learnL\<close>
      have "wf (learnLessState learnL)"
        using wfLearnLessState
        by simp
      with \<open>state0 \<in> ?Q0\<close> obtain state1
        where "state1 \<in> ?Q0" "\<forall>state'. (state', state1) \<in> learnLessState learnL \<longrightarrow> state' \<notin> ?Q0"
        unfolding wf_eq_minimal
        apply (erule_tac x="?Q0" in allE)
        apply (erule_tac x="state0" in allE)
        by auto
      from \<open>state1 \<in> ?Q0\<close>
      have "state1 \<in> Q" "getM state1 = getM state0"
        by auto
      let ?stateMin = state1
      have "\<forall>state'. (state', ?stateMin) \<in> terminationLess F0 decisionVars learnL \<longrightarrow> state' \<notin> Q"
      proof
        fix state'
        show "(state', ?stateMin) \<in> terminationLess F0 decisionVars learnL \<longrightarrow> state' \<notin> Q"
        proof
          assume "(state', ?stateMin) \<in> terminationLess F0 decisionVars learnL"
          hence
            "(state', ?stateMin) \<in> lexLessState F0 decisionVars \<or>
            (state', ?stateMin) \<in> learnLessState learnL"
            unfolding terminationLess_def
            by auto
          moreover
          {
            assume "(state', ?stateMin) \<in> lexLessState F0 decisionVars"
            with \<open>getM state1 = getM state0\<close>
            have "(state', state0) \<in> lexLessState F0 decisionVars"
              unfolding lexLessState_def
              by simp
            with \<open>\<forall>state'. (state', state0) \<in> lexLessState F0 decisionVars \<longrightarrow> state' \<notin> Q\<close>
            have "state' \<notin> Q"
              by simp
          }
          moreover
          {
            assume "(state', ?stateMin) \<in> learnLessState learnL"
            with \<open>\<forall>state'. (state', state1) \<in> learnLessState learnL \<longrightarrow> state' \<notin> ?Q0\<close>
            have "state' \<notin> ?Q0"
              by simp
            from \<open>(state', state1) \<in> learnLessState learnL\<close> \<open>getM state1 = getM state0\<close>
            have "getM state' = getM state0"
              unfolding learnLessState_def
              by auto
            with \<open>state' \<notin> ?Q0\<close>
            have "state' \<notin> Q"
              by simp
          }
          ultimately
          show "state' \<notin> Q"
            by auto
        qed
      qed
      with \<open>?stateMin \<in> Q\<close> have "(\<exists> stateMin \<in> Q. \<forall>state'. (state', stateMin) \<in> terminationLess F0 decisionVars learnL \<longrightarrow> state' \<notin> Q)"
        by auto
    }
    thus ?thesis
      by simp
  qed
qed

text\<open>Using the termination ordering we show that the transition
 relation is well founded on states reachable from initial state.  The
 assumption for the $Learn$ rule is neccessary.\<close>
(*----------------------------------------------------------------------------*)
theorem wfTransitionRelation:
  fixes decisionVars :: "Variable set" and F0 :: "Formula"
  assumes "finite decisionVars" and "isInitialState state0 F0" and
  *: "\<exists> learnL::(Formula \<times> Formula) set.
        wf learnL \<and>
        (\<forall> stateA stateB. appliedLearn stateA stateB  \<longrightarrow> (getF stateB, getF stateA) \<in> learnL)"
  shows "wf {(stateB, stateA).
             (state0, stateA) \<in> transitionRelation decisionVars \<and> (transition stateA stateB decisionVars)}"
(*----------------------------------------------------------------------------*)
proof-
  from * obtain learnL::"(Formula \<times> Formula) set"
    where
    "wf learnL" and
    **: "\<forall> stateA stateB. appliedLearn stateA stateB  \<longrightarrow> (getF stateB, getF stateA) \<in> learnL"
    by auto
  let ?rel = "{(stateB, stateA).
                  (state0, stateA) \<in> transitionRelation decisionVars \<and> (transition stateA stateB decisionVars)}"
  let ?rel'= "terminationLess F0 decisionVars learnL"

  have "\<forall>x y. (x, y) \<in> ?rel \<longrightarrow> (x, y) \<in> ?rel'"
  proof-
    {
      fix stateA::State and stateB::State
      assume "(stateB, stateA) \<in> ?rel"
      hence "(stateB, stateA) \<in> ?rel'"
        using \<open>isInitialState state0 F0\<close>
        using invariantsHoldInValidRunsFromInitialState[of "state0" "F0" "stateA" "decisionVars"]
        using stateIsDecreasedByValidTransitions[of "stateA" "F0" "decisionVars" "stateB"] **
        by simp
    }
    thus ?thesis
      by simp
  qed
  moreover
  have "wf ?rel'"
    using \<open>finite decisionVars\<close> \<open>wf learnL\<close>
    by (rule wfTerminationLess)
  ultimately
  show ?thesis
    using wellFoundedEmbed[of "?rel" "?rel'"]
    by simp
qed

text\<open>We will now give two corollaries of the previous theorem. First
  is a weak termination result that shows that there is a terminating
  run from every intial state to the final one.\<close>
corollary
  fixes decisionVars :: "Variable set" and F0 :: "Formula" and state0 :: "State"
  assumes "finite decisionVars" and "isInitialState state0 F0" and
  *: "\<exists> learnL::(Formula \<times> Formula) set.
        wf learnL \<and>
        (\<forall> stateA stateB. appliedLearn stateA stateB  \<longrightarrow> (getF stateB, getF stateA) \<in> learnL)"
  shows "\<exists> state. (state0, state) \<in> transitionRelation decisionVars \<and> isFinalState state decisionVars"
proof-
  {
    assume "\<not> ?thesis"
    let ?Q = "{state. (state0, state) \<in> transitionRelation decisionVars}"
    let ?rel = "{(stateB, stateA). (state0, stateA) \<in> transitionRelation decisionVars \<and>
                         transition stateA stateB decisionVars}"
    have "state0 \<in> ?Q"
      unfolding transitionRelation_def
      by simp
    hence "\<exists> state. state \<in> ?Q"
      by auto

    from assms
    have "wf ?rel"
      using wfTransitionRelation[of "decisionVars" "state0" "F0"]
      by auto
    hence "\<forall> Q. (\<exists> x. x \<in> Q) \<longrightarrow> (\<exists> stateMin \<in> Q. \<forall> state. (state, stateMin) \<in> ?rel \<longrightarrow> state \<notin> Q)"
      unfolding wf_eq_minimal
      by simp
    hence " (\<exists> x. x \<in> ?Q) \<longrightarrow> (\<exists> stateMin \<in> ?Q. \<forall> state. (state, stateMin) \<in> ?rel \<longrightarrow> state \<notin> ?Q)"
      by rule
    with \<open>\<exists> state. state \<in> ?Q\<close>
    have "\<exists> stateMin \<in> ?Q. \<forall> state. (state, stateMin) \<in> ?rel \<longrightarrow> state \<notin> ?Q"
      by simp
    then obtain stateMin
      where "stateMin \<in> ?Q" and "\<forall> state. (state, stateMin) \<in> ?rel \<longrightarrow> state \<notin> ?Q"
      by auto

    from \<open>stateMin \<in> ?Q\<close>
    have "(state0, stateMin) \<in> transitionRelation decisionVars"
      by simp
    with \<open>\<not> ?thesis\<close>
    have "\<not> isFinalState stateMin decisionVars"
      by simp
    then obtain state'::State
      where "transition stateMin state' decisionVars"
      unfolding isFinalState_def
      by auto
    have "(state', stateMin) \<in> ?rel"
      using \<open>(state0, stateMin) \<in> transitionRelation decisionVars\<close>
            \<open>transition stateMin state' decisionVars\<close>
      by simp
    with \<open>\<forall> state. (state, stateMin) \<in> ?rel \<longrightarrow> state \<notin> ?Q\<close>
    have "state' \<notin> ?Q"
      by force
    moreover
    from \<open>(state0, stateMin) \<in> transitionRelation decisionVars\<close> \<open>transition stateMin state' decisionVars\<close>
    have "state' \<in> ?Q"
      unfolding transitionRelation_def
      using rtrancl_into_rtrancl[of "state0" "stateMin" "{(stateA, stateB). transition stateA stateB decisionVars}" "state'"]
      by simp
    ultimately
    have False
      by simp
  }
  thus ?thesis
    by auto
qed

text\<open>Now we prove the final strong termination result which states
that there cannot be infinite chains of transitions. If there is an
infinite transition chain that starts from an initial state, its
elements would for a set that would contain initial state and for
every element of that set there would be another element of that set
that is directly reachable from it. We show that no such set exists.\<close>
corollary noInfiniteTransitionChains:
  fixes F0::Formula and decisionVars::"Variable set"
  assumes "finite decisionVars" and
  *: "\<exists> learnL::(Formula \<times> Formula) set.
        wf learnL \<and>
        (\<forall> stateA stateB. appliedLearn stateA stateB  \<longrightarrow> (getF stateB, getF stateA) \<in> learnL)"
  shows "\<not> (\<exists> Q::(State set). \<exists> state0 \<in> Q. isInitialState state0 F0 \<and>
                              (\<forall> state \<in> Q. (\<exists> state' \<in> Q. transition state state' decisionVars))
            )"
proof-
  {
  assume "\<not> ?thesis"
  then obtain Q::"State set" and state0::"State"
    where "isInitialState state0 F0" "state0 \<in> Q"
          "\<forall> state \<in> Q. (\<exists> state' \<in> Q. transition state state' decisionVars)"
    by auto
  let ?rel = "{(stateB, stateA). (state0, stateA) \<in> transitionRelation decisionVars \<and>
                         transition stateA stateB decisionVars}"
  from \<open>finite decisionVars\<close> \<open>isInitialState state0 F0\<close> *
  have "wf ?rel"
    using wfTransitionRelation
    by simp
  hence wfmin: "\<forall>Q x. x \<in> Q \<longrightarrow>
         (\<exists>z\<in>Q. \<forall>y. (y, z) \<in> ?rel \<longrightarrow> y \<notin> Q)"
    unfolding wf_eq_minimal
    by simp
  let ?Q = "{state \<in> Q. (state0, state) \<in> transitionRelation decisionVars}"
  from \<open>state0 \<in> Q\<close>
  have "state0 \<in> ?Q"
    unfolding transitionRelation_def
    by simp
  with wfmin
  obtain stateMin::State
    where "stateMin \<in> ?Q" and "\<forall>y. (y, stateMin) \<in> ?rel \<longrightarrow> y \<notin> ?Q"
    apply (erule_tac x="?Q" in allE)
    by auto

  from \<open>stateMin \<in> ?Q\<close>
  have "stateMin \<in> Q" "(state0, stateMin) \<in> transitionRelation decisionVars"
    by auto
  with \<open>\<forall> state \<in> Q. (\<exists> state' \<in> Q. transition state state' decisionVars)\<close>
  obtain state'::State
    where "state' \<in> Q" "transition stateMin state' decisionVars"
    by auto

  with \<open>(state0, stateMin) \<in> transitionRelation decisionVars\<close>
  have "(state', stateMin) \<in> ?rel"
    by simp
  with \<open>\<forall>y. (y, stateMin) \<in> ?rel \<longrightarrow> y \<notin> ?Q\<close>
  have "state' \<notin> ?Q"
    by force

  from \<open>state' \<in> Q\<close> \<open>(state0, stateMin) \<in> transitionRelation decisionVars\<close>
    \<open>transition stateMin state' decisionVars\<close>
  have "state' \<in> ?Q"
    unfolding transitionRelation_def
    using rtrancl_into_rtrancl[of "state0" "stateMin" "{(stateA, stateB). transition stateA stateB decisionVars}" "state'"]
    by simp
  with \<open>state' \<notin> ?Q\<close>
  have False
    by simp
  }
  thus ?thesis
    by force
qed

(******************************************************************************)
subsection\<open>Completeness\<close>
(******************************************************************************)

text\<open>In this section we will first show that each final state is
either \textit{SAT} or \textit{UNSAT} state.\<close>

lemma finalNonConflictState:
  fixes state::State and FO :: Formula
  assumes
  "\<not> applicableDecide state decisionVars"
  shows "vars (elements (getM state)) \<supseteq> decisionVars"
proof
  fix x :: Variable
  let ?l = "Pos x"
  assume "x \<in> decisionVars"
  hence "var ?l = x" and "var ?l \<in> decisionVars" and "var (opposite ?l) \<in> decisionVars"
    by auto
  with \<open>\<not> applicableDecide state decisionVars\<close>
  have "literalTrue ?l (elements (getM state)) \<or> literalFalse ?l (elements (getM state))"
    unfolding applicableDecideCharacterization
    by force
  with \<open>var ?l = x\<close>
  show "x \<in> vars (elements (getM state))"
    using valuationContainsItsLiteralsVariable[of "?l" "elements (getM state)"]
    using valuationContainsItsLiteralsVariable[of "opposite ?l" "elements (getM state)"]
    by auto
qed

lemma finalConflictingState:
  fixes state :: State
  assumes
  "InvariantUniq (getM state)" and
  "InvariantConsistent (getM state)" and
  "InvariantImpliedLiterals (getF state) (getM state)"
  "\<not> applicableBackjump state" and
  "formulaFalse (getF state) (elements (getM state))"
  shows
  "decisions (getM state) = []"
proof-
  from \<open>InvariantUniq (getM state)\<close>
  have "uniq (elements (getM state))"
    unfolding InvariantUniq_def
    .
  from \<open>InvariantConsistent (getM state)\<close>
  have "consistent (elements (getM state))"
    unfolding InvariantConsistent_def
    .

  let ?c = "oppositeLiteralList (decisions (getM state))"
  {
    assume "\<not> ?thesis"
    hence "?c \<noteq> []"
      using oppositeLiteralListNonempty[of "decisions (getM state)"]
      by simp
    moreover
    have "clauseFalse ?c (elements (getM state))"
    proof-
      {
        fix l::Literal
        assume "l el ?c"
        hence "opposite l el decisions (getM state)"
          using literalElListIffOppositeLiteralElOppositeLiteralList [of "l" "?c"]
          by simp
        hence "literalFalse l (elements (getM state))"
          using markedElementsAreElements[of "opposite l" "getM state"]
          by simp
      }
      thus ?thesis
        using clauseFalseIffAllLiteralsAreFalse[of "?c" "elements (getM state)"]
        by simp
    qed
    moreover
    let ?l = "getLastAssertedLiteral (oppositeLiteralList ?c) (elements (getM state))"
    have "isLastAssertedLiteral ?l (oppositeLiteralList ?c) (elements (getM state))"
      using \<open>InvariantUniq (getM state)\<close>
      using getLastAssertedLiteralCharacterization[of "?c" "elements (getM state)"]
        \<open>?c \<noteq> []\<close> \<open>clauseFalse ?c (elements (getM state))\<close>
      unfolding InvariantUniq_def
      by simp
    moreover
    have "\<forall> l. l el ?c \<longrightarrow> (opposite l) el (decisions (getM state))"
    proof-
      {
        fix l::Literal
        assume "l el ?c"
        hence "(opposite l) el (oppositeLiteralList ?c)"
          using literalElListIffOppositeLiteralElOppositeLiteralList[of "l" "?c"]
          by simp
      }
      thus ?thesis
        by simp
    qed
    ultimately
    have "\<exists> level. (isBackjumpLevel level (opposite ?l) ?c (getM state))"
      using \<open>uniq (elements (getM state))\<close>
      using allDecisionsThenExistsBackjumpLevel[of "getM state" "?c" "opposite ?l"]
      by simp
    then obtain level::nat
      where "isBackjumpLevel level (opposite ?l) ?c (getM state)"
      by auto
    with \<open>consistent (elements (getM state))\<close> \<open>uniq (elements (getM state))\<close> \<open>clauseFalse ?c (elements (getM state))\<close>
    have "isUnitClause ?c (opposite ?l) (elements (prefixToLevel level (getM state)))"
      using isBackjumpLevelEnsuresIsUnitInPrefix[of "getM state" "?c" "level" "opposite ?l"]
      by simp
    moreover
    have "formulaEntailsClause (getF state) ?c"
    proof-
      from \<open>clauseFalse ?c (elements (getM state))\<close> \<open>consistent (elements (getM state))\<close>
      have "\<not> clauseTautology ?c"
        using tautologyNotFalse[of "?c" "elements (getM state)"]
        by auto

      from \<open>formulaFalse (getF state) (elements (getM state))\<close> \<open>InvariantImpliedLiterals (getF state) (getM state)\<close>
      have "\<not> satisfiable ((getF state) @ val2form (decisions (getM state)))"
        using InvariantImpliedLiteralsAndFormulaFalseThenFormulaAndDecisionsAreNotSatisfiable
        by simp
      hence "\<not> satisfiable ((getF state) @ val2form (oppositeLiteralList ?c))"
        by simp
      with \<open>\<not> clauseTautology ?c\<close>
      show ?thesis
        using unsatisfiableFormulaWithSingleLiteralClauses
        by simp
    qed
    moreover
    have "var ?l \<in> vars (getF state) \<union> vars (elements (getM state))"
    proof-
      from \<open>isLastAssertedLiteral ?l (oppositeLiteralList ?c) (elements (getM state))\<close>
      have "?l el (oppositeLiteralList ?c)"
        unfolding isLastAssertedLiteral_def
        by simp
      hence "literalTrue ?l (elements (getM state))"
        by (simp add: markedElementsAreElements)
      hence "var ?l \<in> vars (elements (getM state))"
        using valuationContainsItsLiteralsVariable[of "?l" "elements (getM state)"]
        by simp
      thus ?thesis
        by simp
    qed
    moreover
    have "0 \<le> level" "level < (currentLevel (getM state))"
    proof-
      from \<open>isBackjumpLevel level (opposite ?l) ?c (getM state)\<close>
      have "0 \<le> level" "level < (elementLevel ?l (getM state))"
        unfolding isBackjumpLevel_def
        by auto
      thus "0 \<le> level" "level < (currentLevel (getM state))"
        using elementLevelLeqCurrentLevel[of "?l" "getM state"]
        by auto
    qed
    ultimately
    have "applicableBackjump state"
      unfolding applicableBackjumpCharacterization
      by force
    with \<open>\<not> applicableBackjump state\<close>
    have "False"
      by simp
  }
  thus ?thesis
    by auto
qed

lemma finalStateCharacterizationLemma:
  fixes state :: State
  assumes
  "InvariantUniq (getM state)" and
  "InvariantConsistent (getM state)" and
  "InvariantImpliedLiterals (getF state) (getM state)"
  "\<not> applicableDecide state decisionVars"  and
  "\<not> applicableBackjump state"
  shows
  "(\<not> formulaFalse (getF state) (elements (getM state)) \<and> vars (elements (getM state)) \<supseteq> decisionVars) \<or>
   (formulaFalse (getF state) (elements (getM state)) \<and> decisions (getM state) = [])"
proof (cases "formulaFalse (getF state) (elements (getM state))")
  case True
  hence "decisions (getM state) = []"
    using assms
    using finalConflictingState
    by auto
  with True
  show ?thesis
    by simp
next
  case False
  hence  "vars (elements (getM state)) \<supseteq> decisionVars"
    using assms
    using finalNonConflictState
    by auto
  with False
  show ?thesis
    by simp
qed

(*----------------------------------------------------------------------------*)
theorem finalStateCharacterization:
  fixes F0 :: Formula and decisionVars :: "Variable set" and state0 :: State and state :: State
  assumes
  "isInitialState state0 F0" and
  "(state0, state) \<in> transitionRelation decisionVars" and
  "isFinalState state decisionVars"
  shows
  "(\<not> formulaFalse (getF state) (elements (getM state)) \<and> vars (elements (getM state)) \<supseteq> decisionVars) \<or>
   (formulaFalse (getF state) (elements (getM state)) \<and> decisions (getM state) = [])"
(*----------------------------------------------------------------------------*)
proof-
  from \<open>isInitialState state0 F0\<close> \<open>(state0, state) \<in> transitionRelation decisionVars\<close>
  have "invariantsHoldInState state F0 decisionVars"
    using invariantsHoldInValidRunsFromInitialState
    by simp
  hence
    *: "InvariantUniq (getM state)"
    "InvariantConsistent (getM state)"
    "InvariantImpliedLiterals (getF state) (getM state)"
    unfolding invariantsHoldInState_def
    by auto

  from \<open>isFinalState state decisionVars\<close>
  have **:
    "\<not> applicableBackjump state"
    "\<not> applicableDecide state decisionVars"
    unfolding finalStateNonApplicable
    by auto

  from * **
  show ?thesis
    using finalStateCharacterizationLemma[of "state" "decisionVars"]
    by simp
qed

text\<open>Completeness theorems are easy consequences of this characterization and
 soundness.\<close>

(*----------------------------------------------------------------------------*)
theorem completenessForSAT:
  fixes F0 :: Formula and decisionVars :: "Variable set" and state0 :: State and state :: State
  assumes
  "satisfiable F0" and

  "isInitialState state0 F0" and
  "(state0, state) \<in> transitionRelation decisionVars" and
  "isFinalState state decisionVars"
  shows "\<not> formulaFalse (getF state) (elements (getM state)) \<and> vars (elements (getM state)) \<supseteq> decisionVars"
(*----------------------------------------------------------------------------*)
proof-
  from assms
  have *: "(\<not> formulaFalse (getF state) (elements (getM state))  \<and> vars (elements (getM state)) \<supseteq> decisionVars) \<or>
    (formulaFalse (getF state) (elements (getM state)) \<and> decisions (getM state) = [])"
    using finalStateCharacterization[of "state0" "F0" "state" "decisionVars"]
    by auto
  {
    assume "formulaFalse (getF state) (elements (getM state))"
    with *
    have "formulaFalse (getF state) (elements (getM state))" "decisions (getM state) = []"
      by auto
    with assms
      have "\<not> satisfiable F0"
      using soundnessForUNSAT
      by simp
    with \<open>satisfiable F0\<close>
    have False
      by simp
  }
  with * show ?thesis
    by auto
qed

(*----------------------------------------------------------------------------*)
theorem completenessForUNSAT:
  fixes F0 :: Formula and decisionVars :: "Variable set" and state0 :: State and state :: State
  assumes
  "vars F0 \<subseteq> decisionVars" and

  "\<not> satisfiable F0" and

  "isInitialState state0 F0" and
  "(state0, state) \<in> transitionRelation decisionVars" and
  "isFinalState state decisionVars"
  shows
  "formulaFalse (getF state) (elements (getM state)) \<and> decisions (getM state) = []"
(*----------------------------------------------------------------------------*)
proof-
  from assms
  have *:
  "(\<not> formulaFalse (getF state) (elements (getM state)) \<and> vars (elements (getM state)) \<supseteq> decisionVars) \<or>
   (formulaFalse (getF state) (elements (getM state))  \<and> decisions (getM state) = [])"
    using finalStateCharacterization[of "state0" "F0" "state" "decisionVars"]
    by auto
  {
    assume "\<not> formulaFalse (getF state) (elements (getM state))"
    with *
    have "\<not> formulaFalse (getF state) (elements (getM state))" "vars (elements (getM state)) \<supseteq> decisionVars"
      by auto
    with assms
    have "satisfiable F0"
      using soundnessForSAT[of "F0" "decisionVars" "state0" "state"]
      unfolding satisfiable_def
      by auto
    with \<open>\<not> satisfiable F0\<close>
    have False
      by simp
  }
  with * show ?thesis
    by auto
qed

(*----------------------------------------------------------------------------*)
theorem partialCorrectness:
  fixes F0 :: Formula and decisionVars :: "Variable set" and state0 :: State and state :: State
  assumes
  "vars F0 \<subseteq> decisionVars" and

  "isInitialState state0 F0" and
  "(state0, state) \<in> transitionRelation decisionVars" and
  "isFinalState state decisionVars"
  shows
  "satisfiable F0 = (\<not> formulaFalse (getF state) (elements (getM state)))"
(*----------------------------------------------------------------------------*)
using assms
using completenessForUNSAT[of "F0" "decisionVars" "state0" "state"]
using completenessForSAT[of "F0" "state0" "state" "decisionVars"]
by auto

end


(*  Title:      FOLP/IFOLP.thy
    Author:     Martin D Coen, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section \<open>Intuitionistic First-Order Logic with Proofs\<close>

theory IFOLP
imports Pure
begin

ML_file "~~/src/Tools/misc_legacy.ML"

setup Pure_Thy.old_appl_syntax_setup

class "term"
default_sort "term"

typedecl p
typedecl o

consts
      (*** Judgements ***)
 Proof          ::   "[o,p]=>prop"
 EqProof        ::   "[p,p,o]=>prop"    ("(3_ /= _ :/ _)" [10,10,10] 5)

      (*** Logical Connectives -- Type Formers ***)
 eq             ::      "['a,'a] => o"  (infixl "=" 50)
 True           ::      "o"
 False          ::      "o"
 conj           ::      "[o,o] => o"    (infixr "&" 35)
 disj           ::      "[o,o] => o"    (infixr "|" 30)
 imp            ::      "[o,o] => o"    (infixr "-->" 25)
      (*Quantifiers*)
 All            ::      "('a => o) => o"        (binder "ALL " 10)
 Ex             ::      "('a => o) => o"        (binder "EX " 10)
      (*Rewriting gadgets*)
 NORM           ::      "o => o"
 norm           ::      "'a => 'a"

      (*** Proof Term Formers: precedence must exceed 50 ***)
 tt             :: "p"
 contr          :: "p=>p"
 fst            :: "p=>p"
 snd            :: "p=>p"
 pair           :: "[p,p]=>p"           ("(1<_,/_>)")
 split          :: "[p, [p,p]=>p] =>p"
 inl            :: "p=>p"
 inr            :: "p=>p"
 "when"         :: "[p, p=>p, p=>p]=>p"
 lambda         :: "(p => p) => p"      (binder "lam " 55)
 App            :: "[p,p]=>p"           (infixl "`" 60)
 alll           :: "['a=>p]=>p"         (binder "all " 55)
 app            :: "[p,'a]=>p"          (infixl "^" 55)
 exists         :: "['a,p]=>p"          ("(1[_,/_])")
 xsplit         :: "[p,['a,p]=>p]=>p"
 ideq           :: "'a=>p"
 idpeel         :: "[p,'a=>p]=>p"
 nrm            :: p
 NRM            :: p

syntax "_Proof" :: "[p,o]=>prop"    ("(_ /: _)" [51, 10] 5)

parse_translation \<open>
  let fun proof_tr [p, P] = Const (@{const_syntax Proof}, dummyT) $ P $ p
  in [(@{syntax_const "_Proof"}, K proof_tr)] end
\<close>

(*show_proofs = true displays the proof terms -- they are ENORMOUS*)
ML \<open>val show_proofs = Attrib.setup_config_bool @{binding show_proofs} (K false)\<close>

print_translation \<open>
  let
    fun proof_tr' ctxt [P, p] =
      if Config.get ctxt show_proofs then Const (@{syntax_const "_Proof"}, dummyT) $ p $ P
      else P
  in [(@{const_syntax Proof}, proof_tr')] end
\<close>

(**** Propositional logic ****)

(*Equality*)
(* Like Intensional Equality in MLTT - but proofs distinct from terms *)

axiomatization where
ieqI:      "ideq(a) : a=a" and
ieqE:      "[| p : a=b;  !!x. f(x) : P(x,x) |] ==> idpeel(p,f) : P(a,b)"

(* Truth and Falsity *)

axiomatization where
TrueI:     "tt : True" and
FalseE:    "a:False ==> contr(a):P"

(* Conjunction *)

axiomatization where
conjI:     "[| a:P;  b:Q |] ==> <a,b> : P&Q" and
conjunct1: "p:P&Q ==> fst(p):P" and
conjunct2: "p:P&Q ==> snd(p):Q"

(* Disjunction *)

axiomatization where
disjI1:    "a:P ==> inl(a):P|Q" and
disjI2:    "b:Q ==> inr(b):P|Q" and
disjE:     "[| a:P|Q;  !!x. x:P ==> f(x):R;  !!x. x:Q ==> g(x):R
           |] ==> when(a,f,g):R"

(* Implication *)

axiomatization where
impI:      "\<And>P Q f. (!!x. x:P ==> f(x):Q) ==> lam x. f(x):P-->Q" and
mp:        "\<And>P Q f. [| f:P-->Q;  a:P |] ==> f`a:Q"

(*Quantifiers*)

axiomatization where
allI:      "\<And>P. (!!x. f(x) : P(x)) ==> all x. f(x) : ALL x. P(x)" and
spec:      "\<And>P f. (f:ALL x. P(x)) ==> f^x : P(x)"

axiomatization where
exI:       "p : P(x) ==> [x,p] : EX x. P(x)" and
exE:       "[| p: EX x. P(x);  !!x u. u:P(x) ==> f(x,u) : R |] ==> xsplit(p,f):R"

(**** Equality between proofs ****)

axiomatization where
prefl:     "a : P ==> a = a : P" and
psym:      "a = b : P ==> b = a : P" and
ptrans:    "[| a = b : P;  b = c : P |] ==> a = c : P"

axiomatization where
idpeelB:   "[| !!x. f(x) : P(x,x) |] ==> idpeel(ideq(a),f) = f(a) : P(a,a)"

axiomatization where
fstB:      "a:P ==> fst(<a,b>) = a : P" and
sndB:      "b:Q ==> snd(<a,b>) = b : Q" and
pairEC:    "p:P&Q ==> p = <fst(p),snd(p)> : P&Q"

axiomatization where
whenBinl:  "[| a:P;  !!x. x:P ==> f(x) : Q |] ==> when(inl(a),f,g) = f(a) : Q" and
whenBinr:  "[| b:P;  !!x. x:P ==> g(x) : Q |] ==> when(inr(b),f,g) = g(b) : Q" and
plusEC:    "a:P|Q ==> when(a,%x. inl(x),%y. inr(y)) = a : P|Q"

axiomatization where
applyB:     "[| a:P;  !!x. x:P ==> b(x) : Q |] ==> (lam x. b(x)) ` a = b(a) : Q" and
funEC:      "f:P ==> f = lam x. f`x : P"

axiomatization where
specB:      "[| !!x. f(x) : P(x) |] ==> (all x. f(x)) ^ a = f(a) : P(a)"

(**** Definitions ****)

definition Not :: "o => o"  ("~ _" [40] 40)
  where not_def: "~P == P-->False"

definition iff :: "[o,o] => o"  (infixr "<->" 25)
  where "P<->Q == (P-->Q) & (Q-->P)"

(*Unique existence*)
definition Ex1 :: "('a => o) => o"  (binder "EX! " 10)
  where ex1_def: "EX! x. P(x) == EX x. P(x) & (ALL y. P(y) --> y=x)"

(*Rewriting -- special constants to flag normalized terms and formulae*)
axiomatization where
norm_eq: "nrm : norm(x) = x" and
NORM_iff:        "NRM : NORM(P) <-> P"

(*** Sequent-style elimination rules for & --> and ALL ***)

schematic_goal conjE:
  assumes "p:P&Q"
    and "!!x y.[| x:P; y:Q |] ==> f(x,y):R"
  shows "?a:R"
  apply (rule assms(2))
   apply (rule conjunct1 [OF assms(1)])
  apply (rule conjunct2 [OF assms(1)])
  done

schematic_goal impE:
  assumes "p:P-->Q"
    and "q:P"
    and "!!x. x:Q ==> r(x):R"
  shows "?p:R"
  apply (rule assms mp)+
  done

schematic_goal allE:
  assumes "p:ALL x. P(x)"
    and "!!y. y:P(x) ==> q(y):R"
  shows "?p:R"
  apply (rule assms spec)+
  done

(*Duplicates the quantifier; for use with eresolve_tac*)
schematic_goal all_dupE:
  assumes "p:ALL x. P(x)"
    and "!!y z.[| y:P(x); z:ALL x. P(x) |] ==> q(y,z):R"
  shows "?p:R"
  apply (rule assms spec)+
  done

(*** Negation rules, which translate between ~P and P-->False ***)

schematic_goal notI:
  assumes "!!x. x:P ==> q(x):False"
  shows "?p:~P"
  unfolding not_def
  apply (assumption | rule assms impI)+
  done

schematic_goal notE: "p:~P \<Longrightarrow> q:P \<Longrightarrow> ?p:R"
  unfolding not_def
  apply (drule (1) mp)
  apply (erule FalseE)
  done

(*This is useful with the special implication rules for each kind of P. *)
schematic_goal not_to_imp:
  assumes "p:~P"
    and "!!x. x:(P-->False) ==> q(x):Q"
  shows "?p:Q"
  apply (assumption | rule assms impI notE)+
  done

(* For substitution int an assumption P, reduce Q to P-->Q, substitute into
   this implication, then apply impI to move P back into the assumptions.*)
schematic_goal rev_mp: "[| p:P;  q:P --> Q |] ==> ?p:Q"
  apply (assumption | rule mp)+
  done

(*Contrapositive of an inference rule*)
schematic_goal contrapos:
  assumes major: "p:~Q"
    and minor: "!!y. y:P==>q(y):Q"
  shows "?a:~P"
  apply (rule major [THEN notE, THEN notI])
  apply (erule minor)
  done

(** Unique assumption tactic.
    Ignores proof objects.
    Fails unless one assumption is equal and exactly one is unifiable
**)

ML \<open>
local
  fun discard_proof (Const (@{const_name Proof}, _) $ P $ _) = P;
in
fun uniq_assume_tac ctxt =
  SUBGOAL
    (fn (prem,i) =>
      let val hyps = map discard_proof (Logic.strip_assums_hyp prem)
          and concl = discard_proof (Logic.strip_assums_concl prem)
      in
          if exists (fn hyp => hyp aconv concl) hyps
          then case distinct (op =) (filter (fn hyp => Term.could_unify (hyp, concl)) hyps) of
                   [_] => assume_tac ctxt i
                 |  _  => no_tac
          else no_tac
      end);
end;
\<close>

(*** Modus Ponens Tactics ***)

(*Finds P-->Q and P in the assumptions, replaces implication by Q *)
ML \<open>
  fun mp_tac ctxt i =
    eresolve_tac ctxt [@{thm notE}, make_elim @{thm mp}] i  THEN  assume_tac ctxt i
\<close>
method_setup mp = \<open>Scan.succeed (SIMPLE_METHOD' o mp_tac)\<close>

(*Like mp_tac but instantiates no variables*)
ML \<open>
  fun int_uniq_mp_tac ctxt i =
    eresolve_tac ctxt [@{thm notE}, @{thm impE}] i  THEN  uniq_assume_tac ctxt i
\<close>

(*** If-and-only-if ***)

schematic_goal iffI:
  assumes "!!x. x:P ==> q(x):Q"
    and "!!x. x:Q ==> r(x):P"
  shows "?p:P<->Q"
  unfolding iff_def
  apply (assumption | rule assms conjI impI)+
  done

schematic_goal iffE:
  assumes "p:P <-> Q"
    and "!!x y.[| x:P-->Q; y:Q-->P |] ==> q(x,y):R"
  shows "?p:R"
  apply (rule conjE)
   apply (rule assms(1) [unfolded iff_def])
  apply (rule assms(2))
   apply assumption+
  done

(* Destruct rules for <-> similar to Modus Ponens *)

schematic_goal iffD1: "[| p:P <-> Q; q:P |] ==> ?p:Q"
  unfolding iff_def
  apply (rule conjunct1 [THEN mp], assumption+)
  done

schematic_goal iffD2: "[| p:P <-> Q; q:Q |] ==> ?p:P"
  unfolding iff_def
  apply (rule conjunct2 [THEN mp], assumption+)
  done

schematic_goal iff_refl: "?p:P <-> P"
  apply (rule iffI)
   apply assumption+
  done

schematic_goal iff_sym: "p:Q <-> P ==> ?p:P <-> Q"
  apply (erule iffE)
  apply (rule iffI)
   apply (erule (1) mp)+
  done

schematic_goal iff_trans: "[| p:P <-> Q; q:Q<-> R |] ==> ?p:P <-> R"
  apply (rule iffI)
   apply (assumption | erule iffE | erule (1) impE)+
  done

(*** Unique existence.  NOTE THAT the following 2 quantifications
   EX!x such that [EX!y such that P(x,y)]     (sequential)
   EX!x,y such that P(x,y)                    (simultaneous)
 do NOT mean the same thing.  The parser treats EX!x y.P(x,y) as sequential.
***)

schematic_goal ex1I:
  assumes "p:P(a)"
    and "!!x u. u:P(x) ==> f(u) : x=a"
  shows "?p:EX! x. P(x)"
  unfolding ex1_def
  apply (assumption | rule assms exI conjI allI impI)+
  done

schematic_goal ex1E:
  assumes "p:EX! x. P(x)"
    and "!!x u v. [| u:P(x);  v:ALL y. P(y) --> y=x |] ==> f(x,u,v):R"
  shows "?a : R"
  apply (insert assms(1) [unfolded ex1_def])
  apply (erule exE conjE | assumption | rule assms(1))+
  apply (erule assms(2), assumption)
  done

(*** <-> congruence rules for simplification ***)

(*Use iffE on a premise.  For conj_cong, imp_cong, all_cong, ex_cong*)
ML \<open>
fun iff_tac ctxt prems i =
    resolve_tac ctxt (prems RL [@{thm iffE}]) i THEN
    REPEAT1 (eresolve_tac ctxt [asm_rl, @{thm mp}] i)
\<close>

method_setup iff =
  \<open>Attrib.thms >> (fn prems => fn ctxt => SIMPLE_METHOD' (iff_tac ctxt prems))\<close>

schematic_goal conj_cong:
  assumes "p:P <-> P'"
    and "!!x. x:P' ==> q(x):Q <-> Q'"
  shows "?p:(P&Q) <-> (P'&Q')"
  apply (insert assms(1))
  apply (assumption | rule iffI conjI | erule iffE conjE mp | iff assms)+
  done

schematic_goal disj_cong:
  "[| p:P <-> P'; q:Q <-> Q' |] ==> ?p:(P|Q) <-> (P'|Q')"
  apply (erule iffE disjE disjI1 disjI2 | assumption | rule iffI | mp)+
  done

schematic_goal imp_cong:
  assumes "p:P <-> P'"
    and "!!x. x:P' ==> q(x):Q <-> Q'"
  shows "?p:(P-->Q) <-> (P'-->Q')"
  apply (insert assms(1))
  apply (assumption | rule iffI impI | erule iffE | mp | iff assms)+
  done

schematic_goal iff_cong:
  "[| p:P <-> P'; q:Q <-> Q' |] ==> ?p:(P<->Q) <-> (P'<->Q')"
  apply (erule iffE | assumption | rule iffI | mp)+
  done

schematic_goal not_cong:
  "p:P <-> P' ==> ?p:~P <-> ~P'"
  apply (assumption | rule iffI notI | mp | erule iffE notE)+
  done

schematic_goal all_cong:
  assumes "!!x. f(x):P(x) <-> Q(x)"
  shows "?p:(ALL x. P(x)) <-> (ALL x. Q(x))"
  apply (assumption | rule iffI allI | mp | erule allE | iff assms)+
  done

schematic_goal ex_cong:
  assumes "!!x. f(x):P(x) <-> Q(x)"
  shows "?p:(EX x. P(x)) <-> (EX x. Q(x))"
  apply (erule exE | assumption | rule iffI exI | mp | iff assms)+
  done

(*NOT PROVED
ML_Thms.bind_thm ("ex1_cong", prove_goal (the_context ())
    "(!!x.f(x):P(x) <-> Q(x)) ==> ?p:(EX! x.P(x)) <-> (EX! x.Q(x))"
 (fn prems =>
  [ (REPEAT   (eresolve_tac [ex1E, spec RS mp] 1 ORELSE ares_tac [iffI,ex1I] 1
      ORELSE   mp_tac 1
      ORELSE   iff_tac prems 1)) ]))
*)

(*** Equality rules ***)

lemmas refl = ieqI

schematic_goal subst:
  assumes prem1: "p:a=b"
    and prem2: "q:P(a)"
  shows "?p : P(b)"
  apply (rule prem2 [THEN rev_mp])
  apply (rule prem1 [THEN ieqE])
  apply (rule impI)
  apply assumption
  done

schematic_goal sym: "q:a=b ==> ?c:b=a"
  apply (erule subst)
  apply (rule refl)
  done

schematic_goal trans: "[| p:a=b;  q:b=c |] ==> ?d:a=c"
  apply (erule (1) subst)
  done

(** ~ b=a ==> ~ a=b **)
schematic_goal not_sym: "p:~ b=a ==> ?q:~ a=b"
  apply (erule contrapos)
  apply (erule sym)
  done

schematic_goal ssubst: "p:b=a \<Longrightarrow> q:P(a) \<Longrightarrow> ?p:P(b)"
  apply (drule sym)
  apply (erule subst)
  apply assumption
  done

(*A special case of ex1E that would otherwise need quantifier expansion*)
schematic_goal ex1_equalsE: "[| p:EX! x. P(x);  q:P(a);  r:P(b) |] ==> ?d:a=b"
  apply (erule ex1E)
  apply (rule trans)
   apply (rule_tac [2] sym)
   apply (assumption | erule spec [THEN mp])+
  done

(** Polymorphic congruence rules **)

schematic_goal subst_context: "[| p:a=b |]  ==>  ?d:t(a)=t(b)"
  apply (erule ssubst)
  apply (rule refl)
  done

schematic_goal subst_context2: "[| p:a=b;  q:c=d |]  ==>  ?p:t(a,c)=t(b,d)"
  apply (erule ssubst)+
  apply (rule refl)
  done

schematic_goal subst_context3: "[| p:a=b;  q:c=d;  r:e=f |]  ==>  ?p:t(a,c,e)=t(b,d,f)"
  apply (erule ssubst)+
  apply (rule refl)
  done

(*Useful with eresolve_tac for proving equalties from known equalities.
        a = b
        |   |
        c = d   *)
schematic_goal box_equals: "[| p:a=b;  q:a=c;  r:b=d |] ==> ?p:c=d"
  apply (rule trans)
   apply (rule trans)
    apply (rule sym)
    apply assumption+
  done

(*Dual of box_equals: for proving equalities backwards*)
schematic_goal simp_equals: "[| p:a=c;  q:b=d;  r:c=d |] ==> ?p:a=b"
  apply (rule trans)
   apply (rule trans)
    apply (assumption | rule sym)+
  done

(** Congruence rules for predicate letters **)

schematic_goal pred1_cong: "p:a=a' ==> ?p:P(a) <-> P(a')"
  apply (rule iffI)
   apply (tactic \<open>
     DEPTH_SOLVE (assume_tac @{context} 1 ORELSE eresolve_tac @{context} [@{thm subst}, @{thm ssubst}] 1)\<close>)
  done

schematic_goal pred2_cong: "[| p:a=a';  q:b=b' |] ==> ?p:P(a,b) <-> P(a',b')"
  apply (rule iffI)
   apply (tactic \<open>
     DEPTH_SOLVE (assume_tac @{context} 1 ORELSE eresolve_tac @{context} [@{thm subst}, @{thm ssubst}] 1)\<close>)
  done

schematic_goal pred3_cong: "[| p:a=a';  q:b=b';  r:c=c' |] ==> ?p:P(a,b,c) <-> P(a',b',c')"
  apply (rule iffI)
   apply (tactic \<open>
     DEPTH_SOLVE (assume_tac @{context} 1 ORELSE eresolve_tac @{context} [@{thm subst}, @{thm ssubst}] 1)\<close>)
  done

lemmas pred_congs = pred1_cong pred2_cong pred3_cong

(*special case for the equality predicate!*)
lemmas eq_cong = pred2_cong [where P = "op ="]

(*** Simplifications of assumed implications.
     Roy Dyckhoff has proved that conj_impE, disj_impE, and imp_impE
     used with mp_tac (restricted to atomic formulae) is COMPLETE for
     intuitionistic propositional logic.  See
   R. Dyckhoff, Contraction-free sequent calculi for intuitionistic logic
    (preprint, University of St Andrews, 1991)  ***)

schematic_goal conj_impE:
  assumes major: "p:(P&Q)-->S"
    and minor: "!!x. x:P-->(Q-->S) ==> q(x):R"
  shows "?p:R"
  apply (assumption | rule conjI impI major [THEN mp] minor)+
  done

schematic_goal disj_impE:
  assumes major: "p:(P|Q)-->S"
    and minor: "!!x y.[| x:P-->S; y:Q-->S |] ==> q(x,y):R"
  shows "?p:R"
  apply (tactic \<open>DEPTH_SOLVE (assume_tac @{context} 1 ORELSE
      resolve_tac @{context} [@{thm disjI1}, @{thm disjI2}, @{thm impI},
        @{thm major} RS @{thm mp}, @{thm minor}] 1)\<close>)
  done

(*Simplifies the implication.  Classical version is stronger.
  Still UNSAFE since Q must be provable -- backtracking needed.  *)
schematic_goal imp_impE:
  assumes major: "p:(P-->Q)-->S"
    and r1: "!!x y.[| x:P; y:Q-->S |] ==> q(x,y):Q"
    and r2: "!!x. x:S ==> r(x):R"
  shows "?p:R"
  apply (assumption | rule impI major [THEN mp] r1 r2)+
  done

(*Simplifies the implication.  Classical version is stronger.
  Still UNSAFE since ~P must be provable -- backtracking needed.  *)
schematic_goal not_impE:
  assumes major: "p:~P --> S"
    and r1: "!!y. y:P ==> q(y):False"
    and r2: "!!y. y:S ==> r(y):R"
  shows "?p:R"
  apply (assumption | rule notI impI major [THEN mp] r1 r2)+
  done

(*Simplifies the implication.   UNSAFE.  *)
schematic_goal iff_impE:
  assumes major: "p:(P<->Q)-->S"
    and r1: "!!x y.[| x:P; y:Q-->S |] ==> q(x,y):Q"
    and r2: "!!x y.[| x:Q; y:P-->S |] ==> r(x,y):P"
    and r3: "!!x. x:S ==> s(x):R"
  shows "?p:R"
  apply (assumption | rule iffI impI major [THEN mp] r1 r2 r3)+
  done

(*What if (ALL x.~~P(x)) --> ~~(ALL x.P(x)) is an assumption? UNSAFE*)
schematic_goal all_impE:
  assumes major: "p:(ALL x. P(x))-->S"
    and r1: "!!x. q:P(x)"
    and r2: "!!y. y:S ==> r(y):R"
  shows "?p:R"
  apply (assumption | rule allI impI major [THEN mp] r1 r2)+
  done

(*Unsafe: (EX x.P(x))-->S  is equivalent to  ALL x.P(x)-->S.  *)
schematic_goal ex_impE:
  assumes major: "p:(EX x. P(x))-->S"
    and r: "!!y. y:P(a)-->S ==> q(y):R"
  shows "?p:R"
  apply (assumption | rule exI impI major [THEN mp] r)+
  done

schematic_goal rev_cut_eq:
  assumes "p:a=b"
    and "!!x. x:a=b ==> f(x):R"
  shows "?p:R"
  apply (rule assms)+
  done

lemma thin_refl: "!!X. [|p:x=x; PROP W|] ==> PROP W" .

ML_file "hypsubst.ML"

ML \<open>
structure Hypsubst = Hypsubst
(
  (*Take apart an equality judgement; otherwise raise Match!*)
  fun dest_eq (Const (@{const_name Proof}, _) $
    (Const (@{const_name eq}, _)  $ t $ u) $ _) = (t, u);

  val imp_intr = @{thm impI}

  (*etac rev_cut_eq moves an equality to be the last premise. *)
  val rev_cut_eq = @{thm rev_cut_eq}

  val rev_mp = @{thm rev_mp}
  val subst = @{thm subst}
  val sym = @{thm sym}
  val thin_refl = @{thm thin_refl}
);
open Hypsubst;
\<close>

ML_file "intprover.ML"

(*** Rewrite rules ***)

schematic_goal conj_rews:
  "?p1 : P & True <-> P"
  "?p2 : True & P <-> P"
  "?p3 : P & False <-> False"
  "?p4 : False & P <-> False"
  "?p5 : P & P <-> P"
  "?p6 : P & ~P <-> False"
  "?p7 : ~P & P <-> False"
  "?p8 : (P & Q) & R <-> P & (Q & R)"
  apply (tactic \<open>fn st => IntPr.fast_tac @{context} 1 st\<close>)+
  done

schematic_goal disj_rews:
  "?p1 : P | True <-> True"
  "?p2 : True | P <-> True"
  "?p3 : P | False <-> P"
  "?p4 : False | P <-> P"
  "?p5 : P | P <-> P"
  "?p6 : (P | Q) | R <-> P | (Q | R)"
  apply (tactic \<open>IntPr.fast_tac @{context} 1\<close>)+
  done

schematic_goal not_rews:
  "?p1 : ~ False <-> True"
  "?p2 : ~ True <-> False"
  apply (tactic \<open>IntPr.fast_tac @{context} 1\<close>)+
  done

schematic_goal imp_rews:
  "?p1 : (P --> False) <-> ~P"
  "?p2 : (P --> True) <-> True"
  "?p3 : (False --> P) <-> True"
  "?p4 : (True --> P) <-> P"
  "?p5 : (P --> P) <-> True"
  "?p6 : (P --> ~P) <-> ~P"
  apply (tactic \<open>IntPr.fast_tac @{context} 1\<close>)+
  done

schematic_goal iff_rews:
  "?p1 : (True <-> P) <-> P"
  "?p2 : (P <-> True) <-> P"
  "?p3 : (P <-> P) <-> True"
  "?p4 : (False <-> P) <-> ~P"
  "?p5 : (P <-> False) <-> ~P"
  apply (tactic \<open>IntPr.fast_tac @{context} 1\<close>)+
  done

schematic_goal quant_rews:
  "?p1 : (ALL x. P) <-> P"
  "?p2 : (EX x. P) <-> P"
  apply (tactic \<open>IntPr.fast_tac @{context} 1\<close>)+
  done

(*These are NOT supplied by default!*)
schematic_goal distrib_rews1:
  "?p1 : ~(P|Q) <-> ~P & ~Q"
  "?p2 : P & (Q | R) <-> P&Q | P&R"
  "?p3 : (Q | R) & P <-> Q&P | R&P"
  "?p4 : (P | Q --> R) <-> (P --> R) & (Q --> R)"
  apply (tactic \<open>IntPr.fast_tac @{context} 1\<close>)+
  done

schematic_goal distrib_rews2:
  "?p1 : ~(EX x. NORM(P(x))) <-> (ALL x. ~NORM(P(x)))"
  "?p2 : ((EX x. NORM(P(x))) --> Q) <-> (ALL x. NORM(P(x)) --> Q)"
  "?p3 : (EX x. NORM(P(x))) & NORM(Q) <-> (EX x. NORM(P(x)) & NORM(Q))"
  "?p4 : NORM(Q) & (EX x. NORM(P(x))) <-> (EX x. NORM(Q) & NORM(P(x)))"
  apply (tactic \<open>IntPr.fast_tac @{context} 1\<close>)+
  done

lemmas distrib_rews = distrib_rews1 distrib_rews2

schematic_goal P_Imp_P_iff_T: "p:P ==> ?p:(P <-> True)"
  apply (tactic \<open>IntPr.fast_tac @{context} 1\<close>)
  done

schematic_goal not_P_imp_P_iff_F: "p:~P ==> ?p:(P <-> False)"
  apply (tactic \<open>IntPr.fast_tac @{context} 1\<close>)
  done

end


(*  Title:    Example_Metric.thy
    Author:   Maximilian Schäffeler
*)
theory Example_Metric
  imports "HOL-Analysis.Metric_Arith" "HOL-Eisbach.Eisbach_Tools"
begin

text \<open>An Eisbach implementation of the method @{method metric}.
  Slower than the Isabelle/ML implementation but arguably more readable.\<close>

declare [[argo_timeout = 20]]

method dist_refl_sym = simp only: simp_thms dist_commute dist_self

method lin_real_arith uses thms = argo thms

method pre_arith uses argo_thms =
  (simp only: metric_pre_arith)?;
  lin_real_arith thms: argo_thms

method elim_sup =
  (simp only: image_insert image_empty)?;
  dist_refl_sym?;
  (simp only: algebra_simps simp_thms)?;
  (simp only: simp_thms Sup_insert_insert cSup_singleton)?;
  (simp only: simp_thms real_abs_dist)?

method ball_simp = simp only: Set.ball_simps(5,7)

lemmas maxdist_thm = maxdist_thm\<comment> \<open>normalizes indexnames\<close>

method rewr_maxdist for ps::"'a::metric_space set" uses pos_thms =
  match conclusion in
    "?P (dist x y)" (cut) for x y::'a \<Rightarrow> \<open>
    simp only: maxdist_thm[where s=ps and x=x and y=y]
      simp_thms finite.emptyI finite_insert empty_iff insert_iff;
    rewr_maxdist ps pos_thms: pos_thms zero_le_dist[of x y]\<close>
  \<bar> _ \<Rightarrow> \<open>
    ball_simp?;
    dist_refl_sym?;
    elim_sup?;
    pre_arith argo_thms: pos_thms\<close>

lemmas metric_eq_thm = metric_eq_thm\<comment> \<open>normalizes indexnames\<close>
method rewr_metric_eq for ps::"'a::metric_space set" =
  match conclusion in
    "?P (x = y)" (cut) for x y::'a \<Rightarrow> \<open>
    simp only: metric_eq_thm[where s=ps and x=x and y=y] simp_thms empty_iff insert_iff;
    rewr_metric_eq ps\<close>
  \<bar> _ \<Rightarrow> \<open>-\<close>

method find_points for ps::"'a::metric_space set" and t::bool =
  match (t) in
    "Q p" (cut) for p::'a and Q::"'a\<Rightarrow>bool" \<Rightarrow> \<open>
    find_points \<open>insert p ps\<close> \<open>\<forall>p. Q p\<close>\<close>
  \<bar> _ \<Rightarrow> \<open>
    rewr_metric_eq ps;
    rewr_maxdist ps\<close>

method basic_metric_arith for p::"'a::metric_space" =
  dist_refl_sym?;
  match conclusion in
    "Q q" (cut) for q::'a and Q \<Rightarrow> \<open>
    find_points \<open>{q}\<close> \<open>\<forall>p. Q p\<close>\<close>
  \<bar> _ \<Rightarrow> \<open>
    rewr_metric_eq \<open>{}::'a set\<close>;
    rewr_maxdist \<open>{}::'a set\<close>\<close>

method elim_exists_loop for p::"'a::metric_space" =
  match conclusion in
    "\<exists>q::'a. ?P q r" for r::'a \<Rightarrow> \<open>
    print_term r;
    rule exI[of _ r];
    elim_exists_loop p\<close>
  \<bar> "\<forall>x. ?P x" (cut) \<Rightarrow> \<open>
    rule allI;
    elim_exists_loop p\<close>
  \<bar> _ \<Rightarrow> \<open>-\<close>

method elim_exists for p::"'a::metric_space" =
  elim_exists_loop p;
  basic_metric_arith p

method find_type =
  match conclusion in
  (* exists in front *)
    "\<exists>x::'a::metric_space. ?P x" \<Rightarrow> \<open>
      match conclusion in
        "?Q x" (cut) for x::"'a::metric_space" \<Rightarrow> \<open>elim_exists x\<close>
      \<bar> _ \<Rightarrow> \<open>
        rule exI;
        match conclusion in "?Q x" (cut) for x::"'a::metric_space" \<Rightarrow> \<open>elim_exists x\<close>\<close>\<close>
  (* no exists *)
  \<bar> "?P (\<lambda>y. (dist x y))" (cut) for x::"'a::metric_space" \<Rightarrow> \<open>elim_exists x\<close>
  \<bar> "?P (\<lambda>x. (dist x y))" (cut) for y::"'a::metric_space" \<Rightarrow> \<open>elim_exists y\<close>
  \<bar> "?P (\<lambda>y. (x = y))" (cut) for x::"'a::metric_space" \<Rightarrow> \<open>elim_exists x\<close>
  \<bar> "?P (\<lambda>x. (x = y))" (cut) for y::"'a::metric_space" \<Rightarrow> \<open>elim_exists y\<close>
  \<bar> _ \<Rightarrow> \<open>
    rule exI;
    find_type\<close>

method metric_eisbach =
  (simp only: metric_unfold)?;
  (atomize (full))?;
  (simp only: metric_prenex)?;
  (simp only: metric_nnf)?;
  ((rule allI)+)?;
  match conclusion in _ \<Rightarrow> find_type

subsection \<open>examples\<close>

lemma "\<exists>x::'a::metric_space. x=x"
  by metric_eisbach

lemma "\<forall>(x::'a::metric_space). \<exists>y. x = y"
  by metric_eisbach

lemma "\<exists>x y. dist x y = 0"
  by metric_eisbach

lemma "\<exists>y. dist x y = 0"
  by metric_eisbach

lemma "0 = dist x y \<Longrightarrow> x = y"
  by metric_eisbach

lemma "x \<noteq> y \<Longrightarrow> dist x y \<noteq> 0"
  by metric_eisbach

lemma "\<exists>y. dist x y \<noteq> 1"
  by metric_eisbach

lemma "x = y \<longleftrightarrow> dist x x = dist y x \<and> dist x y = dist y y"
  by metric_eisbach

lemma "dist a b \<noteq> dist a c \<Longrightarrow> b \<noteq> c"
  by metric_eisbach

lemma "dist y x + c \<ge> c"
  by metric_eisbach

lemma "dist x y + dist x z \<ge> 0"
  by metric_eisbach

lemma "dist x y \<ge> v \<Longrightarrow> dist x y + dist (a::'a) b \<ge> v" for x::"('a::metric_space)"
  by metric_eisbach

lemma "dist x y < 0 \<longrightarrow> P"
  by metric_eisbach

text \<open>reasoning with the triangle inequality\<close>

lemma "dist a d \<le> dist a b + dist b c + dist c d"
  by metric_eisbach

lemma "dist a e \<le> dist a b + dist b c + dist c d + dist d e"
  by metric_eisbach

lemma "max (dist x y) \<bar>dist x z - dist z y\<bar> = dist x y"
  by metric_eisbach

lemma
  "dist w x < e/3 \<Longrightarrow> dist x y < e/3 \<Longrightarrow> dist y z < e/3 \<Longrightarrow> dist w x < e"
  by metric_eisbach

lemma "dist w x < e/4 \<Longrightarrow> dist x y < e/4 \<Longrightarrow> dist y z < e/2 \<Longrightarrow> dist w z < e"
  by metric_eisbach

lemma "dist x y = r / 2 \<Longrightarrow> (\<forall>z. dist x z < r / 4 \<longrightarrow> dist y z \<le> 3 * r / 4)"
  by metric_eisbach

lemma "\<exists>x. \<forall>r\<le>0. \<exists>z. dist x z \<ge> r"
  by metric_eisbach

lemma "\<And>a r x y. dist x a + dist a y = r \<Longrightarrow> \<forall>z. r \<le> dist x z + dist z y \<Longrightarrow> dist x y = r"
  by metric_eisbach

end


theory Chisholm_A imports SDL                   (*Christoph Benzmüller & Xavier Parent, 2018*)

begin (* Chisholm Example *)
 consts go::\<sigma> tell::\<sigma> kill::\<sigma>
 axiomatization where
  D1: "\<lfloor>\<^bold>O\<^bold>\<langle>go\<^bold>\<rangle>\<rfloor>" (*It ought to be that Jones goes to assist his neighbors.*) and
  D2: "\<lfloor>\<^bold>O\<^bold>\<langle>go \<^bold>\<rightarrow> tell\<^bold>\<rangle>\<rfloor>"  (*It ought to be that if Jones goes, then he tells them he is coming.*) and
  D3: "\<lfloor>\<^bold>O\<^bold>\<langle>\<^bold>\<not>go \<^bold>\<rightarrow> \<^bold>\<not>tell\<^bold>\<rangle>\<rfloor>" (*If Jones doesn't go, then he ought not tell them he is coming.*) and
  D4: "\<lfloor>\<^bold>\<not>go\<rfloor>\<^sub>c\<^sub>w" (*Jones doesn't go. (This is encoded as a locally valid statement.)*)

 (*Some Experiments*)
  sledgehammer_params [max_facts=20] (*Sets default parameters for the theorem provers*)
  nitpick_params [user_axioms,expect=genuine,show_all,format=2] (*... and for the model finder.*)

 lemma True  nitpick [satisfy] oops  (*Consistency-check: Is there a model?*)
 lemma False sledgehammer      oops  (*Inconsistency-check: Can Falsum be derived?*)

 lemma "\<lfloor>\<^bold>O\<^bold>\<langle>\<^bold>\<not>tell\<^bold>\<rangle>\<rfloor>" sledgehammer  nitpick oops   (*Should James not tell?*)
 lemma "\<lfloor>\<^bold>O\<^bold>\<langle>tell\<^bold>\<rangle>\<rfloor>"  sledgehammer  nitpick oops   (*Should James tell?*)
 lemma "\<lfloor>\<^bold>O\<^bold>\<langle>kill\<^bold>\<rangle>\<rfloor>"  sledgehammer  nitpick oops   (*Should James kill?*)

 (* The issue of Chisholm_A: D1 entails D3 (The requirement of logical independence is not met).*)
 lemma  "(\<lfloor>\<^bold>O\<^bold>\<langle>go\<^bold>\<rangle>\<rfloor>) \<longrightarrow> (\<lfloor>\<^bold>O\<^bold>\<langle>\<^bold>\<not>go \<^bold>\<rightarrow> \<^bold>\<not>tell\<^bold>\<rangle>\<rfloor>)" unfolding obligationSDL_def by simp
end

(*
  D2: "\<lfloor>\<^bold>O\<^bold>\<langle>tell\<^bold>|go\<^bold>\<rangle>\<rfloor>" and
  D3: "\<lfloor>\<^bold>O\<^bold>\<langle>\<^bold>\<not>tell\<^bold>|\<^bold>\<not>go\<^bold>\<rangle>\<rfloor>" and
*)


(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory Continuations
imports
  HOLCF
  Maybe
  Nats
  WorkerWrapperNew
begin
(*>*)

section{* Tagless interpreter via double-barreled continuations *}

text{*\label{sec:continuations} *}

type_synonym 'a Cont = "('a \<rightarrow> 'a) \<rightarrow> 'a"

definition
  val2cont :: "'a \<rightarrow> 'a Cont" where
  "val2cont \<equiv> (\<Lambda> a c. c\<cdot>a)"

definition
  cont2val :: "'a Cont \<rightarrow> 'a" where
  "cont2val \<equiv> (\<Lambda> f. f\<cdot>ID)"

lemma cont2val_val2cont_id: "cont2val oo val2cont = ID"
  by (rule cfun_eqI, simp add: val2cont_def cont2val_def)

domain Expr =
    Val (lazy val::"Nat")
  | Add (lazy addl::"Expr") (lazy addr::"Expr")
  | Throw
  | Catch (lazy cbody::"Expr") (lazy chandler::"Expr")

fixrec eval :: "Expr \<rightarrow> Nat Maybe"
where
  "eval\<cdot>(Val\<cdot>n) = Just\<cdot>n"
| "eval\<cdot>(Add\<cdot>x\<cdot>y) = mliftM2 (\<Lambda> a b. a + b)\<cdot>(eval\<cdot>x)\<cdot>(eval\<cdot>y)"
| "eval\<cdot>Throw = mfail"
| "eval\<cdot>(Catch\<cdot>x\<cdot>y) = mcatch\<cdot>(eval\<cdot>x)\<cdot>(eval\<cdot>y)"

fixrec eval_body :: "(Expr \<rightarrow> Nat Maybe) \<rightarrow> Expr \<rightarrow> Nat Maybe"
where
  "eval_body\<cdot>r\<cdot>(Val\<cdot>n) = Just\<cdot>n"
| "eval_body\<cdot>r\<cdot>(Add\<cdot>x\<cdot>y) = mliftM2 (\<Lambda> a b. a + b)\<cdot>(r\<cdot>x)\<cdot>(r\<cdot>y)"
| "eval_body\<cdot>r\<cdot>Throw = mfail"
| "eval_body\<cdot>r\<cdot>(Catch\<cdot>x\<cdot>y) = mcatch\<cdot>(r\<cdot>x)\<cdot>(r\<cdot>y)"

lemma eval_body_strictExpr[simp]: "eval_body\<cdot>r\<cdot>\<bottom> = \<bottom>"
  by (subst eval_body.unfold, simp)

lemma eval_eval_body_eq: "eval = fix\<cdot>eval_body"
  by (rule cfun_eqI, subst eval_def, subst eval_body.unfold, simp)

subsection{* Worker/wrapper *}

definition
  unwrapC :: "(Expr \<rightarrow> Nat Maybe) \<rightarrow> (Expr \<rightarrow> (Nat \<rightarrow> Nat Maybe) \<rightarrow> Nat Maybe \<rightarrow> Nat Maybe)" where
  "unwrapC \<equiv> \<Lambda> g e s f. case g\<cdot>e of Nothing \<Rightarrow> f | Just\<cdot>n \<Rightarrow> s\<cdot>n"

lemma unwrapC_strict[simp]: "unwrapC\<cdot>\<bottom> = \<bottom>"
  unfolding unwrapC_def by (rule cfun_eqI)+ simp

definition
  wrapC :: "(Expr \<rightarrow> (Nat \<rightarrow> Nat Maybe) \<rightarrow> Nat Maybe \<rightarrow> Nat Maybe) \<rightarrow> (Expr \<rightarrow> Nat Maybe)" where
  "wrapC \<equiv> \<Lambda> g e. g\<cdot>e\<cdot>Just\<cdot>Nothing"

lemma wrapC_unwrapC_id: "wrapC oo unwrapC = ID"
proof(intro cfun_eqI)
  fix g e
  show "(wrapC oo unwrapC)\<cdot>g\<cdot>e = ID\<cdot>g\<cdot>e"
    by (cases "g\<cdot>e", simp_all add: wrapC_def unwrapC_def)
qed

definition
  eval_work :: "Expr \<rightarrow> (Nat \<rightarrow> Nat Maybe) \<rightarrow> Nat Maybe \<rightarrow> Nat Maybe" where
  "eval_work \<equiv> fix\<cdot>(unwrapC oo eval_body oo wrapC)"

definition
  eval_wrap :: "Expr \<rightarrow> Nat Maybe" where
  "eval_wrap \<equiv> wrapC\<cdot>eval_work"

fixrec eval_body' :: "(Expr \<rightarrow> (Nat \<rightarrow> Nat Maybe) \<rightarrow> Nat Maybe \<rightarrow> Nat Maybe)
                    \<rightarrow> Expr \<rightarrow> (Nat \<rightarrow> Nat Maybe) \<rightarrow> Nat Maybe \<rightarrow> Nat Maybe"
where
  "eval_body'\<cdot>r\<cdot>(Val\<cdot>n)\<cdot>s\<cdot>f = s\<cdot>n"
| "eval_body'\<cdot>r\<cdot>(Add\<cdot>x\<cdot>y)\<cdot>s\<cdot>f = (case wrapC\<cdot>r\<cdot>x of
                                     Nothing \<Rightarrow> f
                                   | Just\<cdot>n \<Rightarrow> (case wrapC\<cdot>r\<cdot>y of
                                                    Nothing \<Rightarrow> f
                                                  | Just\<cdot>m \<Rightarrow> s\<cdot>(n + m)))"
| "eval_body'\<cdot>r\<cdot>Throw\<cdot>s\<cdot>f = f"
| "eval_body'\<cdot>r\<cdot>(Catch\<cdot>x\<cdot>y)\<cdot>s\<cdot>f = (case wrapC\<cdot>r\<cdot>x of
                                       Nothing \<Rightarrow> (case wrapC\<cdot>r\<cdot>y of
                                                      Nothing \<Rightarrow> f
                                                    | Just\<cdot>n \<Rightarrow> s\<cdot>n)
                                     | Just\<cdot>n \<Rightarrow> s\<cdot>n)"

lemma eval_body'_strictExpr[simp]: "eval_body'\<cdot>r\<cdot>\<bottom>\<cdot>s\<cdot>f = \<bottom>"
  by (subst eval_body'.unfold, simp)

definition
  eval_work' :: "Expr \<rightarrow> (Nat \<rightarrow> Nat Maybe) \<rightarrow> Nat Maybe \<rightarrow> Nat Maybe" where
  "eval_work' \<equiv> fix\<cdot>eval_body'"

text{* This proof is unfortunately quite messy, due to the
simplifier's inability to cope with HOLCF's case distinctions. *}

lemma eval_body'_eval_body_eq: "eval_body' = unwrapC oo eval_body oo wrapC"
  apply (intro cfun_eqI)
  apply (unfold unwrapC_def wrapC_def)
  apply (case_tac xa)
      apply simp_all
    apply (simp add: wrapC_def)
    apply (case_tac "x\<cdot>Expr1\<cdot>Just\<cdot>Nothing")
     apply simp_all
    apply (case_tac "x\<cdot>Expr2\<cdot>Just\<cdot>Nothing")
     apply simp_all
   apply (simp add: mfail_def)
  apply (simp add: mcatch_def wrapC_def)
  apply (case_tac "x\<cdot>Expr1\<cdot>Just\<cdot>Nothing")
   apply simp_all
  done

fixrec eval_body_final :: "(Expr \<rightarrow> (Nat \<rightarrow> Nat Maybe) \<rightarrow> Nat Maybe \<rightarrow> Nat Maybe)
                         \<rightarrow> Expr \<rightarrow> (Nat \<rightarrow> Nat Maybe) \<rightarrow> Nat Maybe \<rightarrow> Nat Maybe"
where
  "eval_body_final\<cdot>r\<cdot>(Val\<cdot>n)\<cdot>s\<cdot>f = s\<cdot>n"
| "eval_body_final\<cdot>r\<cdot>(Add\<cdot>x\<cdot>y)\<cdot>s\<cdot>f = r\<cdot>x\<cdot>(\<Lambda> n. r\<cdot>y\<cdot>(\<Lambda> m. s\<cdot>(n + m))\<cdot>f)\<cdot>f"
| "eval_body_final\<cdot>r\<cdot>Throw\<cdot>s\<cdot>f = f"
| "eval_body_final\<cdot>r\<cdot>(Catch\<cdot>x\<cdot>y)\<cdot>s\<cdot>f = r\<cdot>x\<cdot>s\<cdot>(r\<cdot>y\<cdot>s\<cdot>f)"

lemma eval_body_final_strictExpr[simp]: "eval_body_final\<cdot>r\<cdot>\<bottom>\<cdot>s\<cdot>f = \<bottom>"
  by (subst eval_body_final.unfold, simp)

lemma eval_body'_eval_body_final_eq: "eval_body_final oo unwrapC oo wrapC = eval_body'"
  apply (rule cfun_eqI)+
  apply (case_tac xa)
     apply (simp_all add: unwrapC_def)
  done

definition
  eval_work_final :: "Expr \<rightarrow> (Nat \<rightarrow> Nat Maybe) \<rightarrow> Nat Maybe \<rightarrow> Nat Maybe" where
  "eval_work_final \<equiv> fix\<cdot>eval_body_final"

definition
  eval_final :: "Expr \<rightarrow> Nat Maybe" where
  "eval_final \<equiv> (\<Lambda> e. eval_work_final\<cdot>e\<cdot>Just\<cdot>Nothing)"

lemma "eval = eval_final"
proof -
  have "eval = fix\<cdot>eval_body" by (rule eval_eval_body_eq)
  also from wrapC_unwrapC_id unwrapC_strict have "\<dots> = wrapC\<cdot>(fix\<cdot>eval_body_final)"
    apply (rule worker_wrapper_fusion_new)
    using eval_body'_eval_body_final_eq eval_body'_eval_body_eq by simp
  also have "\<dots> = eval_final"
    unfolding eval_final_def eval_work_final_def wrapC_def
    by simp
  finally show ?thesis .
qed

(*<*)
end
(*>*)