subsection "Lemmas of the elimVar function"

theory EliminateVariable
  imports LinearCase QuadraticCase  "HOL-Library.Quadratic_Discriminant"
begin

lemma elimVar_eq :
  assumes hlength : "length xs = var"
  assumes in_list : "Eq p \<in> set(L)"
  assumes low_pow : "MPoly_Type.degree p var = 1 \<or> MPoly_Type.degree p var = 2"
  shows "((\<exists>x. eval (list_conj (map fm.Atom L @ F)) (xs @ x # \<Gamma>)) =
    ((\<exists>x. eval (elimVar var L F (Eq p)) (xs @ x # \<Gamma>)))\<or> (\<forall>x. aEval (Eq p) (xs @ x # \<Gamma>)))"
proof-

  { fix x
    define A where "A = (isolate_variable_sparse p var 2)"
    define B where "B = (isolate_variable_sparse p var 1)"
    define C where "C = (isolate_variable_sparse p var 0)"
    have freeA : "var \<notin> vars A"
      unfolding A_def
      by (simp add: not_in_isovarspar)
    have freeB : "var \<notin> vars B"
      unfolding B_def
      by (simp add: not_in_isovarspar)
    have freeC : "var \<notin> vars C"
      unfolding C_def
      by (simp add: not_in_isovarspar)
    assume "eval (list_conj (map fm.Atom L @ F)) (xs @ x # \<Gamma>)"
    then have h : "(\<forall>a\<in>set L. aEval a (xs @ x # \<Gamma>)) \<and> (\<forall>f\<in>set F. eval f (xs @ x # \<Gamma>))"
      apply(simp add:eval_list_conj)
      by (meson Un_iff eval.simps(1) image_eqI)
    define X where "X=xs@x#\<Gamma>"
    have Xlength : "length X > var"
      using X_def hlength by auto
    define Aval where "Aval = insertion (nth_default 0 (list_update X var x)) A"
    define Bval where "Bval = insertion (nth_default 0 (list_update X var x)) B"
    define Cval where "Cval = insertion (nth_default 0 (list_update X var x)) C"
    have hinsert : "(xs @ x # \<Gamma>)[var := x] = (xs @ x #\<Gamma>)"
      using hlength by auto
    have allAval : "\<forall>x. insertion (nth_default 0 (xs @ x # \<Gamma>)) A = Aval"
      using Aval_def
      using not_contains_insertion[where var="var", where p = "A", OF freeA, where L = "xs @ x #\<Gamma>", where x="x", where val="Aval"]
      unfolding X_def hinsert using hlength by auto
    have allBval : "\<forall>x. insertion (nth_default 0 (xs @ x # \<Gamma>)) B = Bval"
      using Bval_def
      using not_contains_insertion[where var="var", where p = "B", OF freeB, where L = "xs @ x #\<Gamma>", where x="x", where val="Bval"]
      unfolding X_def hinsert using hlength by auto
    have allCval : "\<forall>x. insertion (nth_default 0 (xs @ x # \<Gamma>)) C = Cval"
      using Cval_def
      using not_contains_insertion[where var="var", where p = "C", OF freeC, where L = "xs @ x #\<Gamma>", where x="x", where val="Cval"]
      unfolding X_def hinsert using hlength by auto
    have insertion_p : "insertion (nth_default 0 X) p = 0"
      using in_list h aEval.simps(1) X_def by fastforce
    have express_p : "p = A * Var var ^ 2 + B * Var var + C"
      using express_poly[OF low_pow] unfolding A_def B_def C_def
      by fastforce
    have insertion_p' : "Aval *x^2+Bval *x+Cval = 0"
      using express_p insertion_p unfolding Aval_def Bval_def Cval_def X_def hinsert
      apply(simp add: insertion_add insertion_mult insertion_pow)
      using  insertion_var by (metis X_def Xlength hinsert)
    have biglemma : "
       ((Aval = 0 \<and>
        Bval \<noteq> 0 \<and>
        (\<forall>f\<in>set L. aEval (linear_substitution var (-C) B f) (xs @ x # \<Gamma>)) \<and>
        (\<forall>f\<in>set F. eval (linear_substitution_fm var (-C) B f) (xs @ x # \<Gamma>)) \<or>
        Aval \<noteq> 0 \<and>
        insertion (nth_default 0 (xs @ x # \<Gamma>)) 4 *
        Aval *
        Cval
        \<le> (Bval)\<^sup>2 \<and>
        ((\<forall>f\<in>set L. eval (quadratic_sub var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>))\<and>
         (\<forall>f\<in>set F. eval (quadratic_sub_fm var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>)) \<or>
         (\<forall>f\<in>set L. eval (quadratic_sub var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>)) \<and>
         (\<forall>f\<in>set F. eval (quadratic_sub_fm var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>))) \<or>
        Aval = 0 \<and>
        Bval = 0 \<and>
        Cval = 0))"
    proof(cases "Aval=0")
      case True
      then have aval0 : "Aval=0" by simp
      show ?thesis proof(cases "Bval=0")
        case True
        then have bval0 :  "Bval=0" by simp
        have h : "eval (list_conj (map fm.Atom L @ F)) (xs @ x # \<Gamma>)"
          using hlength h unfolding X_def
          using \<open>eval (list_conj (map fm.Atom L @ F)) (xs @ x # \<Gamma>)\<close> by blast
        show ?thesis proof(cases "Cval=0")
          case True
          show ?thesis
            by(simp add:aval0 True bval0)
        next
          case False
          show ?thesis
            using insertion_p' aval0 bval0 False by(simp)
        qed
      next
        case False
        have bh : "insertion (nth_default 0 (X[var := - Cval / Bval])) B = Bval"
          using allBval unfolding X_def
          using Bval_def X_def freeB not_contains_insertion by blast
        have ch : "insertion (nth_default 0 (X[var := - Cval / Bval])) C = Cval"
          using allCval unfolding X_def
          using Cval_def X_def freeC not_contains_insertion by blast
        have xh : "x=-Cval/Bval"
        proof-
          have "Bval*x+Cval = 0"
            using insertion_p' aval0
            by simp
          then show ?thesis using False
            by (smt nonzero_mult_div_cancel_left)
        qed
        have freecneg : "var \<notin> vars (-C)" using freeC not_in_neg by auto
        have h1:  "(\<forall>a\<in>set L. aEval (linear_substitution var (-C) (B) a) (X[var := x]))"
          using h xh Bval_def Cval_def False LinearCase.linear[OF Xlength False freecneg freeB, of "-Cval"] freeB freeC freecneg
          by (metis X_def hinsert insertion_neg)
        have h2 : "\<forall>f\<in>set F. eval (linear_substitution_fm var (-C) B f) (X[var := x])"
          using h xh Bval_def Cval_def False LinearCase.linear_fm[OF Xlength False freecneg freeB, of "-Cval"] freeB freeC
          by (metis X_def hinsert insertion_neg)
        show ?thesis using h1 h2 apply(simp add:aval0 False)
          using X_def hlength
          using hinsert by auto
      qed
    next
      case False
      then have aval0 : "Aval \<noteq>0" by simp
      have h4 : "insertion (nth_default 0 (X[var := x])) 4 = 4"
        using insertion_const[where f = "(nth_default 0 (X[var := x]))", where c="4"]
        by (metis MPoly_Type.insertion_one insertion_add numeral_Bit0 one_add_one)
      show ?thesis proof(cases "4 * Aval * Cval \<le> Bval\<^sup>2")
        case True
        have h1a : "var\<notin>vars(-B)"
          by(simp add: freeB not_in_neg)
        have h1b : "var\<notin>vars(1::real mpoly)"
          using isolate_var_one not_in_isovarspar by blast
        have h1c : "var\<notin>vars(-1::real mpoly)"
          by(simp add: h1b not_in_neg)
        have h1d : "var\<notin>vars(4::real mpoly)"
          by (metis h1b not_in_add numeral_Bit0 one_add_one)
        have h1e : "var\<notin>vars(B^2-4*A*C)"
          by(simp add: freeB h1d freeA freeC not_in_mult not_in_pow not_in_sub)
        have h1f : "var\<notin>vars(2::real mpoly)"
          using h1b not_in_add by fastforce
        have h1g : "var\<notin>vars(2*A)"
          by(simp add: freeA h1f not_in_mult)
        have h1h : "freeIn var (quadratic_sub var (-B) (1) (B^2-4*A*C) (2*A) a)"
          using free_in_quad h1a h1b h1e h1g by blast
        have h1i : "freeIn var (quadratic_sub var (-B) (-1) (B^2-4*A*C) (2*A) a)"
          using free_in_quad h1a h1c h1e h1g by blast
        have h2 : "2*Aval \<noteq> 0" using aval0 by auto
        have h3 : "0 \<le> (Bval^2-4*Aval*Cval)" using True by auto
        have h4a : "var \<notin> vars 4"
          by (metis monom_numeral notInKeys_notInVars not_in_add not_in_isovarspar not_in_pow one_add_one power.simps(1) rel_simps(76) vars_monom_keys)
        have h4 : "var \<notin> vars (B^2-4*A*C)" by(simp add: h4a freeA freeB freeC not_in_pow not_in_mult not_in_sub)
        have h5 : "\<forall>x. insertion (nth_default 0 (list_update X var x)) (-B) = -Bval "
          using allBval apply(simp add: insertion_neg)
          by (simp add: B_def Bval_def insertion_isovarspars_free)
        have h6 : "\<forall>x. insertion (nth_default 0 (list_update X var x)) 1 = 1" by simp
        have h6a : "\<forall>x. insertion (nth_default 0 (list_update X var x)) (-1) = (-1)" using h6 by (simp add: insertion_neg)
        have h7a : "\<forall>x. insertion (nth_default 0 (list_update X var x)) 4 = 4" by (metis h6 insertion_add numeral_Bit0 one_add_one)
        have h7b : "var \<notin> vars(4*A*C)" using freeA freeC by (simp add: h4a not_in_mult)
        have h7c : "var \<notin> vars(B^2)" using freeB not_in_pow by auto
        have h7 : "\<forall>x. insertion (nth_default 0 (list_update X var x)) (B^2-4*A*C) = (Bval^2-4*Aval*Cval)"
          using h7a allAval allBval allCval unfolding X_def  using hlength
          apply (simp add: insertion_mult insertion_sub power2_eq_square)
          by (metis A_def Aval_def Bval_def C_def Cval_def X_def freeB insertion_isovarspars_free not_contains_insertion)
        have h8a : "\<forall>x. insertion (nth_default 0 (list_update X var x)) 2 = 2" by (metis h6 insertion_add one_add_one)
        have h8 : "\<forall>x. insertion (nth_default 0 (list_update X var x)) (2*A) = (2*Aval)"
          apply(simp add: allAval h8a insertion_mult)
          by (simp add: A_def Aval_def insertion_isovarspars_free)

        have h1 : "- Bval\<^sup>2 + 4 * Aval * Cval \<le> 0"
          using True by simp
        have xh : "x = (- Bval + sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval)\<or>x=(- Bval - sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval)"
          using insertion_p' aval0 h1
            discriminant_iff unfolding discrim_def by blast
        have p1 : "x = (- Bval + sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval) \<Longrightarrow>
                                                            ((\<forall>a\<in> set L. eval (quadratic_sub var (-B) 1 (B^2-4*A*C) (2*A) a) (X[var := x]))
                                                      \<and>(\<forall>a\<in> set F. eval (quadratic_sub_fm var (-B) 1 (B^2-4*A*C) (2*A) a) (X[var := x])))"
        proof-
          assume x_def : "x = (- Bval + sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval)"
          then have h : "(\<forall>a\<in>set L. aEval a (X[var := (- Bval + sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval)])) \<and> (\<forall>f\<in>set F. eval f (X[var := (- Bval + sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval)]))"
            using h
            using X_def hinsert by auto
          { fix a
            assume in_list : "a\<in> set L"
            have "eval (quadratic_sub var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) a) (X[var := x])"
              using free_in_quad[where a="-B",where b="1", where c="(B^2-4*A*C)", where d="2*A",where var="var",OF h1a h1b h1e h1g]
              using quadratic_sub[where a="-B",where b="1", where c="(B^2-4*A*C)", where d="2*A",where var="var", where L="X", OF Xlength,
                  where Dv="2*Aval", OF h2, where Cv="(Bval^2-4*Aval*Cval)", OF h3, where Av="-Bval", OF h4 h5, where Bv="1", OF h6 h7 h8]
                  h in_list
              using var_not_in_eval by fastforce

          }
          then have left : "(\<forall>a\<in>set L. eval (quadratic_sub var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) a) (X[var := x]))"
            by simp

          { fix a
            assume in_list : "a\<in> set F"
            have "eval (quadratic_sub_fm var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) a) (X[var := x])"
              using free_in_quad_fm[where a="-B",where b="1", where c="(B^2-4*A*C)", where d="2*A",where var="var",OF h1a h1b h1e h1g]
              using quadratic_sub_fm[where a="-B",where b="1", where c="(B^2-4*A*C)", where d="2*A",where var="var", where L="X", OF Xlength,
                  where Dv="2*Aval", OF h2, where Cv="(Bval^2-4*Aval*Cval)", OF h3, where Av="-Bval", OF h4 h5, where Bv="1", OF h6 h7 h8]
                  h in_list
              using var_not_in_eval by fastforce

          }
          then have right : "(\<forall>a\<in>set F. eval (quadratic_sub_fm var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) a) (X[var := x]))"
            by simp
          show ?thesis
            using right left by simp
        qed

        have p2 : "x = (- Bval - sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval) \<Longrightarrow>
                                                            ((\<forall>a\<in> set L. eval (quadratic_sub var (-B) (-1) (B^2-4*A*C) (2*A) a) (X[var := x]))
                                                      \<and>(\<forall>a\<in> set F. eval (quadratic_sub_fm var (-B) (-1) (B^2-4*A*C) (2*A) a) (X[var := x])))"
        proof -
          assume x_def : "x = (- Bval - sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval)"
          then have h : "(\<forall>a\<in>set L. aEval a (X[var := (- Bval - sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval)])) \<and> (\<forall>f\<in>set F. eval f (X[var := (- Bval - sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval)]))"
            using h
            using X_def hinsert by auto
          then have "(\<forall>a\<in>set L. aEval a (X[var := (- Bval - sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval)])) \<and> (\<forall>f\<in>set F. eval f (X[var := (- Bval - sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval)]))"
            using h  by simp
          { fix a
            assume in_list : "a\<in> set L"
            have "eval (quadratic_sub var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) a) (X[var := x])"
              using free_in_quad[where a="-B",where b="-1", where c="(B^2-4*A*C)", where d="2*A",where var="var",OF h1a h1c h1e h1g]
              using quadratic_sub[where a="-B",where b="-1", where c="(B^2-4*A*C)", where d="2*A",where var="var", where L="X", OF Xlength,
                  where Dv="2*Aval", OF h2, where Cv="(Bval^2-4*Aval*Cval)", OF h3, where Av="-Bval", OF h4 h5, where Bv="-1", OF h6a h7 h8]
                  h in_list
              using var_not_in_eval by fastforce

          }
          then have left : "(\<forall>a\<in>set L. eval (quadratic_sub var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) a) (X[var := x]))"
            by simp

          { fix a
            assume in_list : "a\<in> set F"
            have "eval (quadratic_sub_fm var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) a) (X[var := x])"
              using free_in_quad_fm[where a="-B",where b="-1", where c="(B^2-4*A*C)", where d="2*A",where var="var",OF h1a h1c h1e h1g]
              using quadratic_sub_fm[where a="-B",where b="-1", where c="(B^2-4*A*C)", where d="2*A",where var="var", where L="X", OF Xlength,
                  where Dv="2*Aval", OF h2, where Cv="(Bval^2-4*Aval*Cval)", OF h3, where Av="-Bval", OF h4 h5, where Bv="-1", OF h6a h7 h8]
                  h in_list
              using var_not_in_eval by fastforce

          }
          then have right : "(\<forall>a\<in>set F. eval (quadratic_sub_fm var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) a) (X[var := x]))"
            by simp
          show ?thesis
            using right left by simp
        qed
        have subst4 : "insertion (nth_default 0 (xs @ x # \<Gamma>)) 4 = 4" using h7a hlength X_def by auto
        have disj: "(\<forall>a\<in>set L. eval (quadratic_sub var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) a) (xs @ x # \<Gamma>)) \<and>
                                                            (\<forall>a\<in>set F. eval (quadratic_sub_fm var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) a) (xs @ x # \<Gamma>)) \<or>
                                                            (\<forall>a\<in>set L. eval (quadratic_sub var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) a) (xs @ x # \<Gamma>)) \<and>
                                                            (\<forall>a\<in>set F. eval (quadratic_sub_fm var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) a) (xs @ x # \<Gamma>))"
          using xh p1 p2
          unfolding X_def hinsert  by blast
        show ?thesis apply(simp add: aval0 True h7a subst4) using disj
          unfolding X_def hinsert by auto
      next
        case False
        then have det : "0 < - Bval\<^sup>2 + 4 * Aval * Cval"
          by simp
        show ?thesis apply(simp add: aval0 False h4) using discriminant_negative unfolding discrim_def
          using insertion_p'
          using aval0 det by auto
      qed
    qed
    have "(\<exists>x.
       (insertion (nth_default 0 (xs @ x # \<Gamma>)) A = 0 \<and>
        insertion (nth_default 0 (xs @ x # \<Gamma>)) B \<noteq> 0 \<and>
        (\<forall>f\<in>set L. aEval (linear_substitution var (-C) (B) f) (xs @ x # \<Gamma>)) \<and>
        (\<forall>f\<in>set F. eval (linear_substitution_fm var (-C) B f) (xs @ x # \<Gamma>)) \<or>
        insertion (nth_default 0 (xs @ x # \<Gamma>)) A \<noteq> 0 \<and>
        insertion (nth_default 0 (xs @ x # \<Gamma>)) 4 *
        insertion (nth_default 0 (xs @ x # \<Gamma>)) A *
        insertion (nth_default 0 (xs @ x # \<Gamma>)) C
        \<le> (insertion (nth_default 0 (xs @ x # \<Gamma>)) B)\<^sup>2 \<and>
        ((\<forall>f\<in>set L. eval (quadratic_sub var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>))\<and>
         (\<forall>f\<in>set F. eval (quadratic_sub_fm var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>)) \<or>
         (\<forall>f\<in>set L. eval (quadratic_sub var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>)) \<and>
         (\<forall>f\<in>set F. eval (quadratic_sub_fm var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>)))) \<or>
        (Aval = 0 \<and>
        Bval = 0 \<and>
        Cval = 0))"
      apply(rule exI[where x=x])
      using biglemma
      using allAval allBval allCval unfolding A_def B_def C_def Aval_def Bval_def Cval_def X_def hinsert
      by auto
    then obtain x where x : "(insertion (nth_default 0 (xs @ x # \<Gamma>)) A = 0 \<and>
        insertion (nth_default 0 (xs @ x # \<Gamma>)) B \<noteq> 0 \<and>
        (\<forall>f\<in>set L. aEval (linear_substitution var (-C) (B) f) (xs @ x # \<Gamma>)) \<and>
        (\<forall>f\<in>set F. eval (linear_substitution_fm var (-C) B f) (xs @ x # \<Gamma>)) \<or>
        insertion (nth_default 0 (xs @ x # \<Gamma>)) A \<noteq> 0 \<and>
        insertion (nth_default 0 (xs @ x # \<Gamma>)) 4 *
        insertion (nth_default 0 (xs @ x # \<Gamma>)) A *
        insertion (nth_default 0 (xs @ x # \<Gamma>)) C
        \<le> (insertion (nth_default 0 (xs @ x # \<Gamma>)) B)\<^sup>2 \<and>
        ((\<forall>f\<in>set L. eval (quadratic_sub var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>))\<and>
         (\<forall>f\<in>set F. eval (quadratic_sub_fm var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>)) \<or>
         (\<forall>f\<in>set L. eval (quadratic_sub var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>)) \<and>
         (\<forall>f\<in>set F. eval (quadratic_sub_fm var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>)))) \<or>
        (Aval = 0 \<and>
        Bval = 0 \<and>
        Cval = 0)" by auto
    have h : "(\<exists>x. eval (elimVar var L F (Eq p)) (xs @ x # \<Gamma>))\<or>(Aval = 0 \<and> Bval = 0 \<and> Cval = 0)"
    proof(cases "(Aval = 0 \<and> Bval = 0 \<and> Cval = 0)")
      case True
      then show ?thesis by simp
    next
      case False
      have "(\<exists>x. eval (elimVar var L F (Eq p)) (xs @ x # \<Gamma>))"
        apply(rule exI[where x=x])
        apply(simp add: eval_list_conj insertion_mult insertion_sub insertion_pow insertion_add
            del:  quadratic_sub.simps linear_substitution.simps quadratic_sub_fm.simps linear_substitution_fm.simps)
        unfolding A_def[symmetric] B_def[symmetric] C_def[symmetric] One_nat_def[symmetric] X_def[symmetric]
        using hlength x
        by (auto simp add:False)
      then show ?thesis by auto
    qed
    have "(\<exists>x. eval (elimVar var L F (Eq p)) (xs @ x # \<Gamma>))\<or>(\<forall>x. aEval (Eq p) (xs@ x# \<Gamma>))"
    proof(cases "(\<exists>x. eval (elimVar var L F (Eq p)) (xs @ x # \<Gamma>))")
      case True
      then show ?thesis by auto
    next
      case False
      then have "(Aval = 0 \<and> Bval = 0 \<and> Cval = 0)"
        using h by auto
      then have "(\<forall>x. aEval (Eq p) (xs @ x # \<Gamma>))"
        unfolding express_p
        apply(simp add:insertion_add insertion_mult insertion_pow)
        using allAval allBval allCval by auto
      then show ?thesis by auto
    qed
  }
  then have left : "(\<exists>x. eval (list_conj (map fm.Atom L @ F)) (xs @ x # \<Gamma>)) \<Longrightarrow>
                        ((\<exists>x. eval (elimVar var L F (Eq p)) (xs @ x # \<Gamma>))\<or>(\<forall>x. aEval (Eq p) (xs@ x# \<Gamma>)))"
    by blast

  {
    assume hlength : "length (xs::real list) = var"
    define A where "A = (isolate_variable_sparse p var 2)"
    define B where "B = (isolate_variable_sparse p var 1)"
    define C where "C = (isolate_variable_sparse p var 0)"
    have freeA : "var \<notin> vars A"
      unfolding A_def
      by (simp add: not_in_isovarspar)
    have freeB : "var \<notin> vars B"
      unfolding B_def
      by (simp add: not_in_isovarspar)
    have freeC : "var \<notin> vars C"
      unfolding C_def
      by (simp add: not_in_isovarspar)
    have express_p : "p = A*(Var var)^2+B*(Var var)+C"
      using express_poly[OF low_pow] unfolding A_def B_def C_def
      by fastforce
    assume h : "(\<exists>x. (eval (elimVar var L F (Eq p)) (list_update (xs@x#\<Gamma>) var x)))"
    fix x
    define X where "X=xs@x#\<Gamma>"
    have Xlength : "length X > var"
      using X_def hlength by auto
    define Aval where "Aval = insertion (nth_default 0 (list_update X var x)) A"
    define Bval where "Bval = insertion (nth_default 0 (list_update X var x)) B"
    define Cval where "Cval = insertion (nth_default 0 (list_update X var x)) C"
    have allAval : "\<forall>x. insertion (nth_default 0 (list_update X var x)) A = Aval"
      using freeA Aval_def
      using not_contains_insertion by blast
    have allBval : "\<forall>x. insertion (nth_default 0 (list_update X var x)) B = Bval"
      using freeB Bval_def
      using not_contains_insertion by blast
    have allCval : "\<forall>x. insertion (nth_default 0 (list_update X var x)) C = Cval"
      using freeC Cval_def
      using not_contains_insertion by blast
    assume "(eval (elimVar var L F (Eq p)) (list_update (xs@x#\<Gamma>) var x))"
    then have h : "(eval (elimVar var L F (Eq p)) (list_update X var x))"
      unfolding X_def .

    have "(Aval = 0 \<and> Bval \<noteq> 0 \<and>
          (\<forall>f\<in>(\<lambda>a. Atom(linear_substitution var (-C) B a)) ` set L \<union>
             linear_substitution_fm var (-C) B `
             set F.
            eval f (X[var := x])) \<or>
          Aval \<noteq> 0 \<and>
          insertion (nth_default 0 (X[var := x])) 4 * Aval * Cval  \<le> Bval\<^sup>2 \<and>
          ((\<forall>f\<in>(quadratic_sub var (-B) 1 (B^2-4*A*C) (2*A)) `
             set L \<union>
             (quadratic_sub_fm var (-B) 1 (B^2-4*A*C) (2*A)) `
             set F.
            eval f (X[var := x]))
          \<or>(\<forall>f\<in>(quadratic_sub var (-B) (-1) (B^2-4*A*C) (2*A)) `
             set L \<union>
             (quadratic_sub_fm var (-B) (-1) (B^2-4*A*C) (2*A)) `
             set F.
            eval f (X[var := x]))
          ))"
      unfolding Aval_def Bval_def Cval_def A_def B_def C_def
      using h by(simp add: eval_list_conj insertion_mult insertion_sub insertion_pow insertion_add insertion_var Xlength)
    then have h : "(Aval = 0 \<and> Bval \<noteq> 0 \<and>
                            ((\<forall>a\<in> set L. aEval (linear_substitution var (-C) B a) (X[var := x])) \<and>
                            (\<forall>a\<in> set F. eval (linear_substitution_fm var (-C) B a) (X[var := x]))) \<or>
                            Aval \<noteq> 0 \<and> insertion (nth_default 0 (X[var := x])) 4 * Aval * Cval \<le> Bval\<^sup>2 \<and>
                            (((\<forall>a\<in> set L. eval (quadratic_sub var (-B) 1 (B^2-4*A*C) (2*A) a) (X[var := x]))
                            \<and>(\<forall>a\<in> set F. eval (quadratic_sub_fm var (-B) 1 (B^2-4*A*C) (2*A) a) (X[var := x])))
                            \<or>((\<forall>a\<in> set L. eval (quadratic_sub var (-B) (-1) (B^2-4*A*C) (2*A) a) (X[var := x]))
                            \<and>(\<forall>a\<in> set F. eval (quadratic_sub_fm var (-B) (-1) (B^2-4*A*C) (2*A) a) (X[var := x])))))
                          "
      apply(cases "Aval = 0 ")
      apply auto
      by (meson Un_iff eval.simps(1) imageI)
    have h : "(\<exists>x. ((\<forall>a\<in>set L . aEval a ((xs@x#\<Gamma>)[var := x])) \<and> (\<forall>f\<in>set F. eval f ((xs@x#\<Gamma>)[var := x]))))\<or>(Aval=0\<and>Bval=0\<and>Cval=0)"
    proof(cases "Aval=0")
      case True
      then have aval0 : "Aval=0"
        by simp
      show ?thesis proof(cases "Bval = 0")
        case True
        then have bval0 : "Bval = 0" by simp
        show ?thesis proof(cases "Cval=0")
          case True
          then show ?thesis using aval0 bval0 True by auto
        next
          case False
          then show ?thesis using h by(simp add:aval0 bval0 False)
        qed
      next
        case False
        have hb :  "insertion (nth_default 0 (X[var := - Cval / Bval])) B = Bval"
          using allBval by simp
        have hc : "insertion (nth_default 0 (X[var := - Cval / Bval])) (-C) = -Cval"
          using allCval
          by (simp add: insertion_neg)
        have freecneg : "var\<notin>vars(-C)" using freeC not_in_neg by auto
        have p1 : "(\<forall>a\<in>set L. aEval a ((xs @ x # \<Gamma>)[var := - Cval / Bval]))"
          using h apply(simp add: False aval0)
          using linear[OF Xlength False freecneg freeB hc hb]
            list_update_length var_not_in_linear[OF freecneg freeB]
          unfolding X_def using hlength
          by (metis divide_minus_left)

        have p2 : "(\<forall>a\<in>set F. eval a ((xs @ x # \<Gamma>)[var := - Cval / Bval]))"
          using h apply(simp add: False aval0)
          using linear_fm[OF Xlength False freecneg freeB hc hb]
            list_update_length var_not_in_linear_fm[OF freecneg freeB]
          unfolding X_def using hlength var_not_in_eval
          by (metis divide_minus_left linear_substitution_fm.elims linear_substitution_fm_helper.elims)
        show ?thesis
          using p1 p2 hlength by fastforce
      qed
    next
      case False
      then have aval0 : "Aval \<noteq> 0"
        by simp
      have h4 : "insertion (nth_default 0 (X[var := x])) 4 = 4"
        using insertion_const[where f = "(nth_default 0 (X[var := x]))", where c="4"]
        by (metis MPoly_Type.insertion_one insertion_add numeral_Bit0 one_add_one)
      show ?thesis proof(cases "4 * Aval * Cval \<le> Bval\<^sup>2")
        case True
        then have h1 :  "- Bval\<^sup>2 + 4 * Aval * Cval \<le> 0"
          by simp
        have h : "(((\<forall>a\<in> set L. eval (quadratic_sub var (-B) 1 (B^2-4*A*C) (2*A) a) (X[var := x]))
                        \<and>(\<forall>a\<in> set F. eval (quadratic_sub_fm var (-B) 1 (B^2-4*A*C) (2*A) a) (X[var := x])))
                        \<or>((\<forall>a\<in> set L. eval (quadratic_sub var (-B) (-1) (B^2-4*A*C) (2*A) a) (X[var := x]))
                        \<and>(\<forall>a\<in> set F. eval (quadratic_sub_fm var (-B) (-1) (B^2-4*A*C) (2*A) a) (X[var := x]))))"
          using h by(simp add: h1 aval0)
        have h1a : "var\<notin>vars(-B)"
          by(simp add: freeB not_in_neg)
        have h1b : "var\<notin>vars(1::real mpoly)"
          using isolate_var_one not_in_isovarspar by blast
        have h1c : "var\<notin>vars(-1::real mpoly)"
          by(simp add: h1b not_in_neg)
        have h1d : "var\<notin>vars(4::real mpoly)"
          by (metis h1b not_in_add numeral_Bit0 one_add_one)
        have h1e : "var\<notin>vars(B^2-4*A*C)"
          by(simp add: freeB h1d freeA freeC not_in_mult not_in_pow not_in_sub)
        have h1f : "var\<notin>vars(2::real mpoly)"
          using h1b not_in_add by fastforce
        have h1g : "var\<notin>vars(2*A)"
          by(simp add: freeA h1f not_in_mult)
        have h1h : "freeIn var (quadratic_sub var (-B) (1) (B^2-4*A*C) (2*A) a)"
          using free_in_quad h1a h1b h1e h1g by blast
        have h1i : "freeIn var (quadratic_sub var (-B) (-1) (B^2-4*A*C) (2*A) a)"
          using free_in_quad h1a h1c h1e h1g by blast
        have h2 : "2*Aval \<noteq> 0" using aval0 by auto
        have h3 : "0 \<le> (Bval^2-4*Aval*Cval)" using True by auto
        have h4a : "var \<notin> vars 4"
          by (metis monom_numeral notInKeys_notInVars not_in_add not_in_isovarspar not_in_pow one_add_one power.simps(1) rel_simps(76) vars_monom_keys)
        have h4 : "var \<notin> vars (B^2-4*A*C)" by(simp add: h4a freeA freeB freeC not_in_pow not_in_mult not_in_sub)
        have h5 : "\<forall>x. insertion (nth_default 0 (list_update X var x)) (-B) = -Bval " using allBval by(simp add: insertion_neg)
        have h6 : "\<forall>x. insertion (nth_default 0 (list_update X var x)) 1 = 1" by simp
        have h6a : "\<forall>x. insertion (nth_default 0 (list_update X var x)) (-1) = (-1)" using h6 by (simp add: insertion_neg)
        have h7a : "\<forall>x. insertion (nth_default 0 (list_update X var x)) 4 = 4" by (metis h6 insertion_add numeral_Bit0 one_add_one)
        have h7b : "var \<notin> vars(4*A*C)" using freeA freeC by (simp add: h4a not_in_mult)
        have h7c : "var \<notin> vars(B^2)" using freeB not_in_pow by auto
        have h7 : "\<forall>x. insertion (nth_default 0 (list_update X var x)) (B^2-4*A*C) = (Bval^2-4*Aval*Cval)"
          by (simp add: h7a allAval allBval allCval insertion_mult insertion_sub power2_eq_square)
        have h8a : "\<forall>x. insertion (nth_default 0 (list_update X var x)) 2 = 2" by (metis h6 insertion_add one_add_one)
        have h8 : "\<forall>x. insertion (nth_default 0 (list_update X var x)) (2*A) = (2*Aval)" by(simp add: allAval h8a insertion_mult)

        have p1 : "(\<forall>a\<in> set L. eval (quadratic_sub var (-B) 1 (B^2-4*A*C) (2*A) a) (X[var := x]))
                        \<Longrightarrow>(\<forall>a\<in> set F. eval (quadratic_sub_fm var (-B) 1 (B^2-4*A*C) (2*A) a) (X[var := x]))
                          \<Longrightarrow> \<exists>x. length xs = var \<and> ((\<forall>a\<in>set L . aEval a ((xs@x#\<Gamma>)[var := x])) \<and> (\<forall>f\<in>set F. eval f ((xs@x#\<Gamma>)[var := x])))"
        proof-
          assume p1 : "(\<forall>a\<in> set L. eval (quadratic_sub var (-B) 1 (B^2-4*A*C) (2*A) a) (X[var := x]))"
          assume p2 : "(\<forall>a\<in> set F. eval (quadratic_sub_fm var (-B) 1 (B^2-4*A*C) (2*A) a) (X[var := x]))"
          show ?thesis
            using free_in_quad[where a="-B",where b="1", where c="(B^2-4*A*C)", where d="2*A",where var="var",OF h1a h1b h1e h1g]
            using quadratic_sub[where a="-B",where b="1", where c="(B^2-4*A*C)", where d="2*A",where var="var", where L="X", OF Xlength,
                where Dv="2*Aval", OF h2, where Cv="(Bval^2-4*Aval*Cval)", OF h3, where Av="-Bval", OF h4 h5, where Bv="1", OF h6 h7 h8]
            using free_in_quad_fm[where a="-B",where b="1", where c="(B^2-4*A*C)", where d="2*A",where var="var",OF h1a h1b h1e h1g]
            using quadratic_sub_fm[where a="-B",where b="1", where c="(B^2-4*A*C)", where d="2*A",where var="var", where L="X", OF Xlength,
                where Dv="2*Aval", OF h2, where Cv="(Bval^2-4*Aval*Cval)", OF h3, where Av="-Bval", OF h4 h5, where Bv="1", OF h6 h7 h8]
                p1 p2
            using var_not_in_eval
            by (metis X_def hlength list_update_length)
        qed
        have p2 : "(\<forall>a\<in> set L. eval (quadratic_sub var (-B) (-1) (B^2-4*A*C) (2*A) a) (X[var := x]))
                        \<Longrightarrow>(\<forall>a\<in> set F. eval (quadratic_sub_fm var (-B) (-1) (B^2-4*A*C) (2*A) a) (X[var := x]))
                          \<Longrightarrow>\<exists>x. length xs = var \<and> ((\<forall>a\<in>set L . aEval a ((xs@x#\<Gamma>)[var := x])) \<and> (\<forall>f\<in>set F. eval f ((xs@x#\<Gamma>)[var := x])))"
          using free_in_quad[where a="-B",where b="-1", where c="(B^2-4*A*C)", where d="2*A",where var="var",OF h1a h1c h1e h1g]
          using quadratic_sub[where a="-B",where b="-1", where c="(B^2-4*A*C)", where d="2*A",where var="var", where L="X", OF Xlength,
              where Dv="2*Aval", OF h2, where Cv="(Bval^2-4*Aval*Cval)", OF h3, where Av="-Bval", OF h4 h5, where Bv="-1", OF h6a h7 h8]

          using free_in_quad_fm[where a="-B",where b="-1", where c="(B^2-4*A*C)", where d="2*A",where var="var",OF h1a h1c h1e h1g]
          using quadratic_sub_fm[where a="-B",where b="-1", where c="(B^2-4*A*C)", where d="2*A",where var="var", where L="X", OF Xlength,
              where Dv="2*Aval", OF h2, where Cv="(Bval^2-4*Aval*Cval)", OF h3, where Av="-Bval", OF h4 h5, where Bv="-1", OF h6a h7 h8]

          using var_not_in_eval by (metis X_def hlength list_update_length)
        then show ?thesis
          using h p1 p2 by blast
      next
        case False
        then show ?thesis using h by(simp add: aval0 False h4)
      qed
    qed
    have "(\<exists>x.((\<forall>a\<in>set L . aEval a ((xs@x#\<Gamma>)[var := x])) \<and> (\<forall>f\<in>set F. eval f ((xs@x#\<Gamma>)[var := x]))))\<or>(\<forall>x. aEval (Eq p) (xs @ x#\<Gamma>))"
    proof(cases "(\<exists>x.((\<forall>a\<in>set L . aEval a ((xs@x#\<Gamma>)[var := x])) \<and> (\<forall>f\<in>set F. eval f ((xs@x#\<Gamma>)[var := x]))))")
      case True
      then show ?thesis by auto
    next
      case False
      then have "Aval=0\<and>Bval=0\<and>Cval=0" using h by auto
      then have "(\<forall>x. aEval (Eq p) (xs @ x # \<Gamma>))"
        unfolding express_p apply(simp add:insertion_add insertion_mult insertion_pow)
        using allAval allBval allCval hlength unfolding X_def by auto
      then show ?thesis by auto
    qed
  }

  then have right : "(\<exists>x. eval (elimVar var L F (Eq p)) (xs @ x # \<Gamma>)) \<Longrightarrow>
               ((\<exists>x. eval (list_conj (map fm.Atom L @ F)) (xs @ x # \<Gamma>))\<or>(\<forall>x. aEval (Eq p) (xs @ x # \<Gamma>)))"
    by (smt UnE eval.simps(1) eval_list_conj hlength imageE list_update_length set_append set_map)

  show ?thesis using right left by blast
qed

text "simply states that the variable is free in the equality case of the elimVar function"
lemma freeIn_elimVar_eq : "freeIn var (elimVar var L F (Eq p))"
proof-
  have h4 : "var \<notin> vars(4:: real mpoly)" using var_not_in_Const
    by (metis (full_types) isolate_var_one monom_numeral not_in_isovarspar numeral_One vars_monom_keys zero_neq_numeral)
  have hlinear: "\<forall>f\<in>set(map (\<lambda>a. Atom(linear_substitution var (-isolate_variable_sparse p var 0) (isolate_variable_sparse p var (Suc 0)) a)) L @
        map (linear_substitution_fm var (-isolate_variable_sparse p var 0) (isolate_variable_sparse p var (Suc 0)))
         F). freeIn var f"
    using
      var_not_in_linear[where c="(isolate_variable_sparse p var (Suc 0))", where b="(- isolate_variable_sparse p var 0)", where var="var"]
      var_not_in_linear_fm[where c="(isolate_variable_sparse p var (Suc 0))", where b="(-isolate_variable_sparse p var 0)", where var="var"]
      not_in_isovarspar not_in_neg by auto
  have freeA : "var \<notin> vars (- isolate_variable_sparse p var (Suc 0))"
    using not_in_isovarspar not_in_neg by auto
  have freeB1 : "var \<notin> vars (1::real mpoly)"
    by (metis h4 monom_numeral monom_one notInKeys_notInVars vars_monom_keys zero_neq_numeral)
  have freeC : "var \<notin> vars (((isolate_variable_sparse p var (Suc 0))\<^sup>2 -
                    4 * isolate_variable_sparse p var 2 * isolate_variable_sparse p var 0))"
    using not_in_isovarspar not_in_pow not_in_sub not_in_mult h4 by auto
  have freeD : "var \<notin> vars ((2 * isolate_variable_sparse p var 2))"
    using not_in_isovarspar not_in_mult
    by (metis mult_2 not_in_add)
  have freeB2 : "var\<notin>vars (-1::real mpoly)"
    using freeB1 not_in_neg by auto
  have quadratic1 : "\<forall>f\<in>set(map (quadratic_sub var (- isolate_variable_sparse p var (Suc 0)) 1
              ((isolate_variable_sparse p var (Suc 0))\<^sup>2 -
               4 * isolate_variable_sparse p var 2 * isolate_variable_sparse p var 0)
              (2 * isolate_variable_sparse p var 2))
         L @
        map (quadratic_sub_fm var (- isolate_variable_sparse p var (Suc 0)) 1
              ((isolate_variable_sparse p var (Suc 0))\<^sup>2 -
               4 * isolate_variable_sparse p var 2 * isolate_variable_sparse p var 0)
              (2 * isolate_variable_sparse p var 2))
         F). freeIn var f"
    using free_in_quad[OF freeA freeB1 freeC freeD]
      free_in_quad_fm[OF freeA freeB1 freeC freeD] by auto
  have quadratic2 : "\<forall>f\<in>set(map (quadratic_sub var (- isolate_variable_sparse p var (Suc 0)) (-1)
              ((isolate_variable_sparse p var (Suc 0))\<^sup>2 -
               4 * isolate_variable_sparse p var 2 * isolate_variable_sparse p var 0)
              (2 * isolate_variable_sparse p var 2))
         L @
        map (quadratic_sub_fm var (- isolate_variable_sparse p var (Suc 0)) (-1)
              ((isolate_variable_sparse p var (Suc 0))\<^sup>2 -
               4 * isolate_variable_sparse p var 2 * isolate_variable_sparse p var 0)
              (2 * isolate_variable_sparse p var 2))
         F). freeIn var f"
    using free_in_quad[OF freeA freeB2 freeC freeD]
      free_in_quad_fm[OF freeA freeB2 freeC freeD] by auto
  show ?thesis
    using not_in_mult not_in_add h4 not_in_pow not_in_sub freeIn_list_conj not_in_isovarspar hlinear quadratic1 quadratic2
    by simp
qed

text "Theorem 20.2 in the textbook"
lemma elimVar_eq_2 :
  assumes hlength : "length xs = var"
  assumes in_list : "Eq p \<in> set(L)"
  assumes low_pow : "MPoly_Type.degree p var = 1 \<or> MPoly_Type.degree p var = 2"
  assumes nonzero : "\<forall>x.
              insertion (nth_default 0 (xs @ x # \<Gamma>)) (isolate_variable_sparse p var 2) \<noteq> 0
            \<or> insertion (nth_default 0 (xs @ x # \<Gamma>)) (isolate_variable_sparse p var 1) \<noteq> 0
            \<or> insertion (nth_default 0 (xs @ x # \<Gamma>)) (isolate_variable_sparse p var 0) \<noteq> 0" (is ?non0)
  shows "(\<exists>x. eval (list_conj (map fm.Atom L @ F)) (xs @ x # \<Gamma>)) =
         (\<exists>x. eval (elimVar var L F (Eq p)) (xs @ x # \<Gamma>))"
proof-
  define A where "A = (isolate_variable_sparse p var 2)"
  define B where "B = (isolate_variable_sparse p var 1)"
  define C where "C = (isolate_variable_sparse p var 0)"
  have freeA : "var \<notin> vars A"
    unfolding A_def
    by (simp add: not_in_isovarspar)
  have freeB : "var \<notin> vars B"
    unfolding B_def
    by (simp add: not_in_isovarspar)
  have freeC : "var \<notin> vars C"
    unfolding C_def
    by (simp add: not_in_isovarspar)
  have express_p : "p = A*(Var var)^2+B*(Var var)+C"
    using express_poly[OF low_pow] unfolding A_def B_def C_def
    by fastforce
  have af : "isolate_variable_sparse p var 2 = A"
    using A_def by auto
  have bf : "isolate_variable_sparse p var (Suc 0) = B"
    using B_def by auto
  have cf : "isolate_variable_sparse p var 0 = C"
    using C_def by auto
  have xlength : "\<forall>x. (insertion (nth_default 0 (xs @ x # \<Gamma>)) (Var var))= x"
    using hlength insertion_var
    by (metis add.commute add_strict_increasing length_append length_greater_0_conv list.distinct(1) list_update_id nth_append_length order_refl)
  fix x
  define c where "c i = (insertion (nth_default 0 (xs @ x # \<Gamma>)) (isolate_variable_sparse p var i))" for i
  have c2 : "\<forall>x. insertion (nth_default 0 (xs @ x # \<Gamma>)) A = c 2"
    using freeA apply(simp add: A_def c_def)
    by (simp add: hlength insertion_lowerPoly1)
  have c1 : "\<forall>x. insertion (nth_default 0 (xs @ x # \<Gamma>)) B = c 1"
    using freeB apply(simp add: B_def c_def)
    by (simp add: hlength insertion_lowerPoly1)
  have c0 : "\<forall>x. insertion (nth_default 0 (xs @ x # \<Gamma>)) C = c 0"
    using freeC apply(simp add: C_def c_def)
    by (simp add: hlength insertion_lowerPoly1)
  have sum : "\<forall>x. c 2 * x\<^sup>2 + c (Suc 0) * x + c 0 = (\<Sum>i\<le>2. c i * x ^ i)"
    by (simp add: numerals(2))
  have "(\<forall>x. aEval (Eq p) (xs @ x # \<Gamma>)) = (\<not>?non0)"
    apply(simp add : af bf cf)
    unfolding express_p apply(simp add:insertion_add insertion_mult insertion_pow xlength)
    apply(simp add:c2 c1 c0)
    apply(simp add: sum)
    using polyfun_eq_0[where c="c", where n="2"]
    using sum by auto
  then have "\<not>(\<forall>x. aEval (Eq p) (xs @ x \<Gamma>))"
    using nonzero by auto
  then show ?thesis
    using disjE[OF elimVar_eq[OF hlength in_list, where F="F", where \<Gamma>="\<Gamma>"], where R="?thesis"]
    using \<open>(\<forall>x. aEval (Eq p) (xs @ x # \<Gamma>)) = (\<not> (\<forall>x. insertion (nth_default 0 (xs @ x # \<Gamma>)) (isolate_variable_sparse p var 2) \<noteq> 0 \<or> insertion (nth_default 0 (xs @ x # \<Gamma>)) (isolate_variable_sparse p var 1) \<noteq> 0 \<or> insertion (nth_default 0 (xs @ x # \<Gamma>)) (isolate_variable_sparse p var 0) \<noteq> 0))\<close> low_pow nonzero by blast
qed

end


(*  Title:      HOL/MicroJava/BV/Opt.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

More about options.
*)

section \<open>More about Options\<close>

theory Opt
imports
  Err
begin

definition le :: "'a ord \<Rightarrow> 'a option ord"
where
  "le r o\<^sub>1 o\<^sub>2 =
  (case o\<^sub>2 of None \<Rightarrow> o\<^sub>1=None | Some y \<Rightarrow> (case o\<^sub>1 of None \<Rightarrow> True | Some x \<Rightarrow> x \<sqsubseteq>\<^sub>r y))"

definition opt :: "'a set \<Rightarrow> 'a option set"
where
  "opt A = insert None {Some y |y. y \<in> A}"

definition sup :: "'a ebinop \<Rightarrow> 'a option ebinop"
where
  "sup f o\<^sub>1 o\<^sub>2 =
  (case o\<^sub>1 of None \<Rightarrow> OK o\<^sub>2
           | Some x \<Rightarrow> (case o\<^sub>2 of None \<Rightarrow> OK o\<^sub>1
                                 | Some y \<Rightarrow> (case f x y of Err \<Rightarrow> Err | OK z \<Rightarrow> OK (Some z))))"

definition esl :: "'a esl \<Rightarrow> 'a option esl"
where
  "esl = (\<lambda>(A,r,f). (opt A, le r, sup f))"

lemma unfold_le_opt:
  "o\<^sub>1 \<sqsubseteq>\<^bsub>le r\<^esub> o\<^sub>2 =
  (case o\<^sub>2 of None \<Rightarrow> o\<^sub>1=None |
              Some y \<Rightarrow> (case o\<^sub>1 of None \<Rightarrow> True | Some x \<Rightarrow> x \<sqsubseteq>\<^sub>r y))"
(*<*)
apply (unfold lesub_def le_def)
apply (rule refl)
done
(*>*)

lemma le_opt_refl: "order r \<Longrightarrow> x \<sqsubseteq>\<^bsub>le r\<^esub> x"
(*<*) by (simp add: unfold_le_opt split: option.split) (*<*)

lemma le_opt_trans [rule_format]:
  "order r \<Longrightarrow> x \<sqsubseteq>\<^bsub>le r\<^esub> y \<longrightarrow> y \<sqsubseteq>\<^bsub>le r\<^esub> z \<longrightarrow> x \<sqsubseteq>\<^bsub>le r\<^esub> z"
(*<*)
apply (simp add: unfold_le_opt split: option.split)
apply (blast intro: order_trans)
done
(*>*)

lemma le_opt_antisym [rule_format]:
  "order r \<Longrightarrow> x \<sqsubseteq>\<^bsub>le r\<^esub> y \<longrightarrow> y \<sqsubseteq>\<^bsub>le r\<^esub> x \<longrightarrow> x=y"
(*<*)
apply (simp add: unfold_le_opt split: option.split)
apply (blast intro: order_antisym)
done
(*>*)

lemma order_le_opt [intro!,simp]: "order r \<Longrightarrow> order(le r)"
(*<*)
apply (subst order_def)
apply (blast intro: le_opt_refl le_opt_trans le_opt_antisym)
done
(*>*)

lemma None_bot [iff]:  "None \<sqsubseteq>\<^bsub>le r\<^esub> ox"
(*<*)
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done
(*>*)

lemma Some_le [iff]: "(Some x \<sqsubseteq>\<^bsub>le r\<^esub> z) = (\<exists>y. z = Some y \<and> x \<sqsubseteq>\<^sub>r y)"
(*<*)
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done
(*>*)

lemma le_None [iff]: "(x \<sqsubseteq>\<^bsub>le r\<^esub> None) = (x = None)"
(*<*)
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done
(*>*)

lemma OK_None_bot [iff]: "OK None \<sqsubseteq>\<^bsub>Err.le (le r)\<^esub> x"
(*<*) by (simp add: lesub_def Err.le_def le_def split: option.split err.split) (*>*)

lemma sup_None1 [iff]: "x \<squnion>\<^bsub>sup f\<^esub> None = OK x"
(*<*) by (simp add: plussub_def sup_def split: option.split) (*>*)

lemma sup_None2 [iff]: "None \<squnion>\<^bsub>sup f\<^esub> x = OK x"
(*<*) by (simp add: plussub_def sup_def split: option.split) (*>*)

lemma None_in_opt [iff]: "None \<in> opt A"
(*<*) by (simp add: opt_def) (*>*)

lemma Some_in_opt [iff]: "(Some x \<in> opt A) = (x \<in> A)"
(*<*) by (unfold opt_def) auto (*>*)

lemma semilat_opt [intro, simp]:
  "err_semilat L \<Longrightarrow> err_semilat (Opt.esl L)"
(*<*)
proof -
  assume s: "err_semilat L"
  obtain A r f where [simp]: "L = (A,r,f)" by (cases L)
  let ?A0 = "err A" and ?r0 = "Err.le r" and ?f0 = "lift2 f"
  from s obtain
    ord: "order ?r0" and
    clo: "closed ?A0 ?f0" and
    ub1: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. x \<sqsubseteq>\<^bsub>?r0\<^esub> x \<squnion>\<^bsub>?f0\<^esub> y" and
    ub2: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. y \<sqsubseteq>\<^bsub>?r0\<^esub> x \<squnion>\<^bsub>?f0\<^esub> y" and
    lub: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. \<forall>z\<in>?A0. x \<sqsubseteq>\<^bsub>?r0\<^esub> z \<and> y \<sqsubseteq>\<^bsub>?r0\<^esub> z \<longrightarrow> x \<squnion>\<^bsub>?f0\<^esub> y \<sqsubseteq>\<^bsub>?r0\<^esub> z"
    by (unfold semilat_def sl_def) simp

  let ?A = "err (opt A)" and ?r = "Err.le (Opt.le r)" and ?f = "lift2 (Opt.sup f)"

  from ord have "order ?r" by simp
  moreover
  have "closed ?A ?f"
  proof (unfold closed_def, intro strip)
    fix x y assume x: "x \<in> ?A" and y: "y \<in> ?A"

    { fix a b assume ab: "x = OK a" "y = OK b"
      with x have a: "\<And>c. a = Some c \<Longrightarrow> c \<in> A" by (clarsimp simp add: opt_def)
      from ab y have b: "\<And>d. b = Some d \<Longrightarrow> d \<in> A" by (clarsimp simp add: opt_def)
      { fix c d assume "a = Some c" "b = Some d"
        with ab x y have "c \<in> A & d \<in> A" by (simp add: err_def opt_def Bex_def)
        with clo have "f c d \<in> err A"
          by (simp add: closed_def plussub_def err_def' lift2_def)
        moreover fix z assume "f c d = OK z"
        ultimately have "z \<in> A" by simp
      } note f_closed = this
      have "sup f a b \<in> ?A"
      proof (cases a)
        case None thus ?thesis
          by (simp add: sup_def opt_def) (cases b, simp, simp add: b Bex_def)
      next
        case Some thus ?thesis
          by (auto simp add: sup_def opt_def Bex_def a b f_closed split: err.split option.split)
      qed
    }
    thus "x \<squnion>\<^bsub>?f\<^esub> y \<in> ?A" by (simp add: plussub_def lift2_def split: err.split)
  qed
  moreover
  { fix a b c assume "a \<in> opt A" and "b \<in> opt A" and "a \<squnion>\<^bsub>sup f\<^esub> b = OK c"
    moreover from ord have "order r" by simp
    moreover
    { fix x y z assume "x \<in> A" and "y \<in> A"
      hence "OK x \<in> err A \<and> OK y \<in> err A" by simp
      with ub1 ub2
      have "(OK x) \<sqsubseteq>\<^bsub>Err.le r\<^esub> (OK x) \<squnion>\<^bsub>lift2 f\<^esub> (OK y) \<and>
            (OK y) \<sqsubseteq>\<^bsub>Err.le r\<^esub> (OK x) \<squnion>\<^bsub>lift2 f\<^esub> (OK y)"
        by blast
      moreover assume "x \<squnion>\<^sub>f y = OK z"
      ultimately have "x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z"
        by (auto simp add: plussub_def lift2_def Err.le_def lesub_def)
    }
    ultimately have "a \<sqsubseteq>\<^bsub>le r\<^esub> c \<and> b \<sqsubseteq>\<^bsub>le r\<^esub> c"
      by (auto simp add: sup_def le_def lesub_def plussub_def
               dest: order_refl split: option.splits err.splits)
  }
  hence "(\<forall>x\<in>?A. \<forall>y\<in>?A. x \<sqsubseteq>\<^bsub>?r\<^esub> x \<squnion>\<^bsub>?f\<^esub> y) \<and> (\<forall>x\<in>?A. \<forall>y\<in>?A. y \<sqsubseteq>\<^bsub>?r\<^esub> x \<squnion>\<^bsub>?f\<^esub> y)"
    by (auto simp add: lesub_def plussub_def Err.le_def lift2_def split: err.split)
  moreover
  have "\<forall>x\<in>?A. \<forall>y\<in>?A. \<forall>z\<in>?A. x \<sqsubseteq>\<^bsub>?r\<^esub> z \<and> y \<sqsubseteq>\<^bsub>?r\<^esub> z \<longrightarrow> x \<squnion>\<^bsub>?f\<^esub> y \<sqsubseteq>\<^bsub>?r\<^esub> z"
  proof (intro strip, elim conjE)
    fix x y z
    assume xyz: "x \<in> ?A"   "y \<in> ?A"   "z \<in> ?A"
    assume xz: "x \<sqsubseteq>\<^bsub>?r\<^esub> z" and yz: "y \<sqsubseteq>\<^bsub>?r\<^esub> z"
    { fix a b c assume ok: "x = OK a"  "y = OK b"  "z = OK c"
      { fix d e g  assume some: "a = Some d"  "b = Some e"  "c = Some g"
        with ok xyz obtain "OK d:err A" "OK e:err A" "OK g:err A"  by simp
        with lub
        have "\<lbrakk> OK d \<sqsubseteq>\<^bsub>Err.le r\<^esub> OK g; OK e \<sqsubseteq>\<^bsub>Err.le r\<^esub> OK g \<rbrakk> \<Longrightarrow> OK d \<squnion>\<^bsub>lift2 f\<^esub> OK e \<sqsubseteq>\<^bsub>Err.le r\<^esub> OK g"
          by blast
        hence "\<lbrakk> d \<sqsubseteq>\<^sub>r g; e \<sqsubseteq>\<^sub>r g \<rbrakk> \<Longrightarrow> \<exists>y. d \<squnion>\<^sub>f e = OK y \<and> y \<sqsubseteq>\<^sub>r g" by simp
        with ok some xyz xz yz have "x \<squnion>\<^bsub>?f\<^esub> y \<sqsubseteq>\<^bsub>?r\<^esub> z"
          by (auto simp add: sup_def le_def lesub_def lift2_def plussub_def Err.le_def)
      } note this [intro!]
      from ok xyz xz yz have "x \<squnion>\<^bsub>?f\<^esub> y \<sqsubseteq>\<^bsub>?r\<^esub> z"
        by - (cases a, simp, cases b, simp, cases c, simp, blast)
    }
    with xyz xz yz show "x \<squnion>\<^bsub>?f\<^esub> y \<sqsubseteq>\<^bsub>?r\<^esub> z"
      by - (cases x, simp, cases y, simp, cases z, simp+)
  qed
  ultimately show "err_semilat (Opt.esl L)"
    by (unfold semilat_def esl_def sl_def) simp
qed
(*>*)

lemma top_le_opt_Some [iff]: "top (le r) (Some T) = top r T"
(*<*)
apply (unfold top_def)
apply (rule iffI)
 apply blast
apply (rule allI)
apply (case_tac "x")
apply simp+
done
(*>*)

lemma Top_le_conv:  "\<lbrakk> order r; top r T \<rbrakk> \<Longrightarrow> (T \<sqsubseteq>\<^sub>r x) = (x = T)"
(*<*)
apply (unfold top_def)
apply (blast intro: order_antisym)
done
(*>*)

lemma acc_le_optI [intro!]: "acc A r \<Longrightarrow> acc (opt A) (le r)"
(*<*)
apply (unfold acc_def lesub_def le_def lesssub_def)
apply (simp add: wf_eq_minimal split: option.split)
apply clarify
apply (case_tac "\<exists>a. Some a \<in> Q")
 apply (erule_tac x = "{a . Some a \<in> Q}" in allE)
 apply blast
apply (case_tac "x")
 apply blast
apply blast
done
(*>*)

lemma map_option_in_optionI:
  "\<lbrakk> ox \<in> opt S; \<forall>x\<in>S. ox = Some x \<longrightarrow> f x \<in> S \<rbrakk>
  \<Longrightarrow> map_option f ox \<in> opt S"
(*<*)
apply (unfold map_option_case)
apply (simp split: option.split)
apply blast
done
(*>*)

end


theory HybridSC3 imports Main
begin

datatype 'a hybr_form
  =  Pro 'a (\<open>PRO _\<close> [999] 999)
  | Nom nat (\<open>NOM _\<close> [998] 998)
  | Neg \<open>'a hybr_form\<close> (\<open>NOT _\<close> [900] 900)
  | Con \<open>'a hybr_form\<close> \<open>'a hybr_form\<close> (infixl "AND" 300)
  | Sat nat \<open>'a hybr_form\<close> (\<open>AT _ _\<close> [899]  899)
  | Pos \<open>'a hybr_form\<close> (\<open>\<diamond> _\<close> [800] 800)

primrec maxnomP where
  \<open>maxnomP mn (Pro a) = mn\<close> |
  \<open>maxnomP mn (Nom n) = max mn n\<close> |
  \<open>maxnomP mn (Neg p) = maxnomP mn p\<close> |
  \<open>maxnomP mn (Con p1 p2) = max (maxnomP mn p1) (maxnomP mn p2)\<close> |
  \<open>maxnomP mn (Sat n p) = max n (maxnomP mn p)\<close> |
  \<open>maxnomP mn (Pos p) = maxnomP mn p\<close>

primrec mergeP where
  \<open>mergeP (Pro a) na nb = Pro a\<close> |
  \<open>mergeP (Nom n) na nb = Nom (if n = na then nb else n)\<close> |
  \<open>mergeP (Neg p) na nb = Neg (mergeP p na nb)\<close> |
  \<open>mergeP (Con p1 p2) na nb = Con (mergeP p1 na nb) (mergeP p2 na nb)\<close> |
  \<open>mergeP (Sat n p) na nb = Sat (if n = na then nb else n) (mergeP p na nb)\<close> |
  \<open>mergeP (Pos p) na nb = Pos (mergeP p na nb)\<close>

fun mergeNP where
  \<open>mergeNP [] na nb = []\<close> |
  \<open>mergeNP ((n,p) # NP) na nb = (if n = na then nb else n, mergeP p na nb) # (mergeNP NP na nb)\<close>

(*validity checks*)
(*Check if any of the pairs in a list contains two of the same element*)
fun reflect where
  \<open>reflect [] = False\<close> |
  \<open>reflect ((n1,Nom n2) # B) = (n1 = n2 \<or> reflect B)\<close> |
  \<open>reflect (_ # B) = reflect B\<close>

lemma reflect_iff[iff]: \<open>reflect nn \<longleftrightarrow> (\<exists> n. (n,Nom n) \<in> set nn)\<close>
  apply (induct nn)
   apply simp
  by (smt (z3) insert_iff list.distinct(1) list.inject list.set(2)
      reflect.elims(1) reflect.simps(2))

primrec member where
  \<open>member x [] = False\<close> |
  \<open>member x (y # xs) = (x = y \<or> member x xs)\<close>

lemma member_iff[iff]: \<open>member x xs \<longleftrightarrow> x \<in> set xs\<close>
  by (induct xs) simp_all

primrec common where
  \<open>common [] ys = False\<close> |
  \<open>common (x # xs) ys = (member x ys \<or> common xs ys)\<close>

lemma common_iff[iff]: \<open>common xs ys \<longleftrightarrow> set xs \<inter> set ys \<noteq> {}\<close>
  by (induct xs) simp_all

(*
----------EXPLANATION OF PARAMETERS OF ATOMIZE---------
All parameters are lists of tuples representing formulas of different types
The first element identifies the nominal at which the formula holds

LA/RA: LHS and RHS atomic non-nominal propositions. Sequent is valid if they share an element

RN: RHS nominal propositions. Sequent is valid if we have @n n. There is no LN because we process
    them immediately

LP/RP: LHS and RHS possibility relations between nominals. Sequent is valid if they share an element

R: RHS possibility formulas with potentially complex subformulas. Formulas here can be discharged
   multiple times with different witnessing nominals

Q/P: LHS and RHS complex formulas.
*)

function sv where
  (*match RHS*)
  \<open>sv mn cn LA RA Y X Q ((n,Pro a) # P) =
    sv mn cn LA ((n,Pro a) # RA) Y X Q P\<close> |

  \<open>sv mn cn LA RA Y X Q ((n1,Nom n2) # P) =
    sv mn cn LA ((n1,Nom n2) # RA) Y X Q P\<close> |

  \<open>sv mn cn LA RA Y X Q ((n,Neg p) # P) =
    sv mn cn LA RA Y X ((n,p) # Q) P\<close> |

  \<open>sv mn cn LA RA Y X Q ((n,Con p1 p2) # P) =
    ((sv mn cn LA RA Y X Q ((n,p1) # P)) \<and> (sv mn cn LA RA Y X Q ((n,p2) # P)))\<close> |

  \<open>sv mn cn LA RA Y X Q ((n1,Sat n2 p) # P) =
    sv mn cn LA RA Y X Q ((n2,p) # P)\<close> |

  \<open>sv mn cn LA RA Y X Q ((n,Pos p) # P) =
    sv mn cn LA RA Y ((n,p) # X) Q P\<close>|

  (*match LHS*)
  \<open>sv mn cn LA RA Y X ((n,Pro a) # Q) [] =
    sv mn cn ((n,Pro a) # LA) RA Y X Q []\<close> |

  \<open>sv mn cn LA RA Y X ((n1,Nom n2) # Q) [] =
    sv mn cn (mergeNP LA n1 n2) (mergeNP RA n1 n2) (mergeNP Y n1 n2) (mergeNP X n1 n2) (mergeNP Q n1 n2) []\<close> |

  \<open>sv mn cn LA RA Y X ((n,Neg p) # Q) [] =
    sv mn cn LA RA Y X Q [(n,p)]\<close> |

  \<open>sv mn cn LA RA Y X ((n,Con p1 p2) # Q) []=
    sv mn cn LA RA Y X ((n,p1) # (n,p2) # Q) []\<close> |

  \<open>sv mn cn LA RA Y X ((n1,Sat n2 p) # Q) [] =
    sv mn cn LA RA Y X ((n2,p) # Q) []\<close> |

  \<open>sv mn cn LA RA Y X ((n,Pos p) # Q) [] =
    sv (mn + 1) cn ((n,Pos (Nom mn)) # LA) RA Y X ((mn,p) # Q) []\<close> |
(*-------Try all relevant assignments of nominals to possibility on RHS-----------
If no assignment can be made, check if current sequent is a tautology.
Else we can process a statement @n\<diamond>P.
  Find a nominal m to witness the statement
  Check if the sequent with @n\<diamond>P removed fulfills both @n\<diamond>m and @mP
  Lastly, try another assignment. Remember that we already tried m.*)
  \<open>sv mn cn LA RA Y ((n,p) # X) [] [] = (
    if cn < mn
    then (
      sv mn 0 LA ((n,Pos (Nom cn)) # RA) [] (Y @ X) [] [] \<and>
      sv mn 0 LA RA [] (Y @ X) [] [(cn,p)]) \<or>
      sv mn (cn + 1) LA RA Y ((n,p) # X) [] []
    else sv mn 0 LA RA ((n,p) # Y) X [] [])\<close> |
  \<open>sv mn cn LA RA Y [] [] [] = (reflect RA \<or> common LA RA)\<close>
  by pat_completeness simp_all
(*size definition for proving termination of sv*)
termination sorry

definition prover where
  \<open>prover p \<equiv> (let mn = maxnomP 0 p in sv (mn + 2) 0 [] [] [] [] [] [(mn + 1,p)])\<close>

primrec semantics :: \<open>('c \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow>
                  (nat \<Rightarrow> 'c) \<Rightarrow> 'c \<Rightarrow> 'a hybr_form \<Rightarrow> bool\<close> where
  \<open>semantics RE V G w (Pro a) = V w a\<close> |
  \<open>semantics RE V G w (Nom n) = ((G n) = w)\<close> |
  \<open>semantics RE V G w (Neg p) = (\<not> semantics RE V G w p)\<close> |
  \<open>semantics RE V G w (Con p1 p2) = (semantics RE V G w p1 \<and> semantics RE V G w p2)\<close> |
  \<open>semantics RE V G w (Sat n p) = semantics RE V G (G n) p\<close> |
  \<open>semantics RE V G w (Pos p) = (\<exists> v. (RE w v) \<and> (semantics RE V G v p))\<close>

definition \<open>sc RE V G LA RA Y X Q P \<equiv>
  (
    (\<forall> (n,p) \<in> set Q \<union> set LA. semantics RE V G (G n) p)
  ) \<longrightarrow> (
    (\<exists> (n,p) \<in> set P \<union> set RA. semantics RE V G (G n) p) \<or>
    (\<exists> (n,p) \<in> set Y \<union> set X. semantics RE V G (G n) (Pos p))
  )\<close>

definition \<open>
  consistent_soundness mn cn LA RA Y X Q P \<equiv>
  (cn \<noteq> 0 \<longleftrightarrow> Q = [] \<and> P = []) \<and>
  (\<forall> (n,p) \<in> set LA \<union> set RA \<union> set Y \<union> set X \<union> set Q \<union> set P. mn > n \<and> mn > maxnomP 0 p)\<close>

theorem soundness: \<open>
  consistent_soundness mn cn LA RA Y X Q P \<Longrightarrow>
  sv mn cn LA RA Y X Q P \<Longrightarrow>
  (\<forall> RE V G. sc RE V G LA RA Y X Q P)\<close>
proof (induct Y X Q P rule: sv.induct)
  case (1 mn cn LA RA Y X Q n a P)
  then show ?case sorry
next
  case (2 mn cn LA RA Y X Q n1 n2 P)
  then show ?case sorry
next
  case (3 mn cn LA RA Y X Q n p P)
  then show ?case sorry
next
  case (4 mn cn LA RA Y X Q n p1 p2 P)
  then show ?case sorry
next
  case (5 mn cn LA RA Y X Q n1 n2 p P)
  then show ?case sorry
next
  case (6 mn cn LA RA Y X Q n p P)
  then show ?case sorry
next
  case (7 mn cn LA RA Y X n a Q)
  then show ?case sorry
next
  case (8 mn cn LA RA Y X n1 n2 Q)
  then show ?case sorry
next
  case (9 mn cn LA RA Y X n p Q)
  then show ?case sorry
next
  case (10 mn cn LA RA Y X n p1 p2 Q)
  then show ?case sorry
next
  case (11 mn cn LA RA Y X n1 n2 p Q)
  then show ?case sorry
next
  case (12 mn cn LA RA Y X n p Q)
  then show ?case sorry
next
  case (13 mn cn LA RA Y n p X)
  then show ?case sorry
next
  case (14 mn cn LA RA Y)
  then show ?case sorry
qed

(*abbreviations*)
abbreviation Imp (infixr "THEN"  180)
  where "Imp p q \<equiv> Neg (Con p (Neg q))"

abbreviation Iff (infixr "IFF" 180)
  where "Iff p q \<equiv> Con (Imp p q) (Imp q p)"

abbreviation Dis (infixl "OR"  200)
  where "Dis p q \<equiv> Neg (Con (Neg p) (Neg q))"

abbreviation Nes (\<open>\<box> _\<close> 800)
  where "Nes p \<equiv> Neg (Pos (Neg p))"

(*tests*)
datatype atoms = A | B | C | D | E | F | G | H | I | J | K | L | M | N

(*valid tests*)
proposition \<open>prover
  (NOT ((Sat 1 (Pos (NOM 4))) AND
  (NOT (Sat 1 (Pos (NOT ((Sat 2 (Pos (NOM 3))) AND (Sat 3 (Pro A))) AND
  NOT ((Sat 2 (Pos (NOM 4))) AND (Sat 4 (Pro A))))))) AND
  (NOT (Sat 2 (Pos (Pro A))))))\<close>
  by eval

proposition \<open>prover
  (NOT ((Sat 1 (Pos (NOM 4))) AND
  (NOT (Sat 2 (Pos (Pro A)))) AND
  (NOT (Sat 1 (Pos (NOT ((Sat 2 (Pos (NOM 3))) AND (Sat 3 (Pro A))) AND
  NOT ((Sat 2 (Pos (NOM 4))) AND (Sat 4 (Pro A)))))))))\<close>
  by eval

proposition \<open>prover (
  (AT 1 NOM 4) THEN (AT 2 \<diamond> PRO A) OR ((NOT ((AT 2 \<diamond> NOM 3) AND AT 3 PRO A) AND NOT
  ((AT 2 \<diamond> NOM 4) AND AT 4 PRO A))))\<close>
  by eval

proposition \<open>prover (((Sat (1)  (Pos (Nom (2)))) AND (Sat (2) (Pro A)))
                     THEN (Sat (1) (Pos (Pro A))))\<close>
  by eval

proposition \<open>prover (NOT (NOT Pro A AND Pro A))\<close>
  by eval

proposition \<open>prover ((NOM 1 AND PRO A) THEN (AT 1 (PRO A)))\<close>
  by eval

proposition \<open>prover (Pro A THEN (Pro B IFF Pro C) THEN Pro A)\<close>
  by eval

proposition \<open>prover ((Pro A OR Pro B) AND (Pro A OR NOT Pro B) THEN (Pro A))\<close>
  by eval

proposition \<open>prover (NOT (NOT(((Pro B OR (NOT Pro C AND Pro D)) IFF (Pro E OR (Pro C THEN Pro A)))
  IFF (((Pro B OR (NOT Pro C AND Pro D)) THEN (Pro E OR
(Pro C THEN Pro A))) AND ((Pro E OR (Pro C THEN Pro A)) THEN (Pro B OR (NOT Pro C AND Pro D)))))))\<close>
  by eval

proposition \<open>prover (NOT (NOT ((Pro A AND Pro B) THEN ( ((Pro C IFF NOT Pro E) OR NOT Pro F)
THEN ((Pro A AND Pro B) OR (Pro B OR NOT Pro B)) ))
AND (Pro A OR Pro B) AND (Pro C IFF NOT Pro D)))\<close>
  by eval

proposition \<open>prover (NOT ((AT (1) (\<diamond> (NOM 2)))
             AND (AT (2) (Pro A)) AND (AT (1) (\<box> NOT Pro A))))\<close>
  by eval

proposition \<open>prover
 ((AT (1) (\<diamond>(NOM 3))) THEN
  ((AT (2) (Pro A)) OR (AT (1) (\<diamond> (AT (2) (NOT Pro A))))))\<close>
  by eval

proposition \<open>prover ((AT (1) (\<diamond> NOM 2)) AND
                     (AT (2) (\<diamond> NOM 3)) AND
                     (AT (3) (Pro A)) THEN
                     (AT (1) (\<diamond>(\<diamond> (Pro A)))))\<close>
  by eval

proposition \<open>prover ((AT (1) (\<diamond>\<diamond>\<diamond>\<diamond> Pro A)) THEN (AT (1) (\<diamond>\<diamond>\<diamond>\<diamond> Pro A)))\<close>
  by eval

proposition \<open>prover ((AT (1) (
                     (AT (2) (
                     ((\<box>((Pro A) THEN ((NOT ((Pro A) THEN ((Pro B) THEN (Pro A)))) OR (Pro B))))
                      THEN ((\<box>(Pro A)) THEN \<box> (Pro B))))))))\<close>
  by eval

proposition \<open>prover ((\<diamond> NOT PRO A) OR (\<box> PRO A))\<close>
  by eval

proposition \<open>prover ((\<diamond> PRO A) OR (NOT (\<diamond> PRO A)))\<close>
  by eval

proposition \<open>prover ((NOT (\<diamond> PRO A)) OR (\<diamond> PRO A))\<close>
  by eval

proposition \<open>prover ((AT (1) (NOT (\<diamond> NOM (1)))) THEN
                    ((AT (1) (NOM (2) AND (Pro A))) THEN
                     (AT (1) (NOT (\<diamond> NOM (2))))))\<close>
  by eval

proposition \<open>prover ((\<diamond>PRO A) THEN (\<diamond>PRO A))\<close>
  by eval

proposition \<open>prover ((PRO A) AND (AT 1 (\<diamond> NOM 2)) AND (AT 2 (\<diamond> NOM 1)) THEN (AT 1 (\<diamond>\<diamond> NOM 1)))\<close>
  by eval

proposition \<open>prover ((\<diamond> PRO A) THEN (\<diamond> PRO B) OR (\<diamond> NOT PRO B))\<close>
  by eval

proposition \<open>prover ((\<diamond> PRO A) THEN (\<diamond> NOT PRO B) OR (\<diamond> PRO B))\<close>
  by eval

proposition \<open>prover ((\<diamond> PRO A) THEN (\<diamond> (AT 2 NOT (\<diamond> NOM 1))) OR (AT 2 \<diamond> NOM 1))\<close>
  by eval

proposition \<open>prover ((\<diamond> PRO A) THEN (AT 2 \<diamond> NOM 1 ) OR (\<diamond> (AT 2 NOT (\<diamond> NOM 1))))\<close>
  by eval

(*invalid tests*)

proposition \<open>\<not>(prover (Pro A))\<close>
  by eval

proposition \<open>\<not>(prover (Con (Pro A) (Pro A)))\<close>
  by eval

proposition \<open>\<not>(prover (Con (Neg (Pro A)) (Pro A)))\<close>
  by eval

proposition \<open>\<not>(prover (Sat (1) (Con (Neg (Pro A)) (Pro A))))\<close>
  by eval

proposition \<open>\<not>(sv 3 0 [] [] [] [] [(1,\<diamond> NOM 2)] [(1,\<diamond> AT 1 (NOT (\<diamond> PRO A)))])\<close>
  by eval

proposition \<open>\<not>(prover (
  NOT (Pro A AND Pro A)
  AND (Pro C THEN Pro B) AND NOT (NOT Pro E THEN (Pro C OR NOT NOT Pro D))))\<close>
  by eval

proposition \<open>\<not>(prover (
NOT (Pro A AND Pro A) AND (Pro C THEN Pro B) AND
 (AT (1) (NOT (NOT Pro E THEN (Pro C OR NOT NOT Pro D)))) AND
 (AT (2) (AT (3) (Pro C)))
))\<close>
  by eval

proposition \<open>\<not>(prover (
(\<diamond>(Pro A)) AND (\<diamond>((Pro A) AND (\<diamond>(Pro A)))) AND (\<box>((Pro A) AND (\<diamond>(Pro A)) AND
 (\<diamond>((\<diamond>(NOT (Pro A))) AND (\<box>(Pro B)))))) AND
(\<box>(NOT Pro B)) AND ((Pro A) IFF (Pro C)) AND (\<box>((Pro A) IFF (Pro C))) AND
((Pro K) OR (Pro L) OR (Pro M) OR (Pro N) OR (Pro F)) AND
((NOT Pro K) OR (NOT Pro L) OR (NOT Pro M)) AND
(\<box>\<box>\<box>((Pro K) IFF (Pro L)))
))\<close>
  by eval

proposition \<open>\<not>prover ((AT (2) (Pro A)) THEN (AT (1) (\<diamond> (AT (2) (Pro A)))))\<close>
  by eval

proposition \<open>\<not>prover ((Pro A) THEN (Sat (1) (Pro A)))\<close>
  by eval

value \<open>maxnomP 0 ((Pro A) THEN (Sat (1) (Pro A)))\<close>

proposition \<open>\<not>prover (AT 1 (\<diamond> ((NOT (AT 1 (\<diamond> NOM 2))) OR (PRO A OR NOT PRO A))))\<close>
  by eval

proposition \<open>\<not>prover ((\<diamond> NOT(\<diamond> PRO A)) OR \<diamond> NOT (\<diamond> PRO A))\<close>
  by eval

proposition \<open>\<not>prover (PRO A THEN \<diamond> PRO A)\<close>
  by eval

proposition \<open>\<not>prover (AT 1 (\<diamond> ((PRO A OR NOT PRO A) OR NOT (AT 1 \<diamond> NOM 2))))\<close>
  by eval

(*export
definition \<open>main \<equiv> prover (Sat 1 (Neg (Con (Pro A) (Neg (Pro A)))))\<close>
proposition main by eval
export_code main in Haskell*)

end


(*  Title:      HOL/Nitpick_Examples/Refute_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Refute examples adapted to Nitpick.
*)

section \<open>Refute Examples Adapted to Nitpick\<close>

theory Refute_Nits
imports Main
begin

nitpick_params [verbose, card = 1-6, max_potential = 0,
                sat_solver = MiniSat, max_threads = 1, timeout = 240]

lemma "P \<and> Q"
apply (rule conjI)
nitpick [expect = genuine] 1
nitpick [expect = genuine] 2
nitpick [expect = genuine]
nitpick [card = 5, expect = genuine]
nitpick [sat_solver = SAT4J, expect = genuine] 2
oops

subsection \<open>Examples and Test Cases\<close>

subsubsection \<open>Propositional logic\<close>

lemma "True"
nitpick [expect = none]
apply auto
done

lemma "False"
nitpick [expect = genuine]
oops

lemma "P"
nitpick [expect = genuine]
oops

lemma "\<not> P"
nitpick [expect = genuine]
oops

lemma "P \<and> Q"
nitpick [expect = genuine]
oops

lemma "P \<or> Q"
nitpick [expect = genuine]
oops

lemma "P \<longrightarrow> Q"
nitpick [expect = genuine]
oops

lemma "(P::bool) = Q"
nitpick [expect = genuine]
oops

lemma "(P \<or> Q) \<longrightarrow> (P \<and> Q)"
nitpick [expect = genuine]
oops

subsubsection \<open>Predicate logic\<close>

lemma "P x y z"
nitpick [expect = genuine]
oops

lemma "P x y \<longrightarrow> P y x"
nitpick [expect = genuine]
oops

lemma "P (f (f x)) \<longrightarrow> P x \<longrightarrow> P (f x)"
nitpick [expect = genuine]
oops

subsubsection \<open>Equality\<close>

lemma "P = True"
nitpick [expect = genuine]
oops

lemma "P = False"
nitpick [expect = genuine]
oops

lemma "x = y"
nitpick [expect = genuine]
oops

lemma "f x = g x"
nitpick [expect = genuine]
oops

lemma "(f::'a\<Rightarrow>'b) = g"
nitpick [expect = genuine]
oops

lemma "(f::('d\<Rightarrow>'d)\<Rightarrow>('c\<Rightarrow>'d)) = g"
nitpick [expect = genuine]
oops

lemma "distinct [a, b]"
nitpick [expect = genuine]
apply simp
nitpick [expect = genuine]
oops

subsubsection \<open>First-Order Logic\<close>

lemma "\<exists>x. P x"
nitpick [expect = genuine]
oops

lemma "\<forall>x. P x"
nitpick [expect = genuine]
oops

lemma "\<exists>!x. P x"
nitpick [expect = genuine]
oops

lemma "Ex P"
nitpick [expect = genuine]
oops

lemma "All P"
nitpick [expect = genuine]
oops

lemma "Ex1 P"
nitpick [expect = genuine]
oops

lemma "(\<exists>x. P x) \<longrightarrow> (\<forall>x. P x)"
nitpick [expect = genuine]
oops

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>y. \<forall>x. P x y)"
nitpick [expect = genuine]
oops

lemma "(\<exists>x. P x) \<longrightarrow> (\<exists>!x. P x)"
nitpick [expect = genuine]
oops

text \<open>A true statement (also testing names of free and bound variables being identical)\<close>

lemma "(\<forall>x y. P x y \<longrightarrow> P y x) \<longrightarrow> (\<forall>x. P x y) \<longrightarrow> P y x"
nitpick [expect = none]
apply fast
done

text \<open>"A type has at most 4 elements."\<close>

lemma "\<not> distinct [a, b, c, d, e]"
nitpick [expect = genuine]
apply simp
nitpick [expect = genuine]
oops

lemma "distinct [a, b, c, d]"
nitpick [expect = genuine]
apply simp
nitpick [expect = genuine]
oops

text \<open>"Every reflexive and symmetric relation is transitive."\<close>

lemma "\<lbrakk>\<forall>x. P x x; \<forall>x y. P x y \<longrightarrow> P y x\<rbrakk> \<Longrightarrow> P x y \<longrightarrow> P y z \<longrightarrow> P x z"
nitpick [expect = genuine]
oops

text \<open>The ``Drinker's theorem''\<close>

lemma "\<exists>x. f x = g x \<longrightarrow> f = g"
nitpick [expect = none]
apply (auto simp add: ext)
done

text \<open>And an incorrect version of it\<close>

lemma "(\<exists>x. f x = g x) \<longrightarrow> f = g"
nitpick [expect = genuine]
oops

text \<open>"Every function has a fixed point."\<close>

lemma "\<exists>x. f x = x"
nitpick [expect = genuine]
oops

text \<open>"Function composition is commutative."\<close>

lemma "f (g x) = g (f x)"
nitpick [expect = genuine]
oops

text \<open>"Two functions that are equivalent wrt.\ the same predicate 'P' are equal."\<close>

lemma "((P::('a\<Rightarrow>'b)\<Rightarrow>bool) f = P g) \<longrightarrow> (f x = g x)"
nitpick [expect = genuine]
oops

subsubsection \<open>Higher-Order Logic\<close>

lemma "\<exists>P. P"
nitpick [expect = none]
apply auto
done

lemma "\<forall>P. P"
nitpick [expect = genuine]
oops

lemma "\<exists>!P. P"
nitpick [expect = none]
apply auto
done

lemma "\<exists>!P. P x"
nitpick [expect = genuine]
oops

lemma "P Q \<or> Q x"
nitpick [expect = genuine]
oops

lemma "x \<noteq> All"
nitpick [expect = genuine]
oops

lemma "x \<noteq> Ex"
nitpick [expect = genuine]
oops

lemma "x \<noteq> Ex1"
nitpick [expect = genuine]
oops

text \<open>``The transitive closure of an arbitrary relation is non-empty.''\<close>

definition "trans" :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
"trans P \<equiv> (\<forall>x y z. P x y \<longrightarrow> P y z \<longrightarrow> P x z)"

definition
"subset" :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
"subset P Q \<equiv> (\<forall>x y. P x y \<longrightarrow> Q x y)"

definition
"trans_closure" :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
"trans_closure P Q \<equiv> (subset Q P) \<and> (trans P) \<and> (\<forall>R. subset Q R \<longrightarrow> trans R \<longrightarrow> subset P R)"

lemma "trans_closure T P \<longrightarrow> (\<exists>x y. T x y)"
nitpick [expect = genuine]
oops

text \<open>``The union of transitive closures is equal to the transitive closure of unions.''\<close>

lemma "(\<forall>x y. (P x y \<or> R x y) \<longrightarrow> T x y) \<longrightarrow> trans T \<longrightarrow> (\<forall>Q. (\<forall>x y. (P x y \<or> R x y) \<longrightarrow> Q x y) \<longrightarrow> trans Q \<longrightarrow> subset T Q)
 \<longrightarrow> trans_closure TP P
 \<longrightarrow> trans_closure TR R
 \<longrightarrow> (T x y = (TP x y \<or> TR x y))"
nitpick [expect = genuine]
oops

text \<open>``Every surjective function is invertible.''\<close>

lemma "(\<forall>y. \<exists>x. y = f x) \<longrightarrow> (\<exists>g. \<forall>x. g (f x) = x)"
nitpick [expect = genuine]
oops

text \<open>``Every invertible function is surjective.''\<close>

lemma "(\<exists>g. \<forall>x. g (f x) = x) \<longrightarrow> (\<forall>y. \<exists>x. y = f x)"
nitpick [expect = genuine]
oops

text \<open>``Every point is a fixed point of some function.''\<close>

lemma "\<exists>f. f x = x"
nitpick [card = 1-7, expect = none]
apply (rule_tac x = "\<lambda>x. x" in exI)
apply simp
done

text \<open>Axiom of Choice: first an incorrect version\<close>

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>!f. \<forall>x. P x (f x))"
nitpick [expect = genuine]
oops

text \<open>And now two correct ones\<close>

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>f. \<forall>x. P x (f x))"
nitpick [card = 1-4, expect = none]
apply (simp add: choice)
done

lemma "(\<forall>x. \<exists>!y. P x y) \<longrightarrow> (\<exists>!f. \<forall>x. P x (f x))"
nitpick [card = 1-3, expect = none]
apply auto
 apply (simp add: ex1_implies_ex choice)
apply (fast intro: ext)
done

subsubsection \<open>Metalogic\<close>

lemma "\<And>x. P x"
nitpick [expect = genuine]
oops

lemma "f x \<equiv> g x"
nitpick [expect = genuine]
oops

lemma "P \<Longrightarrow> Q"
nitpick [expect = genuine]
oops

lemma "\<lbrakk>P; Q; R\<rbrakk> \<Longrightarrow> S"
nitpick [expect = genuine]
oops

lemma "(x \<equiv> Pure.all) \<Longrightarrow> False"
nitpick [expect = genuine]
oops

lemma "(x \<equiv> (\<equiv>)) \<Longrightarrow> False"
nitpick [expect = genuine]
oops

lemma "(x \<equiv> (\<Longrightarrow>)) \<Longrightarrow> False"
nitpick [expect = genuine]
oops

subsubsection \<open>Schematic Variables\<close>

schematic_goal "?P"
nitpick [expect = none]
apply auto
done

schematic_goal "x = ?y"
nitpick [expect = none]
apply auto
done

subsubsection \<open>Abstractions\<close>

lemma "(\<lambda>x. x) = (\<lambda>x. y)"
nitpick [expect = genuine]
oops

lemma "(\<lambda>f. f x) = (\<lambda>f. True)"
nitpick [expect = genuine]
oops

lemma "(\<lambda>x. x) = (\<lambda>y. y)"
nitpick [expect = none]
apply simp
done

subsubsection \<open>Sets\<close>

lemma "P (A::'a set)"
nitpick [expect = genuine]
oops

lemma "P (A::'a set set)"
nitpick [expect = genuine]
oops

lemma "{x. P x} = {y. P y}"
nitpick [expect = none]
apply simp
done

lemma "x \<in> {x. P x}"
nitpick [expect = genuine]
oops

lemma "P (\<in>)"
nitpick [expect = genuine]
oops

lemma "P ((\<in>) x)"
nitpick [expect = genuine]
oops

lemma "P Collect"
nitpick [expect = genuine]
oops

lemma "A Un B = A Int B"
nitpick [expect = genuine]
oops

lemma "(A Int B) Un C = (A Un C) Int B"
nitpick [expect = genuine]
oops

lemma "Ball A P \<longrightarrow> Bex A P"
nitpick [expect = genuine]
oops

subsubsection \<open>\<^const>\<open>undefined\<close>\<close>

lemma "undefined"
nitpick [expect = genuine]
oops

lemma "P undefined"
nitpick [expect = genuine]
oops

lemma "undefined x"
nitpick [expect = genuine]
oops

lemma "undefined undefined"
nitpick [expect = genuine]
oops

subsubsection \<open>\<^const>\<open>The\<close>\<close>

lemma "The P"
nitpick [expect = genuine]
oops

lemma "P The"
nitpick [expect = genuine]
oops

lemma "P (The P)"
nitpick [expect = genuine]
oops

lemma "(THE x. x=y) = z"
nitpick [expect = genuine]
oops

lemma "Ex P \<longrightarrow> P (The P)"
nitpick [expect = genuine]
oops

subsubsection \<open>\<^const>\<open>Eps\<close>\<close>

lemma "Eps P"
nitpick [expect = genuine]
oops

lemma "P Eps"
nitpick [expect = genuine]
oops

lemma "P (Eps P)"
nitpick [expect = genuine]
oops

lemma "(SOME x. x=y) = z"
nitpick [expect = genuine]
oops

lemma "Ex P \<longrightarrow> P (Eps P)"
nitpick [expect = none]
apply (auto simp add: someI)
done

subsubsection \<open>Operations on Natural Numbers\<close>

lemma "(x::nat) + y = 0"
nitpick [expect = genuine]
oops

lemma "(x::nat) = x + x"
nitpick [expect = genuine]
oops

lemma "(x::nat) - y + y = x"
nitpick [expect = genuine]
oops

lemma "(x::nat) = x * x"
nitpick [expect = genuine]
oops

lemma "(x::nat) < x + y"
nitpick [card = 1, expect = genuine]
oops

text \<open>\<times>\<close>

lemma "P (x::'a\<times>'b)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a\<times>'b. P x"
nitpick [expect = genuine]
oops

lemma "P (x, y)"
nitpick [expect = genuine]
oops

lemma "P (fst x)"
nitpick [expect = genuine]
oops

lemma "P (snd x)"
nitpick [expect = genuine]
oops

lemma "P Pair"
nitpick [expect = genuine]
oops

lemma "P (case x of Pair a b \<Rightarrow> f a b)"
nitpick [expect = genuine]
oops

subsubsection \<open>Subtypes (typedef), typedecl\<close>

text \<open>A completely unspecified non-empty subset of \<^typ>\<open>'a\<close>:\<close>

definition "myTdef = insert (undefined::'a) (undefined::'a set)"

typedef 'a myTdef = "myTdef :: 'a set"
unfolding myTdef_def by auto

lemma "(x::'a myTdef) = y"
nitpick [expect = genuine]
oops

typedecl myTdecl

definition "T_bij = {(f::'a\<Rightarrow>'a). \<forall>y. \<exists>!x. f x = y}"

typedef 'a T_bij = "T_bij :: ('a \<Rightarrow> 'a) set"
unfolding T_bij_def by auto

lemma "P (f::(myTdecl myTdef) T_bij)"
nitpick [expect = genuine]
oops

subsubsection \<open>Inductive Datatypes\<close>

text \<open>unit\<close>

lemma "P (x::unit)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::unit. P x"
nitpick [expect = genuine]
oops

lemma "P ()"
nitpick [expect = genuine]
oops

lemma "P (case x of () \<Rightarrow> u)"
nitpick [expect = genuine]
oops

text \<open>option\<close>

lemma "P (x::'a option)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a option. P x"
nitpick [expect = genuine]
oops

lemma "P None"
nitpick [expect = genuine]
oops

lemma "P (Some x)"
nitpick [expect = genuine]
oops

lemma "P (case x of None \<Rightarrow> n | Some u \<Rightarrow> s u)"
nitpick [expect = genuine]
oops

text \<open>+\<close>

lemma "P (x::'a+'b)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a+'b. P x"
nitpick [expect = genuine]
oops

lemma "P (Inl x)"
nitpick [expect = genuine]
oops

lemma "P (Inr x)"
nitpick [expect = genuine]
oops

lemma "P Inl"
nitpick [expect = genuine]
oops

lemma "P (case x of Inl a \<Rightarrow> l a | Inr b \<Rightarrow> r b)"
nitpick [expect = genuine]
oops

text \<open>Non-recursive datatypes\<close>

datatype T1 = A | B

lemma "P (x::T1)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::T1. P x"
nitpick [expect = genuine]
oops

lemma "P A"
nitpick [expect = genuine]
oops

lemma "P B"
nitpick [expect = genuine]
oops

lemma "rec_T1 a b A = a"
nitpick [expect = none]
apply simp
done

lemma "rec_T1 a b B = b"
nitpick [expect = none]
apply simp
done

lemma "P (rec_T1 a b x)"
nitpick [expect = genuine]
oops

lemma "P (case x of A \<Rightarrow> a | B \<Rightarrow> b)"
nitpick [expect = genuine]
oops

datatype 'a T2 = C T1 | D 'a

lemma "P (x::'a T2)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a T2. P x"
nitpick [expect = genuine]
oops

lemma "P D"
nitpick [expect = genuine]
oops

lemma "rec_T2 c d (C x) = c x"
nitpick [expect = none]
apply simp
done

lemma "rec_T2 c d (D x) = d x"
nitpick [expect = none]
apply simp
done

lemma "P (rec_T2 c d x)"
nitpick [expect = genuine]
oops

lemma "P (case x of C u \<Rightarrow> c u | D v \<Rightarrow> d v)"
nitpick [expect = genuine]
oops

datatype ('a, 'b) T3 = E "'a \<Rightarrow> 'b"

lemma "P (x::('a, 'b) T3)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::('a, 'b) T3. P x"
nitpick [expect = genuine]
oops

lemma "P E"
nitpick [expect = genuine]
oops

lemma "rec_T3 e (E x) = e x"
nitpick [card = 1-4, expect = none]
apply simp
done

lemma "P (rec_T3 e x)"
nitpick [expect = genuine]
oops

lemma "P (case x of E f \<Rightarrow> e f)"
nitpick [expect = genuine]
oops

text \<open>Recursive datatypes\<close>

text \<open>nat\<close>

lemma "P (x::nat)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::nat. P x"
nitpick [expect = genuine]
oops

lemma "P (Suc 0)"
nitpick [expect = genuine]
oops

lemma "P Suc"
nitpick [card = 1-7, expect = none]
oops

lemma "rec_nat zero suc 0 = zero"
nitpick [expect = none]
apply simp
done

lemma "rec_nat zero suc (Suc x) = suc x (rec_nat zero suc x)"
nitpick [expect = none]
apply simp
done

lemma "P (rec_nat zero suc x)"
nitpick [expect = genuine]
oops

lemma "P (case x of 0 \<Rightarrow> zero | Suc n \<Rightarrow> suc n)"
nitpick [expect = genuine]
oops

text \<open>'a list\<close>

lemma "P (xs::'a list)"
nitpick [expect = genuine]
oops

lemma "\<forall>xs::'a list. P xs"
nitpick [expect = genuine]
oops

lemma "P [x, y]"
nitpick [expect = genuine]
oops

lemma "rec_list nil cons [] = nil"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "rec_list nil cons (x#xs) = cons x xs (rec_list nil cons xs)"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "P (rec_list nil cons xs)"
nitpick [expect = genuine]
oops

lemma "P (case x of Nil \<Rightarrow> nil | Cons a b \<Rightarrow> cons a b)"
nitpick [expect = genuine]
oops

lemma "(xs::'a list) = ys"
nitpick [expect = genuine]
oops

lemma "a # xs = b # xs"
nitpick [expect = genuine]
oops

datatype BitList = BitListNil | Bit0 BitList | Bit1 BitList

lemma "P (x::BitList)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::BitList. P x"
nitpick [expect = genuine]
oops

lemma "P (Bit0 (Bit1 BitListNil))"
nitpick [expect = genuine]
oops

lemma "rec_BitList nil bit0 bit1 BitListNil = nil"
nitpick [expect = none]
apply simp
done

lemma "rec_BitList nil bit0 bit1 (Bit0 xs) = bit0 xs (rec_BitList nil bit0 bit1 xs)"
nitpick [expect = none]
apply simp
done

lemma "rec_BitList nil bit0 bit1 (Bit1 xs) = bit1 xs (rec_BitList nil bit0 bit1 xs)"
nitpick [expect = none]
apply simp
done

lemma "P (rec_BitList nil bit0 bit1 x)"
nitpick [expect = genuine]
oops

datatype 'a BinTree = Leaf 'a | Node "'a BinTree" "'a BinTree"

lemma "P (x::'a BinTree)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a BinTree. P x"
nitpick [expect = genuine]
oops

lemma "P (Node (Leaf x) (Leaf y))"
nitpick [expect = genuine]
oops

lemma "rec_BinTree l n (Leaf x) = l x"
nitpick [expect = none]
apply simp
done

lemma "rec_BinTree l n (Node x y) = n x y (rec_BinTree l n x) (rec_BinTree l n y)"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "P (rec_BinTree l n x)"
nitpick [expect = genuine]
oops

lemma "P (case x of Leaf a \<Rightarrow> l a | Node a b \<Rightarrow> n a b)"
nitpick [expect = genuine]
oops

text \<open>Mutually recursive datatypes\<close>

datatype 'a aexp = Number 'a | ITE "'a bexp" "'a aexp" "'a aexp"
 and 'a bexp = Equal "'a aexp" "'a aexp"

lemma "P (x::'a aexp)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a aexp. P x"
nitpick [expect = genuine]
oops

lemma "P (ITE (Equal (Number x) (Number y)) (Number x) (Number y))"
nitpick [expect = genuine]
oops

lemma "P (x::'a bexp)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a bexp. P x"
nitpick [expect = genuine]
oops

lemma "rec_aexp number ite equal (Number x) = number x"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "rec_aexp number ite equal (ITE x y z) = ite x y z (rec_bexp number ite equal x) (rec_aexp number ite equal y) (rec_aexp number ite equal z)"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "P (rec_aexp number ite equal x)"
nitpick [expect = genuine]
oops

lemma "P (case x of Number a \<Rightarrow> number a | ITE b a1 a2 \<Rightarrow> ite b a1 a2)"
nitpick [expect = genuine]
oops

lemma "rec_bexp number ite equal (Equal x y) = equal x y (rec_aexp number ite equal x) (rec_aexp number ite equal y)"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "P (rec_bexp number ite equal x)"
nitpick [expect = genuine]
oops

lemma "P (case x of Equal a1 a2 \<Rightarrow> equal a1 a2)"
nitpick [expect = genuine]
oops

datatype X = A | B X | C Y and Y = D X | E Y | F

lemma "P (x::X)"
nitpick [expect = genuine]
oops

lemma "P (y::Y)"
nitpick [expect = genuine]
oops

lemma "P (B (B A))"
nitpick [expect = genuine]
oops

lemma "P (B (C F))"
nitpick [expect = genuine]
oops

lemma "P (C (D A))"
nitpick [expect = genuine]
oops

lemma "P (C (E F))"
nitpick [expect = genuine]
oops

lemma "P (D (B A))"
nitpick [expect = genuine]
oops

lemma "P (D (C F))"
nitpick [expect = genuine]
oops

lemma "P (E (D A))"
nitpick [expect = genuine]
oops

lemma "P (E (E F))"
nitpick [expect = genuine]
oops

lemma "P (C (D (C F)))"
nitpick [expect = genuine]
oops

lemma "rec_X a b c d e f A = a"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "rec_X a b c d e f (B x) = b x (rec_X a b c d e f x)"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "rec_X a b c d e f (C y) = c y (rec_Y a b c d e f y)"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "rec_Y a b c d e f (D x) = d x (rec_X a b c d e f x)"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "rec_Y a b c d e f (E y) = e y (rec_Y a b c d e f y)"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "rec_Y a b c d e f F = f"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "P (rec_X a b c d e f x)"
nitpick [expect = genuine]
oops

lemma "P (rec_Y a b c d e f y)"
nitpick [expect = genuine]
oops

text \<open>Other datatype examples\<close>

text \<open>Indirect recursion is implemented via mutual recursion.\<close>

datatype XOpt = CX "XOpt option" | DX "bool \<Rightarrow> XOpt option"

lemma "P (x::XOpt)"
nitpick [expect = genuine]
oops

lemma "P (CX None)"
nitpick [expect = genuine]
oops

lemma "P (CX (Some (CX None)))"
nitpick [expect = genuine]
oops

lemma "P (rec_X cx dx n1 s1 n2 s2 x)"
nitpick [expect = genuine]
oops

datatype 'a YOpt = CY "('a \<Rightarrow> 'a YOpt) option"

lemma "P (x::'a YOpt)"
nitpick [expect = genuine]
oops

lemma "P (CY None)"
nitpick [expect = genuine]
oops

lemma "P (CY (Some (\<lambda>a. CY None)))"
nitpick [expect = genuine]
oops

datatype Trie = TR "Trie list"

lemma "P (x::Trie)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::Trie. P x"
nitpick [expect = genuine]
oops

lemma "P (TR [TR []])"
nitpick [expect = genuine]
oops

datatype InfTree = Leaf | Node "nat \<Rightarrow> InfTree"

lemma "P (x::InfTree)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::InfTree. P x"
nitpick [expect = genuine]
oops

lemma "P (Node (\<lambda>n. Leaf))"
nitpick [expect = genuine]
oops

lemma "rec_InfTree leaf node Leaf = leaf"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "rec_InfTree leaf node (Node g) = node ((\<lambda>InfTree. (InfTree, rec_InfTree leaf node InfTree)) \<circ> g)"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "P (rec_InfTree leaf node x)"
nitpick [expect = genuine]
oops

datatype 'a lambda = Var 'a | App "'a lambda" "'a lambda" | Lam "'a \<Rightarrow> 'a lambda"

lemma "P (x::'a lambda)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a lambda. P x"
nitpick [expect = genuine]
oops

lemma "P (Lam (\<lambda>a. Var a))"
nitpick [card = 1-5, expect = none]
nitpick [card 'a = 4, card "'a lambda" = 5, expect = genuine]
oops

lemma "rec_lambda var app lam (Var x) = var x"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "rec_lambda var app lam (App x y) = app x y (rec_lambda var app lam x) (rec_lambda var app lam y)"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "rec_lambda var app lam (Lam x) = lam ((\<lambda>lambda. (lambda, rec_lambda var app lam lambda)) \<circ> x)"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "P (rec_lambda v a l x)"
nitpick [expect = genuine]
oops

text \<open>Taken from "Inductive datatypes in HOL", p. 8:\<close>

datatype (dead 'a, 'b) T = C "'a \<Rightarrow> bool" | D "'b list"
datatype 'c U = E "('c, 'c U) T"

lemma "P (x::'c U)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'c U. P x"
nitpick [expect = genuine]
oops

lemma "P (E (C (\<lambda>a. True)))"
nitpick [expect = genuine]
oops

subsubsection \<open>Records\<close>

record ('a, 'b) point =
  xpos :: 'a
  ypos :: 'b

lemma "(x::('a, 'b) point) = y"
nitpick [expect = genuine]
oops

record ('a, 'b, 'c) extpoint = "('a, 'b) point" +
  ext :: 'c

lemma "(x::('a, 'b, 'c) extpoint) = y"
nitpick [expect = genuine]
oops

subsubsection \<open>Inductively Defined Sets\<close>

inductive_set undefinedSet :: "'a set" where
"undefined \<in> undefinedSet"

lemma "x \<in> undefinedSet"
nitpick [expect = genuine]
oops

inductive_set evenCard :: "'a set set"
where
"{} \<in> evenCard" |
"\<lbrakk>S \<in> evenCard; x \<notin> S; y \<notin> S; x \<noteq> y\<rbrakk> \<Longrightarrow> S \<union> {x, y} \<in> evenCard"

lemma "S \<in> evenCard"
nitpick [expect = genuine]
oops

inductive_set
even :: "nat set"
and odd :: "nat set"
where
"0 \<in> even" |
"n \<in> even \<Longrightarrow> Suc n \<in> odd" |
"n \<in> odd \<Longrightarrow> Suc n \<in> even"

lemma "n \<in> odd"
nitpick [expect = genuine]
oops

consts f :: "'a \<Rightarrow> 'a"

inductive_set a_even :: "'a set" and a_odd :: "'a set" where
"undefined \<in> a_even" |
"x \<in> a_even \<Longrightarrow> f x \<in> a_odd" |
"x \<in> a_odd \<Longrightarrow> f x \<in> a_even"

lemma "x \<in> a_odd"
nitpick [expect = genuine]
oops

subsubsection \<open>Examples Involving Special Functions\<close>

lemma "card x = 0"
nitpick [expect = genuine]
oops

lemma "finite x"
nitpick [expect = none]
oops

lemma "xs @ [] = ys @ []"
nitpick [expect = genuine]
oops

lemma "xs @ ys = ys @ xs"
nitpick [expect = genuine]
oops

lemma "f (lfp f) = lfp f"
nitpick [card = 2, expect = genuine]
oops

lemma "f (gfp f) = gfp f"
nitpick [card = 2, expect = genuine]
oops

lemma "lfp f = gfp f"
nitpick [card = 2, expect = genuine]
oops

subsubsection \<open>Axiomatic Type Classes and Overloading\<close>

text \<open>A type class without axioms:\<close>

class classA

lemma "P (x::'a::classA)"
nitpick [expect = genuine]
oops

text \<open>An axiom with a type variable (denoting types which have at least two elements):\<close>

class classC =
  assumes classC_ax: "\<exists>x y. x \<noteq> y"

lemma "P (x::'a::classC)"
nitpick [expect = genuine]
oops

lemma "\<exists>x y. (x::'a::classC) \<noteq> y"
nitpick [expect = none]
sorry

text \<open>A type class for which a constant is defined:\<close>

class classD =
  fixes classD_const :: "'a \<Rightarrow> 'a"
  assumes classD_ax: "classD_const (classD_const x) = classD_const x"

lemma "P (x::'a::classD)"
nitpick [expect = genuine]
oops

text \<open>A type class with multiple superclasses:\<close>

class classE = classC + classD

lemma "P (x::'a::classE)"
nitpick [expect = genuine]
oops

text \<open>OFCLASS:\<close>

lemma "OFCLASS('a::type, type_class)"
nitpick [expect = none]
apply intro_classes
done

lemma "OFCLASS('a::classC, type_class)"
nitpick [expect = none]
apply intro_classes
done

lemma "OFCLASS('a::type, classC_class)"
nitpick [expect = genuine]
oops

text \<open>Overloading:\<close>

consts inverse :: "'a \<Rightarrow> 'a"

overloading inverse_bool \<equiv> "inverse :: bool \<Rightarrow> bool"
begin
  definition "inverse (b::bool) \<equiv> \<not> b"
end

overloading inverse_set \<equiv> "inverse :: 'a set \<Rightarrow> 'a set"
begin
  definition "inverse (S::'a set) \<equiv> -S"
end

overloading inverse_pair \<equiv> "inverse :: 'a \<times> 'b \<Rightarrow> 'a \<times> 'b"
begin
  definition "inverse_pair p \<equiv> (inverse (fst p), inverse (snd p))"
end

lemma "inverse b"
nitpick [expect = genuine]
oops

lemma "P (inverse (S::'a set))"
nitpick [expect = genuine]
oops

lemma "P (inverse (p::'a\<times>'b))"
nitpick [expect = genuine]
oops

end