theory FSet

imports QuotMain

begin

inductive

  list_eq (infix "\<approx>" 50)

where

  "a#b#xs \<approx> b#a#xs"

| "[] \<approx> []"

| "xs \<approx> ys \<Longrightarrow> ys \<approx> xs"

| "a#a#xs \<approx> a#xs"

| "xs \<approx> ys \<Longrightarrow> a#xs \<approx> a#ys"

| "\<lbrakk>xs1 \<approx> xs2; xs2 \<approx> xs3\<rbrakk> \<Longrightarrow> xs1 \<approx> xs3"

lemma list_eq_refl:

  shows "xs \<approx> xs"

  apply (induct xs)

   apply (auto intro: list_eq.intros)

  done

lemma equiv_list_eq:

  shows "EQUIV list_eq"

  unfolding EQUIV_REFL_SYM_TRANS REFL_def SYM_def TRANS_def

  apply(auto intro: list_eq.intros list_eq_refl)

  done

quotient fset = "'a list" / "list_eq"

  apply(rule equiv_list_eq)

  done

print_theorems

typ "'a fset"

thm "Rep_fset"

thm "ABS_fset_def"

ML {* @{term "Abs_fset"} *}

local_setup {*

  make_const_def @{binding EMPTY} @{term "[]"} NoSyn @{typ "'a list"} @{typ "'a fset"} #> snd

*}

term Nil

term EMPTY

thm EMPTY_def

local_setup {*

  make_const_def @{binding INSERT} @{term "op #"} NoSyn @{typ "'a list"} @{typ "'a fset"} #> snd

*}

term Cons

term INSERT

thm INSERT_def

local_setup {*

  make_const_def @{binding UNION} @{term "op @"} NoSyn @{typ "'a list"} @{typ "'a fset"} #> snd

*}

term append

term UNION

thm UNION_def

thm QUOTIENT_fset

thm QUOT_TYPE_I_fset.thm11

fun

  membship :: "'a \<Rightarrow> 'a list \<Rightarrow> bool" (infix "memb" 100)

where

  m1: "(x memb []) = False"

| m2: "(x memb (y#xs)) = ((x=y) \<or> (x memb xs))"

fun

  card1 :: "'a list \<Rightarrow> nat"

where

  card1_nil: "(card1 []) = 0"

| card1_cons: "(card1 (x # xs)) = (if (x memb xs) then (card1 xs) else (Suc (card1 xs)))"

local_setup {*

  make_const_def @{binding card} @{term "card1"} NoSyn @{typ "'a list"} @{typ "'a fset"} #> snd

*}

term card1

term card

thm card_def

(* text {*

 Maybe make_const_def should require a theorem that says that the particular lifted function

 respects the relation. With it such a definition would be impossible:

 make_const_def @{binding CARD} @{term "length"} NoSyn @{typ "'a list"} @{typ "'a fset"} #> snd

*}*)

lemma card1_0:

  fixes a :: "'a list"

  shows "(card1 a = 0) = (a = [])"

  apply (induct a)

   apply (simp)

  apply (simp_all)

   apply meson

  apply (simp_all)

  done

lemma not_mem_card1:

  fixes x :: "'a"

  fixes xs :: "'a list"

  shows "~(x memb xs) \<Longrightarrow> card1 (x # xs) = Suc (card1 xs)"

  by simp

lemma mem_cons:

  fixes x :: "'a"

  fixes xs :: "'a list"

  assumes a : "x memb xs"

  shows "x # xs \<approx> xs"

  using a

  apply (induct xs)

  apply (auto intro: list_eq.intros)

  done

lemma card1_suc:

  fixes xs :: "'a list"

  fixes n :: "nat"

  assumes c: "card1 xs = Suc n"

  shows "\<exists>a ys. ~(a memb ys) \<and> xs \<approx> (a # ys)"

  using c

apply(induct xs)

apply (metis Suc_neq_Zero card1_0)

apply (metis QUOT_TYPE_I_fset.R_trans card1_cons list_eq_refl mem_cons)

done

primrec

  fold1

where

  "fold1 f (g :: 'a \<Rightarrow> 'b) (z :: 'b) [] = z"

| "fold1 f g z (a # A) =

     (if ((!u v. (f u v = f v u))

      \<and> (!u v w. ((f u (f v w) = f (f u v) w))))

     then (

       if (a memb A) then (fold1 f g z A) else (f (g a) (fold1 f g z A))

     ) else z)"

(* fold1_def is not usable, but: *)

thm fold1.simps

lemma fs1_strong_cases:

  fixes X :: "'a list"

  shows "(X = []) \<or> (\<exists>a. \<exists> Y. (~(a memb Y) \<and> (X \<approx> a # Y)))"

  apply (induct X)

  apply (simp)

  apply (metis QUOT_TYPE_I_fset.thm11 list_eq_refl mem_cons m1)

  done

local_setup {*

  make_const_def @{binding IN} @{term "membship"} NoSyn @{typ "'a list"} @{typ "'a fset"} #> snd

*}

term membship

term IN

thm IN_def

local_setup {*

  make_const_def @{binding fold} @{term "fold1::('b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> 'b"} NoSyn @{typ "'a list"} @{typ "'a fset"} #> snd

*}

term fold1

term fold

thm fold_def

local_setup {*

*}

term map

term fmap

thm fmap_def

ML {*

  val consts = [@{const_name "Nil"}, @{const_name "Cons"},

                @{const_name "membship"}, @{const_name "card1"},

                @{const_name "append"}, @{const_name "fold1"},

                @{const_name "map"}];

*}

ML {* val fset_defs = @{thms EMPTY_def IN_def UNION_def card_def INSERT_def fmap_def fold_def} *}

ML {* val fset_defs_sym = add_lower_defs @{context} fset_defs *}

lemma memb_rsp:

  fixes z

  assumes a: "list_eq x y"

  shows "(z memb x) = (z memb y)"

  using a by induct auto

lemma ho_memb_rsp:

  "(op = ===> (op \<approx> ===> op =)) (op memb) (op memb)"

  apply (simp add: FUN_REL.simps)

  apply (metis memb_rsp)

  done

lemma card1_rsp:

  fixes a b :: "'a list"

  assumes e: "a \<approx> b"

  shows "card1 a = card1 b"

  using e apply induct

  apply (simp_all add:memb_rsp)

  done

lemma ho_card1_rsp: "op \<approx> ===> op = card1 card1"

  apply (simp add: FUN_REL.simps)

  apply (metis card1_rsp)

  done

lemma cons_rsp:

  fixes z

  assumes a: "xs \<approx> ys"

  shows "(z # xs) \<approx> (z # ys)"

  using a by (rule list_eq.intros(5))

lemma ho_cons_rsp:

  "op = ===> op \<approx> ===> op \<approx> op # op #"

  apply (simp add: FUN_REL.simps)

  apply (metis cons_rsp)

  done

lemma append_rsp_fst:

  assumes a : "list_eq l1 l2"

  shows "list_eq (l1 @ s) (l2 @ s)"

  using a

  apply(induct)

  apply(auto intro: list_eq.intros)

  apply(rule list_eq_refl)

done

(* Need stronger induction... *)

lemma "(a @ b) \<approx> (b @ a)"

  apply(induct a)

  sorry

lemma ho_append_rsp:

  "op \<approx> ===> op \<approx> ===> op \<approx> op @ op @"

sorry

lemma map_rsp:

  assumes a: "a \<approx> b"

  shows "map f a \<approx> map f b"

  using a

  apply (induct)

  apply(auto intro: list_eq.intros)

  done

lemma ho_map_rsp:

  "op = ===> op = ===> op \<approx> ===> op \<approx> map map"

  apply (simp add: FUN_REL.simps)

  apply (rule allI)

  apply (rule allI)

  apply (rule impI)

  apply (rule allI)

  apply (rule allI)

  apply (rule impI)

  sorry (* apply (auto simp add: map_rsp[of "xa" "ya"]) *)

lemma map_append :

  "(map f ((a::'a list) @ b)) \<approx>

  ((map f a) ::'a list) @ (map f b)"

 apply simp

 apply (rule list_eq_refl)

 done

thm list.induct

lemma list_induct_hol4:

  fixes P :: "'a list \<Rightarrow> bool"

  assumes a: "((P []) \<and> (\<forall>t. (P t) \<longrightarrow> (\<forall>h. (P (h # t)))))"

  shows "\<forall>l. (P l)"

  using a

  apply (rule_tac allI)

  apply (induct_tac "l")

  apply (simp)

  apply (metis)

  done

prove list_induct_r: {*

   build_regularize_goal (atomize_thm @{thm list_induct_hol4}) @{typ "'a List.list"} @{term "op \<approx>"} @{context} *}

  apply (simp only: equiv_res_forall[OF equiv_list_eq])

  thm RIGHT_RES_FORALL_REGULAR

  apply (rule RIGHT_RES_FORALL_REGULAR)

  prefer 2

  apply (assumption)

  apply (metis)

  done

(* The all_prs and ex_prs should be proved for the instance... *)

ML {*

fun r_mk_comb_tac_fset ctxt =

  r_mk_comb_tac ctxt @{thm QUOTIENT_fset} @{thm list_eq_refl} @{thm QUOT_TYPE_I_fset.R_trans2}

  (@{thms ho_memb_rsp ho_cons_rsp ho_card1_rsp ho_map_rsp ho_append_rsp} @ @{thms ho_all_prs ho_ex_prs})

*}

ML {* val thm = @{thm list_induct_r} OF [atomize_thm @{thm list_induct_hol4}] *}

ML {* val trm_r = build_repabs_goal @{context} thm consts @{typ "'a list"} @{typ "'a fset"} *}

ML {* val trm = build_repabs_term @{context} thm consts @{typ "'a list"} @{typ "'a fset"} *}

ML {* trm_r *}

prove list_induct_tr: trm_r

apply (atomize(full))

apply (tactic {* REPEAT_ALL_NEW (r_mk_comb_tac_fset @{context}) 1 *})

done

prove list_induct_t: trm

apply (simp only: list_induct_tr[symmetric])

apply (tactic {* rtac thm 1 *})

done

thm m2

ML {* atomize_thm @{thm m2} *}

prove m2_r_p: {*

   build_regularize_goal (atomize_thm @{thm m2}) @{typ "'a List.list"} @{term "op \<approx>"} @{context} *}

  apply (simp add: equiv_res_forall[OF equiv_list_eq])

done

ML {* val m2_r = @{thm m2_r_p} OF [atomize_thm @{thm m2}] *}

ML {* val m2_t_g = build_repabs_goal @{context} m2_r consts @{typ "'a list"} @{typ "'a fset"} *}

ML {* val m2_t = build_repabs_term @{context} m2_r consts @{typ "'a list"} @{typ "'a fset"} *}

prove m2_t_p: m2_t_g

apply (atomize(full))

apply (tactic {* REPEAT_ALL_NEW (r_mk_comb_tac_fset @{context}) 1 *})

done

prove m2_t: m2_t

apply (simp only: m2_t_p[symmetric])

apply (tactic {* rtac m2_r 1 *})

done

lemma id_apply2 [simp]: "id x \<equiv> x"

  by (simp add: id_def)

ML {*

   val lpis = @{thm LAMBDA_PRS} OF [@{thm QUOTIENT_fset}, @{thm IDENTITY_QUOTIENT}];

   val lpist = @{thm "HOL.sym"} OF [lpis];

   val lam_prs = MetaSimplifier.rewrite_rule [@{thm id_apply2}] lpist

*}

text {* the proper way to do it *}

ML {*

  fun findabs rty tm =

    case tm of

      Abs(_, T, b) =>

        let

          val b' = subst_bound ((Free ("x", T)), b);

          val tys = findabs rty b'

          val ty = fastype_of tm

        in if needs_lift rty ty then (ty :: tys) else tys

        end

    | f $ a => (findabs rty f) @ (findabs rty a)

    | _ => []

*}

ML {* val quot = @{thm QUOTIENT_fset} *}

ML {* val abs = findabs @{typ "'a list"} (prop_of (atomize_thm @{thm list_induct_hol4})) *}

ML {* val simp_lam_prs_thms = map (make_simp_lam_prs_thm @{context} quot) abs *}

ML {*

  fun simp_lam_prs lthy thm =

    simp_lam_prs lthy (eqsubst_thm lthy simp_lam_prs_thms thm)

    handle _ => thm

*}

ML {* val m2_t' = eqsubst_thm @{context} [lam_prs] @{thm m2_t} *}

ML {* val ithm = simp_allex_prs @{context} quot m2_t' *}

ML fset_defs_sym

ML {* val rthm = MetaSimplifier.rewrite_rule fset_defs_sym ithm *}

ML {* ObjectLogic.rulify rthm *}

ML {* val card1_suc_a = atomize_thm @{thm card1_suc} *}

prove card1_suc_r_p: {*

   build_regularize_goal (atomize_thm @{thm card1_suc}) @{typ "'a List.list"} @{term "op \<approx>"} @{context} *}

  apply (simp add: equiv_res_forall[OF equiv_list_eq] equiv_res_exists[OF equiv_list_eq])

done

ML {* val card1_suc_r = @{thm card1_suc_r_p} OF [atomize_thm @{thm card1_suc}] *}

ML {* val card1_suc_t_g = build_repabs_goal @{context} card1_suc_r consts @{typ "'a list"} @{typ "'a fset"} *}

ML {* val card1_suc_t = build_repabs_term @{context} card1_suc_r consts @{typ "'a list"} @{typ "'a fset"} *}

prove card1_suc_t_p: card1_suc_t_g

apply (atomize(full))

apply (tactic {* REPEAT_ALL_NEW (r_mk_comb_tac_fset @{context}) 1 *})

done

prove card1_suc_t: card1_suc_t

apply (simp only: card1_suc_t_p[symmetric])

apply (tactic {* rtac card1_suc_r 1 *})

done

ML {* val card1_suc_t_n = @{thm card1_suc_t} *}

ML {* val card1_suc_t' = simp_lam_prs @{context} @{thm card1_suc_t} *}

ML {* val ithm = simp_allex_prs @{context} quot card1_suc_t' *}

ML {* val rthm = MetaSimplifier.rewrite_rule fset_defs_sym ithm *}

ML {* val qthm = MetaSimplifier.rewrite_rule @{thms QUOT_TYPE_I_fset.REPS_same} rthm *}