(* Title:     HOL/MiniML/Type.thy

   Author:    Wolfgang Naraschewski and Tobias Nipkow
   Copyright  1996 TU Muenchen
*)

header "MiniML-types and type substitutions"

theory Type
imports Maybe
begin

-- "type expressions"
datatype "typ" = TVar nat | Fun "typ" "typ" (infixr "->" 70)

-- "type schemata"
datatype type_scheme = FVar nat | BVar nat | SFun type_scheme type_scheme (infixr "=->" 70)

-- "embedding types into type schemata"
primrec mk_scheme :: "typ => type_scheme" where
  "mk_scheme (TVar n) = (FVar n)"
| "mk_scheme (t1 -> t2) = ((mk_scheme t1) =-> (mk_scheme t2))"

-- "type variable substitution"
type_synonym subst = "nat => typ"

class type_struct =
  fixes free_tv :: "'a => nat set"
    -- {* @{text "free_tv s"}: the type variables occuring freely in the type structure s *}
  fixes free_tv_ML :: "'a => nat list"
    -- {* executable version of @{text free_tv}: Implementation with lists *}
  fixes bound_tv :: "'a => nat set"
    -- {* @{text "bound_tv s"}: the type variables occuring bound in the type structure s *}
  fixes min_new_bound_tv :: "'a => nat"
    -- "minimal new free / bound variable"
  fixes app_subst :: "subst => 'a => 'a" ("$")
    -- "extension of substitution to type structures"

instantiation "typ" :: type_struct
begin

primrec free_tv_typ where
  free_tv_TVar:    "free_tv (TVar m) = {m}"
| free_tv_Fun:     "free_tv (t1 -> t2) = (free_tv t1) Un (free_tv t2)"

primrec app_subst_typ where
  app_subst_TVar: "$ S (TVar n) = S n"
| app_subst_Fun:  "$ S (t1 -> t2) = ($ S t1) -> ($ S t2)"

instance ..

end

instantiation type_scheme :: type_struct
begin

primrec free_tv_type_scheme where
  "free_tv (FVar m) = {m}"
| "free_tv (BVar m) = {}"
| "free_tv (S1 =-> S2) = (free_tv S1) Un (free_tv S2)"

primrec free_tv_ML_type_scheme where
  "free_tv_ML (FVar m) = [m]"
| "free_tv_ML (BVar m) = []"
| "free_tv_ML (S1 =-> S2) = (free_tv_ML S1) @ (free_tv_ML S2)"

primrec bound_tv_type_scheme where
  "bound_tv (FVar m) = {}"
| "bound_tv (BVar m) = {m}"
| "bound_tv (S1 =-> S2) = (bound_tv S1) Un (bound_tv S2)"

primrec min_new_bound_tv_type_scheme where
  "min_new_bound_tv (FVar n) = 0"
| "min_new_bound_tv (BVar n) = Suc n"
| "min_new_bound_tv (sch1 =-> sch2) = max (min_new_bound_tv sch1) (min_new_bound_tv sch2)"

primrec app_subst_type_scheme where
  "$ S (FVar n) = mk_scheme (S n)"
| "$ S (BVar n) = (BVar n)"
| "$ S (sch1 =-> sch2) = ($ S sch1) =-> ($ S sch2)"

instance ..

end

instantiation list :: (type_struct) type_struct
begin

primrec free_tv_list where
  "free_tv [] = {}"
| "free_tv (x#l) = (free_tv x) Un (free_tv l)"

primrec free_tv_ML_list where
  "free_tv_ML [] = []"
| "free_tv_ML (x#l) = (free_tv_ML x) @ (free_tv_ML l)"

primrec bound_tv_list where
  "bound_tv [] = {}"
| "bound_tv (x#l) = (bound_tv x) Un (bound_tv l)"

definition app_subst_list where
  app_subst_list: "$ S = map ($ S)"

instance ..

end

text
{* @{text "new_tv s n"} computes whether n is a new type variable w.r.t. a type
   structure s, i.e. whether n is greater than any type variable
   occuring in the type structure *}
definition
  new_tv :: "[nat,'a::type_struct] => bool" where
  "new_tv n ts = (! m. m:(free_tv ts) --> m<n)"

-- "identity"
definition
  id_subst :: subst where
  "id_subst = (%n. TVar n)"

-- "domain of a substitution"
definition
  dom :: "subst => nat set" where
  "dom S = {n. S n ~= TVar n}"

-- "codomain of a substitution: the introduced variables"
definition
  cod :: "subst => nat set" where
  "cod S = (UN m:dom S. (free_tv (S m)))"

class of_nat =
  fixes of_nat :: "nat \<Rightarrow> 'a"

instantiation nat :: of_nat
begin

definition
  "of_nat n = n"

instance ..

end

class typ_of =
  fixes typ_of :: "'a \<Rightarrow> typ"

instantiation "typ" :: typ_of
begin

definition
  "typ_of T = T"

instance ..

end

instantiation "fun" :: (of_nat, typ_of) type_struct
begin

definition free_tv_fun where
  "free_tv f = (let S = \<lambda>n. typ_of (f (of_nat n)) in (dom S) Un (cod S))"

instance ..

end

lemma free_tv_subst:
  "free_tv S = (dom S) Un (cod S)"
  by (simp add: free_tv_fun_def of_nat_nat_def typ_of_typ_def )

-- "unification algorithm mgu"
axiomatization mgu :: "typ \<Rightarrow> typ \<Rightarrow> subst option" where
  mgu_eq:   "mgu t1 t2 = Some U ==> $U t1 = $U t2"
  and mgu_mg:   "[| (mgu t1 t2) = Some U; $S t1 = $S t2 |] ==> ? R. S = $R o U"
  and mgu_Some: "$S t1 = $S t2 ==> ? U. mgu t1 t2 = Some U"
  and mgu_free: "mgu t1 t2 = Some U ==> (free_tv U) <= (free_tv t1) Un (free_tv t2)"

declare mgu_eq [simp] mgu_mg [simp] mgu_free [simp]
lemma mk_scheme_Fun [rule_format]: "mk_scheme t = sch1 =-> sch2 --> (? t1 t2. sch1 = mk_scheme t1 & sch2 = mk_scheme t2)"
apply (induct_tac "t")
apply (simp (no_asm))
apply simp
apply fast
done

lemma mk_scheme_injective [rule_format]: "!t'. mk_scheme t = mk_scheme t' --> t=t'"
apply (induct_tac "t")
 apply (rule allI)
 apply (induct_tac "t'")
  apply (simp (no_asm))
 apply simp
apply (rule allI)
apply (induct_tac "t'")
 apply (simp (no_asm))
apply simp
done

lemma free_tv_mk_scheme: "free_tv (mk_scheme t) = free_tv t"
apply (induct_tac "t")
apply (simp_all (no_asm_simp))
done

declare free_tv_mk_scheme [simp]

lemma subst_mk_scheme: "$ S (mk_scheme t) = mk_scheme ($ S t)"
apply (induct_tac "t")
apply (simp_all (no_asm_simp))
done

declare subst_mk_scheme [simp]

-- "constructor laws for @{text app_subst}"

lemma app_subst_Nil:
  "$ S [] = []"

apply (unfold app_subst_list)
apply (simp (no_asm))
done

declare app_subst_Nil [simp] app_subst_Cons [simp]

-- {* constructor laws for @{text new_tv} *}

lemma new_tv_TVar:
  "new_tv n (TVar m) = (m<n)"

apply (unfold new_tv_def)
apply (fastforce)
done

lemma new_tv_FVar:
  "new_tv n (FVar m) = (m<n)"
apply (unfold new_tv_def)
apply (fastforce)
done

lemma new_tv_BVar:
  "new_tv n (BVar m) = True"
apply (unfold new_tv_def)
apply (simp (no_asm))
done

lemma new_tv_Fun:
  "new_tv n (t1 -> t2) = (new_tv n t1 & new_tv n t2)"
apply (unfold new_tv_def)
apply (fastforce)
done

lemma new_tv_Fun2:
  "new_tv n (t1 =-> t2) = (new_tv n t1 & new_tv n t2)"
apply (unfold new_tv_def)
apply (fastforce)
done

lemma new_tv_Nil:
  "new_tv n []"
apply (unfold new_tv_def)
apply (simp (no_asm))
done

lemma new_tv_Cons:
  "new_tv n (x#l) = (new_tv n x & new_tv n l)"
apply (unfold new_tv_def)
apply (fastforce)
done

lemma new_tv_TVar_subst: "new_tv n TVar"
apply (unfold new_tv_def)
apply (intro strip)
apply (simp add: free_tv_subst dom_def cod_def)
done

declare
  new_tv_TVar [simp] new_tv_FVar [simp] new_tv_BVar [simp]
  new_tv_Fun [simp] new_tv_Fun2 [simp] new_tv_Nil [simp]
  new_tv_Cons [simp] new_tv_TVar_subst [simp]

lemma new_tv_id_subst [simp]: "new_tv n id_subst"
  by (simp add: id_subst_def new_tv_def free_tv_subst dom_def cod_def)

lemma new_if_subst_type_scheme [simp]: "new_tv n (sch::type_scheme) \<Longrightarrow>
    $(%k. if k<n then S k else S' k) sch = $S sch"
  by (induct sch) simp_all

lemma new_if_subst_type_scheme_list [simp]: "new_tv n (A::type_scheme list) \<Longrightarrow>
    $(%k. if k<n then S k else S' k) A = $S A"
  by (induct A) simp_all

-- "constructor laws for @{text dom} and @{text cod}"

lemma dom_id_subst [simp]: "dom id_subst = {}"
  unfolding dom_def id_subst_def empty_def by simp

lemma cod_id_subst [simp]: "cod id_subst = {}"
  unfolding cod_def by simp

lemma free_tv_id_subst [simp]: "free_tv id_subst = {}"
  unfolding free_tv_subst by simp

lemma free_tv_nth_A_impl_free_tv_A [rule_format, simp]:
  "!n. n < length A --> x : free_tv (A!n) --> x : free_tv A"
apply (induct A)
apply simp
apply (rule allI)
apply (induct_tac n)
apply simp
apply simp
done

text
{* if two substitutions yield the same result if applied to a type
   structure the substitutions coincide on the free type variables
   occurring in the type structure *}

lemma typ_substitutions_only_on_free_variables:
  "(!x:free_tv t. (S x) = (S' x)) \<Longrightarrow> $ S (t::typ) = $ S' t"
  by (induct t) simp_all

lemma eq_free_eq_subst_te: "(!n. n:(free_tv t) --> S1 n = S2 n) ==> $ S1 (t::typ) = $ S2 t"
apply (rule typ_substitutions_only_on_free_variables)
apply simp
done

lemma scheme_substitutions_only_on_free_variables:
  "(!x:free_tv sch. (S x) = (S' x)) \<Longrightarrow> $ S (sch::type_scheme) = $ S' sch"
  by (induct sch) simp_all

lemma eq_free_eq_subst_type_scheme:
  "(!n. n:(free_tv sch) --> S1 n = S2 n) ==> $ S1 (sch::type_scheme) = $ S2 sch"
apply (rule scheme_substitutions_only_on_free_variables)
apply simp
done

lemma weaken_asm_Un: "((!x:A. (P x)) --> Q) ==> ((!x:A Un B. (P x)) --> Q)"
  by fast

lemma scheme_list_substitutions_only_on_free_variables [rule_format]:
  "(!x:free_tv A. (S x) = (S' x)) --> $ S (A::type_scheme list) = $ S' A"
apply (induct_tac A)
apply simp
apply simp
apply (rule weaken_asm_Un)
apply (intro strip)
apply (erule scheme_substitutions_only_on_free_variables)
done

lemma eq_subst_te_eq_free:
  "$ S1 (t::typ) = $ S2 t \<Longrightarrow> n:(free_tv t) \<Longrightarrow> S1 n = S2 n"
  by (induct t) auto

lemma eq_subst_type_scheme_eq_free [rule_format]:
  "$ S1 (sch::type_scheme) = $ S2 sch --> n:(free_tv sch) --> S1 n = S2 n"
apply (induct_tac "sch")
(* case TVar n *)
apply simp
(* case BVar n *)
apply (intro strip)
apply (erule mk_scheme_injective)
apply simp
(* case Fun t1 t2 *)
apply simp
done

lemma eq_subst_scheme_list_eq_free:
  "$S1 (A::type_scheme list) = $S2 A \<Longrightarrow> n:(free_tv A) \<Longrightarrow> S1 n = S2 n"
proof (induct A)
  case Nil
  then show ?case by fastforce
next
  case Cons
  then show ?case by (fastforce intro: eq_subst_type_scheme_eq_free)
qed

lemma codD: "v : cod S ==> v : free_tv S"
  unfolding free_tv_subst by blast

lemma not_free_impl_id: "x ~: free_tv S ==> S x = TVar x"
  unfolding free_tv_subst dom_def by blast

lemma free_tv_le_new_tv: "[| new_tv n t; m:free_tv t |] ==> m<n"
  unfolding new_tv_def by blast

lemma cod_app_subst [simp]:
  "[| v : free_tv(S n); v~=n |] ==> v : cod S"
apply (unfold dom_def cod_def UNION_eq Bex_def)
apply (simp (no_asm))
apply (safe intro!: exI)
prefer 2 apply (assumption)
apply simp
done

lemma free_tv_subst_var: "free_tv (S (v::nat)) <= insert v (cod S)"
apply (cases "v:dom S")
apply (fastforce simp add: cod_def)
apply (fastforce simp add: dom_def)
done

lemma free_tv_app_subst_te: "free_tv ($ S (t::typ)) <= cod S Un free_tv t"
proof (induct t)
  case (TVar n) then show ?case by (simp add: free_tv_subst_var)
next
  case (Fun t1 t2) then show ?case by fastforce
qed

lemma free_tv_app_subst_type_scheme:
    "free_tv ($ S (sch::type_scheme)) <= cod S Un free_tv sch"
proof (induct sch)
  case (FVar n)
  then show ?case by (simp add: free_tv_subst_var)
next
  case (BVar n)
  then show ?case by simp
next
  case (SFun t1 t2)
  then show ?case by fastforce
qed

lemma free_tv_app_subst_scheme_list: "free_tv ($ S (A::type_scheme list)) <= cod S Un free_tv A"
proof (induct A)
  case Nil then show ?case by simp
next
  case (Cons a al)
  with free_tv_app_subst_type_scheme
  show ?case by fastforce
qed

lemma free_tv_comp_subst:
  "free_tv (%u::nat. $ s1 (s2 u) :: typ) <=
    free_tv s1 Un free_tv s2"
  unfolding free_tv_subst dom_def
  by (force simp add: cod_def dom_def
    dest!:free_tv_app_subst_te [THEN subsetD])

lemma free_tv_o_subst:
    "free_tv ($ S1 o S2) <= free_tv S1 Un free_tv (S2 :: nat => typ)"
  unfolding o_def by (rule free_tv_comp_subst)

lemma free_tv_of_substitutions_extend_to_types:
    "n : free_tv t \<Longrightarrow> free_tv (S n) <= free_tv ($ S t::typ)"
  by (induct t) auto

lemma free_tv_of_substitutions_extend_to_schemes:
    "n : free_tv sch \<Longrightarrow> free_tv (S n) <= free_tv ($ S sch::type_scheme)"
  by (induct sch) auto

lemma free_tv_of_substitutions_extend_to_scheme_lists [simp]:
    "n : free_tv A \<Longrightarrow> free_tv (S n) <= free_tv ($ S A::type_scheme list)"
  by (induct A) (auto dest: free_tv_of_substitutions_extend_to_schemes)

lemma free_tv_ML_scheme:
  fixes sch :: type_scheme
  shows "(n : free_tv sch) = (n: set (free_tv_ML sch))"
  by (induct sch) simp_all

lemma free_tv_ML_scheme_list:
  fixes A :: "type_scheme list"
  shows "(n : free_tv A) = (n: set (free_tv_ML A))"
  by (induct_tac A) (simp_all add: free_tv_ML_scheme)

-- "lemmata for @{text bound_tv}"

lemma bound_tv_mk_scheme [simp]: "bound_tv (mk_scheme t) = {}"
  by (induct t) simp_all

lemma bound_tv_subst_scheme [simp]:
  fixes sch :: type_scheme
  shows "bound_tv ($ S sch) = bound_tv sch"
  by (induct sch) simp_all

lemma bound_tv_subst_scheme_list [simp]:
  fixes A :: "type_scheme list"
  shows "bound_tv ($ S A) = bound_tv A"
  by (induct A) simp_all

-- "lemmata for @{text new_tv}"

lemma new_tv_subst:
  "new_tv n S = ((!m. n <= m --> (S m = TVar m)) &
                 (! l. l < n --> new_tv n (S l) ))"

apply (unfold new_tv_def)
apply (safe)
  (* ==> *)
  apply (fastforce dest: leD simp add: free_tv_subst dom_def)
 apply (subgoal_tac "m:cod S | S l = TVar l")
  apply safe
   apply (fastforce dest: UnI2 simp add: free_tv_subst)
  apply (drule_tac P = "%x. m:free_tv x" in subst , assumption)
  apply simp
 apply (fastforce simp add: free_tv_subst cod_def dom_def)
(* <== *)
apply (unfold free_tv_subst cod_def dom_def)
apply safe
apply (metis not_leE)+
done

lemma new_tv_list: "new_tv n x = (!y:set x. new_tv n y)"
  by (induct x) simp_all

-- "substitution affects only variables occurring freely"
lemma subst_te_new_tv [simp]:
    "new_tv n (t::typ) --> $(%x. if x=n then t' else S x) t = $S t"
  by (induct t) simp_all

lemma subst_te_new_type_scheme [simp]:
    "new_tv n (sch::type_scheme) \<Longrightarrow> $(%x. if x=n then sch' else S x) sch = $S sch"
  by (induct sch) simp_all

lemma subst_tel_new_scheme_list [simp]:
    "new_tv n (A::type_scheme list) \<Longrightarrow> $(%x. if x=n then t else S x) A = $S A"
  by (induct A) simp_all

-- "all greater variables are also new"
lemma new_tv_le:
  "n<=m ==> new_tv n t ==> new_tv m t"
apply (unfold new_tv_def)
apply safe
apply (drule spec)
apply (erule (1) notE impE)
apply (simp (no_asm))
done

lemma new_tv_typ_le: "n<=m ==> new_tv n (t::typ) ==> new_tv m t"
  by (simp add: new_tv_le)

lemma new_scheme_list_le: "n<=m ==> new_tv n (A::type_scheme list) ==> new_tv m A"
  by (simp add: new_tv_le)

lemma new_tv_subst_le: "n<=m ==> new_tv n (S::subst) ==> new_tv m S"
  by (simp add: new_tv_le)

-- "@{text new_tv} property remains if a substitution is applied"
lemma new_tv_subst_var:
  "[| n<m; new_tv m (S::subst) |] ==> new_tv m (S n)"
  by (simp add: new_tv_subst)

lemma new_tv_subst_te [simp]:
    "new_tv n S \<Longrightarrow> new_tv n (t::typ) \<Longrightarrow> new_tv n ($ S t)"
  by (induct t) (auto simp add: new_tv_subst)

lemma new_tv_subst_type_scheme [rule_format, simp]:
  "new_tv n S --> new_tv n (sch::type_scheme) --> new_tv n ($ S sch)"
apply (induct sch)
apply (simp_all)
apply (unfold new_tv_def)
apply (simp (no_asm) add: free_tv_subst dom_def cod_def)
apply (intro strip)
apply (rename_tac nat m)
apply (case_tac "S nat = TVar nat")
apply simp
apply (drule_tac x = "m" in spec)
apply fast
done

lemma new_tv_subst_scheme_list [simp]:
    "new_tv n S \<Longrightarrow> new_tv n (A::type_scheme list) \<Longrightarrow> new_tv n ($ S A)"
  by (induct A) auto

lemma new_tv_Suc_list: "new_tv n A --> new_tv (Suc n) ((TVar n)#A)"
  by (simp add: new_tv_list)

lemma new_tv_only_depends_on_free_tv_type_scheme:
  fixes sch :: type_scheme
  shows "free_tv sch = free_tv sch' \<Longrightarrow> new_tv n sch \<Longrightarrow> new_tv n sch'"
  unfolding new_tv_def by simp

lemma new_tv_only_depends_on_free_tv_scheme_list:
  fixes A :: "type_scheme list"
  shows "free_tv A = free_tv A' \<Longrightarrow> new_tv n A \<Longrightarrow> new_tv n A'"
  unfolding new_tv_def by simp

lemma new_tv_nth_nat_A [rule_format]:
  "!nat. nat < length A --> new_tv n A --> (new_tv n (A!nat))"
apply (unfold new_tv_def)
apply (induct A)
apply simp
apply (rule allI)
apply (induct_tac "nat")
apply (intro strip)
apply simp
apply (simp (no_asm))
done

-- "composition of substitutions preserves @{text new_tv} proposition"
lemma new_tv_subst_comp_1 [simp]:
  "[| new_tv n (S::subst); new_tv n R |] ==> new_tv n (($ R) o S)"
  by (simp add: new_tv_subst)

lemma new_tv_subst_comp_2 [simp]:
  "[| new_tv n (S::subst); new_tv n R |] ==> new_tv n (%v.$ R (S v))"
  by (simp add: new_tv_subst)

-- "new type variables do not occur freely in a type structure"
lemma new_tv_not_free_tv [simp]:
    "new_tv n A ==> n~:(free_tv A)"
  by (auto simp add: new_tv_def)

lemma fresh_variable_types [simp]: "!!t::typ. ? n. (new_tv n t)"
apply (unfold new_tv_def)
apply (induct_tac t)
apply (rename_tac nat)
apply (rule_tac x = "Suc nat" in exI)
apply (simp (no_asm_simp))
apply (erule exE)+
apply (rename_tac "n'")
apply (rule_tac x = "max n n'" in exI)
apply (simp add: less_max_iff_disj)
done

lemma fresh_variable_type_schemes [simp]:
  "!!sch::type_scheme. ? n. (new_tv n sch)"
apply (unfold new_tv_def)
apply (induct_tac sch)
apply (rename_tac nat)
apply (rule_tac x = "Suc nat" in exI)
apply (simp (no_asm))
apply (rename_tac nat)
apply (rule_tac x = "Suc nat" in exI)
apply (simp (no_asm))
apply (erule exE)+
apply (rename_tac "n'")
apply (rule_tac x = "max n n'" in exI)
apply (simp add: less_max_iff_disj)
done

lemma fresh_variable_type_scheme_lists [simp]:
  "!!A::type_scheme list. ? n. (new_tv n A)"
apply (induct_tac A)
apply (simp (no_asm))
apply (simp (no_asm))
apply (erule exE)
apply (cut_tac sch = "a" in fresh_variable_type_schemes)
apply (erule exE)
apply (rename_tac "n'")
apply (rule_tac x = " (max n n') " in exI)
apply (subgoal_tac "n <= (max n n') ")
apply (subgoal_tac "n' <= (max n n') ")
apply (fast dest: new_tv_le)
apply (simp_all add: le_max_iff_disj)
done

lemma make_one_new_out_of_two:
  "[| ? n1. (new_tv n1 x); ? n2. (new_tv n2 y)|] ==> ? n. (new_tv n x) & (new_tv n y)"
apply (erule exE)+
apply (rename_tac "n1" "n2")
apply (rule_tac x = " (max n1 n2) " in exI)
apply (subgoal_tac "n1 <= max n1 n2")
apply (subgoal_tac "n2 <= max n1 n2")
apply (fast dest: new_tv_le)
apply (simp_all (no_asm) add: le_max_iff_disj)
done

lemma ex_fresh_variable:
  "!!(A::type_scheme list) (A'::type_scheme list) (t::typ) (t'::typ).
          ? n. (new_tv n A) & (new_tv n A') & (new_tv n t) & (new_tv n t')"
apply (cut_tac t = "t" in fresh_variable_types)
apply (cut_tac t = "t'" in fresh_variable_types)
apply (drule make_one_new_out_of_two)
apply assumption
apply (erule_tac V = "? n. new_tv n t'" in thin_rl)
apply (cut_tac A = "A" in fresh_variable_type_scheme_lists)
apply (cut_tac A = "A'" in fresh_variable_type_scheme_lists)
apply (rotate_tac 1)
apply (drule make_one_new_out_of_two)
apply assumption
apply (erule_tac V = "? n. new_tv n A'" in thin_rl)
apply (erule exE)+
apply (rename_tac n2 n1)
apply (rule_tac x = " (max n1 n2) " in exI)
apply (unfold new_tv_def)
apply (simp (no_asm) add: less_max_iff_disj)
apply blast
done

-- "mgu does not introduce new type variables"
lemma mgu_new:
      "[|mgu t1 t2 = Some u; new_tv n t1; new_tv n t2|] ==> new_tv n u"
apply (unfold new_tv_def)
apply (fast dest: mgu_free)
done

(* lemmata for substitutions *)

lemma length_app_subst_list [simp]:
   "!!A:: ('a::type_struct) list. length ($ S A) = length A"
  unfolding app_subst_list by simp

lemma subst_TVar_scheme [simp]:
  fixes sch :: type_scheme
  shows "$ TVar sch = sch"
  by (induct sch) simp_all

lemma subst_TVar_scheme_list [simp]:
  fixes A :: "type_scheme list"
  shows "$ TVar A = A"
  by (induct A) (simp_all add: app_subst_list)

-- "application of @{text id_subst} does not change type expression"
lemma app_subst_id_te [simp]: "$ id_subst = (%t::typ. t)"
apply (unfold id_subst_def)
apply (rule ext)
apply (induct_tac "t")
apply simp_all
done

lemma app_subst_id_type_scheme [simp]:
  "$ id_subst = (%sch::type_scheme. sch)"
apply (unfold id_subst_def)
apply (rule ext)
apply (induct_tac "sch")
apply simp_all
done

-- "application of @{text id_subst} does not change list of type expressions"
lemma app_subst_id_tel [simp]:
  "$ id_subst = (%A::type_scheme list. A)"
apply (unfold app_subst_list)
apply (rule ext)
apply (induct_tac "A")
apply simp_all
done

lemma id_subst_sch [simp]:
  fixes sch :: type_scheme
  shows "$ id_subst sch = sch"
  by (induct sch) (simp_all add: id_subst_def)

lemma id_subst_A [simp]:
  fixes A :: "type_scheme list"
  shows "$ id_subst A = A"
  by (induct A) simp_all

-- "composition of substitutions"
lemma o_id_subst [simp]: "$S o id_subst = S"
  unfolding id_subst_def o_def by simp

lemma subst_comp_te: "$ R ($ S t::typ) = $ (%x. $ R (S x) ) t"
  by (induct t) simp_all

lemma subst_comp_type_scheme:
  "$ R ($ S sch::type_scheme) = $ (%x. $ R (S x) ) sch"
  by (induct sch) simp_all

lemma subst_comp_scheme_list:
  "$ R ($ S A::type_scheme list) = $ (%x. $ R (S x)) A"
unfolding app_subst_list
proof (induct A)
  case Nil then show ?case by simp
next
  case (Cons x xl)
  then show ?case by (simp add: subst_comp_type_scheme)
qed

lemma subst_id_on_type_scheme_list':
  fixes A :: "type_scheme list"
  shows "!x : free_tv A. S x = (TVar x) ==> $ S A = $ id_subst A"
apply (rule scheme_list_substitutions_only_on_free_variables)
apply (simp add: id_subst_def)
done

lemma subst_id_on_type_scheme_list:
  fixes A :: "type_scheme list"
  shows "!x : free_tv A. S x = (TVar x) ==> $ S A = A"
apply (subst subst_id_on_type_scheme_list')
apply assumption
apply simp
done

lemma nth_subst [rule_format]:
  "!n. n < length A --> ($ S A)!n = $S (A!n)"
apply (induct A)
apply simp
apply (rule allI)
apply (rename_tac "n1")
apply (induct_tac "n1")
apply simp
apply simp
done

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   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.*)
  theory TIP_prop_56
imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun drop :: "Nat => 'a list => 'a list" where
"drop (Z) y = y"
| "drop (S z) (nil2) = nil2"
| "drop (S z) (cons2 x2 x3) = drop z x3"

fun t2 :: "Nat => Nat => Nat" where
"t2 (Z) y = y"
| "t2 (S z) y = S (t2 z y)"

theorem property0 :
  "((drop n (drop m xs)) = (drop (t2 n m) xs))"
  oops

end


theory TailCall
  imports "../00Utils/Environment"
begin

datatype tco_return =
    TCOReturn
  | TCOJump

datatype tco_code =
  TCOLookup nat
  | TCOPushCon nat
  | TCOPushLam "tco_code list" tco_return
  | TCOApply

datatype tco_closure =
  TCOConst nat
  | TCOLam "tco_closure list" "tco_code list" tco_return

type_synonym tco_stack_frame = "tco_closure list \<times> tco_code list \<times> tco_return"

datatype tco_code_state = TCOS "tco_closure list" "tco_stack_frame list"

inductive evaltco :: "tco_code_state \<Rightarrow> tco_code_state \<Rightarrow> bool" (infix "\<leadsto>\<^sub>t\<^sub>c\<^sub>o" 50) where
  evtco_lookup [simp]: "lookup env x = Some v \<Longrightarrow>
    TCOS vs ((env, TCOLookup x # cd, r) # sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o TCOS (v # vs) ((env, cd, r) # sfs)"
| evtco_pushcon [simp]: "TCOS vs ((env, TCOPushCon k # cd, r) # sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
    TCOS (TCOConst k # vs) ((env, cd, r) # sfs)"
| evtco_pushlam [simp]: "TCOS vs ((env, TCOPushLam cd' r' # cd, r) # sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
    TCOS (TCOLam env cd' r' # vs) ((env, cd, r) # sfs)"
| evtco_apply [simp]: "TCOS (v # TCOLam env' cd' r' # vs) ((env, TCOApply # cd, r) # sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
    TCOS vs ((v # env', cd', r') # (env, cd, r) # sfs)"
| evtco_return [simp]: "TCOS vs ((env, [], TCOReturn) # sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o TCOS vs sfs"
| evtco_jump [simp]: "TCOS (v # TCOLam env' cd' r' # vs) ((env, [], TCOJump) # sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
    TCOS vs ((v # env', cd', r') # sfs)"

theorem determinismt: "\<Sigma> \<leadsto>\<^sub>t\<^sub>c\<^sub>o \<Sigma>' \<Longrightarrow> \<Sigma> \<leadsto>\<^sub>t\<^sub>c\<^sub>o \<Sigma>'' \<Longrightarrow> \<Sigma>' = \<Sigma>''"
proof (induction \<Sigma> \<Sigma>' rule: evaltco.induct)
  case (evtco_lookup env x v vs cd r sfs)
  from evtco_lookup(2, 1) show ?case
    by (induction "TCOS vs ((env, TCOLookup x # cd, r) # sfs)" \<Sigma>'' rule: evaltco.induct) simp_all
next
  case (evtco_pushcon vs env k cd r sfs)
  thus ?case
    by (induction "TCOS vs ((env, TCOPushCon k # cd, r) # sfs)" \<Sigma>'' rule: evaltco.induct) simp_all
next
  case (evtco_pushlam vs env cd' r' cd r sfs)
  thus ?case
    by (induction "TCOS vs ((env, TCOPushLam cd' r' # cd, r) # sfs)" \<Sigma>'' rule: evaltco.induct)
       simp_all
next
  case (evtco_apply v env' cd' r' vs env cd r sfs)
  thus ?case
    by (induction "TCOS (v # TCOLam env' cd' r' # vs) ((env, TCOApply # cd, r) # sfs)" \<Sigma>''
        rule: evaltco.induct)
       simp_all
next
  case (evtco_return vs env sfs)
  thus ?case by (induction "TCOS vs ((env, [], TCOReturn) # sfs)" \<Sigma>'' rule: evaltco.induct) simp_all
next
  case (evtco_jump v env' cd' r' vs env sfs)
  thus ?case
    by (induction "TCOS (v # TCOLam env' cd' r' # vs) ((env, [], TCOJump) # sfs)" \<Sigma>''
        rule: evaltco.induct)
       simp_all
qed

end


(*  Title:      HOL/ZF/Games.thy
    Author:     Steven Obua

An application of HOLZF: Partizan Games.  See "Partizan Games in
Isabelle/HOLZF", available from http://www4.in.tum.de/~obua/partizan
*)

theory Games
imports MainZF
begin

definition fixgames :: "ZF set \<Rightarrow> ZF set" where
  "fixgames A \<equiv> { Opair l r | l r. explode l \<subseteq> A & explode r \<subseteq> A}"

definition games_lfp :: "ZF set" where
  "games_lfp \<equiv> lfp fixgames"

definition games_gfp :: "ZF set" where
  "games_gfp \<equiv> gfp fixgames"

lemma mono_fixgames: "mono (fixgames)"
  apply (auto simp add: mono_def fixgames_def)
  apply (rule_tac x=l in exI)
  apply (rule_tac x=r in exI)
  apply auto
  done

lemma games_lfp_unfold: "games_lfp = fixgames games_lfp"
  by (auto simp add: def_lfp_unfold games_lfp_def mono_fixgames)

lemma games_gfp_unfold: "games_gfp = fixgames games_gfp"
  by (auto simp add: def_gfp_unfold games_gfp_def mono_fixgames)

lemma games_lfp_nonempty: "Opair Empty Empty \<in> games_lfp"
proof -
  have "fixgames {} \<subseteq> games_lfp"
    apply (subst games_lfp_unfold)
    apply (simp add: mono_fixgames[simplified mono_def, rule_format])
    done
  moreover have "fixgames {} = {Opair Empty Empty}"
    by (simp add: fixgames_def explode_Empty)
  finally show ?thesis
    by auto
qed

definition left_option :: "ZF \<Rightarrow> ZF \<Rightarrow> bool" where
  "left_option g opt \<equiv> (Elem opt (Fst g))"

definition right_option :: "ZF \<Rightarrow> ZF \<Rightarrow> bool" where
  "right_option g opt \<equiv> (Elem opt (Snd g))"

definition is_option_of :: "(ZF * ZF) set" where
  "is_option_of \<equiv> { (opt, g) | opt g. g \<in> games_gfp \<and> (left_option g opt \<or> right_option g opt) }"

lemma games_lfp_subset_gfp: "games_lfp \<subseteq> games_gfp"
proof -
  have "games_lfp \<subseteq> fixgames games_lfp"
    by (simp add: games_lfp_unfold[symmetric])
  then show ?thesis
    by (simp add: games_gfp_def gfp_upperbound)
qed

lemma games_option_stable:
  assumes fixgames: "games = fixgames games"
  and g: "g \<in> games"
  and opt: "left_option g opt \<or> right_option g opt"
  shows "opt \<in> games"
proof -
  from g fixgames have "g \<in> fixgames games" by auto
  then have "\<exists> l r. g = Opair l r \<and> explode l \<subseteq> games \<and> explode r \<subseteq> games"
    by (simp add: fixgames_def)
  then obtain l where "\<exists> r. g = Opair l r \<and> explode l \<subseteq> games \<and> explode r \<subseteq> games" ..
  then obtain r where lr: "g = Opair l r \<and> explode l \<subseteq> games \<and> explode r \<subseteq> games" ..
  with opt show ?thesis
    by (auto intro: Elem_explode_in simp add: left_option_def right_option_def Fst Snd)
qed

lemma option2elem: "(opt,g) \<in> is_option_of  \<Longrightarrow> \<exists> u v. Elem opt u \<and> Elem u v \<and> Elem v g"
  apply (simp add: is_option_of_def)
  apply (subgoal_tac "(g \<in> games_gfp) = (g \<in> (fixgames games_gfp))")
  prefer 2
  apply (simp add: games_gfp_unfold[symmetric])
  apply (auto simp add: fixgames_def left_option_def right_option_def Fst Snd)
  apply (rule_tac x=l in exI, insert Elem_Opair_exists, blast)
  apply (rule_tac x=r in exI, insert Elem_Opair_exists, blast)
  done

lemma is_option_of_subset_is_Elem_of: "is_option_of \<subseteq> (is_Elem_of\<^sup>+)"
proof -
  {
    fix opt
    fix g
    assume "(opt, g) \<in> is_option_of"
    then have "\<exists> u v. (opt, u) \<in> (is_Elem_of\<^sup>+) \<and> (u,v) \<in> (is_Elem_of\<^sup>+) \<and> (v,g) \<in> (is_Elem_of\<^sup>+)"
      apply -
      apply (drule option2elem)
      apply (auto simp add: r_into_trancl' is_Elem_of_def)
      done
    then have "(opt, g) \<in> (is_Elem_of\<^sup>+)"
      by (blast intro: trancl_into_rtrancl trancl_rtrancl_trancl)
  }
  then show ?thesis by auto
qed

lemma wfzf_is_option_of: "wfzf is_option_of"
proof -
  have "wfzf (is_Elem_of\<^sup>+)" by (simp add: wfzf_trancl wfzf_is_Elem_of)
  then show ?thesis
    apply (rule wfzf_subset)
    apply (rule is_option_of_subset_is_Elem_of)
    done
  qed

lemma games_gfp_imp_lfp: "g \<in> games_gfp \<longrightarrow> g \<in> games_lfp"
proof -
  have unfold_gfp: "\<And> x. x \<in> games_gfp \<Longrightarrow> x \<in> (fixgames games_gfp)"
    by (simp add: games_gfp_unfold[symmetric])
  have unfold_lfp: "\<And> x. (x \<in> games_lfp) = (x \<in> (fixgames games_lfp))"
    by (simp add: games_lfp_unfold[symmetric])
  show ?thesis
    apply (rule wf_induct[OF wfzf_implies_wf[OF wfzf_is_option_of]])
    apply (auto simp add: is_option_of_def)
    apply (drule_tac unfold_gfp)
    apply (simp add: fixgames_def)
    apply (auto simp add: left_option_def Fst right_option_def Snd)
    apply (subgoal_tac "explode l \<subseteq> games_lfp")
    apply (subgoal_tac "explode r \<subseteq> games_lfp")
    apply (subst unfold_lfp)
    apply (auto simp add: fixgames_def)
    apply (simp_all add: explode_Elem Elem_explode_in)
    done
qed

theorem games_lfp_eq_gfp: "games_lfp = games_gfp"
  apply (auto simp add: games_gfp_imp_lfp)
  apply (insert games_lfp_subset_gfp)
  apply auto
  done

theorem unique_games: "(g = fixgames g) = (g = games_lfp)"
proof -
  {
    fix g
    assume g: "g = fixgames g"
    from g have "fixgames g \<subseteq> g" by auto
    then have l:"games_lfp \<subseteq> g"
      by (simp add: games_lfp_def lfp_lowerbound)
    from g have "g \<subseteq> fixgames g" by auto
    then have u:"g \<subseteq> games_gfp"
      by (simp add: games_gfp_def gfp_upperbound)
    from l u games_lfp_eq_gfp[symmetric] have "g = games_lfp"
      by auto
  }
  note games = this
  show ?thesis
    apply (rule iffI)
    apply (erule games)
    apply (simp add: games_lfp_unfold[symmetric])
    done
qed

lemma games_lfp_option_stable:
  assumes g: "g \<in> games_lfp"
  and opt: "left_option g opt \<or> right_option g opt"
  shows "opt \<in> games_lfp"
  apply (rule games_option_stable[where g=g])
  apply (simp add: games_lfp_unfold[symmetric])
  apply (simp_all add: assms)
  done

lemma is_option_of_imp_games:
  assumes hyp: "(opt, g) \<in> is_option_of"
  shows "opt \<in> games_lfp \<and> g \<in> games_lfp"
proof -
  from hyp have g_game: "g \<in> games_lfp"
    by (simp add: is_option_of_def games_lfp_eq_gfp)
  from hyp have "left_option g opt \<or> right_option g opt"
    by (auto simp add: is_option_of_def)
  with g_game games_lfp_option_stable[OF g_game, OF this] show ?thesis
    by auto
qed

lemma games_lfp_represent: "x \<in> games_lfp \<Longrightarrow> \<exists> l r. x = Opair l r"
  apply (rule exI[where x="Fst x"])
  apply (rule exI[where x="Snd x"])
  apply (subgoal_tac "x \<in> (fixgames games_lfp)")
  apply (simp add: fixgames_def)
  apply (auto simp add: Fst Snd)
  apply (simp add: games_lfp_unfold[symmetric])
  done

definition "game = games_lfp"

typedef game = game
  unfolding game_def by (blast intro: games_lfp_nonempty)

definition left_options :: "game \<Rightarrow> game zet" where
  "left_options g \<equiv> zimage Abs_game (zexplode (Fst (Rep_game g)))"

definition right_options :: "game \<Rightarrow> game zet" where
  "right_options g \<equiv> zimage Abs_game (zexplode (Snd (Rep_game g)))"

definition options :: "game \<Rightarrow> game zet" where
  "options g \<equiv> zunion (left_options g) (right_options g)"

definition Game :: "game zet \<Rightarrow> game zet \<Rightarrow> game" where
  "Game L R \<equiv> Abs_game (Opair (zimplode (zimage Rep_game L)) (zimplode (zimage Rep_game R)))"

lemma Repl_Rep_game_Abs_game: "\<forall> e. Elem e z \<longrightarrow> e \<in> games_lfp \<Longrightarrow> Repl z (Rep_game o Abs_game) = z"
  apply (subst Ext)
  apply (simp add: Repl)
  apply auto
  apply (subst Abs_game_inverse, simp_all add: game_def)
  apply (rule_tac x=za in exI)
  apply (subst Abs_game_inverse, simp_all add: game_def)
  done

lemma game_split: "g = Game (left_options g) (right_options g)"
proof -
  have "\<exists> l r. Rep_game g = Opair l r"
    apply (insert Rep_game[of g])
    apply (simp add: game_def games_lfp_represent)
    done
  then obtain l r where lr: "Rep_game g = Opair l r" by auto
  have partizan_g: "Rep_game g \<in> games_lfp"
    apply (insert Rep_game[of g])
    apply (simp add: game_def)
    done
  have "\<forall> e. Elem e l \<longrightarrow> left_option (Rep_game g) e"
    by (simp add: lr left_option_def Fst)
  then have partizan_l: "\<forall> e. Elem e l \<longrightarrow> e \<in> games_lfp"
    apply auto
    apply (rule games_lfp_option_stable[where g="Rep_game g", OF partizan_g])
    apply auto
    done
  have "\<forall> e. Elem e r \<longrightarrow> right_option (Rep_game g) e"
    by (simp add: lr right_option_def Snd)
  then have partizan_r: "\<forall> e. Elem e r \<longrightarrow> e \<in> games_lfp"
    apply auto
    apply (rule games_lfp_option_stable[where g="Rep_game g", OF partizan_g])
    apply auto
    done
  let ?L = "zimage (Abs_game) (zexplode l)"
  let ?R = "zimage (Abs_game) (zexplode r)"
  have L:"?L = left_options g"
    by (simp add: left_options_def lr Fst)
  have R:"?R = right_options g"
    by (simp add: right_options_def lr Snd)
  have "g = Game ?L ?R"
    apply (simp add: Game_def Rep_game_inject[symmetric] comp_zimage_eq zimage_zexplode_eq zimplode_zexplode)
    apply (simp add: Repl_Rep_game_Abs_game partizan_l partizan_r)
    apply (subst Abs_game_inverse)
    apply (simp_all add: lr[symmetric] Rep_game)
    done
  then show ?thesis
    by (simp add: L R)
qed

lemma Opair_in_games_lfp:
  assumes l: "explode l \<subseteq> games_lfp"
  and r: "explode r \<subseteq> games_lfp"
  shows "Opair l r \<in> games_lfp"
proof -
  note f = unique_games[of games_lfp, simplified]
  show ?thesis
    apply (subst f)
    apply (simp add: fixgames_def)
    apply (rule exI[where x=l])
    apply (rule exI[where x=r])
    apply (auto simp add: l r)
    done
qed

lemma left_options[simp]: "left_options (Game l r) = l"
  apply (simp add: left_options_def Game_def)
  apply (subst Abs_game_inverse)
  apply (simp add: game_def)
  apply (rule Opair_in_games_lfp)
  apply (auto simp add: explode_Elem Elem_zimplode zimage_iff Rep_game[simplified game_def])
  apply (simp add: Fst zexplode_zimplode comp_zimage_eq)
  apply (simp add: zet_ext_eq zimage_iff Rep_game_inverse)
  done

lemma right_options[simp]: "right_options (Game l r) = r"
  apply (simp add: right_options_def Game_def)
  apply (subst Abs_game_inverse)
  apply (simp add: game_def)
  apply (rule Opair_in_games_lfp)
  apply (auto simp add: explode_Elem Elem_zimplode zimage_iff Rep_game[simplified game_def])
  apply (simp add: Snd zexplode_zimplode comp_zimage_eq)
  apply (simp add: zet_ext_eq zimage_iff Rep_game_inverse)
  done

lemma Game_ext: "(Game l1 r1 = Game l2 r2) = ((l1 = l2) \<and> (r1 = r2))"
  apply auto
  apply (subst left_options[where l=l1 and r=r1,symmetric])
  apply (subst left_options[where l=l2 and r=r2,symmetric])
  apply simp
  apply (subst right_options[where l=l1 and r=r1,symmetric])
  apply (subst right_options[where l=l2 and r=r2,symmetric])
  apply simp
  done

definition option_of :: "(game * game) set" where
  "option_of \<equiv> image (\<lambda> (option, g). (Abs_game option, Abs_game g)) is_option_of"

lemma option_to_is_option_of: "((option, g) \<in> option_of) = ((Rep_game option, Rep_game g) \<in> is_option_of)"
  apply (auto simp add: option_of_def)
  apply (subst Abs_game_inverse)
  apply (simp add: is_option_of_imp_games game_def)
  apply (subst Abs_game_inverse)
  apply (simp add: is_option_of_imp_games game_def)
  apply simp
  apply (auto simp add: Bex_def image_def)
  apply (rule exI[where x="Rep_game option"])
  apply (rule exI[where x="Rep_game g"])
  apply (simp add: Rep_game_inverse)
  done

lemma wf_is_option_of: "wf is_option_of"
  apply (rule wfzf_implies_wf)
  apply (simp add: wfzf_is_option_of)
  done

lemma wf_option_of[simp, intro]: "wf option_of"
proof -
  have option_of: "option_of = inv_image is_option_of Rep_game"
    apply (rule set_eqI)
    apply (case_tac "x")
    by (simp add: option_to_is_option_of)
  show ?thesis
    apply (simp add: option_of)
    apply (auto intro: wf_is_option_of)
    done
qed

lemma right_option_is_option[simp, intro]: "zin x (right_options g) \<Longrightarrow> zin x (options g)"
  by (simp add: options_def zunion)

lemma left_option_is_option[simp, intro]: "zin x (left_options g) \<Longrightarrow> zin x (options g)"
  by (simp add: options_def zunion)

lemma zin_options[simp, intro]: "zin x (options g) \<Longrightarrow> (x, g) \<in> option_of"
  apply (simp add: options_def zunion left_options_def right_options_def option_of_def
    image_def is_option_of_def zimage_iff zin_zexplode_eq)
  apply (cases g)
  apply (cases x)
  apply (auto simp add: Abs_game_inverse games_lfp_eq_gfp[symmetric] game_def
    right_option_def[symmetric] left_option_def[symmetric])
  done

function
  neg_game :: "game \<Rightarrow> game"
where
  [simp del]: "neg_game g = Game (zimage neg_game (right_options g)) (zimage neg_game (left_options g))"
by auto
termination by (relation "option_of") auto

lemma "neg_game (neg_game g) = g"
  apply (induct g rule: neg_game.induct)
  apply (subst neg_game.simps)+
  apply (simp add: comp_zimage_eq)
  apply (subgoal_tac "zimage (neg_game o neg_game) (left_options g) = left_options g")
  apply (subgoal_tac "zimage (neg_game o neg_game) (right_options g) = right_options g")
  apply (auto simp add: game_split[symmetric])
  apply (auto simp add: zet_ext_eq zimage_iff)
  done

function
  ge_game :: "(game * game) \<Rightarrow> bool"
where
  [simp del]: "ge_game (G, H) = (\<forall> x. if zin x (right_options G) then (
                          if zin x (left_options H) then \<not> (ge_game (H, x) \<or> (ge_game (x, G)))
                                                    else \<not> (ge_game (H, x)))
                          else (if zin x (left_options H) then \<not> (ge_game (x, G)) else True))"
by auto
termination by (relation "(gprod_2_1 option_of)")
 (simp, auto simp: gprod_2_1_def)

lemma ge_game_eq: "ge_game (G, H) = (\<forall> x. (zin x (right_options G) \<longrightarrow> \<not> ge_game (H, x)) \<and> (zin x (left_options H) \<longrightarrow> \<not> ge_game (x, G)))"
  apply (subst ge_game.simps[where G=G and H=H])
  apply (auto)
  done

lemma ge_game_leftright_refl[rule_format]:
  "\<forall> y. (zin y (right_options x) \<longrightarrow> \<not> ge_game (x, y)) \<and> (zin y (left_options x) \<longrightarrow> \<not> (ge_game (y, x))) \<and> ge_game (x, x)"
proof (induct x rule: wf_induct[OF wf_option_of])
  case (1 "g")
  {
    fix y
    assume y: "zin y (right_options g)"
    have "\<not> ge_game (g, y)"
    proof -
      have "(y, g) \<in> option_of" by (auto intro: y)
      with 1 have "ge_game (y, y)" by auto
      with y show ?thesis by (subst ge_game_eq, auto)
    qed
  }
  note right = this
  {
    fix y
    assume y: "zin y (left_options g)"
    have "\<not> ge_game (y, g)"
    proof -
      have "(y, g) \<in> option_of" by (auto intro: y)
      with 1 have "ge_game (y, y)" by auto
      with y show ?thesis by (subst ge_game_eq, auto)
    qed
  }
  note left = this
  from left right show ?case
    by (auto, subst ge_game_eq, auto)
qed

lemma ge_game_refl: "ge_game (x,x)" by (simp add: ge_game_leftright_refl)

lemma "\<forall> y. (zin y (right_options x) \<longrightarrow> \<not> ge_game (x, y)) \<and> (zin y (left_options x) \<longrightarrow> \<not> (ge_game (y, x))) \<and> ge_game (x, x)"
proof (induct x rule: wf_induct[OF wf_option_of])
  case (1 "g")
  show ?case
  proof (auto, goal_cases)
    {case prems: (1 y)
      from prems have "(y, g) \<in> option_of" by (auto)
      with 1 have "ge_game (y, y)" by auto
      with prems have "\<not> ge_game (g, y)"
        by (subst ge_game_eq, auto)
      with prems show ?case by auto}
    note right = this
    {case prems: (2 y)
      from prems have "(y, g) \<in> option_of" by (auto)
      with 1 have "ge_game (y, y)" by auto
      with prems have "\<not> ge_game (y, g)"
        by (subst ge_game_eq, auto)
      with prems show ?case by auto}
    note left = this
    {case 3
      from left right show ?case
        by (subst ge_game_eq, auto)
    }
  qed
qed

definition eq_game :: "game \<Rightarrow> game \<Rightarrow> bool" where
  "eq_game G H \<equiv> ge_game (G, H) \<and> ge_game (H, G)"

lemma eq_game_sym: "(eq_game G H) = (eq_game H G)"
  by (auto simp add: eq_game_def)

lemma eq_game_refl: "eq_game G G"
  by (simp add: ge_game_refl eq_game_def)

lemma induct_game: "(\<And>x. \<forall>y. (y, x) \<in> lprod option_of \<longrightarrow> P y \<Longrightarrow> P x) \<Longrightarrow> P a"
  by (erule wf_induct[OF wf_lprod[OF wf_option_of]])

lemma ge_game_trans:
  assumes "ge_game (x, y)" "ge_game (y, z)"
  shows "ge_game (x, z)"
proof -
  {
    fix a
    have "\<forall> x y z. a = [x,y,z] \<longrightarrow> ge_game (x,y) \<longrightarrow> ge_game (y,z) \<longrightarrow> ge_game (x, z)"
    proof (induct a rule: induct_game)
      case (1 a)
      show ?case
      proof ((rule allI | rule impI)+, goal_cases)
        case prems: (1 x y z)
        show ?case
        proof -
          { fix xr
            assume xr:"zin xr (right_options x)"
            assume a: "ge_game (z, xr)"
            have "ge_game (y, xr)"
              apply (rule 1[rule_format, where y="[y,z,xr]"])
              apply (auto intro: xr lprod_3_1 simp add: prems a)
              done
            moreover from xr have "\<not> ge_game (y, xr)"
              by (simp add: prems(2)[simplified ge_game_eq[of x y], rule_format, of xr, simplified xr])
            ultimately have "False" by auto
          }
          note xr = this
          { fix zl
            assume zl:"zin zl (left_options z)"
            assume a: "ge_game (zl, x)"
            have "ge_game (zl, y)"
              apply (rule 1[rule_format, where y="[zl,x,y]"])
              apply (auto intro: zl lprod_3_2 simp add: prems a)
              done
            moreover from zl have "\<not> ge_game (zl, y)"
              by (simp add: prems(3)[simplified ge_game_eq[of y z], rule_format, of zl, simplified zl])
            ultimately have "False" by auto
          }
          note zl = this
          show ?thesis
            by (auto simp add: ge_game_eq[of x z] intro: xr zl)
        qed
      qed
    qed
  }
  note trans = this[of "[x, y, z]", simplified, rule_format]
  with assms show ?thesis by blast
qed

lemma eq_game_trans: "eq_game a b \<Longrightarrow> eq_game b c \<Longrightarrow> eq_game a c"
  by (auto simp add: eq_game_def intro: ge_game_trans)

definition zero_game :: game
 where  "zero_game \<equiv> Game zempty zempty"

function
  plus_game :: "game \<Rightarrow> game \<Rightarrow> game"
where
  [simp del]: "plus_game G H = Game (zunion (zimage (\<lambda> g. plus_game g H) (left_options G))
                                   (zimage (\<lambda> h. plus_game G h) (left_options H)))
                           (zunion (zimage (\<lambda> g. plus_game g H) (right_options G))
                                   (zimage (\<lambda> h. plus_game G h) (right_options H)))"
by auto
termination by (relation "gprod_2_2 option_of")
  (simp, auto simp: gprod_2_2_def)

lemma plus_game_comm: "plus_game G H = plus_game H G"
proof (induct G H rule: plus_game.induct)
  case (1 G H)
  show ?case
    by (auto simp add:
      plus_game.simps[where G=G and H=H]
      plus_game.simps[where G=H and H=G]
      Game_ext zet_ext_eq zunion zimage_iff 1)
qed

lemma game_ext_eq: "(G = H) = (left_options G = left_options H \<and> right_options G = right_options H)"
proof -
  have "(G = H) = (Game (left_options G) (right_options G) = Game (left_options H) (right_options H))"
    by (simp add: game_split[symmetric])
  then show ?thesis by auto
qed

lemma left_zero_game[simp]: "left_options (zero_game) = zempty"
  by (simp add: zero_game_def)

lemma right_zero_game[simp]: "right_options (zero_game) = zempty"
  by (simp add: zero_game_def)

lemma plus_game_zero_right[simp]: "plus_game G zero_game = G"
proof -
  have "H = zero_game \<longrightarrow> plus_game G H = G " for G H
  proof (induct G H rule: plus_game.induct, rule impI, goal_cases)
    case prems: (1 G H)
    note induct_hyp = this[simplified prems, simplified] and this
    show ?case
      apply (simp only: plus_game.simps[where G=G and H=H])
      apply (simp add: game_ext_eq prems)
      apply (auto simp add:
        zimage_cong [where f = "\<lambda> g. plus_game g zero_game" and g = "id"]
        induct_hyp)
      done
  qed
  then show ?thesis by auto
qed

lemma plus_game_zero_left: "plus_game zero_game G = G"
  by (simp add: plus_game_comm)

lemma left_imp_options[simp]: "zin opt (left_options g) \<Longrightarrow> zin opt (options g)"
  by (simp add: options_def zunion)

lemma right_imp_options[simp]: "zin opt (right_options g) \<Longrightarrow> zin opt (options g)"
  by (simp add: options_def zunion)

lemma left_options_plus:
  "left_options (plus_game u v) =  zunion (zimage (\<lambda>g. plus_game g v) (left_options u)) (zimage (\<lambda>h. plus_game u h) (left_options v))"
  by (subst plus_game.simps, simp)

lemma right_options_plus:
  "right_options (plus_game u v) =  zunion (zimage (\<lambda>g. plus_game g v) (right_options u)) (zimage (\<lambda>h. plus_game u h) (right_options v))"
  by (subst plus_game.simps, simp)

lemma left_options_neg: "left_options (neg_game u) = zimage neg_game (right_options u)"
  by (subst neg_game.simps, simp)

lemma right_options_neg: "right_options (neg_game u) = zimage neg_game (left_options u)"
  by (subst neg_game.simps, simp)

lemma plus_game_assoc: "plus_game (plus_game F G) H = plus_game F (plus_game G H)"
proof -
  have "\<forall>F G H. a = [F, G, H] \<longrightarrow> plus_game (plus_game F G) H = plus_game F (plus_game G H)" for a
  proof (induct a rule: induct_game, (rule impI | rule allI)+, goal_cases)
    case prems: (1 x F G H)
    let ?L = "plus_game (plus_game F G) H"
    let ?R = "plus_game F (plus_game G H)"
    note options_plus = left_options_plus right_options_plus
    {
      fix opt
      note hyp = prems(1)[simplified prems(2), rule_format]
      have F: "zin opt (options F)  \<Longrightarrow> plus_game (plus_game opt G) H = plus_game opt (plus_game G H)"
        by (blast intro: hyp lprod_3_3)
      have G: "zin opt (options G) \<Longrightarrow> plus_game (plus_game F opt) H = plus_game F (plus_game opt H)"
        by (blast intro: hyp lprod_3_4)
      have H: "zin opt (options H) \<Longrightarrow> plus_game (plus_game F G) opt = plus_game F (plus_game G opt)"
        by (blast intro: hyp lprod_3_5)
      note F and G and H
    }
    note induct_hyp = this
    have "left_options ?L = left_options ?R \<and> right_options ?L = right_options ?R"
      by (auto simp add:
        plus_game.simps[where G="plus_game F G" and H=H]
        plus_game.simps[where G="F" and H="plus_game G H"]
        zet_ext_eq zunion zimage_iff options_plus
        induct_hyp left_imp_options right_imp_options)
    then show ?case
      by (simp add: game_ext_eq)
  qed
  then show ?thesis by auto
qed

lemma neg_plus_game: "neg_game (plus_game G H) = plus_game (neg_game G) (neg_game H)"
proof (induct G H rule: plus_game.induct)
  case (1 G H)
  note opt_ops =
    left_options_plus right_options_plus
    left_options_neg right_options_neg
  show ?case
    by (auto simp add: opt_ops
      neg_game.simps[of "plus_game G H"]
      plus_game.simps[of "neg_game G" "neg_game H"]
      Game_ext zet_ext_eq zunion zimage_iff 1)
qed

lemma eq_game_plus_inverse: "eq_game (plus_game x (neg_game x)) zero_game"
proof (induct x rule: wf_induct[OF wf_option_of], goal_cases)
  case prems: (1 x)
  then have ihyp: "eq_game (plus_game y (neg_game y)) zero_game" if "zin y (options x)" for y
    using that by (auto simp add: prems)
  have case1: "\<not> (ge_game (zero_game, plus_game y (neg_game x)))"
    if y: "zin y (right_options x)" for y
    apply (subst ge_game.simps, simp)
    apply (rule exI[where x="plus_game y (neg_game y)"])
    apply (auto simp add: ihyp[of y, simplified y right_imp_options eq_game_def])
    apply (auto simp add: left_options_plus left_options_neg zunion zimage_iff intro: y)
    done
  have case2: "\<not> (ge_game (zero_game, plus_game x (neg_game y)))"
    if y: "zin y (left_options x)" for y
    apply (subst ge_game.simps, simp)
    apply (rule exI[where x="plus_game y (neg_game y)"])
    apply (auto simp add: ihyp[of y, simplified y left_imp_options eq_game_def])
    apply (auto simp add: left_options_plus zunion zimage_iff intro: y)
    done
  have case3: "\<not> (ge_game (plus_game y (neg_game x), zero_game))"
    if y: "zin y (left_options x)" for y
    apply (subst ge_game.simps, simp)
    apply (rule exI[where x="plus_game y (neg_game y)"])
    apply (auto simp add: ihyp[of y, simplified y left_imp_options eq_game_def])
    apply (auto simp add: right_options_plus right_options_neg zunion zimage_iff intro: y)
    done
  have case4: "\<not> (ge_game (plus_game x (neg_game y), zero_game))"
    if y: "zin y (right_options x)" for y
    apply (subst ge_game.simps, simp)
    apply (rule exI[where x="plus_game y (neg_game y)"])
    apply (auto simp add: ihyp[of y, simplified y right_imp_options eq_game_def])
    apply (auto simp add: right_options_plus zunion zimage_iff intro: y)
    done
  show ?case
    apply (simp add: eq_game_def)
    apply (simp add: ge_game.simps[of "plus_game x (neg_game x)" "zero_game"])
    apply (simp add: ge_game.simps[of "zero_game" "plus_game x (neg_game x)"])
    apply (simp add: right_options_plus left_options_plus right_options_neg left_options_neg zunion zimage_iff)
    apply (auto simp add: case1 case2 case3 case4)
    done
qed

lemma ge_plus_game_left: "ge_game (y,z) = ge_game (plus_game x y, plus_game x z)"
proof -
  have "\<forall>x y z. a = [x,y,z] \<longrightarrow> ge_game (y,z) = ge_game (plus_game x y, plus_game x z)" for a
  proof (induct a rule: induct_game, (rule impI | rule allI)+, goal_cases)
    case prems: (1 a x y z)
    note induct_hyp = prems(1)[rule_format, simplified prems(2)]
    {
      assume hyp: "ge_game(plus_game x y, plus_game x z)"
      have "ge_game (y, z)"
      proof -
        { fix yr
          assume yr: "zin yr (right_options y)"
          from hyp have "\<not> (ge_game (plus_game x z, plus_game x yr))"
            by (auto simp add: ge_game_eq[of "plus_game x y" "plus_game x z"]
              right_options_plus zunion zimage_iff intro: yr)
          then have "\<not> (ge_game (z, yr))"
            apply (subst induct_hyp[where y="[x, z, yr]", of "x" "z" "yr"])
            apply (simp_all add: yr lprod_3_6)
            done
        }
        note yr = this
        { fix zl
          assume zl: "zin zl (left_options z)"
          from hyp have "\<not> (ge_game (plus_game x zl, plus_game x y))"
            by (auto simp add: ge_game_eq[of "plus_game x y" "plus_game x z"]
              left_options_plus zunion zimage_iff intro: zl)
          then have "\<not> (ge_game (zl, y))"
            apply (subst prems(1)[rule_format, where y="[x, zl, y]", of "x" "zl" "y"])
            apply (simp_all add: prems(2) zl lprod_3_7)
            done
        }
        note zl = this
        show "ge_game (y, z)"
          apply (subst ge_game_eq)
          apply (auto simp add: yr zl)
          done
      qed
    }
    note right_imp_left = this
    {
      assume yz: "ge_game (y, z)"
      {
        fix x'
        assume x': "zin x' (right_options x)"
        assume hyp: "ge_game (plus_game x z, plus_game x' y)"
        then have n: "\<not> (ge_game (plus_game x' y, plus_game x' z))"
          by (auto simp add: ge_game_eq[of "plus_game x z" "plus_game x' y"]
            right_options_plus zunion zimage_iff intro: x')
        have t: "ge_game (plus_game x' y, plus_game x' z)"
          apply (subst induct_hyp[symmetric])
          apply (auto intro: lprod_3_3 x' yz)
          done
        from n t have "False" by blast
      }
      note case1 = this
      {
        fix x'
        assume x': "zin x' (left_options x)"
        assume hyp: "ge_game (plus_game x' z, plus_game x y)"
        then have n: "\<not> (ge_game (plus_game x' y, plus_game x' z))"
          by (auto simp add: ge_game_eq[of "plus_game x' z" "plus_game x y"]
            left_options_plus zunion zimage_iff intro: x')
        have t: "ge_game (plus_game x' y, plus_game x' z)"
          apply (subst induct_hyp[symmetric])
          apply (auto intro: lprod_3_3 x' yz)
          done
        from n t have "False" by blast
      }
      note case3 = this
      {
        fix y'
        assume y': "zin y' (right_options y)"
        assume hyp: "ge_game (plus_game x z, plus_game x y')"
        then have "ge_game(z, y')"
          apply (subst induct_hyp[of "[x, z, y']" "x" "z" "y'"])
          apply (auto simp add: hyp lprod_3_6 y')
          done
        with yz have "ge_game (y, y')"
          by (blast intro: ge_game_trans)
        with y' have "False" by (auto simp add: ge_game_leftright_refl)
      }
      note case2 = this
      {
        fix z'
        assume z': "zin z' (left_options z)"
        assume hyp: "ge_game (plus_game x z', plus_game x y)"
        then have "ge_game(z', y)"
          apply (subst induct_hyp[of "[x, z', y]" "x" "z'" "y"])
          apply (auto simp add: hyp lprod_3_7 z')
          done
        with yz have "ge_game (z', z)"
          by (blast intro: ge_game_trans)
        with z' have "False" by (auto simp add: ge_game_leftright_refl)
      }
      note case4 = this
      have "ge_game(plus_game x y, plus_game x z)"
        apply (subst ge_game_eq)
        apply (auto simp add: right_options_plus left_options_plus zunion zimage_iff)
        apply (auto intro: case1 case2 case3 case4)
        done
    }
    note left_imp_right = this
    show ?case by (auto intro: right_imp_left left_imp_right)
  qed
  from this[of "[x, y, z]"] show ?thesis by blast
qed

lemma ge_plus_game_right: "ge_game (y,z) = ge_game(plus_game y x, plus_game z x)"
  by (simp add: ge_plus_game_left plus_game_comm)

lemma ge_neg_game: "ge_game (neg_game x, neg_game y) = ge_game (y, x)"
proof -
  have "\<forall>x y. a = [x, y] \<longrightarrow> ge_game (neg_game x, neg_game y) = ge_game (y, x)" for a
  proof (induct a rule: induct_game, (rule impI | rule allI)+, goal_cases)
    case prems: (1 a x y)
    note ihyp = prems(1)[rule_format, simplified prems(2)]
    { fix xl
      assume xl: "zin xl (left_options x)"
      have "ge_game (neg_game y, neg_game xl) = ge_game (xl, y)"
        apply (subst ihyp)
        apply (auto simp add: lprod_2_1 xl)
        done
    }
    note xl = this
    { fix yr
      assume yr: "zin yr (right_options y)"
      have "ge_game (neg_game yr, neg_game x) = ge_game (x, yr)"
        apply (subst ihyp)
        apply (auto simp add: lprod_2_2 yr)
        done
    }
    note yr = this
    show ?case
      by (auto simp add: ge_game_eq[of "neg_game x" "neg_game y"] ge_game_eq[of "y" "x"]
        right_options_neg left_options_neg zimage_iff  xl yr)
  qed
  from this[of "[x,y]"] show ?thesis by blast
qed

definition eq_game_rel :: "(game * game) set" where
  "eq_game_rel \<equiv> { (p, q) . eq_game p q }"

definition "Pg = UNIV//eq_game_rel"

typedef Pg = Pg
  unfolding Pg_def by (auto simp add: quotient_def)

lemma equiv_eq_game[simp]: "equiv UNIV eq_game_rel"
  by (auto simp add: equiv_def refl_on_def sym_def trans_def eq_game_rel_def
    eq_game_sym intro: eq_game_refl eq_game_trans)

instantiation Pg :: "{ord, zero, plus, minus, uminus}"
begin

definition
  Pg_zero_def: "0 = Abs_Pg (eq_game_rel `` {zero_game})"

definition
  Pg_le_def: "G \<le> H \<longleftrightarrow> (\<exists> g h. g \<in> Rep_Pg G \<and> h \<in> Rep_Pg H \<and> ge_game (h, g))"

definition
  Pg_less_def: "G < H \<longleftrightarrow> G \<le> H \<and> G \<noteq> (H::Pg)"

definition
  Pg_minus_def: "- G = the_elem (\<Union>g \<in> Rep_Pg G. {Abs_Pg (eq_game_rel `` {neg_game g})})"

definition
  Pg_plus_def: "G + H = the_elem (\<Union>g \<in> Rep_Pg G. \<Union>h \<in> Rep_Pg H. {Abs_Pg (eq_game_rel `` {plus_game g h})})"

definition
  Pg_diff_def: "G - H = G + (- (H::Pg))"

instance ..

end

lemma Rep_Abs_eq_Pg[simp]: "Rep_Pg (Abs_Pg (eq_game_rel `` {g})) = eq_game_rel `` {g}"
  apply (subst Abs_Pg_inverse)
  apply (auto simp add: Pg_def quotient_def)
  done

lemma char_Pg_le[simp]: "(Abs_Pg (eq_game_rel `` {g}) \<le> Abs_Pg (eq_game_rel `` {h})) = (ge_game (h, g))"
  apply (simp add: Pg_le_def)
  apply (auto simp add: eq_game_rel_def eq_game_def intro: ge_game_trans ge_game_refl)
  done

lemma char_Pg_eq[simp]: "(Abs_Pg (eq_game_rel `` {g}) = Abs_Pg (eq_game_rel `` {h})) = (eq_game g h)"
  apply (simp add: Rep_Pg_inject [symmetric])
  apply (subst eq_equiv_class_iff[of UNIV])
  apply (simp_all)
  apply (simp add: eq_game_rel_def)
  done

lemma char_Pg_plus[simp]: "Abs_Pg (eq_game_rel `` {g}) + Abs_Pg (eq_game_rel `` {h}) = Abs_Pg (eq_game_rel `` {plus_game g h})"
proof -
  have "(\<lambda> g h. {Abs_Pg (eq_game_rel `` {plus_game g h})}) respects2 eq_game_rel"
    apply (simp add: congruent2_def)
    apply (auto simp add: eq_game_rel_def eq_game_def)
    apply (rule_tac y="plus_game a ba" in ge_game_trans)
    apply (simp add: ge_plus_game_left[symmetric] ge_plus_game_right[symmetric])+
    apply (rule_tac y="plus_game b aa" in ge_game_trans)
    apply (simp add: ge_plus_game_left[symmetric] ge_plus_game_right[symmetric])+
    done
  then show ?thesis
    by (simp add: Pg_plus_def UN_equiv_class2[OF equiv_eq_game equiv_eq_game])
qed

lemma char_Pg_minus[simp]: "- Abs_Pg (eq_game_rel `` {g}) = Abs_Pg (eq_game_rel `` {neg_game g})"
proof -
  have "(\<lambda> g. {Abs_Pg (eq_game_rel `` {neg_game g})}) respects eq_game_rel"
    apply (simp add: congruent_def)
    apply (auto simp add: eq_game_rel_def eq_game_def ge_neg_game)
    done
  then show ?thesis
    by (simp add: Pg_minus_def UN_equiv_class[OF equiv_eq_game])
qed

lemma eq_Abs_Pg[rule_format, cases type: Pg]: "(\<forall> g. z = Abs_Pg (eq_game_rel `` {g}) \<longrightarrow> P) \<longrightarrow> P"
  apply (cases z, simp)
  apply (simp add: Rep_Pg_inject[symmetric])
  apply (subst Abs_Pg_inverse, simp)
  apply (auto simp add: Pg_def quotient_def)
  done

instance Pg :: ordered_ab_group_add
proof
  fix a b c :: Pg
  show "a - b = a + (- b)" by (simp add: Pg_diff_def)
  {
    assume ab: "a \<le> b"
    assume ba: "b \<le> a"
    from ab ba show "a = b"
      apply (cases a, cases b)
      apply (simp add: eq_game_def)
      done
  }
  then show "(a < b) = (a \<le> b \<and> \<not> b \<le> a)" by (auto simp add: Pg_less_def)
  show "a + b = b + a"
    apply (cases a, cases b)
    apply (simp add: eq_game_def plus_game_comm)
    done
  show "a + b + c = a + (b + c)"
    apply (cases a, cases b, cases c)
    apply (simp add: eq_game_def plus_game_assoc)
    done
  show "0 + a = a"
    apply (cases a)
    apply (simp add: Pg_zero_def plus_game_zero_left)
    done
  show "- a + a = 0"
    apply (cases a)
    apply (simp add: Pg_zero_def eq_game_plus_inverse plus_game_comm)
    done
  show "a \<le> a"
    apply (cases a)
    apply (simp add: ge_game_refl)
    done
  {
    assume ab: "a \<le> b"
    assume bc: "b \<le> c"
    from ab bc show "a \<le> c"
      apply (cases a, cases b, cases c)
      apply (auto intro: ge_game_trans)
      done
  }
  {
    assume ab: "a \<le> b"
    from ab show "c + a \<le> c + b"
      apply (cases a, cases b, cases c)
      apply (simp add: ge_plus_game_left[symmetric])
      done
  }
qed

end


theory PLProver
imports Main BDT Formula
begin

fun    form2bdt :: "form \<Rightarrow> bdt"
where "form2bdt (Atom a)= (BDT.Atom a)"
     |"form2bdt (Var x) = (IF x (BDT.Atom True) (BDT.Atom False))"
     |"form2bdt (Neg p) = (neg (form2bdt p) )"
     |"form2bdt (Bin And p q)= comb (\<and>) (form2bdt p) (form2bdt q)"
     |"form2bdt (Bin Or p q)= comb (\<or>) (form2bdt p) (form2bdt q)"
     |"form2bdt (Bin Impl p q)= comb (\<longrightarrow>) (form2bdt p) (form2bdt q)"

(** Tester la fonction *)
value "form2bdt P1"
value "form2bdt P2"

(** Prouver que la transformation form2bdt préserve la sémantique des formules *)

lemma form2bdt_correct:" I\<^sub>f\<^sub>o\<^sub>r\<^sub>m  \<phi> \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>\<rbrakk> \<gamma>"
proof(induct \<phi>)
  case (Var x)
  then show ?case   by simp
next
  case (Atom x)
  then show ?case  by simp
next
  case (Neg \<phi>)
  then show ?case
    by(simp add:negt_corr)
next
  case (Bin binop \<phi>1 \<phi>2)
  then show ?case
    proof(cases binop)
      case And
      show ?thesis by(simp add: `I\<^sub>f\<^sub>o\<^sub>r\<^sub>m \<phi>1 \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>1\<rbrakk> \<gamma>`
                                `I\<^sub>f\<^sub>o\<^sub>r\<^sub>m \<phi>2 \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>2\<rbrakk> \<gamma>`
                                `binop = And` comb_correct)
    next
      case Or
        assume * : "I\<^sub>f\<^sub>o\<^sub>r\<^sub>m \<phi>1 \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>1\<rbrakk> \<gamma>"
        and ** : "I\<^sub>f\<^sub>o\<^sub>r\<^sub>m \<phi>2 \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>2\<rbrakk> \<gamma>"
        and ***: " binop = Or"
      then show ?thesis by(simp add: * ** *** comb_correct)
    next
      case Impl
        assume * : "I\<^sub>f\<^sub>o\<^sub>r\<^sub>m \<phi>1 \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>1\<rbrakk> \<gamma>"
        and ** : "I\<^sub>f\<^sub>o\<^sub>r\<^sub>m \<phi>2 \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>2\<rbrakk> \<gamma>"
        and ***: " binop = Impl"
      then show ?thesis by(simp add: * ** *** comb_correct)
    qed
qed

lemma form2bdt_correct':" I\<^sub>f\<^sub>o\<^sub>r\<^sub>m  \<phi> \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>\<rbrakk> \<gamma>"
proof(induct \<phi>)
  case (Var x)
  then show ?case by simp
next
  case (Atom x)
  then show ?case by simp
next
  case (Neg \<phi>)
  then show ?case
       proof(simp,cases \<phi>)
         case (Var x1)
         then show "\<lbrakk>I\<^sub>f\<^sub>o\<^sub>r\<^sub>m \<phi> \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>\<rbrakk> \<gamma>; \<phi> = Var x1\<rbrakk> \<Longrightarrow> (\<not> I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>\<rbrakk> \<gamma>) =
                    I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>neg (form2bdt \<phi>)\<rbrakk> \<gamma>"
           by simp
       next
         case (Atom x2)
         then show " \<lbrakk>I\<^sub>f\<^sub>o\<^sub>r\<^sub>m \<phi> \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>\<rbrakk> \<gamma>; \<phi> = form.Atom x2\<rbrakk> \<Longrightarrow>
                     (\<not> I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>\<rbrakk> \<gamma>) = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>neg (form2bdt \<phi>)\<rbrakk> \<gamma>" by simp
       next
         case (Neg x3)
         then show "\<lbrakk>I\<^sub>f\<^sub>o\<^sub>r\<^sub>m \<phi> \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>\<rbrakk> \<gamma>; \<phi> = neg\<^sub>F x3\<rbrakk> \<Longrightarrow>
                    (\<not> I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>\<rbrakk> \<gamma>) = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>neg (form2bdt \<phi>)\<rbrakk> \<gamma>"
             by (simp add: negt_corr')
       next
         case (Bin x41 x42 x43)
         then show "\<lbrakk>I\<^sub>f\<^sub>o\<^sub>r\<^sub>m \<phi> \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>\<rbrakk> \<gamma>; \<phi> = Bin x41 x42 x43\<rbrakk> \<Longrightarrow>
                    (\<not> I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>\<rbrakk> \<gamma>) = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>neg (form2bdt \<phi>)\<rbrakk> \<gamma>"
           by (simp add: negt_corr')
       qed
next
  case (Bin binop \<phi>1 \<phi>2)
  then show ?case
     apply(insert Bin.hyps)
     proof(cases binop)
       case And
       then show "\<lbrakk>I\<^sub>f\<^sub>o\<^sub>r\<^sub>m \<phi>1 \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>1\<rbrakk> \<gamma>;
                   I\<^sub>f\<^sub>o\<^sub>r\<^sub>m \<phi>2 \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>2\<rbrakk> \<gamma>; binop = And\<rbrakk>
                   \<Longrightarrow> I\<^sub>f\<^sub>o\<^sub>r\<^sub>m (Bin binop \<phi>1 \<phi>2) \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt (Bin binop \<phi>1 \<phi>2)\<rbrakk> \<gamma>"
             by(simp add:  comb_correct')
     next
       case Or
       then show "\<lbrakk>I\<^sub>f\<^sub>o\<^sub>r\<^sub>m \<phi>1 \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>1\<rbrakk> \<gamma>;
                   I\<^sub>f\<^sub>o\<^sub>r\<^sub>m \<phi>2 \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>2\<rbrakk> \<gamma>; binop = Or\<rbrakk>
                   \<Longrightarrow> I\<^sub>f\<^sub>o\<^sub>r\<^sub>m (Bin binop \<phi>1 \<phi>2) \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt (Bin binop \<phi>1 \<phi>2)\<rbrakk> \<gamma>"
                      by(simp add:  comb_correct')
     next
       case Impl
       then show "\<lbrakk>I\<^sub>f\<^sub>o\<^sub>r\<^sub>m \<phi>1 \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>1\<rbrakk> \<gamma>;
                   I\<^sub>f\<^sub>o\<^sub>r\<^sub>m \<phi>2 \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt \<phi>2\<rbrakk> \<gamma>; binop = Impl\<rbrakk>
                   \<Longrightarrow> I\<^sub>f\<^sub>o\<^sub>r\<^sub>m (Bin binop \<phi>1 \<phi>2) \<gamma> = I\<^sub>b\<^sub>d\<^sub>t \<lbrakk>form2bdt (Bin binop \<phi>1 \<phi>2)\<rbrakk> \<gamma>"
                      by(simp add:  comb_correct')
     qed
qed

(** A quelle condition sur i j n m a-t-on ordered n i t -> ordered m j t ?
    faire la preuve correspondante *)

lemma ordered_incl: " ordered n i t \<Longrightarrow> \<forall> m j. undefined (* compléter *) \<Longrightarrow> ordered m j t"
sorry
(* compléter *)

(** Définir une fonction qui renvoie le maximum des variables
   rencontrées dans une formule propositionnelle +1 (0 si pas de variable)
   on pourra utiliser la fonction max *)

fun  maxvar
where "maxvar (Atom a) = undefined "    (* compléter *)
     |"maxvar(Var x) =   undefined " (* compléter *)
     |"maxvar(Neg p) =  undefined " (* compléter *)
     |"maxvar(Bin opn p q) =  undefined " (* compléter *)

(** Prouver que le résultat de form2bdt donne un arbre ordonné entre 0 et maxvar *)

lemma form2bdt_ord :"ordered (maxvar f) 0 (form2bdt f)"
sorry
(* compléter *)

(** * Tester qu'un BDT (ordonné) est une tautologie *)
(* Ecrire une fonction booléenne qui teste si un BDT correspond à une tautologie *)

fun istauto
where "istauto (BDT.Atom a) = undefined"  (* compléter *)
     |"istauto (BDT.IF x l r) =  undefined"   (* compléter *)

(** Enoncer et prouver la correction de ce test, on pourra distinguer
    le cas où le test est positif et le cas où le test est négatif *)

lemma istauto_true_corr : "istauto t"
      (* compléter *)
sorry

end


section \<open>Terminated Lazy Lists as Quotients of Lazy Lists\<close>

text \<open>
This file demonstrates the lift_bnf utility for quotients on the example of lazy lists.

See the Coinductive AFP entry for a much more extensive library
of (terminated) lazy lists.
\<close>

theory TLList
imports Main
begin

codatatype (lset: 'a) llist = LNil | LCons 'a "'a llist"
  for map: lmap rel: lrel

inductive lfinite where
  LNil: "lfinite LNil"
| LCons: "\<And>x xs. lfinite xs \<Longrightarrow> lfinite (LCons x xs)"

lemma lfinite_lmapI: "lfinite xs \<Longrightarrow> lfinite (lmap f xs)"
  by (induct xs rule: lfinite.induct) (auto intro: lfinite.intros)

lemma lfinite_lmapD: "lfinite (lmap f xs) \<Longrightarrow> lfinite xs"
proof (induct "lmap f xs" arbitrary: xs rule: lfinite.induct)
  case LNil
  then show ?case
    by (cases xs) (auto intro: lfinite.intros)
next
  case (LCons y ys)
  then show ?case
    by (cases xs) (auto intro: lfinite.intros)
qed

lemma lfinite_lmap[simp]: "lfinite (lmap f xs) = lfinite xs"
  by (metis lfinite_lmapI lfinite_lmapD)

lemma lfinite_lrel: "lfinite xs \<Longrightarrow> lrel R xs ys \<Longrightarrow> lfinite ys"
proof (induct xs arbitrary: ys rule: lfinite.induct)
  case LNil
  then show ?case
    by (cases ys) (auto intro: lfinite.intros)
next
  case (LCons x xs)
  then show ?case
    by (cases ys) (auto intro: lfinite.intros)
      qed

lemma lfinite_lrel': "lfinite ys \<Longrightarrow> lrel R xs ys \<Longrightarrow> lfinite xs"
  using lfinite_lrel llist.rel_flip by blast

lemma lfinite_lrel_eq:
   "lrel R xs ys \<Longrightarrow> lfinite xs = lfinite ys"
  using lfinite_lrel lfinite_lrel' by blast+

definition eq_tllist where
  "eq_tllist p q = (fst p = fst q \<and> (if lfinite (fst p) then snd p = snd q else True))"

quotient_type ('a, 'b) tllist = "'a llist \<times> 'b" / eq_tllist
  apply (rule equivpI)
    apply (rule reflpI; auto simp: eq_tllist_def)
   apply (rule sympI; auto simp: eq_tllist_def)
  apply (rule transpI; auto simp: eq_tllist_def)
  done

primcorec lconst where
  "lconst a = LCons a (lconst a)"

lemma lfinite_lconst[simp]: "\<not> lfinite (lconst a)"
proof
  assume "lfinite (lconst a)"
  then show "False"
  apply (induct "lconst a" rule: lfinite.induct)
  subgoal by (subst (asm) lconst.code) auto
  subgoal by (subst (asm) (2) lconst.code) auto
  done
qed

lemma lset_lconst: "x \<in> lset (lconst b) \<Longrightarrow> x = b"
  apply (induct x "lconst b" arbitrary: b rule: llist.set_induct)
  subgoal by (subst (asm) lconst.code) auto
  subgoal by (subst (asm) (2) lconst.code) auto
  done

lift_bnf (tlset1: 'a, tlset2: 'b) tllist
  [wits: "\<lambda>a. (lconst a, undefined)" ]
  for map: tlmap rel: tlrel
  subgoal for P Q P' Q'
    by (force simp: eq_tllist_def relcompp_apply llist.rel_compp lfinite_lrel_eq split: if_splits)
  subgoal for Ss
    by (auto simp: eq_tllist_def)
  subgoal for Ss
    apply (auto 0 0 simp: eq_tllist_def)
    by metis
  subgoal for x b
    by (auto simp: eq_tllist_def llist.set_map dest: lset_lconst split: if_splits)
  subgoal for x b
    by (auto simp: eq_tllist_def sum_set_defs split: if_splits sum.splits)
  done

lift_definition TLNil :: "'b \<Rightarrow> ('a, 'b) tllist" is "\<lambda>b. (LNil, b)" .
lift_definition TLCons :: "'a \<Rightarrow> ('a, 'b) tllist \<Rightarrow> ('a, 'b) tllist" is "\<lambda>x (xs, b). (LCons x xs, b)"
  by (auto simp: eq_tllist_def split: if_splits elim: lfinite.cases)

lemma lfinite_LCons: "lfinite (LCons x xs) = lfinite xs"
  using lfinite.simps by auto

lemmas lfinite_simps[simp] = lfinite.LNil lfinite_LCons

lemma tlset_TLNil: "tlset1 (TLNil b) = {}" "tlset2 (TLNil b) = {b}"
  by (transfer; auto simp: eq_tllist_def split: if_splits)+

lemma tlset_TLCons: "tlset1 (TLCons x xs) = {x} \<union> tlset1 xs" "tlset2 (TLCons x xs) = tlset2 xs"
  by (transfer; auto simp: eq_tllist_def split: if_splits)+

lift_definition tlfinite :: "('a, 'b) tllist \<Rightarrow> bool" is "\<lambda>(xs, _). lfinite xs"
  by (auto simp: eq_tllist_def)

lemma tlfinite_tlset2: "tlfinite xs \<Longrightarrow> tlset2 xs \<noteq> {}"
  apply (transfer, safe)
  subgoal for xs b
    by (induct xs rule: lfinite.induct) (auto simp: eq_tllist_def setr.simps)
  done

lemma tlfinite_tlset2': "b \<in> tlset2 xs \<Longrightarrow> tlfinite xs"
  by (transfer fixing: b, auto simp: eq_tllist_def setr.simps split: if_splits)

lemma "\<not> tlfinite xs \<Longrightarrow> tlset2 xs = {}"
  by (meson equals0I tlfinite_tlset2')

end