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

header{* MoreList *}

theory MoreList
imports Main "~~/src/HOL/Library/Multiset"
begin

text{* Theory contains some additional lemmas and functions for the
@{term List} datatype. Warning: some of these notions are obsolete
because they already exist in {\em List.thy} in similiar form. *}

(*********************************************************)
(*               last and butlast                        *)
(*********************************************************)
subsection{* @{term "last"} and @{term "butlast"} - last element of list and elements before it *}
lemma listEqualsButlastAppendLast:
  assumes "list \<noteq> []"
  shows "list = (butlast list) @ [last list]"
using assms
by (induct list) auto

lemma lastListInList [simp]:
  assumes "list \<noteq> []"
  shows "last list \<in> set list"
using assms
by (induct list) auto

lemma butlastIsSubset:
  shows "set (butlast list) \<subseteq> set list"
by (induct list) (auto split: split_if_asm)

lemma setListIsSetButlastAndLast:
  shows "set list \<subseteq> set (butlast list) \<union> {last list}"
by (induct list) auto

lemma butlastAppend:
  shows "butlast (list1 @ list2) = (if list2 = [] then butlast list1 else (list1 @ butlast list2))"
by (induct list1) auto

(*********************************************************)
(*                   removeAll                           *)
(*********************************************************)
subsection{* @{term removeAll} - element removal *}

lemma removeAll_multiset:
  assumes "distinct a" "x \<in> set a"
  shows "multiset_of a = {#x#} + multiset_of (removeAll x a)"
using assms
proof (induct a)
  case (Cons y a')
  thus ?case
  proof (cases "x = y")
    case True
    with `distinct (y # a')` `x \<in> set (y # a')`
    have "\<not>  x \<in> set a'"
      by auto
    hence "removeAll x a' = a'"
      by (rule removeAll_id)
    with `x = y` show ?thesis
      by (simp add: union_commute)
  next
    case False
    with `x \<in> set (y # a')`
    have "x \<in> set a'"
      by simp
    with `distinct (y # a')`
    have "x \<noteq> y" "distinct a'"
      by auto
    hence "multiset_of a' = {#x#} + multiset_of (removeAll x a')"
      using `x \<in> set a'`
      using Cons(1)
      by simp
    thus ?thesis
      using `x \<noteq> y`
      by (simp add: union_assoc)
  qed
qed simp

lemma removeAll_map:
  assumes "\<forall> x y. x \<noteq> y \<longrightarrow> f x \<noteq> f y"
  shows "removeAll (f x) (map f a) = map f (removeAll x a)"
using assms
by (induct a arbitrary: x) auto

(*********************************************************)
(*                   uniq                                *)
(*********************************************************)
subsection{* @{term uniq} - no duplicate elements. *}
text{* @{term "(uniq list)"} holds iff there are no repeated elements
in a list.  Obsolete: same as @{term "distinct"} in {\em List.thy}. *}

primrec uniq :: "'a list => bool"
where
"uniq [] = True" |
"uniq (h#t) = (h \<notin> set t \<and> uniq t)"

lemma uniqDistinct:
"uniq l = distinct l"
by (induct l) auto

lemma uniqAppend:
  assumes "uniq (l1 @ l2)"
  shows "uniq l1" "uniq l2"
using assms
by (induct l1) auto

lemma uniqAppendIff:
  "uniq (l1 @ l2) = (uniq l1 \<and> uniq l2 \<and> set l1 \<inter> set l2 = {})" (is "?lhs = ?rhs")
by (induct l1) auto

lemma uniqAppendElement:
  assumes "uniq l"
  shows "e \<notin> set l = uniq (l @ [e])"
using assms
by (induct l) (auto split: split_if_asm)

lemma uniqImpliesNotLastMemButlast:
  assumes "uniq l"
  shows "last l \<notin> set (butlast l)"
proof (cases "l = []")
  case True
  thus ?thesis
    using assms
    by simp
next
  case False
  hence "l = butlast l @ [last l]"
    by (rule listEqualsButlastAppendLast)
  moreover
  with `uniq l`
  have "uniq (butlast l)"
    using uniqAppend[of "butlast l" "[last l]"]
    by simp
  ultimately
  show ?thesis
    using assms
    using uniqAppendElement[of "butlast l" "last l"]
    by simp
qed

lemma uniqButlastNotUniqListImpliesLastMemButlast:
  assumes "uniq (butlast l)" "\<not> uniq l"
  shows "last l \<in> set (butlast l)"
proof (cases "l = []")
  case True
  thus ?thesis
    using assms
    by auto
next
  case False
  hence "l = butlast l @ [(last l)]"
    by (rule listEqualsButlastAppendLast)
  thus ?thesis
    using assms
    using uniqAppendElement[of "butlast l" "last l"]
    by auto
qed

lemma uniqRemdups:
  shows "uniq (remdups x)"
by (induct x) auto

lemma uniqHeadTailSet:
  assumes "uniq l"
  shows "set (tl l) = (set l) - {hd l}"
using assms
by (induct l) auto

lemma uniqLengthEqCardSet:
assumes "uniq l"
shows "length l = card (set l)"
using assms
by (induct l) auto

lemma lengthGtOneTwoDistinctElements:
assumes
  "uniq l" "length l > 1" "l \<noteq> []"
shows
  "\<exists> a1 a2. a1 \<in> set l \<and> a2 \<in> set l \<and> a1 \<noteq> a2"
proof-
  let ?a1 = "l ! 0"
  let ?a2 = "l ! 1"
  have "?a1 \<in> set l"
    using nth_mem[of "0" "l"]
    using assms
    by simp
  moreover
  have "?a2 \<in> set l"
    using nth_mem[of "1" "l"]
    using assms
    by simp
  moreover
  have "?a1 \<noteq> ?a2"
    using nth_eq_iff_index_eq[of "l" "0" "1"]
    using assms
    by (auto simp add: uniqDistinct)
  ultimately
  show ?thesis
    by auto
qed

(*********************************************************)
(*                   firstPos                            *)
(*********************************************************)
subsection {* @{term firstPos} - first position of an element *}
text{* @{term "firstPos"} returns the zero-based index of the first
  occurence of an element int a list, or the length of the list if the
  element does not occur. *}

primrec firstPos :: "'a => 'a list => nat"
where
"firstPos a [] = 0" |
"firstPos a (h # t) = (if a = h then 0 else 1 + (firstPos a t))"

lemma firstPosEqualZero:
  shows "(firstPos a (m # M') = 0) = (a = m)"
by (induct M') auto

lemma firstPosLeLength:
  assumes "a \<in> set l"
  shows "firstPos a l < length l"
using assms
by (induct l) auto

lemma firstPosAppend:
  assumes "a \<in> set l"
  shows "firstPos a l = firstPos a (l @ l')"
using assms
by (induct l) auto

lemma firstPosAppendNonMemberFirstMemberSecond:
  assumes "a \<notin> set l1" and  "a \<in> set l2"
  shows "firstPos a (l1 @ l2) = length l1 + firstPos a l2"
using assms
by (induct l1) auto

lemma firstPosDomainForElements:
  shows "(0 \<le> firstPos a l \<and> firstPos a l < length l) = (a \<in> set l)" (is "?lhs = ?rhs")
  by (induct l) auto

lemma firstPosEqual:
  assumes "a \<in> set l" and "b \<in> set l"
  shows "(firstPos a l = firstPos b l) = (a = b)" (is "?lhs = ?rhs")
proof-
  {
    assume "?lhs"
    hence "?rhs"
      using assms
    proof (induct l)
      case (Cons m l')
      {
        assume "a = m"
        have "b = m"
        proof-
          from `a = m`
          have "firstPos a (m # l') = 0"
            by simp
          with Cons
          have "firstPos b (m # l') = 0"
            by simp
          with `b \<in> set (m # l')`
          have "firstPos b (m # l') = 0"
            by simp
          thus ?thesis
            using firstPosEqualZero[of "b" "m" "l'"]
            by simp
        qed
        with `a = m`
        have ?case
          by simp
      }
      note * = this
      moreover
      {
        assume "b = m"
        have "a = m"
        proof-
          from `b = m`
          have "firstPos b (m # l') = 0"
            by simp
          with Cons
          have "firstPos a (m # l') = 0"
            by simp
          with `a \<in> set (m # l')`
          have "firstPos a (m # l') = 0"
            by simp
          thus ?thesis
            using firstPosEqualZero[of "a" "m" "l'"]
            by simp
        qed
        with `b = m`
        have ?case
          by simp
      }
      note ** = this
      moreover
      {
        assume Q: "a \<noteq> m" "b \<noteq> m"
        from Q `a \<in> set (m # l')`
        have "a \<in> set l'"
          by simp
        from Q `b \<in> set (m # l')`
        have "b \<in> set l'"
          by simp
        from `a \<in> set l'` `b \<in> set l'` Cons
        have "firstPos a l' = firstPos b l'"
          by (simp split: split_if_asm)
        with Cons
        have ?case
          by (simp split: split_if_asm)
      }
      note *** = this
      moreover
      {
        have "a = m \<or> b = m \<or> a \<noteq> m \<and> b \<noteq> m"
          by auto
      }
      ultimately
      show ?thesis
      proof (cases "a = m")
        case True
        thus ?thesis
          by (rule *)
      next
        case False
        thus ?thesis
        proof (cases "b = m")
          case True
          thus ?thesis
            by (rule **)
        next
          case False
          with `a \<noteq> m` show ?thesis
            by (rule ***)
        qed
      qed
    qed simp
  } thus ?thesis
    by auto
qed

lemma firstPosLast:
  assumes "l \<noteq> []" "uniq l"
  shows "(firstPos x l = length l - 1) = (x = last l)"
using assms
by (induct l) auto

(*********************************************************)
(*                   precedes                            *)
(*********************************************************)
subsection{* @{term precedes} - ordering relation induced by @{term firstPos} *}
definition precedes :: "'a => 'a => 'a list => bool"
where
"precedes a b l == (a \<in> set l \<and> b \<in> set l \<and>  firstPos a l <= firstPos b l)"

lemma noElementsPrecedesFirstElement:
  assumes "a \<noteq> b"
  shows "\<not> precedes a b (b # list)"
proof-
  {
    assume "precedes a b (b # list)"
    hence "a \<in> set (b # list)" "firstPos a (b # list) <= 0"
      unfolding precedes_def
      by (auto split: split_if_asm)
    hence  "firstPos a (b # list) = 0"
      by auto
    with `a \<noteq> b`
    have False
      using firstPosEqualZero[of "a" "b" "list"]
      by simp
  }
  thus ?thesis
    by auto
qed

lemma lastPrecedesNoElement:
assumes "uniq l"
shows "\<not>(\<exists> a. a \<noteq> last l \<and> precedes (last l) a l)"
proof-
  {
    assume "\<not> ?thesis"
    then obtain "a"
      where "precedes (last l) a l" "a \<noteq> last l"
      by auto
    hence "a \<in> set l" "last l \<in> set l" "firstPos (last l) l \<le> firstPos a l"
      unfolding precedes_def
      by auto
    hence "length l - 1 \<le> firstPos a l"
      using firstPosLast[of "l" "last l"]
      using `uniq l`
      by force
    hence "firstPos a l = length l - 1"
      using firstPosDomainForElements[of "a" "l"]
      using `a \<in> set l`
      by auto
    hence "a = last l"
      using firstPosLast[of "l" "last l"]
      using `a \<in> set l` `last l \<in> set l`
      using `uniq l`
      using firstPosEqual[of "a" "l" "last l"]
      by force
    with `a \<noteq> last l`
    have False
      by simp
  }
  thus ?thesis
    by auto
qed

lemma precedesAppend:
  assumes "precedes a b l"
  shows "precedes a b (l @ l')"
proof-
  from `precedes a b l`
  have "a \<in> set l" "b \<in> set l" "firstPos a l \<le> firstPos b l"
    unfolding precedes_def
    by (auto split: split_if_asm)
  thus ?thesis
    using firstPosAppend[of "a" "l" "l'"]
    using firstPosAppend[of "b" "l" "l'"]
    unfolding precedes_def
    by simp
qed

lemma precedesMemberHeadMemberTail:
  assumes "a \<in> set l1" and "b \<notin> set l1" and "b \<in> set l2"
  shows "precedes a b (l1 @ l2)"
proof-
  from `a \<in> set l1`
  have "firstPos a l1 < length l1"
    using firstPosLeLength [of "a" "l1"]
    by simp
  moreover
  from `a \<in> set l1`
  have "firstPos a (l1 @ l2) = firstPos a l1"
    using firstPosAppend[of "a" "l1" "l2"]
    by simp
  moreover
  from `b \<notin> set l1` `b \<in> set l2`
  have "firstPos b (l1 @ l2) = length l1 + firstPos b l2"
    by (rule firstPosAppendNonMemberFirstMemberSecond)
  moreover
  have "firstPos b l2 \<ge> 0"
    by auto
  ultimately
  show ?thesis
    unfolding precedes_def
    using `a \<in> set l1` `b \<in> set l2`
    by simp
qed

lemma precedesReflexivity:
  assumes "a \<in> set l"
  shows "precedes a a l"
using assms
unfolding precedes_def
by simp

lemma precedesTransitivity:
  assumes
  "precedes a b l" and "precedes b c l"
  shows
  "precedes a c l"
using assms
unfolding precedes_def
by auto

lemma precedesAntisymmetry:
  assumes
  "a \<in> set l" and "b \<in> set l" and
  "precedes a b l" and "precedes b a l"
  shows
  "a = b"
proof-
  from assms
  have "firstPos a l = firstPos b l"
    unfolding precedes_def
    by auto
  thus ?thesis
    using firstPosEqual[of "a" "l" "b"]
    using assms
    by simp
qed

lemma precedesTotalOrder:
  assumes "a \<in> set l" and "b \<in> set l"
  shows "a=b \<or> precedes a b l \<or> precedes b a l"
using assms
unfolding precedes_def
by auto

lemma precedesMap:
  assumes "precedes a b list" and "\<forall> x y. x \<noteq> y \<longrightarrow> f x \<noteq> f y"
  shows "precedes (f a) (f b) (map f list)"
using assms
proof (induct list)
  case (Cons l list')
    {
      assume "a = l"
      have ?case
      proof-
        from `a = l`
        have "firstPos (f a) (map f (l # list')) = 0"
          using firstPosEqualZero[of "f a" "f l" "map f list'"]
          by simp
        moreover
        from `precedes a b (l # list')`
        have "b \<in> set (l # list')"
          unfolding precedes_def
          by simp
        hence "f b \<in> set (map f (l # list'))"
          by auto
        moreover
        hence "firstPos (f b) (map f (l # list')) \<ge>  0"
          by auto
        ultimately
        show ?thesis
          using `a = l` `f b \<in> set (map f (l # list'))`
          unfolding precedes_def
          by simp
      qed
    }
    moreover
    {
      assume "b = l"
      with `precedes a b (l # list')`
      have "a = l"
        using noElementsPrecedesFirstElement[of "a" "l" "list'"]
        by auto
      from `a = l` `b = l`
      have ?case
        unfolding precedes_def
        by simp
    }
    moreover
    {
      assume "a \<noteq> l" "b \<noteq> l"
      with `\<forall> x y. x \<noteq> y \<longrightarrow> f x \<noteq> f y`
      have "f a \<noteq> f l" "f b \<noteq> f l"
        by auto
      from `precedes a b (l # list')`
      have "b \<in> set(l # list')" "a \<in> set(l # list')" "firstPos a (l # list') \<le> firstPos b (l # list')"
        unfolding precedes_def
        by auto
      with `a \<noteq> l` `b \<noteq> l`
      have "a \<in> set list'" "b \<in> set list'" "firstPos a list' \<le> firstPos b list'"
        by auto
      hence "precedes a b list'"
        unfolding precedes_def
        by simp
      with Cons
      have "precedes (f a) (f b) (map f list')"
        by simp
      with `f a \<noteq> f l` `f b \<noteq> f l`
      have ?case
        unfolding precedes_def
        by auto
    }
    ultimately
    show ?case
      by auto
next
  case Nil
  thus ?case
    unfolding precedes_def
    by simp
qed

lemma precedesFilter:
  assumes "precedes a b list" and "f a" and "f b"
  shows "precedes a b (filter f list)"
using assms
proof(induct list)
  case (Cons l list')
  show ?case
  proof-
    from `precedes a b (l # list')`
    have "a \<in> set(l # list')" "b \<in> set(l # list')" "firstPos a (l # list') \<le> firstPos b (l # list')"
      unfolding precedes_def
      by auto
    from `f a` `a \<in> set(l # list')`
    have "a \<in> set(filter f (l # list'))"
      by auto
    moreover
    from `f b` `b \<in> set(l # list')`
    have "b \<in> set(filter f (l # list'))"
      by auto
    moreover
    have "firstPos a (filter f (l # list')) \<le> firstPos b (filter f (l # list'))"
    proof-
      {
        assume "a = l"
        with `f a`
        have "firstPos a (filter f (l # list')) = 0"
          by auto
        with `b \<in> set (filter f (l # list'))`
        have ?thesis
          by auto
      }
      moreover
      {
        assume "b = l"
        with `precedes a b (l # list')`
        have "a = b"
          using noElementsPrecedesFirstElement[of "a" "b" "list'"]
          by auto
        hence ?thesis
          by (simp add: precedesReflexivity)
      }
      moreover
      {
        assume "a \<noteq> l" "b \<noteq> l"
        with `precedes a b (l # list')`
        have "firstPos a list' \<le> firstPos b list'"
          unfolding precedes_def
          by auto
        moreover
        from `a \<noteq> l` `a \<in> set (l # list')`
        have "a \<in> set list'"
          by simp
        moreover
        from `b \<noteq> l` `b \<in> set (l # list')`
        have "b \<in> set list'"
          by simp
        ultimately
        have "precedes a b list'"
          unfolding precedes_def
          by simp
        with `f a` `f b` Cons(1)
        have "precedes a b (filter f list')"
          by simp
        with `a \<noteq> l` `b \<noteq> l`
        have ?thesis
          unfolding precedes_def
          by auto
      }
      ultimately
      show ?thesis
        by blast
    qed
    ultimately
    show ?thesis
      unfolding precedes_def
      by simp
  qed
qed simp

definition
"precedesOrder list == {(a, b). precedes a b list \<and> a \<noteq> b}"

lemma transPrecedesOrder:
  "trans (precedesOrder list)"
proof-
  {
    fix x y z
    assume "precedes x y list" "x \<noteq> y" "precedes y z list" "y \<noteq> z"
    hence "precedes x z list" "x \<noteq> z"
      using precedesTransitivity[of "x" "y" "list" "z"]
      using firstPosEqual[of "y" "list" "z"]
      unfolding precedes_def
      by auto
  }
  thus ?thesis
    unfolding trans_def
    unfolding precedesOrder_def
    by blast
qed

lemma wellFoundedPrecedesOrder:
  shows "wf (precedesOrder list)"
unfolding wf_eq_minimal
proof-
  show "\<forall>Q a. a:Q \<longrightarrow> (\<exists> aMin \<in> Q. \<forall> a'. (a', aMin) \<in> precedesOrder list \<longrightarrow> a' \<notin> Q)"
  proof-
    {
      fix a :: "'a" and Q::"'a set"
      assume "a \<in> Q"
      let ?listQ = "filter (\<lambda> x. x \<in> Q) list"
      have "\<exists> aMin \<in> Q. \<forall> a'. (a', aMin) \<in> precedesOrder list \<longrightarrow> a' \<notin> Q"
      proof (cases "?listQ = []")
        case True
        let ?aMin = a
        have "\<forall> a'. (a', ?aMin) \<in> precedesOrder list \<longrightarrow> a' \<notin> Q"
        proof-
          {
            fix a'
            assume "(a', ?aMin) \<in> precedesOrder list"
            hence "a \<in> set list"
              unfolding precedesOrder_def
              unfolding precedes_def
              by simp
            with `a \<in> Q`
            have "a \<in> set ?listQ"
              by (induct list) auto
            with `?listQ = []`
            have "False"
              by simp
            hence "a' \<notin> Q"
              by simp
          }
          thus ?thesis
            by simp
        qed
        with `a \<in> Q` obtain aMin where "aMin \<in> Q" "\<forall> a'. (a', aMin) \<in> precedesOrder list \<longrightarrow> a' \<notin> Q"
          by auto
        thus ?thesis
          by auto
      next
        case False
        let ?aMin = "hd ?listQ"
        from False
        have "?aMin \<in> Q"
          by (induct list) auto
        have "\<forall> a'. (a', ?aMin) \<in> precedesOrder list \<longrightarrow> a' \<notin> Q"
        proof
          fix a'
          {
            assume "(a', ?aMin) \<in> precedesOrder list"
            hence "a' \<in> set list" "precedes a' ?aMin list" "a' \<noteq> ?aMin"
              unfolding precedesOrder_def
              unfolding precedes_def
              by auto
            have "a' \<notin> Q"
            proof-
              {
                assume "a' \<in> Q"
                with `?aMin \<in> Q` `precedes a' ?aMin list`
                have "precedes a' ?aMin ?listQ"
                    using precedesFilter[of "a'" "?aMin" "list" "\<lambda> x. x \<in> Q"]
                    by blast
                from `a' \<noteq> ?aMin`
                have "\<not> precedes a' (hd ?listQ) (hd ?listQ # tl ?listQ)"
                  by (rule noElementsPrecedesFirstElement)
                with False `precedes a' ?aMin ?listQ`
                have "False"
                  by auto
              }
              thus ?thesis
                by auto
            qed
          } thus "(a', ?aMin) \<in> precedesOrder list \<longrightarrow> a' \<notin> Q"
            by simp
        qed
        with `?aMin \<in> Q`
        show ?thesis
          ..
      qed
    }
    thus ?thesis
      by simp
  qed
qed

(*********************************************************)
(*                   prefix                              *)
(*********************************************************)
subsection{* @{term isPrefix} - prefixes of list. *}
text{* Check if a list is a prefix of another list. Obsolete: similiar
notion is defined in {\em List\_prefixes.thy}. *}

definition
  isPrefix :: "'a list => 'a list => bool"
  where "isPrefix p t = (\<exists> s. p @ s = t)"

lemma prefixIsSubset:
  assumes "isPrefix p l"
  shows "set p \<subseteq> set l"
using assms
unfolding isPrefix_def
by auto

lemma uniqListImpliesUniqPrefix:
assumes "isPrefix p l" and "uniq l"
shows "uniq p"
proof-
  from `isPrefix p l` obtain s
    where "p @ s = l"
    unfolding isPrefix_def
    by auto
  with `uniq l`
  show ?thesis
    using uniqAppend[of "p" "s"]
    by simp
qed

lemma firstPosPrefixElement:
  assumes "isPrefix p l" and "a \<in> set p"
  shows "firstPos a p = firstPos a l"
proof-
  from `isPrefix p l` obtain s
    where "p @ s = l"
    unfolding isPrefix_def
    by auto
  with `a \<in> set p`
  show ?thesis
    using firstPosAppend[of "a" "p" "s"]
    by simp
qed

lemma laterInPrefixRetainsPrecedes:
  assumes
  "isPrefix p l" and "precedes a b l" and "b \<in> set p"
  shows
  "precedes a b p"
proof-
  from `isPrefix p l` obtain s
    where "p @ s = l"
    unfolding isPrefix_def
    by auto
  from `precedes a b l`
  have "a \<in> set l" "b \<in> set l" "firstPos a l \<le> firstPos b l"
    unfolding precedes_def
    by (auto split: split_if_asm)

  from `p @ s = l` `b \<in> set p`
  have "firstPos b l = firstPos b p"
    using firstPosAppend [of "b" "p" "s"]
    by simp

  show ?thesis
  proof (cases "a \<in> set p")
    case True
    from `p @ s = l` `a \<in> set p`
    have "firstPos a l = firstPos a p"
      using firstPosAppend [of "a" "p" "s"]
      by simp

    from `firstPos a l = firstPos a p` `firstPos b l = firstPos b p` `firstPos a l \<le> firstPos b l`
    `a \<in> set p` `b \<in> set p`
    show ?thesis
      unfolding precedes_def
      by simp
  next
    case False
    from `a \<notin> set p` `a \<in> set l` `p @ s = l`
    have "a \<in> set s"
      by auto
    with `a \<notin> set p` `p @ s = l`
    have "firstPos a l = length p + firstPos a s"
      using firstPosAppendNonMemberFirstMemberSecond[of "a" "p" "s"]
      by simp
    moreover
    from `b \<in> set p`
    have "firstPos b p < length p"
      by (rule firstPosLeLength)
    ultimately
    show ?thesis
      using `firstPos b l = firstPos b p` `firstPos a l \<le> firstPos b l`
      by simp
  qed
qed

(*********************************************************)
(*                       List diff                       *)
(*********************************************************)
subsection{* @{term "list_diff"} - the set difference operation on two lists. *}

primrec list_diff :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
"list_diff x [] = x" |
"list_diff x (y#ys) = list_diff (removeAll y x) ys"

lemma [simp]:
  shows "list_diff (x # xs) y = (if x \<in> set y then list_diff xs y else x # list_diff xs y)"
proof (induct y arbitrary: xs)
  case (Cons y ys)
  thus ?case
  proof (cases "x = y")
    case True
    thus ?thesis
      by simp
  next
    case False
    thus ?thesis
    proof (cases "x \<in> set ys")
      case True
      thus ?thesis
        using Cons
        by simp
    next
      case False
      thus ?thesis
        using Cons
        by simp
    qed
  qed
qed simp

lemma listDiffIff:
  shows "(x \<in> set a \<and> x \<notin> set b) = (x \<in> set (list_diff a b))"
by (induct a) auto

lemma listDiffDoubleRemoveAll:
  assumes "x \<in> set a"
  shows "list_diff b a = list_diff b (x # a)"
using assms
by (induct b) auto

lemma removeAllListDiff[simp]:
  shows "removeAll x (list_diff a b) = list_diff (removeAll x a) b"
by (induct a) auto

lemma listDiffRemoveAllNonMember:
  assumes "x \<notin> set a"
  shows "list_diff a b = list_diff a (removeAll x b)"
using assms
proof (induct b arbitrary: a)
  case (Cons y b')
  from `x \<notin> set a`
  have "x \<notin> set (removeAll y a)"
    by auto
  thus ?case
  proof (cases "x = y")
    case False
    thus ?thesis
      using Cons(2)
      using Cons(1)[of "removeAll y a"]
      using `x \<notin> set (removeAll y a)`
      by auto
  next
    case True
    thus ?thesis
      using Cons(1)[of "removeAll y a"]
      using `x \<notin> set a`
      using `x \<notin> set (removeAll y a)`
      by auto
  qed
qed simp

lemma listDiffMap:
  assumes "\<forall> x y. x \<noteq> y \<longrightarrow> f x \<noteq> f y"
  shows "map f (list_diff a b) = list_diff (map f a) (map f b)"
using assms
by (induct b arbitrary: a) (auto simp add: removeAll_map)

(*********************************************************)
(*                       Remdups                         *)
(*********************************************************)
subsection{* @{term remdups} - removing duplicates *}
lemma remdupsRemoveAllCommute[simp]:
  shows "remdups (removeAll a list) = removeAll a (remdups list)"
by (induct list) auto

lemma remdupsAppend:
  shows "remdups (a @ b) = remdups (list_diff a b) @ remdups b"
proof (induct a)
  case (Cons x a')
  thus ?case
    using listDiffIff[of "x" "a'" "b"]
    by auto
qed simp

lemma remdupsAppendSet:
  shows "set (remdups (a @ b)) = set (remdups a @ remdups (list_diff b a))"
proof (induct a)
  case Nil
  thus ?case
    by auto
next
  case (Cons x a')
  thus ?case
  proof (cases "x \<in> set a'")
    case True
    thus ?thesis
      using Cons
      using listDiffDoubleRemoveAll[of "x" "a'" "b"]
      by simp
  next
    case False
    thus ?thesis
    proof (cases "x \<in> set b")
      case True
      show ?thesis
      proof-
        have "set (remdups (x # a') @ remdups (list_diff b (x # a'))) =
          set (x # remdups a' @ remdups (list_diff b (x # a')))"
          using `x \<notin> set a'`
          by auto
        also have "\<dots> = set (x # remdups a' @ remdups (list_diff (removeAll x b) a'))"
          by auto
        also have "\<dots> = set (x # remdups a' @ remdups (removeAll x (list_diff b a')))"
          by simp
        also have "\<dots> = set (remdups a' @ x # remdups (removeAll x (list_diff b a')))"
          by simp
        also have "\<dots> = set (remdups a' @ x # removeAll x (remdups (list_diff b a')))"
          by (simp only: remdupsRemoveAllCommute)
        also have "\<dots> = set (remdups a') \<union> set (x # removeAll x (remdups (list_diff b a')))"
          by simp
        also have "\<dots> = set (remdups a') \<union> {x} \<union> set (removeAll x (remdups (list_diff b a')))"
          by auto
        also have "\<dots> = set (remdups a') \<union> set (remdups (list_diff b a'))"
        proof-
          from `x \<notin> set a'` `x \<in> set b`
          have "x \<in> set (list_diff b a')"
            using listDiffIff[of "x" "b" "a'"]
            by simp
          hence "x \<in> set (remdups (list_diff b a'))"
            by auto
          thus ?thesis
            by auto
        qed
        also have "\<dots> = set (remdups (a' @ b))"
          using Cons(1)
          by simp
        also have "\<dots> = set (remdups ((x # a') @ b))"
          using `x \<in> set b`
          by simp
        finally show ?thesis
          by simp
      qed
    next
      case False
      thus ?thesis
      proof-
        have "set (remdups (x # a') @ remdups (list_diff b (x # a'))) =
          set (x # (remdups a') @ remdups (list_diff b (x # a')))"
          using `x \<notin> set a'`
          by auto
        also have "\<dots> = set (x # remdups a' @ remdups (list_diff (removeAll x b) a'))"
          by auto
        also have "\<dots> = set (x # remdups a' @ remdups (list_diff b a'))"
          using `x \<notin> set b`
          by auto
        also have "\<dots> = {x} \<union> set (remdups (a' @ b))"
          using Cons(1)
          by simp
        also have "\<dots> = set (remdups ((x # a') @ b))"
          by auto
        finally show ?thesis
          by simp
      qed
    qed
  qed
qed

lemma remdupsAppendMultiSet:
  shows "multiset_of (remdups (a @ b)) = multiset_of (remdups a @ remdups (list_diff b a))"
proof (induct a)
  case Nil
  thus ?case
    by auto
next
  case (Cons x a')
  thus ?case
  proof (cases "x \<in> set a'")
    case True
    thus ?thesis
      using Cons
      using listDiffDoubleRemoveAll[of "x" "a'" "b"]
      by simp
    next
    case False
    thus ?thesis
    proof (cases "x \<in> set b")
      case True
      show ?thesis
      proof-
        have "multiset_of (remdups (x # a') @ remdups (list_diff b (x # a'))) =
          multiset_of (x # remdups a' @ remdups (list_diff b (x # a')))"
        proof-
          have "remdups (x # a') = x # remdups a'"
            using `x \<notin> set a'`
            by auto
          thus ?thesis
            by simp
        qed
        also have "\<dots> = multiset_of (x # remdups a' @ remdups (list_diff (removeAll x b) a'))"
          by auto
        also have "\<dots> = multiset_of (x # remdups a' @ remdups (removeAll x (list_diff b a')))"
          by simp
        also have "\<dots> = multiset_of (remdups a' @ x # remdups (removeAll x (list_diff b a')))"
          by (simp add: union_assoc)
        also have "\<dots> = multiset_of (remdups a' @ x # removeAll x (remdups (list_diff b a')))"
          by (simp only: remdupsRemoveAllCommute)
        also have "\<dots> = multiset_of (remdups a') + multiset_of (x # removeAll x (remdups (list_diff b a')))"
          by simp
        also have "\<dots> = multiset_of (remdups a') + {#x#} + multiset_of (removeAll x (remdups (list_diff b a')))"
          by (simp add: union_assoc) (simp add: union_commute)
        also have "\<dots> = multiset_of (remdups a') + multiset_of (remdups (list_diff b a'))"
        proof-
          from `x \<notin> set a'` `x \<in> set b`
          have "x \<in> set (list_diff b a')"
            using listDiffIff[of "x" "b" "a'"]
            by simp
          hence "x \<in> set (remdups (list_diff b a'))"
            by auto
          thus ?thesis
            using removeAll_multiset[of "remdups (list_diff b a')" "x"]
            by (simp add: union_assoc)
        qed
        also have "\<dots> = multiset_of (remdups (a' @ b))"
          using Cons(1)
          by simp
        also have "\<dots> = multiset_of (remdups ((x # a') @ b))"
          using `x \<in> set b`
          by simp
        finally show ?thesis
          by simp
      qed
    next
      case False
      thus ?thesis
      proof-
        have "multiset_of (remdups (x # a') @ remdups (list_diff b (x # a'))) =
          multiset_of (x # remdups a' @ remdups (list_diff b (x # a')))"
        proof-
          have "remdups (x # a') = x # remdups a'"
            using `x \<notin> set a'`
            by auto
          thus ?thesis
            by simp
        qed
        also have "\<dots> = multiset_of (x # remdups a' @ remdups (list_diff (removeAll x b) a'))"
          by auto
        also have "\<dots> = multiset_of (x # remdups a' @ remdups (list_diff b a'))"
          using `x \<notin> set b`
          using removeAll_id[of "x" "b"]
          by simp
        also have "\<dots> = {#x#} + multiset_of (remdups (a' @ b))"
          using Cons(1)
          by (simp add: union_commute)
        also have "\<dots> = multiset_of (remdups ((x # a') @ b))"
          using `x \<notin> set a'` `x \<notin> set b`
          by (auto simp add: union_commute)
        finally show ?thesis
          by simp
      qed
    qed
  qed
qed

lemma remdupsListDiff:
"remdups (list_diff a b) = list_diff (remdups a) (remdups b)"
proof(induct a)
  case Nil
  thus ?case
    by simp
next
  case (Cons x a')
  thus ?case
    using listDiffIff[of "x" "a'" "b"]
    by auto
qed

(*********************************************************)
(*                       Multiset                        *)
(*********************************************************)

(* Repetition of lemmas from Multiset.thy -
   neccessary for r which I do not know how to represent as order instance. *)

definition
"multiset_le a b r == a = b \<or> (a, b) \<in> mult r"

lemma multisetEmptyLeI:
assumes
"trans r"
shows
"multiset_le {#} a r"
unfolding multiset_le_def
using assms
using one_step_implies_mult[of "r" "a" "{#}" "{#}"]
by auto

lemma multisetUnionLessMono2:
shows
  "trans r \<Longrightarrow> (b1, b2) \<in> mult r \<Longrightarrow> (a + b1, a + b2) \<in> mult r"
unfolding mult_def
apply (erule trancl_induct)
apply (blast intro: mult1_union transI)
apply (blast intro: mult1_union transI trancl_trans)
done

lemma multisetUnionLessMono1:
shows
  "trans r \<Longrightarrow> (a1, a2) \<in> mult r \<Longrightarrow> (a1 + b, a2 + b) \<in> mult r"
using union_commute[of "a1" "b"]
using union_commute[of "a2" "b"]
using multisetUnionLessMono2[of "r" "a1" "a2" "b"]
by simp

lemma multisetUnionLeMono2:
assumes
  "trans r"
  "multiset_le b1 b2 r"
shows
  "multiset_le (a + b1) (a + b2) r"
using assms
unfolding multiset_le_def
using multisetUnionLessMono2[of "r" "b1" "b2" "a"]
by auto

lemma multisetUnionLeMono1:
assumes
  "trans r"
  "multiset_le a1 a2 r"
shows
  "multiset_le (a1 + b) (a2 + b) r"
using assms
unfolding multiset_le_def
using multisetUnionLessMono1[of "r" "a1" "a2" "b"]
by auto

lemma multisetLeTrans:
assumes
  "trans r"
  "multiset_le x y r"
  "multiset_le y z r"
shows
  "multiset_le x z r"
using assms
unfolding multiset_le_def
unfolding mult_def
by (blast intro: trancl_trans)

lemma multisetUnionLeMono:
assumes
  "trans r"
  "multiset_le a1 a2 r"
  "multiset_le b1 b2 r"
shows
  "multiset_le (a1 + b1) (a2 + b2) r"
using assms
using multisetUnionLeMono1[of "r" "a1" "a2" "b1"]
using multisetUnionLeMono2[of "r" "b1" "b2" "a2"]
using multisetLeTrans[of "r" "a1 + b1" "a2 + b1" "a2 + b2"]
by simp

lemma multisetLeListDiff:
assumes
  "trans r"
shows
  "multiset_le (multiset_of (list_diff a b)) (multiset_of a) r"
proof (induct a)
  case Nil
  thus ?case
    unfolding multiset_le_def
    by simp
next
  case (Cons x a')
  thus ?case
    using assms
    using multisetEmptyLeI[of "r" "{#x#}"]
    using multisetUnionLeMono[of "r" "multiset_of (list_diff a' b)" "multiset_of a'" "{#}" "{#x#}"]
    using multisetUnionLeMono1[of "r" "multiset_of (list_diff a' b)" "multiset_of a'" "{#x#}"]
    by auto
qed

(*********************************************************)
(*                       Levi                            *)
(*********************************************************)
subsection{* Levi's lemma *}

text{* Obsolete: these two lemmas are already proved as @{term
append_eq_append_conv2} and @{term append_eq_Cons_conv}. *}

lemma FullLevi:
  shows "(x @ y = z @ w) =
                (x = z \<and> y = w \<or>
                (\<exists> t. z @ t = x \<and> t @ y = w) \<or>
                (\<exists> t. x @ t = z \<and> t @ w = y))" (is "?lhs = ?rhs")
proof
  assume "?rhs"
  thus "?lhs"
    by auto
next
  assume "?lhs"
  thus "?rhs"
  proof (induct x arbitrary: z)
    case (Cons a x')
    show ?case
    proof (cases "z = []")
      case True
      with `(a # x') @ y = z @ w`
      obtain t where "z @ t = a # x'" "t @ y = w"
        by auto
      thus ?thesis
        by auto
    next
      case False
      then obtain b and z' where "z = b # z'"
        by (auto simp add: neq_Nil_conv)
      with `(a # x') @ y = z @ w`
      have "x' @ y = z' @ w" "a = b"
        by auto
      with Cons(1)[of "z'"]
      have "x' = z' \<and> y = w \<or> (\<exists>t. z' @ t = x' \<and> t @ y = w) \<or> (\<exists>t. x' @ t = z' \<and> t @ w = y)"
        by simp
      with `a = b` `z = b # z'`
      show ?thesis
        by auto
    qed
  qed simp
qed

lemma SimpleLevi:
  shows "(p @ s = a # list) =
             ( p = [] \<and> s = a # list \<or>
              (\<exists> t. p = a # t \<and> t @ s = list))"
by (induct p) auto

subsection{* Single element lists *}
lemma lengthOneCharacterisation:
  shows "(length l = 1) = (l = [hd l])"
by (induct l) auto

lemma lengthOneImpliesOnlyElement:
  assumes "length l = 1" and "a : set l"
  shows "\<forall> a'. a' : set l \<longrightarrow> a' = a"
proof (cases l)
  case (Cons literal' clause')
  with assms
  show ?thesis
    by auto
qed simp

end


theory sort_SSortSorts
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

fun ssortminimum :: "int => int list => int" where
"ssortminimum x (Nil2) = x"
| "ssortminimum x (Cons2 z ys) =
     (if z <= x then ssortminimum z ys else ssortminimum x ys)"

fun delete :: "int => int list => int list" where
"delete x (Nil2) = Nil2"
| "delete x (Cons2 z ys) =
     (if x = z then ys else Cons2 z (delete x ys))"

fun ssort :: "int list => int list" where
"ssort (Nil2) = Nil2"
| "ssort (Cons2 y ys) =
     Cons2
       (ssortminimum y ys)
       (ssort (delete (ssortminimum y ys) (Cons2 y ys)))"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun ordered :: "int list => bool" where
"ordered (Nil2) = True"
| "ordered (Cons2 y (Nil2)) = True"
| "ordered (Cons2 y (Cons2 y2 xs)) =
     and2 (y <= y2) (ordered (Cons2 y2 xs))"

(*hipster ssortminimum delete ssort and2 ordered *)

theorem x0 :
  "!! (x :: int list) . ordered (ssort x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Prop_Logic
  imports Main
begin

lemma "A \<longrightarrow> A"
  apply (rule impI)
  apply assumption
  done

lemma "A \<and> B \<Longrightarrow> B \<and> A"
  apply (rule conjI)
   apply (erule conjE)
   apply assumption
  apply (erule conjE)
  apply assumption
  done

lemma "P \<or> Q \<Longrightarrow> Q \<or> P"
  apply (erule disjE)
   apply (rule disjI2)
   apply assumption
  apply (rule disjI1)
  apply assumption
  done

lemma "(A \<and> B) \<longrightarrow> (A \<or> B)"
  by (rule impI, erule conjE, rule disjI1)

lemma "((A \<or> B) \<or> C) \<longrightarrow> A \<or> (B \<or> C)"
  apply (rule impI)
  apply (erule disjE)
   apply (erule disjE)
    apply (rule disjI1)
    apply assumption
   apply (rule disjI2)
   apply (rule disjI1)
   apply assumption
  apply (rule disjI2)
  apply (rule disjI2)
  apply assumption
  done

lemma "A \<longrightarrow> B \<longrightarrow> A"
  apply (rule impI)+
  apply assumption
  done

lemma "(A \<or> A) = (A \<and> A)"
  apply (rule iffI)
   apply (erule disjE)
    apply (rule conjI)
     apply assumption+
   apply (rule conjI)
    apply assumption+
  apply (erule conjE)
  apply (rule disjI1)
  apply assumption
  done

lemma "(A \<longrightarrow> B \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> B) \<longrightarrow> A \<longrightarrow> C"
  apply (rule impI)+
  apply (erule impE)
   apply assumption
  apply (erule impE)
   apply assumption
  apply (erule impE)
   apply assumption+
  done

lemma "\<not>\<not>A \<longrightarrow> A"
  apply (rule impI)
  apply (rule classical)
  apply (erule notE)
  apply assumption
  done

lemma "A \<longrightarrow> \<not>\<not>A"
  apply (rule impI)
  apply (rule notI)
  apply (erule notE)
  apply assumption
  done

lemma "(\<not>A \<longrightarrow> B) \<longrightarrow> (\<not>B \<longrightarrow> A)"
  apply (rule impI)+
  apply (rule classical)
  apply (erule impE)
   apply assumption
  apply (erule notE)
  apply assumption
  done

lemma "((A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A"
  apply (rule impI)
  apply (rule classical)
  apply (erule impE)
   apply (rule impI)
   apply (erule notE)
   apply assumption+
  done

lemma "A \<or> \<not>A"
  apply (rule classical)
  apply (rule disjI2)
  apply (rule notI)
  apply (erule notE)
  apply (rule disjI1)
  apply assumption
  done

lemma "(\<not>(A \<and> B)) = (\<not>A \<or> \<not>B)"
  apply (rule iffI)
   apply (rule classical)
   apply (erule notE)
   apply (rule conjI)
    apply (rule classical)
    apply (erule notE)
    apply (rule disjI1)
    apply assumption
   apply (rule classical)
   apply (erule notE)
   apply (rule disjI2)
   apply assumption
  apply (rule notI)
  apply (erule conjE)
  apply (erule disjE)
   apply (erule notE, assumption)+
  done

lemma "(\<not>(A \<or> B)) = (\<not>A \<and> \<not>B)"
  apply (rule iffI)
   apply (rule conjI)
    apply (rule notI)
    apply (erule notE)
    apply (rule disjI1)
    apply assumption
   apply (rule notI)
   apply (erule notE)
   apply (rule disjI2)
   apply assumption
  apply (erule conjE)
  apply (rule notI)
  apply (erule notE)
  apply (erule disjE)
   apply assumption
  apply (rule classical)
  apply (erule notE)
  apply assumption
  done

lemma "p \<and> q \<longleftrightarrow> q \<and> p"
  apply (rule iffI)
   apply (rule conjI)
    apply (erule conjE)
    apply (assumption)
   apply (erule conjE)
   apply (assumption)
  apply (rule conjI)
   apply (erule conjE)
   apply (assumption)
  apply (erule conjE)
  apply (assumption)
  done

end


section\<open>Untyped (Unsorted) First-Order Logic\<close>
theory U
imports TermsAndClauses
begin

text\<open>Even though untyped FOL is a particular case of many-typed FOL, we find
it convenient to represent it separately.\<close>

subsection \<open>Signatures\<close>

locale Signature =
fixes
    wtFsym :: "'fsym \<Rightarrow> bool"
and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> nat"
and parOf :: "'psym \<Rightarrow> nat"
assumes countable_wtFsym: "countable {f::'fsym. wtFsym f}"
and countable_wtPsym: "countable {p::'psym. wtPsym p}"
begin

(* Well-typed terms *)
fun wt where
"wt (Var x) \<longleftrightarrow> True"
|
"wt (Fn f Tl) \<longleftrightarrow> wtFsym f \<and> list_all wt Tl \<and> arOf f = length Tl"

lemma wt_induct[elim, consumes 1, case_names Var Fn, induct pred: wt]:
assumes T: "wt T"
and Var: "\<And> x. \<phi> (Var x)"
and Fn:
"\<And> f Tl.
   \<lbrakk>wtFsym f; list_all wt Tl; arOf f = length Tl; list_all \<phi> Tl\<rbrakk>
 \<Longrightarrow> \<phi> (Fn f Tl)"
shows "\<phi> T"
proof-
  have "wt T \<longrightarrow> \<phi> T"
  apply (induct T) using Var Fn by (auto simp: list_all_iff)
  thus ?thesis using T by auto
qed

(* Well-typed substitutions *)
definition "wtSB \<pi> \<equiv> \<forall> x. wt (\<pi> x)"

lemma wtSB_wt[simp]: "wtSB \<pi> \<Longrightarrow> wt (\<pi> x)"
unfolding wtSB_def by auto

lemma wt_subst[simp]:
assumes "wtSB \<pi>" and "wt T"
shows "wt (subst \<pi> T)"
using assms by (induct T) (auto simp: list_all_length)

lemma wtSB_o:
assumes 1: "wtSB \<pi>1" and 2: "wtSB \<pi>2"
shows "wtSB (subst \<pi>1 o \<pi>2)"
using 2 unfolding wtSB_def using 1 by auto

end (* context Signature *)

subsection \<open>Structures\<close>

(* Environment *)
type_synonym 'univ env = "var \<Rightarrow> 'univ"

(* Structure *)
locale Struct = Signature wtFsym wtPsym arOf parOf
for wtFsym and wtPsym
and arOf :: "'fsym \<Rightarrow> nat"
and parOf :: "'psym \<Rightarrow> nat"
+
fixes
    D :: "'univ \<Rightarrow> bool"
and intF :: "'fsym \<Rightarrow> 'univ list \<Rightarrow> 'univ"
and intP :: "'psym \<Rightarrow> 'univ list \<Rightarrow> bool"
assumes
NE_D: "NE D" and
intF: "\<lbrakk>wtFsym f; length al = arOf f; list_all D al\<rbrakk> \<Longrightarrow> D (intF f al)"
and
dummy: "parOf = parOf \<and> intF = intF \<and> intP = intP"
begin

(* Well-typed environment *)
definition "wtE \<xi> \<equiv> \<forall> x. D (\<xi> x)"

lemma wtTE_D[simp]: "wtE \<xi> \<Longrightarrow> D (\<xi> x)"
unfolding wtE_def by simp

(* Interpretation of terms: *)
fun int where
"int \<xi> (Var x) = \<xi> x"
|
"int \<xi> (Fn f Tl) = intF f (map (int \<xi>) Tl)"

(* Soundness of typing w.r.t. interpretation: *)
lemma wt_int:
assumes wtE: "wtE \<xi>" and wt_T: "wt T"
shows "D (int \<xi> T)"
using wt_T apply(induct T)
apply (metis int.simps(1) wtE wtE_def)
unfolding int.simps apply(rule intF)
unfolding list_all_map comp_def by auto

lemma int_o:
"int (int \<xi> o \<rho>) T = int \<xi> (subst \<rho> T)"
apply(induct T) apply simp_all  unfolding list_all_iff o_def
using map_ext by (metis (lifting, no_types))

lemmas int_subst = int_o[symmetric]

lemma int_o_subst:
"int \<xi> o subst \<rho> = int (int \<xi> o \<rho>)"
apply(rule ext) apply(subst comp_def) unfolding int_o[symmetric] ..

lemma wtE_o:
assumes 1: "wtE \<xi>" and 2: "wtSB \<rho>"
shows "wtE (int \<xi> o \<rho>)"
unfolding wtE_def apply safe
unfolding comp_def apply(rule wt_int[OF 1]) using 2 by auto

end

context Signature begin

text\<open>Well-typed (i.e., well-formed) atoms, literals, caluses and problems:\<close>

fun wtA where
"wtA (Eq T1 T2) \<longleftrightarrow> wt T1 \<and> wt T2"
|
"wtA (Pr p Tl) \<longleftrightarrow> wtPsym p \<and> list_all wt Tl \<and> parOf p = length Tl"

fun wtL where
"wtL (Pos a) \<longleftrightarrow> wtA a"
|
"wtL (Neg a) \<longleftrightarrow> wtA a"

definition "wtC \<equiv> list_all wtL"

definition "wtPB \<Phi> \<equiv> \<forall> c \<in> \<Phi>. wtC c"

end (* context Signature *)

context Struct begin

(* Satisfaction of atoms: *)
fun satA where
"satA \<xi> (Eq T1 T2) \<longleftrightarrow> int \<xi> T1 = int \<xi> T2"
|
"satA \<xi> (Pr r Tl) \<longleftrightarrow> intP r (map (int \<xi>) Tl)"

(* Satisfaction literals: *)
fun satL where
"satL \<xi> (Pos a) \<longleftrightarrow> satA \<xi> a"
|
"satL \<xi> (Neg a) \<longleftrightarrow> \<not> satA \<xi> a"

(* Satisfaction of clauses: *)
definition "satC \<xi> \<equiv> list_ex (satL \<xi>)"

(* satisfaction of problems *)
definition "satPB \<xi> \<Phi> \<equiv> \<forall> c \<in> \<Phi>. satC \<xi> c"

definition "SAT \<Phi> \<equiv> \<forall> \<xi>. wtE \<xi> \<longrightarrow> satPB \<xi> \<Phi>"

end (* context Struct *)

subsection\<open>Problems\<close>

locale Problem = Signature wtFsym wtPsym arOf parOf
for wtFsym and wtPsym
and arOf :: "'fsym \<Rightarrow> nat"
and parOf :: "'psym \<Rightarrow> nat"
+
fixes \<Phi> :: "('fsym, 'psym) prob"
assumes wt_\<Phi>: "wtPB \<Phi>"

subsection\<open>Models of a problem\<close>

locale Model =
  Problem wtFsym wtPsym arOf parOf \<Phi> +
  Struct wtFsym wtPsym arOf parOf D intF intP
for wtFsym and wtPsym
and arOf :: "'fsym \<Rightarrow> nat"
and parOf :: "'psym \<Rightarrow> nat"
and \<Phi> :: "('fsym, 'psym) prob"
and D :: "'univ \<Rightarrow> bool"
and intF :: "'fsym \<Rightarrow> 'univ list \<Rightarrow> 'univ"
and intP :: "'psym \<Rightarrow> 'univ list \<Rightarrow> bool"
+
assumes SAT: "SAT \<Phi>"

end


(*  Title:      HOL/Isar_Examples/Hoare.thy
    Author:     Makarius

A formulation of Hoare logic suitable for Isar.
*)

section \<open>Hoare Logic\<close>

theory Hoare
  imports "HOL-Hoare.Hoare_Tac"
begin

subsection \<open>Abstract syntax and semantics\<close>

text \<open>
  The following abstract syntax and semantics of Hoare Logic over \<^verbatim>\<open>WHILE\<close>
  programs closely follows the existing tradition in Isabelle/HOL of
  formalizing the presentation given in @{cite \<open>\S6\<close> "Winskel:1993"}. See also
  \<^dir>\<open>~~/src/HOL/Hoare\<close> and @{cite "Nipkow:1998:Winskel"}.
\<close>

type_synonym 'a bexp = "'a set"
type_synonym 'a assn = "'a set"
type_synonym 'a var = "'a \<Rightarrow> nat"

datatype 'a com =
    Basic "'a \<Rightarrow> 'a"
  | Seq "'a com" "'a com"    ("(_;/ _)" [60, 61] 60)
  | Cond "'a bexp" "'a com" "'a com"
  | While "'a bexp" "'a assn" "'a var" "'a com"

abbreviation Skip  ("SKIP")
  where "SKIP \<equiv> Basic id"

type_synonym 'a sem = "'a \<Rightarrow> 'a \<Rightarrow> bool"

primrec iter :: "nat \<Rightarrow> 'a bexp \<Rightarrow> 'a sem \<Rightarrow> 'a sem"
  where
    "iter 0 b S s s' \<longleftrightarrow> s \<notin> b \<and> s = s'"
  | "iter (Suc n) b S s s' \<longleftrightarrow> s \<in> b \<and> (\<exists>s''. S s s'' \<and> iter n b S s'' s')"

primrec Sem :: "'a com \<Rightarrow> 'a sem"
  where
    "Sem (Basic f) s s' \<longleftrightarrow> s' = f s"
  | "Sem (c1; c2) s s' \<longleftrightarrow> (\<exists>s''. Sem c1 s s'' \<and> Sem c2 s'' s')"
  | "Sem (Cond b c1 c2) s s' \<longleftrightarrow> (if s \<in> b then Sem c1 s s' else Sem c2 s s')"
  | "Sem (While b x y c) s s' \<longleftrightarrow> (\<exists>n. iter n b (Sem c) s s')"

definition Valid :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a bexp \<Rightarrow> bool"  ("(3\<turnstile> _/ (2_)/ _)" [100, 55, 100] 50)
  where "\<turnstile> P c Q \<longleftrightarrow> (\<forall>s s'. Sem c s s' \<longrightarrow> s \<in> P \<longrightarrow> s' \<in> Q)"

lemma ValidI [intro?]: "(\<And>s s'. Sem c s s' \<Longrightarrow> s \<in> P \<Longrightarrow> s' \<in> Q) \<Longrightarrow> \<turnstile> P c Q"
  by (simp add: Valid_def)

lemma ValidD [dest?]: "\<turnstile> P c Q \<Longrightarrow> Sem c s s' \<Longrightarrow> s \<in> P \<Longrightarrow> s' \<in> Q"
  by (simp add: Valid_def)

subsection \<open>Primitive Hoare rules\<close>

text \<open>
  From the semantics defined above, we derive the standard set of primitive
  Hoare rules; e.g.\ see @{cite \<open>\S6\<close> "Winskel:1993"}. Usually, variant forms
  of these rules are applied in actual proof, see also \S\ref{sec:hoare-isar}
  and \S\ref{sec:hoare-vcg}.

  \<^medskip>
  The \<open>basic\<close> rule represents any kind of atomic access to the state space.
  This subsumes the common rules of \<open>skip\<close> and \<open>assign\<close>, as formulated in
  \S\ref{sec:hoare-isar}.
\<close>

theorem basic: "\<turnstile> {s. f s \<in> P} (Basic f) P"
proof
  fix s s'
  assume s: "s \<in> {s. f s \<in> P}"
  assume "Sem (Basic f) s s'"
  then have "s' = f s" by simp
  with s show "s' \<in> P" by simp
qed

text \<open>
  The rules for sequential commands and semantic consequences are established
  in a straight forward manner as follows.
\<close>

theorem seq: "\<turnstile> P c1 Q \<Longrightarrow> \<turnstile> Q c2 R \<Longrightarrow> \<turnstile> P (c1; c2) R"
proof
  assume cmd1: "\<turnstile> P c1 Q" and cmd2: "\<turnstile> Q c2 R"
  fix s s'
  assume s: "s \<in> P"
  assume "Sem (c1; c2) s s'"
  then obtain s'' where sem1: "Sem c1 s s''" and sem2: "Sem c2 s'' s'"
    by auto
  from cmd1 sem1 s have "s'' \<in> Q" ..
  with cmd2 sem2 show "s' \<in> R" ..
qed

theorem conseq: "P' \<subseteq> P \<Longrightarrow> \<turnstile> P c Q \<Longrightarrow> Q \<subseteq> Q' \<Longrightarrow> \<turnstile> P' c Q'"
proof
  assume P'P: "P' \<subseteq> P" and QQ': "Q \<subseteq> Q'"
  assume cmd: "\<turnstile> P c Q"
  fix s s' :: 'a
  assume sem: "Sem c s s'"
  assume "s \<in> P'" with P'P have "s \<in> P" ..
  with cmd sem have "s' \<in> Q" ..
  with QQ' show "s' \<in> Q'" ..
qed

text \<open>
  The rule for conditional commands is directly reflected by the corresponding
  semantics; in the proof we just have to look closely which cases apply.
\<close>

theorem cond:
  assumes case_b: "\<turnstile> (P \<inter> b) c1 Q"
    and case_nb: "\<turnstile> (P \<inter> -b) c2 Q"
  shows "\<turnstile> P (Cond b c1 c2) Q"
proof
  fix s s'
  assume s: "s \<in> P"
  assume sem: "Sem (Cond b c1 c2) s s'"
  show "s' \<in> Q"
  proof cases
    assume b: "s \<in> b"
    from case_b show ?thesis
    proof
      from sem b show "Sem c1 s s'" by simp
      from s b show "s \<in> P \<inter> b" by simp
    qed
  next
    assume nb: "s \<notin> b"
    from case_nb show ?thesis
    proof
      from sem nb show "Sem c2 s s'" by simp
      from s nb show "s \<in> P \<inter> -b" by simp
    qed
  qed
qed

text \<open>
  The \<open>while\<close> rule is slightly less trivial --- it is the only one based on
  recursion, which is expressed in the semantics by a Kleene-style least
  fixed-point construction. The auxiliary statement below, which is by
  induction on the number of iterations is the main point to be proven; the
  rest is by routine application of the semantics of \<^verbatim>\<open>WHILE\<close>.
\<close>

theorem while:
  assumes body: "\<turnstile> (P \<inter> b) c P"
  shows "\<turnstile> P (While b X Y c) (P \<inter> -b)"
proof
  fix s s' assume s: "s \<in> P"
  assume "Sem (While b X Y c) s s'"
  then obtain n where "iter n b (Sem c) s s'" by auto
  from this and s show "s' \<in> P \<inter> -b"
  proof (induct n arbitrary: s)
    case 0
    then show ?case by auto
  next
    case (Suc n)
    then obtain s'' where b: "s \<in> b" and sem: "Sem c s s''"
      and iter: "iter n b (Sem c) s'' s'" by auto
    from Suc and b have "s \<in> P \<inter> b" by simp
    with body sem have "s'' \<in> P" ..
    with iter show ?case by (rule Suc)
  qed
qed

subsection \<open>Concrete syntax for assertions\<close>

text \<open>
  We now introduce concrete syntax for describing commands (with embedded
  expressions) and assertions. The basic technique is that of semantic
  ``quote-antiquote''. A \<^emph>\<open>quotation\<close> is a syntactic entity delimited by an
  implicit abstraction, say over the state space. An \<^emph>\<open>antiquotation\<close> is a
  marked expression within a quotation that refers the implicit argument; a
  typical antiquotation would select (or even update) components from the
  state.

  We will see some examples later in the concrete rules and applications.

  \<^medskip>
  The following specification of syntax and translations is for Isabelle
  experts only; feel free to ignore it.

  While the first part is still a somewhat intelligible specification of the
  concrete syntactic representation of our Hoare language, the actual ``ML
  drivers'' is quite involved. Just note that the we re-use the basic
  quote/antiquote translations as already defined in Isabelle/Pure (see \<^ML>\<open>Syntax_Trans.quote_tr\<close>, and \<^ML>\<open>Syntax_Trans.quote_tr'\<close>,).
\<close>

syntax
  "_quote" :: "'b \<Rightarrow> ('a \<Rightarrow> 'b)"
  "_antiquote" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'b"  ("\<acute>_" [1000] 1000)
  "_Subst" :: "'a bexp \<Rightarrow> 'b \<Rightarrow> idt \<Rightarrow> 'a bexp"  ("_[_'/\<acute>_]" [1000] 999)
  "_Assert" :: "'a \<Rightarrow> 'a set"  ("(\<lbrace>_\<rbrace>)" [0] 1000)
  "_Assign" :: "idt \<Rightarrow> 'b \<Rightarrow> 'a com"  ("(\<acute>_ :=/ _)" [70, 65] 61)
  "_Cond" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com \<Rightarrow> 'a com"
    ("(0IF _/ THEN _/ ELSE _/ FI)" [0, 0, 0] 61)
  "_While_inv" :: "'a bexp \<Rightarrow> 'a assn \<Rightarrow> 'a com \<Rightarrow> 'a com"
    ("(0WHILE _/ INV _ //DO _ /OD)"  [0, 0, 0] 61)
  "_While" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com"  ("(0WHILE _ //DO _ /OD)"  [0, 0] 61)

translations
  "\<lbrace>b\<rbrace>" \<rightharpoonup> "CONST Collect (_quote b)"
  "B [a/\<acute>x]" \<rightharpoonup> "\<lbrace>\<acute>(_update_name x (\<lambda>_. a)) \<in> B\<rbrace>"
  "\<acute>x := a" \<rightharpoonup> "CONST Basic (_quote (\<acute>(_update_name x (\<lambda>_. a))))"
  "IF b THEN c1 ELSE c2 FI" \<rightharpoonup> "CONST Cond \<lbrace>b\<rbrace> c1 c2"
  "WHILE b INV i DO c OD" \<rightharpoonup> "CONST While \<lbrace>b\<rbrace> i (\<lambda>_. 0) c"
  "WHILE b DO c OD" \<rightleftharpoons> "WHILE b INV CONST undefined DO c OD"

parse_translation \<open>
  let
    fun quote_tr [t] = Syntax_Trans.quote_tr \<^syntax_const>\<open>_antiquote\<close> t
      | quote_tr ts = raise TERM ("quote_tr", ts);
  in [(\<^syntax_const>\<open>_quote\<close>, K quote_tr)] end
\<close>

text \<open>
  As usual in Isabelle syntax translations, the part for printing is more
  complicated --- we cannot express parts as macro rules as above. Don't look
  here, unless you have to do similar things for yourself.
\<close>

print_translation \<open>
  let
    fun quote_tr' f (t :: ts) =
          Term.list_comb (f $ Syntax_Trans.quote_tr' \<^syntax_const>\<open>_antiquote\<close> t, ts)
      | quote_tr' _ _ = raise Match;

    val assert_tr' = quote_tr' (Syntax.const \<^syntax_const>\<open>_Assert\<close>);

    fun bexp_tr' name ((Const (\<^const_syntax>\<open>Collect\<close>, _) $ t) :: ts) =
          quote_tr' (Syntax.const name) (t :: ts)
      | bexp_tr' _ _ = raise Match;

    fun assign_tr' (Abs (x, _, f $ k $ Bound 0) :: ts) =
          quote_tr' (Syntax.const \<^syntax_const>\<open>_Assign\<close> $ Syntax_Trans.update_name_tr' f)
            (Abs (x, dummyT, Syntax_Trans.const_abs_tr' k) :: ts)
      | assign_tr' _ = raise Match;
  in
   [(\<^const_syntax>\<open>Collect\<close>, K assert_tr'),
    (\<^const_syntax>\<open>Basic\<close>, K assign_tr'),
    (\<^const_syntax>\<open>Cond\<close>, K (bexp_tr' \<^syntax_const>\<open>_Cond\<close>)),
    (\<^const_syntax>\<open>While\<close>, K (bexp_tr' \<^syntax_const>\<open>_While_inv\<close>))]
  end
\<close>

subsection \<open>Rules for single-step proof \label{sec:hoare-isar}\<close>

text \<open>
  We are now ready to introduce a set of Hoare rules to be used in single-step
  structured proofs in Isabelle/Isar. We refer to the concrete syntax
  introduce above.

  \<^medskip>
  Assertions of Hoare Logic may be manipulated in calculational proofs, with
  the inclusion expressed in terms of sets or predicates. Reversed order is
  supported as well.
\<close>

lemma [trans]: "\<turnstile> P c Q \<Longrightarrow> P' \<subseteq> P \<Longrightarrow> \<turnstile> P' c Q"
  by (unfold Valid_def) blast
lemma [trans] : "P' \<subseteq> P \<Longrightarrow> \<turnstile> P c Q \<Longrightarrow> \<turnstile> P' c Q"
  by (unfold Valid_def) blast

lemma [trans]: "Q \<subseteq> Q' \<Longrightarrow> \<turnstile> P c Q \<Longrightarrow> \<turnstile> P c Q'"
  by (unfold Valid_def) blast
lemma [trans]: "\<turnstile> P c Q \<Longrightarrow> Q \<subseteq> Q' \<Longrightarrow> \<turnstile> P c Q'"
  by (unfold Valid_def) blast

lemma [trans]:
    "\<turnstile> \<lbrace>\<acute>P\<rbrace> c Q \<Longrightarrow> (\<And>s. P' s \<longrightarrow> P s) \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P'\<rbrace> c Q"
  by (simp add: Valid_def)
lemma [trans]:
    "(\<And>s. P' s \<longrightarrow> P s) \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P\<rbrace> c Q \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P'\<rbrace> c Q"
  by (simp add: Valid_def)

lemma [trans]:
    "\<turnstile> P c \<lbrace>\<acute>Q\<rbrace> \<Longrightarrow> (\<And>s. Q s \<longrightarrow> Q' s) \<Longrightarrow> \<turnstile> P c \<lbrace>\<acute>Q'\<rbrace>"
  by (simp add: Valid_def)
lemma [trans]:
    "(\<And>s. Q s \<longrightarrow> Q' s) \<Longrightarrow> \<turnstile> P c \<lbrace>\<acute>Q\<rbrace> \<Longrightarrow> \<turnstile> P c \<lbrace>\<acute>Q'\<rbrace>"
  by (simp add: Valid_def)

text \<open>
  Identity and basic assignments.\<^footnote>\<open>The \<open>hoare\<close> method introduced in
  \S\ref{sec:hoare-vcg} is able to provide proper instances for any number of
  basic assignments, without producing additional verification conditions.\<close>
\<close>

lemma skip [intro?]: "\<turnstile> P SKIP P"
proof -
  have "\<turnstile> {s. id s \<in> P} SKIP P" by (rule basic)
  then show ?thesis by simp
qed

lemma assign: "\<turnstile> P [\<acute>a/\<acute>x::'a] \<acute>x := \<acute>a P"
  by (rule basic)

text \<open>
  Note that above formulation of assignment corresponds to our preferred way
  to model state spaces, using (extensible) record types in HOL @{cite
  "Naraschewski-Wenzel:1998:HOOL"}. For any record field \<open>x\<close>, Isabelle/HOL
  provides a functions \<open>x\<close> (selector) and \<open>x_update\<close> (update). Above, there is
  only a place-holder appearing for the latter kind of function: due to
  concrete syntax \<open>\<acute>x := \<acute>a\<close> also contains \<open>x_update\<close>.\<^footnote>\<open>Note that due to the
  external nature of HOL record fields, we could not even state a general
  theorem relating selector and update functions (if this were required here);
  this would only work for any particular instance of record fields introduced
  so far.\<close>

  \<^medskip>
  Sequential composition --- normalizing with associativity achieves proper of
  chunks of code verified separately.
\<close>

lemmas [trans, intro?] = seq

lemma seq_assoc [simp]: "\<turnstile> P c1;(c2;c3) Q \<longleftrightarrow> \<turnstile> P (c1;c2);c3 Q"
  by (auto simp add: Valid_def)

text \<open>Conditional statements.\<close>

lemmas [trans, intro?] = cond

lemma [trans, intro?]:
  "\<turnstile> \<lbrace>\<acute>P \<and> \<acute>b\<rbrace> c1 Q
      \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P \<and> \<not> \<acute>b\<rbrace> c2 Q
      \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P\<rbrace> IF \<acute>b THEN c1 ELSE c2 FI Q"
    by (rule cond) (simp_all add: Valid_def)

text \<open>While statements --- with optional invariant.\<close>

lemma [intro?]: "\<turnstile> (P \<inter> b) c P \<Longrightarrow> \<turnstile> P (While b P V c) (P \<inter> -b)"
  by (rule while)

lemma [intro?]: "\<turnstile> (P \<inter> b) c P \<Longrightarrow> \<turnstile> P (While b undefined V c) (P \<inter> -b)"
  by (rule while)

lemma [intro?]:
  "\<turnstile> \<lbrace>\<acute>P \<and> \<acute>b\<rbrace> c \<lbrace>\<acute>P\<rbrace>
    \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P\<rbrace> WHILE \<acute>b INV \<lbrace>\<acute>P\<rbrace> DO c OD \<lbrace>\<acute>P \<and> \<not> \<acute>b\<rbrace>"
  by (simp add: while Collect_conj_eq Collect_neg_eq)

lemma [intro?]:
  "\<turnstile> \<lbrace>\<acute>P \<and> \<acute>b\<rbrace> c \<lbrace>\<acute>P\<rbrace>
    \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P\<rbrace> WHILE \<acute>b DO c OD \<lbrace>\<acute>P \<and> \<not> \<acute>b\<rbrace>"
  by (simp add: while Collect_conj_eq Collect_neg_eq)

subsection \<open>Verification conditions \label{sec:hoare-vcg}\<close>

text \<open>
  We now load the \<^emph>\<open>original\<close> ML file for proof scripts and tactic definition
  for the Hoare Verification Condition Generator (see \<^dir>\<open>~~/src/HOL/Hoare\<close>).
  As far as we are concerned here, the result is a proof method \<open>hoare\<close>, which
  may be applied to a Hoare Logic assertion to extract purely logical
  verification conditions. It is important to note that the method requires
  \<^verbatim>\<open>WHILE\<close> loops to be fully annotated with invariants beforehand.
  Furthermore, only \<^emph>\<open>concrete\<close> pieces of code are handled --- the underlying
  tactic fails ungracefully if supplied with meta-variables or parameters, for
  example.
\<close>

lemma SkipRule: "p \<subseteq> q \<Longrightarrow> Valid p (Basic id) q"
  by (auto simp add: Valid_def)

lemma BasicRule: "p \<subseteq> {s. f s \<in> q} \<Longrightarrow> Valid p (Basic f) q"
  by (auto simp: Valid_def)

lemma SeqRule: "Valid P c1 Q \<Longrightarrow> Valid Q c2 R \<Longrightarrow> Valid P (c1;c2) R"
  by (auto simp: Valid_def)

lemma CondRule:
  "p \<subseteq> {s. (s \<in> b \<longrightarrow> s \<in> w) \<and> (s \<notin> b \<longrightarrow> s \<in> w')}
    \<Longrightarrow> Valid w c1 q \<Longrightarrow> Valid w' c2 q \<Longrightarrow> Valid p (Cond b c1 c2) q"
  by (auto simp: Valid_def)

lemma iter_aux:
  "\<forall>s s'. Sem c s s' \<longrightarrow> s \<in> I \<and> s \<in> b \<longrightarrow> s' \<in> I \<Longrightarrow>
       (\<And>s s'. s \<in> I \<Longrightarrow> iter n b (Sem c) s s' \<Longrightarrow> s' \<in> I \<and> s' \<notin> b)"
  by (induct n) auto

lemma WhileRule:
    "p \<subseteq> i \<Longrightarrow> Valid (i \<inter> b) c i \<Longrightarrow> i \<inter> (-b) \<subseteq> q \<Longrightarrow> Valid p (While b i v c) q"
  apply (clarsimp simp: Valid_def)
  apply (drule iter_aux)
    prefer 2
    apply assumption
   apply blast
  apply blast
  done

declare BasicRule [Hoare_Tac.BasicRule]
  and SkipRule [Hoare_Tac.SkipRule]
  and SeqRule [Hoare_Tac.SeqRule]
  and CondRule [Hoare_Tac.CondRule]
  and WhileRule [Hoare_Tac.WhileRule]

method_setup hoare =
  \<open>Scan.succeed (fn ctxt =>
    (SIMPLE_METHOD'
      (Hoare_Tac.hoare_tac ctxt
        (simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm "Record.K_record_comp"}] )))))\<close>
  "verification condition generator for Hoare logic"

end