theory Category imports FreeLogic

abbrevs "modphism" = ":\<rightarrow>" and
        "wedge" = "\<leftarrow>-()-\<rightarrow>"

begin

 (*Begin: some useful parameter settings*)
declare [[ smt_solver = cvc4, smt_oracle = true, smt_timeout = 120]] declare [[ show_types ]]
sledgehammer_params [provers = cvc4 z3 spass e vampire remote_leo3]
nitpick_params [user_axioms, show_all, format = 2]
(*nitpick_params[user_axioms, show_all, format = 2, expect = genuine]*)
 (*End: some useful parameter settings*)

section \<open>The basis of category theory\<close>

class category =
  fixes domain:: "'a \<Rightarrow> 'a" ("dom _" [108] 109) and
        codomain:: "'a\<Rightarrow> 'a" ("cod _" [110] 111) and
        composition:: "'a \<Rightarrow> 'a  \<Rightarrow> 'a" (infix "\<cdot>" 110)

  assumes
        S1: "E(dom x) \<^bold>\<rightarrow> E x" and
        S2: "E(cod y) \<^bold>\<rightarrow> E y" and
        S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" and
        S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
        S5: "x\<cdot>(dom x) \<cong> x" and
        S6: "(cod y)\<cdot>y \<cong> y"
begin

definition object where "object x \<equiv> dom x \<simeq> x"

definition arrow ("(_):(_)\<rightarrow>(_)" [120,120,120] 119) where
  "x:a\<rightarrow>b \<equiv> dom x \<simeq> a \<and> cod x \<simeq> b"

definition wedge ("_\<leftarrow>_- (_) -_\<rightarrow>_" [120,0,0,0,120] 119) where
  "a \<leftarrow>f- (x) -g\<rightarrow> b \<equiv> dom f \<simeq> x \<and> cod f \<simeq> a \<and> dom g \<simeq> x \<and> cod g \<simeq> b"

definition monic::"'a \<Rightarrow> bool" where
  "monic m \<equiv> \<forall>f g. m\<cdot>f \<simeq> m\<cdot>g \<longrightarrow> f \<simeq> g"

definition epi::"'a \<Rightarrow> bool" where
  "epi m \<equiv> \<forall>f g. f\<cdot>m \<simeq> g\<cdot>m \<longrightarrow> f \<simeq> g"

definition isomorphism::"'a \<Rightarrow> bool" where
  "isomorphism f \<equiv> \<exists>g. f\<cdot>g \<cong> (dom g) \<and> g\<cdot>f \<cong> (dom f)"

definition isomorphic::"'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "isomorphic z y \<equiv> \<exists>f. dom f \<cong> z \<and> cod f \<cong> y \<and> isomorphism f"

definition initial::"'a \<Rightarrow> bool" where
  "initial z \<equiv> \<^bold>\<forall>t. (\<exists>!f. dom f \<simeq> z \<and> cod f \<simeq> t)"

definition final::"'a \<Rightarrow> bool" where
  "final z \<equiv> \<^bold>\<forall>t. (\<exists>!f. dom f \<simeq> t \<and> cod f \<simeq> z)"

\<comment>\<open>Checking equivalences of definitions\<close>
lemma StrongerInitial1: "(initial z) \<longrightarrow>  (\<^bold>\<forall>t. (\<^bold>\<exists>!f. dom f \<simeq> z \<and> cod f \<simeq> t))"
  by (metis (no_types) S1 initial_def ExId_def)

lemma StrongerInitial2: "(\<^bold>\<forall>t. (\<^bold>\<exists>!f. dom f \<simeq> z \<and> cod f \<simeq> t)) \<longrightarrow> initial z"
  by (smt S2 initial_def ExId_def)

lemma WeakerInitial1: "(\<^bold>\<forall>t. (\<exists>!f. dom f \<cong> z \<and> cod f \<cong> t)) \<longrightarrow> initial z"
  by (smt S5 category.S2 category.S3 category_axioms initial_def KlEq_def ExId_def)
lemma WeakerInitial2: "initial z \<longrightarrow> (\<^bold>\<forall>t. (\<exists>!f. dom f \<cong> z \<and> cod f \<cong> t))"
  by (smt initial_def KlEq_def ExId_def)
(*The same as above would do for final*)

end

lemma (in category) InitialsAreIsomorphic: "initial z \<and> initial y \<longrightarrow> isomorphic z y"
  by (metis ExId_def KlEq_def local.S1 local.S3 local.S5 local.S6 local.initial_def local.isomorphic_def local.isomorphism_def)

lemma (in category) InitialIsUnique: "\<forall>z. \<forall>f. initial z \<and> (dom f \<cong> z \<and> cod f \<cong> z) \<longrightarrow> z \<cong> f"
  by (metis ExId_def KlEq_def initial_def local.S2 local.S3 local.S6)

lemma (in category) FinalsAreIsomorphic: "final z \<and> final y \<longrightarrow> isomorphic z y"
  unfolding final_def isomorphic_def isomorphism_def
  apply(auto)
  by (metis ExId_def KlEq_def local.S2 local.S3 local.S5)

lemma (in category) FinalIsUnique: "\<forall>z. \<forall>f. final z \<and> ( dom f \<cong> z \<and> cod f \<cong> z) \<longrightarrow> z \<cong> f" unfolding final_def
  apply(auto)
  by (metis ExId_def KlEq_def local.S2 local.S3 local.S5)

lemma (in category) TwoMonicsBetweenTypes: "(\<^bold>\<forall>(m::'a) (n::'a). monic m \<and> monic n \<and> dom m \<simeq> dom n \<and> cod m \<simeq> cod n \<longrightarrow> (m\<simeq>n))" nitpick oops

(*Relationship between isomorphisms and epic and monic maps*)
proposition (in category) "isomorphism m \<longrightarrow> monic m \<and> epi m" \<comment>\<open>cvc4 proves this\<close>
  by (smt ExId_def KlEq_def epi_def isomorphism_def local.S2 local.S3 local.S4 local.S5 local.S6 monic_def)

proposition (in category) "monic m \<and> epi m \<longrightarrow> isomorphism m" nitpick oops

section \<open>Product\<close>

definition (in category) product::"'a \<Rightarrow> 'a \<Rightarrow> 'a  \<Rightarrow> bool" where
"product a b c \<equiv> \<^bold>\<exists>p1 p2. p1:c\<rightarrow>a \<and> p2:c\<rightarrow>b \<and>
                  (\<^bold>\<forall>x f g. (a\<leftarrow>f-(x)-g\<rightarrow>b) \<longrightarrow> (\<^bold>\<exists>!h. h:x\<rightarrow>c \<and> f \<simeq> p1\<cdot>h \<and> g \<simeq> p2\<cdot>h))"

lemma (in category) "((product a b c) \<and> (product a b d)) \<longrightarrow> isomorphic c d" for a::"'a" and b::"'a" and c::'a and d::"'a"
  unfolding isomorphic_def  isomorphism_def product_def arrow_def wedge_def ExId_def KlEq_def
  by (smt S3 S4 S5)

lemma (in category) "isomorphic c d" if 1: "product a b c" and 2: "product a b d" for a::"'a" and b::"'a" and c::'a and d::"'a"
proof -
  from 1 obtain p1 p2 where "E p1" and "E p2" and
    projMap1: "dom p1 \<simeq> c \<and> cod p1 \<simeq> a \<and> dom p2 \<simeq> c \<and> cod p2 \<simeq> b" and
    uniqueMap1: "\<^bold>\<forall>x f g. ((dom f \<simeq> x \<and> cod f \<simeq> a \<and> dom g \<simeq> x \<and> cod g \<simeq> b) \<longrightarrow>
                   (\<^bold>\<exists>!h. dom h \<simeq> x \<and> cod h \<simeq> c \<and> f \<simeq> p1\<cdot>h \<and> g \<simeq> p2\<cdot>h))" unfolding product_def arrow_def wedge_def ExId_def KlEq_def by auto

  from 2 obtain i j where "E i" and "E j" and
    projMap2: "dom i \<simeq> d \<and> cod i \<simeq> a \<and> dom j \<simeq> d \<and> cod j \<simeq> b" and
    uniqueMap2: "(\<^bold>\<forall>x f g. (dom f \<simeq> x \<and> cod f \<simeq> a \<and> dom g \<simeq> x \<and> cod g \<simeq> b) \<longrightarrow>
                  (\<^bold>\<exists>!h. dom h \<simeq> x \<and> cod h \<simeq> d \<and> f \<simeq> i\<cdot>h \<and> g \<simeq> j\<cdot>h))" unfolding product_def arrow_def wedge_def ExId_def KlEq_def by auto

  let ?universalMap1 = "\<lambda>h::'a. dom h \<simeq> d \<and> cod h \<simeq> c \<and> i \<simeq> p1\<cdot>h \<and> j \<simeq> p2\<cdot>h"

  from uniqueMap1 projMap2 have mapDC: "(\<^bold>\<exists>!h. ?universalMap1 h)" unfolding ExId_def KlEq_def
     by (smt S1) (*also: by (simp add: S1) works but takes longer*)
  then obtain h where uniMap_h: "?universalMap1 h" and h_unique: "(\<^bold>\<forall>x. ?universalMap1 x \<longrightarrow> x = h)" by fast

  let ?universalMap2 = "\<lambda>h. dom h \<simeq> c \<and> cod h \<simeq> d \<and> p1 \<simeq> i\<cdot>h \<and> p2 \<simeq> j\<cdot>h"

  from uniqueMap2 projMap1 have mapCD: "\<^bold>\<exists>!h. ?universalMap2 h" unfolding ExId_def KlEq_def
    by (smt S1) (*also: by (simp add: S1) works but takes longer*)
  then obtain g where uniMap_g: "?universalMap2 g" and g_unique: "(\<^bold>\<forall>x. ?universalMap2 x \<longrightarrow> x = g)" by fast

  have "p1 \<simeq> p1 \<cdot> (h \<cdot> g)" and "i \<simeq> i\<cdot>(g\<cdot>h)"
    apply (metis ExId_def KlEq_def S4 uniMap_g uniMap_h)
    by (metis ExId_def KlEq_def S4 uniMap_g uniMap_h)

  have "p2 \<simeq> p2 \<cdot> (h \<cdot> g)" and "j \<simeq> j \<cdot> (g \<cdot> h)"
    apply (metis ExId_def KlEq_def S4 uniMap_g uniMap_h)
    by (metis ExId_def KlEq_def S4 uniMap_g uniMap_h)

  hence "dom (h \<cdot> g) \<simeq> c" and "dom (g \<cdot> h) \<simeq> d"
    apply (metis ExId_def KlEq_def S3 S4 uniMap_g uniMap_h)
    by (metis ExId_def KlEq_def S3 S4 uniMap_g uniMap_h)

  from uniqueMap1 have "\<^bold>\<exists>!h. dom h \<simeq> c \<and> cod h \<simeq> c \<and> p1 \<simeq> p1\<cdot>h \<and> p2 \<simeq> p2\<cdot>h"
    by (smt ExId_def \<open>E (p1::'a)\<close> \<open>E (p2::'a)\<close> projMap1)

  hence id_hg: "h\<cdot>g \<simeq> c"
    by (metis ExId_def KlEq_def S3 S5 S6 \<open>dom h \<cdot> g \<simeq> c\<close> \<open>p1 \<simeq> p1 \<cdot> (h \<cdot> g)\<close> \<open>p2 \<simeq> p2 \<cdot> (h \<cdot> g)\<close>)

  from uniqueMap2 have "\<^bold>\<exists>!h. dom h \<simeq> d \<and> cod h \<simeq> d \<and> i \<simeq> i\<cdot>h \<and> j \<simeq> j\<cdot>h"
    by (smt ExId_def \<open>E (i::'a)\<close> \<open>E (j::'a)\<close> projMap2)
  hence id_gh: "g\<cdot>h \<simeq> d"
    by (metis ExId_def KlEq_def S3 S5 S6 \<open>dom g \<cdot> h \<simeq> d\<close> \<open>i \<simeq> i \<cdot> (g \<cdot> h)\<close> \<open>j \<simeq> j \<cdot> (g \<cdot> h)\<close>)

  show ?thesis unfolding isomorphism_def isomorphic_def KlEq_def ExId_def
    using uniMap_g id_gh id_hg uniMap_h unfolding isomorphism_def isomorphic_def KlEq_def ExId_def
      by blast
  qed

(*Even when defining all definitions used as abbreviations sledgehammer doesn't find a proof*)
lemma (in category) "product a b c \<longrightarrow> product b a c" unfolding product_def arrow_def wedge_def ExId_def KlEq_def
  by smt

lemma (in category) "product b a c" if "product a b c"
proof -
  from that obtain \<pi>\<^sub>1 \<pi>\<^sub>2 where 1: "E \<pi>\<^sub>1" and 2: "E \<pi>\<^sub>2" and 3: "\<pi>\<^sub>1:c\<rightarrow>a" and 4: "\<pi>\<^sub>2:c\<rightarrow>b"
                              and "\<^bold>\<forall>x f g. (a\<leftarrow>f-(x)-g\<rightarrow>b) \<longrightarrow> (\<^bold>\<exists>!h. h:x\<rightarrow>c \<and> f \<simeq> \<pi>\<^sub>1\<cdot>h \<and> g \<simeq> \<pi>\<^sub>2\<cdot>h)" unfolding product_def by blast

  then have "\<^bold>\<forall>x f g. (b\<leftarrow>f-(x)-g\<rightarrow>a) \<longrightarrow> (\<^bold>\<exists>!h. h:x\<rightarrow>c \<and> f \<simeq> \<pi>\<^sub>2\<cdot>h \<and> g \<simeq> \<pi>\<^sub>1\<cdot>h)" unfolding wedge_def arrow_def
    by smt

  thus ?thesis unfolding product_def using 1 2 3 4 by blast
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_list_nat_perm_refl
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun elem :: "'a => 'a list => bool" where
"elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "isPermutation xs xs"
  oops

end


theory SDL        (* SDL: Standard Deontic Logic. C. Benzmüller & X. Parent, 2019 *)
  imports Main
begin
 typedecl i (*Type for possible worlds.*)
 type_synonym \<sigma> = "(i\<Rightarrow>bool)"
 type_synonym \<gamma> = "\<sigma>\<Rightarrow>\<sigma>"
 type_synonym \<rho> = "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>"

 consts R::"i\<Rightarrow>i\<Rightarrow>bool" (infixr "R" 70) (*Accessibility relation.*)
        aw::i (*Actual world.*)

 abbreviation SDLtop::\<sigma> ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
 abbreviation SDLbot::\<sigma> ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
 abbreviation SDLnot::\<gamma> ("\<^bold>\<not>_"[52]53) where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w)"
 abbreviation SDLand::\<rho> (infixr"\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. \<phi>(w) \<and> \<psi>(w)"
 abbreviation SDLor::\<rho> (infixr"\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. \<phi>(w) \<or> \<psi>(w)"
 abbreviation SDLimp::\<rho> (infixr"\<^bold>\<rightarrow>"49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w) \<longrightarrow> \<psi>(w)"
 abbreviation SDLequ::\<rho> (infixr"\<^bold>\<leftrightarrow>"48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w) \<longleftrightarrow> \<psi>(w)"

 abbreviation SDLobligatory::\<gamma> ("OB") where "OB \<phi> \<equiv> \<lambda>w. \<forall>v.  w R v \<longrightarrow> \<phi>(v)"
 abbreviation SDLpermissible::\<gamma> ("PE") where "PE \<phi> \<equiv> \<^bold>\<not>(OB(\<^bold>\<not>\<phi>))"
 abbreviation SDLimpermissible::\<gamma> ("IM") where "IM \<phi> \<equiv> OB(\<^bold>\<not>\<phi>)"
 abbreviation SDLomissible::\<gamma> ("OM") where "OM \<phi> \<equiv> \<^bold>\<not>(OB \<phi>)"
 abbreviation SDLoptional::\<gamma> ("OP") where "OP \<phi> \<equiv> (\<^bold>\<not>(OB \<phi>) \<^bold>\<and>  \<^bold>\<not>(OB(\<^bold>\<not>\<phi>)))"

 abbreviation SDLvalid::"\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>"[7]105)  where "\<lfloor>A\<rfloor> \<equiv> \<forall>w. A w"       (*Global validity.*)
 abbreviation SDLvalidcw::"\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sub>l"[7]105)    where "\<lfloor>A\<rfloor>\<^sub>l \<equiv> A aw"   (*Validity in actual world.*)

(*Possibilist Quantification.*)
 abbreviation SDLforall ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w.\<forall>x. (\<Phi> x w)"
 abbreviation SDLforallB (binder"\<^bold>\<forall>"[8]9) where "\<^bold>\<forall>x. \<phi>(x) \<equiv> \<^bold>\<forall>\<phi>"
 abbreviation SDLexists ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>w.\<exists>x. (\<Phi> x w)"
 abbreviation SDLexistsB (binder"\<^bold>\<exists>"[8]9) where "\<^bold>\<exists>x. \<phi>(x) \<equiv> \<^bold>\<exists>\<phi>"

 axiomatization where D: "\<lfloor>\<^bold>\<not> ((OB \<phi>) \<^bold>\<and> (OB (\<^bold>\<not> \<phi>)))\<rfloor>" (*Axiom D: seriality of r.*)
 lemma seriality: "(\<forall>w. \<exists>v. w R v)" sledgehammer
  using D by auto

 abbreviation SDLobl::\<gamma> ("\<^bold>\<circle><_>") where "\<^bold>\<circle><\<phi>> \<equiv>  OB \<phi>"  (*New syntax: A is obligatory.*)

(*Consistency confirmed by model finder Nitpick.*)
 lemma True nitpick[satisfy,user_axioms,expect=genuine] oops

(*Barcan formulas.*)
 lemma Barcan:         "\<lfloor>(\<^bold>\<forall>d. \<^bold>\<circle><\<phi>(d)>) \<^bold>\<rightarrow> (\<^bold>\<circle><\<^bold>\<forall>d. \<phi>(d)>)\<rfloor>" by simp
 lemma ConverseBarcan: "\<lfloor>(\<^bold>\<circle><\<^bold>\<forall>d. \<phi>(d)>) \<^bold>\<rightarrow> (\<^bold>\<forall>d. \<^bold>\<circle><\<phi>(d)>)\<rfloor>" by simp
end


theory Codatatype_thru_Datatype
imports Main
begin

section {* Inductive Datatypes with Nesting through Codatatypes as in Isabelle/HOL *}

text {*
The abstract interface between a codatatype and a datatype through which it is
nested is a relator. This is modeled below by an @{text all2} predicate.
*}

subsection {* Basic Setup *}

hide_const (open) Nil Cons hd tl

text \<open>
This will be called @{text "iota!"} in Nunchaku:
\<close>

definition The_bang :: "('a \<Rightarrow> bool) \<Rightarrow> 'a" where
  "The_bang P = (if \<exists>x. P x then The P else Nitpick.unknown)"

definition pred_of_fun :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool" where
  "pred_of_fun p f x y \<longleftrightarrow> p x \<and> f x = y"

typedecl elem
typedecl tree
typedecl forest

nitpick_params [user_axioms, dont_box, show_all, atoms elem = a b c d e f g h i j k l,
  atoms forest = as bs cs ds es fs gs hs "is" js ks ls,
  atoms tree = aa bb cc dd ee ff gg hh ii jj kk ll]

subsection {* Datatype Destructors *}

axiomatization
  null :: "forest \<Rightarrow> bool" and
  hd :: "forest \<Rightarrow> tree" and
  tl :: "forest \<Rightarrow> forest"

axiomatization where
  unique_nil: "\<And>xs ys. null xs \<Longrightarrow> null ys \<Longrightarrow> xs = ys" and
  unique_cons: "\<And>xs ys. \<not> null xs \<Longrightarrow> \<not> null ys \<Longrightarrow> hd xs = hd ys \<Longrightarrow> tl xs = tl ys \<Longrightarrow> xs = ys" and
  acyclic: "\<And>xs. \<not> tranclp (pred_of_fun (Not \<circ> null) tl) xs xs"

text \<open>
It is important to ignore the lists hiding under the trees for acyclicity.
\<close>

inductive
  all2 :: "(tree \<Rightarrow> tree \<Rightarrow> bool) \<Rightarrow> forest \<Rightarrow> forest \<Rightarrow> bool"
where
  "null xs \<Longrightarrow> null ys \<Longrightarrow> all2 p xs ys"
|  "\<not> null xs \<Longrightarrow> \<not> null ys \<Longrightarrow> p (hd xs) (hd ys) \<Longrightarrow> all2 p (tl xs) (tl ys) \<Longrightarrow> all2 p xs ys"

lemma all2_mono[mono]: "(\<And>xx yy. p xx yy \<longrightarrow> q xx yy) \<Longrightarrow> all2 p xs ys \<longrightarrow> all2 q xs ys"
  sorry

subsection {* Codatatype Destructors *}

axiomatization
  lab :: "tree \<Rightarrow> elem" and
  sub :: "tree \<Rightarrow> forest"
thm rel_fun_mono'

coinductive bisim :: "tree \<Rightarrow> tree \<Rightarrow> bool" where
  "lab xx = lab yy \<Longrightarrow> all2 bisim (sub xx) (sub yy) \<Longrightarrow> bisim xx yy"

axiomatization where
  unique: "\<And>xs ys. bisim xs ys \<Longrightarrow> xs = ys"

nitpick_params [card elem = 3, card forest = 1-5, card tree = 1-5, iter = 1-5, mono]

subsection {* Datatype Constructors *}

definition
  Nil :: forest
where
  "Nil = The_bang (\<lambda>ys. null ys)"

definition
  Cons :: "tree \<Rightarrow> forest \<Rightarrow> forest"
where
  "Cons x xs = The_bang (\<lambda>ys. \<not> null ys \<and> hd ys = x \<and> tl ys = xs)"

lemma "Nil \<noteq> Cons x xs"
  nitpick[satisfy, expect = genuine]
  nitpick[expect = none]
  sorry

lemma "xs = Nil \<or> xs = Cons (hd xs) (tl xs)"
  nitpick[satisfy, expect = genuine]
  nitpick [expect = none]
  sorry

lemma "xs \<noteq> Cons x xs"
  nitpick [expect = none]
  sorry

lemma "xs \<noteq> Cons x (Cons y xs)"
  nitpick [expect = none]
  sorry

lemma "xs = ys \<longleftrightarrow> (null xs \<and> null ys) \<or> (\<not> null xs \<and> \<not> null ys \<and> hd xs = hd ys \<and> tl xs = tl ys)"
  nitpick [expect = none]
  sorry

lemma "xs \<noteq> Nil \<Longrightarrow> xs \<noteq> sub (hd xs)"
  nitpick [expect = genuine]
  oops

subsection {* Codatatype Constructors *}

definition
  Node :: "elem \<Rightarrow> forest \<Rightarrow> tree"
where
  "Node x xs = The_bang (\<lambda>yy. lab yy = x \<and> sub yy = xs)"

lemma "xx \<noteq> Node x (Cons xx xs)"
  nitpick [expect = genuine]
  sorry

lemma "xx \<noteq> Node x (Cons (Node y (Cons xx Nil)) Nil)"
  nitpick [expect = genuine]
  nitpick [satisfy, expect = genuine]
  sorry

lemma "xx = yy \<longleftrightarrow> lab xx = lab yy \<and> sub xx = sub yy"
  nitpick [expect = none]
  sorry

lemma "sub xx \<noteq> Nil \<Longrightarrow> tl (sub xx) \<noteq> sub xx"
  nitpick [expect = none]
  oops

end


theory Official
  imports Defs
begin

(* Definitions *)

fun aux where
  "aux [] _ = True"
| "aux _ [] = False"
| "aux (x#xs) (y#ys) = (if x = y then aux xs ys else aux (x # xs) ys)"

fun aux2 where
  "aux2 ys acc [] = True"
| "aux2 ys acc (x # xs) \<longleftrightarrow> aux (acc @ xs) ys \<and> aux2 ys (acc @ [x]) xs"

definition
  "judge xs ys \<longleftrightarrow> aux2 ys [] xs"

(* Task *)

theorem judge_correct: "judge xs ys \<longleftrightarrow> all_proper_subseq xs ys"
  oops

(* Solution *)

lemma aux_def: "aux xs ys \<longleftrightarrow> Sublist.subseq xs ys"
  by (induction xs ys rule: aux.induct) auto

lemma aux2_def: "aux2 ys zs xs \<longleftrightarrow> (\<forall>i < length xs. aux (zs @ take i xs @ drop (Suc i) xs) ys)"
proof (induction ys zs xs rule: aux2.induct)
  case (2 ys acc x xs)
  show ?case
    apply (auto simp: 2)
    subgoal for i
      by (cases i) auto
    done
qed auto

lemma strict_subseq_only_if: "Sublist.subseq xs ys \<Longrightarrow> xs \<noteq> ys \<Longrightarrow>
  \<exists>i < length ys. Sublist.subseq xs (take i ys @ drop (Suc i) ys)"
  by (induction xs ys rule: list_emb.induct) auto

lemma strict_subseq_if: "i < length ys \<Longrightarrow> Sublist.subseq xs (take i ys @ drop (Suc i) ys) \<Longrightarrow>
  Sublist.strict_subseq xs ys"
  by (auto simp: strict_subseq_def)
     (metis append_Nil append_take_drop_id drop_drop list_emb_Nil plus_1_eq_Suc subseq_append
      subseq_append' subseq_order.dual_order.trans)

lemma strict_subseq_iff: "Sublist.strict_subseq xs ys \<longleftrightarrow>
  (\<exists>i < length ys. Sublist.subseq xs (take i ys @ drop (Suc i) ys))"
  using strict_subseq_only_if strict_subseq_if
  unfolding strict_subseq_def
  by blast

theorem judge_correct: "judge xs ys \<longleftrightarrow> all_proper_subseq xs ys"
  by (auto simp: judge_def aux2_def aux_def all_proper_subseq_def strict_subseq_iff)

definition judge_string :: "string \<Rightarrow> string \<Rightarrow> bool" where
  "judge_string = judge"

export_code judge_string String.explode in OCaml module_name Judge file_prefix official

end