(*  Title:      HOL/BNF/Tools/bnf_gfp_rec_sugar.ML

    Author:     Lorenz Panny, TU Muenchen

    Author:     Jasmin Blanchette, TU Muenchen

    Copyright   2013

Corecursor sugar.

*)

signature BNF_GFP_REC_SUGAR =

sig

  val add_primcorecursive_cmd: bool ->

    (binding * string option * mixfix) list * ((Attrib.binding * string) * string option) list ->

    Proof.context -> Proof.state

  val add_primcorec_cmd: bool ->

    (binding * string option * mixfix) list * ((Attrib.binding * string) * string option) list ->

    local_theory -> local_theory

end;

structure BNF_GFP_Rec_Sugar : BNF_GFP_REC_SUGAR =

struct

open Ctr_Sugar

open BNF_Util

open BNF_Def

open BNF_FP_Util

open BNF_FP_Def_Sugar

open BNF_FP_N2M_Sugar

open BNF_FP_Rec_Sugar_Util

open BNF_GFP_Rec_Sugar_Tactics

val codeN = "code"

val ctrN = "ctr"

val discN = "disc"

val selN = "sel"

val nitpicksimp_attrs = @{attributes [nitpick_simp]};

val simp_attrs = @{attributes [simp]};

val code_nitpicksimp_attrs = Code.add_default_eqn_attrib :: nitpicksimp_attrs;

exception Primcorec_Error of string * term list;

fun primcorec_error str = raise Primcorec_Error (str, []);

fun primcorec_error_eqn str eqn = raise Primcorec_Error (str, [eqn]);

fun primcorec_error_eqns str eqns = raise Primcorec_Error (str, eqns);

datatype corec_call =

  Dummy_No_Corec of int |

  No_Corec of int |

  Mutual_Corec of int * int * int |

  Nested_Corec of int;

type basic_corec_ctr_spec =

  {ctr: term,

   disc: term,

   sels: term list};

type corec_ctr_spec =

  {ctr: term,

   disc: term,

   sels: term list,

   pred: int option,

   calls: corec_call list,

   discI: thm,

   sel_thms: thm list,

   collapse: thm,

   corec_thm: thm,

   disc_corec: thm,

   sel_corecs: thm list};

type corec_spec =

  {corec: term,

   nested_maps: thm list,

   nested_map_idents: thm list,

   nested_map_comps: thm list,

   ctr_specs: corec_ctr_spec list};

exception AINT_NO_MAP of term;

fun not_codatatype ctxt T =

  error ("Not a codatatype: " ^ Syntax.string_of_typ ctxt T);

fun ill_formed_corec_call ctxt t =

  error ("Ill-formed corecursive call: " ^ quote (Syntax.string_of_term ctxt t));

fun invalid_map ctxt t =

  error ("Invalid map function in " ^ quote (Syntax.string_of_term ctxt t));

fun unexpected_corec_call ctxt t =

  error ("Unexpected corecursive call: " ^ quote (Syntax.string_of_term ctxt t));

val mk_conjs = try (foldr1 HOLogic.mk_conj) #> the_default @{const True};

val mk_disjs = try (foldr1 HOLogic.mk_disj) #> the_default @{const False};

val conjuncts_s = filter_out (curry (op =) @{const True}) o HOLogic.conjuncts;

fun s_not @{const True} = @{const False}

  | s_not @{const False} = @{const True}

  | s_not (@{const Not} $ t) = t

  | s_not (@{const conj} $ t $ u) = @{const disj} $ s_not t $ s_not u

  | s_not (@{const disj} $ t $ u) = @{const conj} $ s_not t $ s_not u

  | s_not t = @{const Not} $ t;

val s_not_conj = conjuncts_s o s_not o mk_conjs;

fun propagate_unit_pos u cs = if member (op aconv) cs u then [@{const False}] else cs;

fun propagate_unit_neg not_u cs = remove (op aconv) not_u cs;

fun propagate_units css =

  (case List.partition (can the_single) css of

     ([], _) => css

   | ([u] :: uss, css') =>

     [u] :: propagate_units (map (propagate_unit_neg (s_not u))

       (map (propagate_unit_pos u) (uss @ css'))));

fun s_conjs cs =

  if member (op aconv) cs @{const False} then @{const False}

  else mk_conjs (remove (op aconv) @{const True} cs);

fun s_disjs ds =

  if member (op aconv) ds @{const True} then @{const True}

  else mk_disjs (remove (op aconv) @{const False} ds);

fun s_dnf css0 =

  let val css = propagate_units css0 in

    if null css then

      [@{const False}]

    else if exists null css then

      []

    else

      map (fn c :: cs => (c, cs)) css

      |> AList.coalesce (op =)

      |> map (fn (c, css) => c :: s_dnf css)

      |> (fn [cs] => cs | css => [s_disjs (map s_conjs css)])

  end;

fun fold_rev_let_if_case ctxt f bound_Ts t =

  let

    val thy = Proof_Context.theory_of ctxt;

    fun fld conds t =

      (case Term.strip_comb t of

        (Const (@{const_name Let}, _), [_, _]) => fld conds (unfold_let t)

      | (Const (@{const_name If}, _), [cond, then_branch, else_branch]) =>

        fld (conds @ conjuncts_s cond) then_branch o fld (conds @ s_not_conj [cond]) else_branch

      | (Const (c, _), args as _ :: _ :: _) =>

        let val n = num_binder_types (Sign.the_const_type thy c) - 1 in

          if n >= 0 andalso n < length args then

            (case fastype_of1 (bound_Ts, nth args n) of

              Type (s, Ts) =>

              (case dest_case ctxt s Ts t of

                NONE => apsnd (f conds t)

              | SOME (conds', branches) =>

                apfst (cons s) o fold_rev (uncurry fld)

                  (map (append conds o conjuncts_s) conds' ~~ branches))

            | _ => apsnd (f conds t))

          else

            apsnd (f conds t)

        end

      | _ => apsnd (f conds t))

  in

    fld [] t o pair []

  end;

fun case_of ctxt = ctr_sugar_of ctxt #> Option.map (fst o dest_Const o #casex);

fun massage_let_if_case ctxt has_call massage_leaf =

  let

    val thy = Proof_Context.theory_of ctxt;

    fun check_no_call t = if has_call t then unexpected_corec_call ctxt t else ();

    fun massage_abs bound_Ts 0 t = massage_rec bound_Ts t

      | massage_abs bound_Ts m (Abs (s, T, t)) = Abs (s, T, massage_abs (T :: bound_Ts) (m - 1) t)

      | massage_abs bound_Ts m t =

        let val T = domain_type (fastype_of1 (bound_Ts, t)) in

          Abs (Name.uu, T, massage_abs (T :: bound_Ts) (m - 1) (incr_boundvars 1 t $ Bound 0))

        end

    and massage_rec bound_Ts t =

      let val typof = curry fastype_of1 bound_Ts in

        (case Term.strip_comb t of

          (Const (@{const_name Let}, _), [_, _]) => massage_rec bound_Ts (unfold_let t)

        | (Const (@{const_name If}, _), obj :: (branches as [_, _])) =>

          let val branches' = map (massage_rec bound_Ts) branches in

            Term.list_comb (If_const (typof (hd branches')) $ tap check_no_call obj, branches')

          end

        | (Const (c, _), args as _ :: _ :: _) =>

          (case try strip_fun_type (Sign.the_const_type thy c) of

            SOME (gen_branch_Ts, gen_body_fun_T) =>

            let

              val gen_branch_ms = map num_binder_types gen_branch_Ts;

              val n = length gen_branch_ms;

            in

              if n < length args then

                (case gen_body_fun_T of

                  Type (_, [Type (T_name, _), _]) =>

                  if case_of ctxt T_name = SOME c then

                    let

                      val (branches, obj_leftovers) = chop n args;

                      val branches' = map2 (massage_abs bound_Ts) gen_branch_ms branches;

                      val branch_Ts' = map typof branches';

                      val body_T' = snd (strip_typeN (hd gen_branch_ms) (hd branch_Ts'));

                      val casex' = Const (c, branch_Ts' ---> map typof obj_leftovers ---> body_T');

                    in

                      Term.list_comb (casex', branches' @ tap (List.app check_no_call) obj_leftovers)

                    end

                  else

                    massage_leaf bound_Ts t

                | _ => massage_leaf bound_Ts t)

              else

                massage_leaf bound_Ts t

            end

          | NONE => massage_leaf bound_Ts t)

        | _ => massage_leaf bound_Ts t)

      end

  in

    massage_rec

  end;

val massage_mutual_corec_call = massage_let_if_case;

fun curried_type (Type (@{type_name fun}, [Type (@{type_name prod}, Ts), T])) = Ts ---> T;

fun massage_nested_corec_call ctxt has_call raw_massage_call bound_Ts U t =

  let

    fun check_no_call t = if has_call t then unexpected_corec_call ctxt t else ();

    val build_map_Inl = build_map ctxt (uncurry Inl_const o dest_sumT o snd);

    fun massage_mutual_call bound_Ts U T t =

      if has_call t then

        (case try dest_sumT U of

          SOME (U1, U2) => if U1 = T then raw_massage_call bound_Ts T U2 t else invalid_map ctxt t

        | NONE => invalid_map ctxt t)

      else

        build_map_Inl (T, U) $ t;

    fun massage_mutual_fun bound_Ts U T t =

      (case t of

        Const (@{const_name comp}, _) $ t1 $ t2 =>

        mk_comp bound_Ts (massage_mutual_fun bound_Ts U T t1, tap check_no_call t2)

      | _ =>

        let

          val var = Var ((Name.uu, Term.maxidx_of_term t + 1),

            domain_type (fastype_of1 (bound_Ts, t)));

        in

          Term.lambda var (massage_mutual_call bound_Ts U T (t $ var))

        end);

    fun massage_map bound_Ts (Type (_, Us)) (Type (s, Ts)) t =

        (case try (dest_map ctxt s) t of

          SOME (map0, fs) =>

          let

            val Type (_, dom_Ts) = domain_type (fastype_of1 (bound_Ts, t));

            val map' = mk_map (length fs) dom_Ts Us map0;

            val fs' =

              map_flattened_map_args ctxt s (map3 (massage_map_or_map_arg bound_Ts) Us Ts) fs;

          in

            Term.list_comb (map', fs')

          end

        | NONE => raise AINT_NO_MAP t)

      | massage_map _ _ _ t = raise AINT_NO_MAP t

    and massage_map_or_map_arg bound_Ts U T t =

      if T = U then

        tap check_no_call t

      else

        massage_map bound_Ts U T t

        handle AINT_NO_MAP _ => massage_mutual_fun bound_Ts U T t;

    fun massage_call bound_Ts U T =

      massage_let_if_case ctxt has_call (fn bound_Ts => fn t =>

        if has_call t then

          (case U of

            Type (s, Us) =>

            (case try (dest_ctr ctxt s) t of

              SOME (f, args) =>

              let

                val typof = curry fastype_of1 bound_Ts;

                val f' = mk_ctr Us f

                val f'_T = typof f';

                val arg_Ts = map typof args;

              in

                Term.list_comb (f', map3 (massage_call bound_Ts) (binder_types f'_T) arg_Ts args)

              end

            | NONE =>

              (case t of

                Const (@{const_name prod_case}, _) $ t' =>

                let

                  val U' = curried_type U;

                  val T' = curried_type T;

                in

                  Const (@{const_name prod_case}, U' --> U) $ massage_call bound_Ts U' T' t'

                end

              | t1 $ t2 =>

                (if has_call t2 then

                  massage_mutual_call bound_Ts U T t

                else

                  massage_map bound_Ts U T t1 $ t2

                  handle AINT_NO_MAP _ => massage_mutual_call bound_Ts U T t)

              | Abs (s, T', t') =>

                Abs (s, T', massage_call (T' :: bound_Ts) (range_type U) (range_type T) t')

              | _ => massage_mutual_call bound_Ts U T t))

          | _ => ill_formed_corec_call ctxt t)

        else

          build_map_Inl (T, U) $ t) bound_Ts;

    val T = fastype_of1 (bound_Ts, t);

  in

    if has_call t then massage_call bound_Ts U T t else build_map_Inl (T, U) $ t

  end;

val fold_rev_corec_call = fold_rev_let_if_case;

fun expand_to_ctr_term ctxt s Ts t =

  (case ctr_sugar_of ctxt s of

    SOME {ctrs, casex, ...} =>

    Term.list_comb (mk_case Ts (Type (s, Ts)) casex, map (mk_ctr Ts) ctrs) $ t

  | NONE => raise Fail "expand_to_ctr_term");

fun expand_corec_code_rhs ctxt has_call bound_Ts t =

  (case fastype_of1 (bound_Ts, t) of

    Type (s, Ts) =>

    massage_let_if_case ctxt has_call (fn _ => fn t =>

      if can (dest_ctr ctxt s) t then t else expand_to_ctr_term ctxt s Ts t) bound_Ts t

  | _ => raise Fail "expand_corec_code_rhs");

fun massage_corec_code_rhs ctxt massage_ctr =

  massage_let_if_case ctxt (K false)

    (fn bound_Ts => uncurry (massage_ctr bound_Ts) o Term.strip_comb);

fun fold_rev_corec_code_rhs ctxt f =

  snd ooo fold_rev_let_if_case ctxt (fn conds => uncurry (f conds) o Term.strip_comb);

fun case_thms_of_term ctxt bound_Ts t =

  let

    val (caseT_names, _) = fold_rev_let_if_case ctxt (K (K I)) bound_Ts t ();

    val ctr_sugars = map (the o ctr_sugar_of ctxt) caseT_names;

  in

    (maps #distincts ctr_sugars, maps #discIs ctr_sugars, maps #sel_splits ctr_sugars,

     maps #sel_split_asms ctr_sugars)

  end;

fun basic_corec_specs_of ctxt res_T =

  (case res_T of

    Type (T_name, _) =>

    (case Ctr_Sugar.ctr_sugar_of ctxt T_name of

      NONE => not_codatatype ctxt res_T

    | SOME {ctrs, discs, selss, ...} =>

      let

        val thy = Proof_Context.theory_of ctxt;

        val gfpT = body_type (fastype_of (hd ctrs));

        val As_rho = tvar_subst thy [gfpT] [res_T];

        val substA = Term.subst_TVars As_rho;

        fun mk_spec ctr disc sels = {ctr = substA ctr, disc = substA disc, sels = map substA sels};

      in

        map3 mk_spec ctrs discs selss

      end)

  | _ => not_codatatype ctxt res_T);

(*FIXME: remove special cases for product and sum once they are registered as datatypes*)

fun map_thms_of_typ ctxt (Type (s, _)) =

    if s = @{type_name prod} then

      @{thms map_pair_simp}

    else if s = @{type_name sum} then

      @{thms sum_map.simps}

    else

      (case fp_sugar_of ctxt s of

        SOME {index, mapss, ...} => nth mapss index

      | NONE => [])

  | map_thms_of_typ _ _ = [];

fun corec_specs_of bs arg_Ts res_Ts get_indices callssss0 lthy =

  let

    val thy = Proof_Context.theory_of lthy;

    val ((missing_res_Ts, perm0_kks,

          fp_sugars as {nested_bnfs, fp_res = {xtor_co_iterss = dtor_coiters1 :: _, ...},

            co_inducts = coinduct_thms, ...} :: _, (_, gfp_sugar_thms)), lthy') =

      nested_to_mutual_fps Greatest_FP bs res_Ts get_indices callssss0 lthy;

    val perm_fp_sugars = sort (int_ord o pairself #index) fp_sugars;

    val indices = map #index fp_sugars;

    val perm_indices = map #index perm_fp_sugars;

    val perm_ctrss = map (#ctrs o of_fp_sugar #ctr_sugars) perm_fp_sugars;

    val perm_ctr_Tsss = map (map (binder_types o fastype_of)) perm_ctrss;

    val perm_gfpTs = map (body_type o fastype_of o hd) perm_ctrss;

    val nn0 = length res_Ts;

    val nn = length perm_gfpTs;

    val kks = 0 upto nn - 1;

    val perm_ns = map length perm_ctr_Tsss;

    val perm_Cs = map (domain_type o body_fun_type o fastype_of o co_rec_of o

      of_fp_sugar (#xtor_co_iterss o #fp_res)) perm_fp_sugars;

    val (perm_p_Tss, (perm_q_Tssss, _, perm_f_Tssss, _)) =

      mk_coiter_fun_arg_types perm_ctr_Tsss perm_Cs perm_ns (co_rec_of dtor_coiters1);

    val (perm_p_hss, h) = indexedd perm_p_Tss 0;

    val (perm_q_hssss, h') = indexedddd perm_q_Tssss h;

    val (perm_f_hssss, _) = indexedddd perm_f_Tssss h';

    val fun_arg_hs =

      flat (map3 flat_corec_preds_predsss_gettersss perm_p_hss perm_q_hssss perm_f_hssss);

    fun unpermute0 perm0_xs = permute_like (op =) perm0_kks kks perm0_xs;

    fun unpermute perm_xs = permute_like (op =) perm_indices indices perm_xs;

    val coinduct_thmss = map (unpermute0 o conj_dests nn) coinduct_thms;

    val p_iss = map (map (find_index_eq fun_arg_hs)) (unpermute perm_p_hss);

    val q_issss = map (map (map (map (find_index_eq fun_arg_hs)))) (unpermute perm_q_hssss);

    val f_issss = map (map (map (map (find_index_eq fun_arg_hs)))) (unpermute perm_f_hssss);

    val f_Tssss = unpermute perm_f_Tssss;

    val gfpTs = unpermute perm_gfpTs;

    val Cs = unpermute perm_Cs;

    val As_rho = tvar_subst thy (take nn0 gfpTs) res_Ts;

    val Cs_rho = map (fst o dest_TVar) Cs ~~ pad_list HOLogic.unitT nn arg_Ts;

    val substA = Term.subst_TVars As_rho;

    val substAT = Term.typ_subst_TVars As_rho;

    val substCT = Term.typ_subst_TVars Cs_rho;

    val perm_Cs' = map substCT perm_Cs;

    fun call_of nullary [] [g_i] [Type (@{type_name fun}, [_, T])] =

        (if exists_subtype_in Cs T then Nested_Corec

         else if nullary then Dummy_No_Corec

         else No_Corec) g_i

      | call_of _ [q_i] [g_i, g_i'] _ = Mutual_Corec (q_i, g_i, g_i');

    fun mk_ctr_spec ctr disc sels p_ho q_iss f_iss f_Tss discI sel_thms collapse corec_thm

        disc_corec sel_corecs =

      let val nullary = not (can dest_funT (fastype_of ctr)) in

        {ctr = substA ctr, disc = substA disc, sels = map substA sels, pred = p_ho,

         calls = map3 (call_of nullary) q_iss f_iss f_Tss, discI = discI, sel_thms = sel_thms,

         collapse = collapse, corec_thm = corec_thm, disc_corec = disc_corec,

         sel_corecs = sel_corecs}

      end;

    fun mk_ctr_specs index (ctr_sugars : ctr_sugar list) p_is q_isss f_isss f_Tsss coiter_thmsss

        disc_coitersss sel_coiterssss =

      let

        val ctrs = #ctrs (nth ctr_sugars index);

        val discs = #discs (nth ctr_sugars index);

        val selss = #selss (nth ctr_sugars index);

        val p_ios = map SOME p_is @ [NONE];

        val discIs = #discIs (nth ctr_sugars index);

        val sel_thmss = #sel_thmss (nth ctr_sugars index);

        val collapses = #collapses (nth ctr_sugars index);

        val corec_thms = co_rec_of (nth coiter_thmsss index);

        val disc_corecs = co_rec_of (nth disc_coitersss index);

        val sel_corecss = co_rec_of (nth sel_coiterssss index);

      in

        map13 mk_ctr_spec ctrs discs selss p_ios q_isss f_isss f_Tsss discIs sel_thmss collapses

          corec_thms disc_corecs sel_corecss

      end;

    fun mk_spec ({T, index, ctr_sugars, co_iterss = coiterss, co_iter_thmsss = coiter_thmsss,

          disc_co_itersss = disc_coitersss, sel_co_iterssss = sel_coiterssss, ...} : fp_sugar)

        p_is q_isss f_isss f_Tsss =

      {corec = mk_co_iter thy Greatest_FP (substAT T) perm_Cs' (co_rec_of (nth coiterss index)),

       nested_maps = maps (map_thms_of_typ lthy o T_of_bnf) nested_bnfs,

       nested_map_idents = map (unfold_thms lthy @{thms id_def} o map_id0_of_bnf) nested_bnfs,

       nested_map_comps = map map_comp_of_bnf nested_bnfs,

       ctr_specs = mk_ctr_specs index ctr_sugars p_is q_isss f_isss f_Tsss coiter_thmsss

         disc_coitersss sel_coiterssss};

  in

    ((is_some gfp_sugar_thms, map5 mk_spec fp_sugars p_iss q_issss f_issss f_Tssss, missing_res_Ts,

      co_induct_of coinduct_thms, strong_co_induct_of coinduct_thms, co_induct_of coinduct_thmss,

      strong_co_induct_of coinduct_thmss), lthy')

  end;

val undef_const = Const (@{const_name undefined}, dummyT);

val abs_tuple = HOLogic.tupled_lambda o HOLogic.mk_tuple;

fun abstract vs =

  let fun a n (t $ u) = a n t $ a n u

        | a n (Abs (v, T, b)) = Abs (v, T, a (n + 1) b)

        | a n t = let val idx = find_index (equal t) vs in

            if idx < 0 then t else Bound (n + idx) end

  in a 0 end;

fun mk_prod1 bound_Ts (t, u) =

  HOLogic.pair_const (fastype_of1 (bound_Ts, t)) (fastype_of1 (bound_Ts, u)) $ t $ u;

fun mk_tuple1 bound_Ts = the_default HOLogic.unit o try (foldr1 (mk_prod1 bound_Ts));

type coeqn_data_disc = {

  fun_name: string,

  fun_T: typ,

  fun_args: term list,

  ctr: term,

  ctr_no: int, (*###*)

  disc: term,

  prems: term list,

  auto_gen: bool,

  maybe_ctr_rhs: term option,

  maybe_code_rhs: term option,

  user_eqn: term

};

type coeqn_data_sel = {

  fun_name: string,

  fun_T: typ,

  fun_args: term list,

  ctr: term,

  sel: term,

  rhs_term: term,

  user_eqn: term

};

datatype coeqn_data =

  Disc of coeqn_data_disc |

  Sel of coeqn_data_sel;

fun dissect_coeqn_disc seq fun_names (basic_ctr_specss : basic_corec_ctr_spec list list)

    maybe_ctr_rhs maybe_code_rhs prems' concl matchedsss =

  let

    fun find_subterm p = let (* FIXME \<exists>? *)

      fun f (t as u $ v) = if p t then SOME t else merge_options (f u, f v)

        | f t = if p t then SOME t else NONE

      in f end;

    val applied_fun = concl

      |> find_subterm (member ((op =) o apsnd SOME) fun_names o try (fst o dest_Free o head_of))

      |> the

      handle Option.Option => primcorec_error_eqn "malformed discriminator formula" concl;

    val ((fun_name, fun_T), fun_args) = strip_comb applied_fun |>> dest_Free;

    val SOME basic_ctr_specs = AList.lookup (op =) (fun_names ~~ basic_ctr_specss) fun_name;

    val discs = map #disc basic_ctr_specs;

    val ctrs = map #ctr basic_ctr_specs;

    val not_disc = head_of concl = @{term Not};

    val _ = not_disc andalso length ctrs <> 2 andalso

      primcorec_error_eqn "negated discriminator for a type with \<noteq> 2 constructors" concl;

    val disc' = find_subterm (member (op =) discs o head_of) concl;

    val eq_ctr0 = concl |> perhaps (try HOLogic.dest_not) |> try (HOLogic.dest_eq #> snd)

        |> (fn SOME t => let val n = find_index (equal t) ctrs in

          if n >= 0 then SOME n else NONE end | _ => NONE);

    val _ = is_some disc' orelse is_some eq_ctr0 orelse

      primcorec_error_eqn "no discriminator in equation" concl;

    val ctr_no' =

      if is_none disc' then the eq_ctr0 else find_index (equal (head_of (the disc'))) discs;

    val ctr_no = if not_disc then 1 - ctr_no' else ctr_no';

    val {ctr, disc, ...} = nth basic_ctr_specs ctr_no;

    val catch_all = try (fst o dest_Free o the_single) prems' = SOME Name.uu_;

    val matchedss = AList.lookup (op =) matchedsss fun_name |> the_default [];

    val prems = map (abstract (List.rev fun_args)) prems';

    val real_prems =

      (if catch_all orelse seq then maps s_not_conj matchedss else []) @

      (if catch_all then [] else prems);

    val matchedsss' = AList.delete (op =) fun_name matchedsss

      |> cons (fun_name, if seq then matchedss @ [prems] else matchedss @ [real_prems]);

    val user_eqn =

      (real_prems, concl)

      |>> map HOLogic.mk_Trueprop ||> HOLogic.mk_Trueprop o abstract (List.rev fun_args)

      |> curry Logic.list_all (map dest_Free fun_args) o Logic.list_implies;

  in

    (Disc {

      fun_name = fun_name,

      fun_T = fun_T,

      fun_args = fun_args,

      ctr = ctr,

      ctr_no = ctr_no,

      disc = disc,

      prems = real_prems,

      auto_gen = catch_all,

      maybe_ctr_rhs = maybe_ctr_rhs,

      maybe_code_rhs = maybe_code_rhs,

      user_eqn = user_eqn

    }, matchedsss')

  end;

fun dissect_coeqn_sel fun_names (basic_ctr_specss : basic_corec_ctr_spec list list) eqn'

    maybe_of_spec eqn =

  let

    val (lhs, rhs) = HOLogic.dest_eq eqn

      handle TERM _ =>

        primcorec_error_eqn "malformed function equation (expected \"lhs = rhs\")" eqn;

    val sel = head_of lhs;

    val ((fun_name, fun_T), fun_args) = dest_comb lhs |> snd |> strip_comb |> apfst dest_Free

      handle TERM _ =>

        primcorec_error_eqn "malformed selector argument in left-hand side" eqn;

    val basic_ctr_specs = the (AList.lookup (op =) (fun_names ~~ basic_ctr_specss) fun_name)

      handle Option.Option => primcorec_error_eqn "malformed selector argument in left-hand side" eqn;

    val {ctr, ...} =

      (case maybe_of_spec of

        SOME of_spec => the (find_first (equal of_spec o #ctr) basic_ctr_specs)

      | NONE => filter (exists (equal sel) o #sels) basic_ctr_specs |> the_single

          handle List.Empty => primcorec_error_eqn "ambiguous selector - use \"of\"" eqn);

    val user_eqn = drop_All eqn';

  in

    Sel {

      fun_name = fun_name,

      fun_T = fun_T,

      fun_args = fun_args,

      ctr = ctr,

      sel = sel,

      rhs_term = rhs,

      user_eqn = user_eqn

    }

  end;

fun dissect_coeqn_ctr seq fun_names (basic_ctr_specss : basic_corec_ctr_spec list list) eqn'

    maybe_code_rhs prems concl matchedsss =

  let

    val (lhs, rhs) = HOLogic.dest_eq concl;

    val (fun_name, fun_args) = strip_comb lhs |>> fst o dest_Free;

    val SOME basic_ctr_specs = AList.lookup (op =) (fun_names ~~ basic_ctr_specss) fun_name;

    val (ctr, ctr_args) = strip_comb (unfold_let rhs);

    val {disc, sels, ...} = the (find_first (equal ctr o #ctr) basic_ctr_specs)

      handle Option.Option => primcorec_error_eqn "not a constructor" ctr;

    val disc_concl = betapply (disc, lhs);

    val (maybe_eqn_data_disc, matchedsss') = if length basic_ctr_specs = 1

      then (NONE, matchedsss)

      else apfst SOME (dissect_coeqn_disc seq fun_names basic_ctr_specss

          (SOME (abstract (List.rev fun_args) rhs)) maybe_code_rhs prems disc_concl matchedsss);

    val sel_concls = sels ~~ ctr_args

      |> map (fn (sel, ctr_arg) => HOLogic.mk_eq (betapply (sel, lhs), ctr_arg));

(*

val _ = tracing ("reduced\n    " ^ Syntax.string_of_term @{context} concl ^ "\nto\n    \<cdot> " ^

 (is_some maybe_eqn_data_disc ? K (Syntax.string_of_term @{context} disc_concl ^ "\n    \<cdot> ")) "" ^

 space_implode "\n    \<cdot> " (map (Syntax.string_of_term @{context}) sel_concls) ^

 "\nfor premise(s)\n    \<cdot> " ^

 space_implode "\n    \<cdot> " (map (Syntax.string_of_term @{context}) prems));

*)

    val eqns_data_sel =

      map (dissect_coeqn_sel fun_names basic_ctr_specss eqn' (SOME ctr)) sel_concls;

  in

    (the_list maybe_eqn_data_disc @ eqns_data_sel, matchedsss')

  end;

fun dissect_coeqn_code lthy has_call fun_names basic_ctr_specss eqn' concl matchedsss =

  let

    val (lhs, (rhs', rhs)) = HOLogic.dest_eq concl ||> `(expand_corec_code_rhs lthy has_call []);

    val (fun_name, fun_args) = strip_comb lhs |>> fst o dest_Free;

    val SOME basic_ctr_specs = AList.lookup (op =) (fun_names ~~ basic_ctr_specss) fun_name;

    val cond_ctrs = fold_rev_corec_code_rhs lthy (fn cs => fn ctr => fn _ =>

        if member ((op =) o apsnd #ctr) basic_ctr_specs ctr

        then cons (ctr, cs)

        else primcorec_error_eqn "not a constructor" ctr) [] rhs' []

      |> AList.group (op =);

    val ctr_premss = (case cond_ctrs of [_] => [[]] | _ => map (s_dnf o snd) cond_ctrs);

    val ctr_concls = cond_ctrs |> map (fn (ctr, _) =>

        binder_types (fastype_of ctr)

        |> map_index (fn (n, T) => massage_corec_code_rhs lthy (fn _ => fn ctr' => fn args =>

          if ctr' = ctr then nth args n else Const (@{const_name undefined}, T)) [] rhs')

        |> curry list_comb ctr

        |> curry HOLogic.mk_eq lhs);

  in

    fold_map2 (dissect_coeqn_ctr false fun_names basic_ctr_specss eqn'

        (SOME (abstract (List.rev fun_args) rhs)))

      ctr_premss ctr_concls matchedsss

  end;

fun dissect_coeqn lthy seq has_call fun_names (basic_ctr_specss : basic_corec_ctr_spec list list)

    eqn' maybe_of_spec matchedsss =

  let

    val eqn = drop_All eqn'

      handle TERM _ => primcorec_error_eqn "malformed function equation" eqn';

    val (prems, concl) = Logic.strip_horn eqn

      |> apfst (map HOLogic.dest_Trueprop) o apsnd HOLogic.dest_Trueprop;

    val head = concl

      |> perhaps (try HOLogic.dest_not) |> perhaps (try (fst o HOLogic.dest_eq))

      |> head_of;

    val maybe_rhs = concl |> perhaps (try HOLogic.dest_not) |> try (snd o HOLogic.dest_eq);

    val discs = maps (map #disc) basic_ctr_specss;

    val sels = maps (maps #sels) basic_ctr_specss;

    val ctrs = maps (map #ctr) basic_ctr_specss;

  in

    if member (op =) discs head orelse

      is_some maybe_rhs andalso

        member (op =) (filter (null o binder_types o fastype_of) ctrs) (the maybe_rhs) then

      dissect_coeqn_disc seq fun_names basic_ctr_specss NONE NONE prems concl matchedsss

      |>> single

    else if member (op =) sels head then

      ([dissect_coeqn_sel fun_names basic_ctr_specss eqn' maybe_of_spec concl], matchedsss)

    else if is_Free head andalso member (op =) fun_names (fst (dest_Free head)) andalso

      member (op =) ctrs (head_of (unfold_let (the maybe_rhs))) then

      dissect_coeqn_ctr seq fun_names basic_ctr_specss eqn' NONE prems concl matchedsss

    else if is_Free head andalso member (op =) fun_names (fst (dest_Free head)) andalso

      null prems then

      dissect_coeqn_code lthy has_call fun_names basic_ctr_specss eqn' concl matchedsss

      |>> flat

    else

      primcorec_error_eqn "malformed function equation" eqn

  end;

fun build_corec_arg_disc (ctr_specs : corec_ctr_spec list)

    ({fun_args, ctr_no, prems, ...} : coeqn_data_disc) =

  if is_none (#pred (nth ctr_specs ctr_no)) then I else

    s_conjs prems

    |> curry subst_bounds (List.rev fun_args)

    |> HOLogic.tupled_lambda (HOLogic.mk_tuple fun_args)

    |> K |> nth_map (the (#pred (nth ctr_specs ctr_no)));

fun build_corec_arg_no_call (sel_eqns : coeqn_data_sel list) sel =

  find_first (equal sel o #sel) sel_eqns

  |> try (fn SOME {fun_args, rhs_term, ...} => abs_tuple fun_args rhs_term)

  |> the_default undef_const

  |> K;

fun build_corec_args_mutual_call lthy has_call (sel_eqns : coeqn_data_sel list) sel =

  (case find_first (equal sel o #sel) sel_eqns of

    NONE => (I, I, I)

  | SOME {fun_args, rhs_term, ... } =>

    let

      val bound_Ts = List.rev (map fastype_of fun_args);

      fun rewrite_stop _ t = if has_call t then @{term False} else @{term True};

      fun rewrite_end _ t = if has_call t then undef_const else t;

      fun rewrite_cont bound_Ts t =

        if has_call t then mk_tuple1 bound_Ts (snd (strip_comb t)) else undef_const;

      fun massage f _ = massage_mutual_corec_call lthy has_call f bound_Ts rhs_term

        |> abs_tuple fun_args;

    in

      (massage rewrite_stop, massage rewrite_end, massage rewrite_cont)

    end);

fun build_corec_arg_nested_call lthy has_call (sel_eqns : coeqn_data_sel list) sel =

  (case find_first (equal sel o #sel) sel_eqns of

    NONE => I

  | SOME {fun_args, rhs_term, ...} =>

    let

      val bound_Ts = List.rev (map fastype_of fun_args);

      fun rewrite bound_Ts U T (Abs (v, V, b)) = Abs (v, V, rewrite (V :: bound_Ts) U T b)

        | rewrite bound_Ts U T (t as _ $ _) =

          let val (u, vs) = strip_comb t in

            if is_Free u andalso has_call u then

              Inr_const U T $ mk_tuple1 bound_Ts vs

            else if try (fst o dest_Const) u = SOME @{const_name prod_case} then

              map (rewrite bound_Ts U T) vs |> chop 1 |>> HOLogic.mk_split o the_single |> list_comb

            else

              list_comb (rewrite bound_Ts U T u, map (rewrite bound_Ts U T) vs)

          end

        | rewrite _ U T t =

          if is_Free t andalso has_call t then Inr_const U T $ HOLogic.unit else t;

      fun massage t =

        rhs_term

        |> massage_nested_corec_call lthy has_call rewrite bound_Ts (range_type (fastype_of t))

        |> abs_tuple fun_args;

    in

      massage

    end);

fun build_corec_args_sel lthy has_call (all_sel_eqns : coeqn_data_sel list)

    (ctr_spec : corec_ctr_spec) =

  (case filter (equal (#ctr ctr_spec) o #ctr) all_sel_eqns of

    [] => I

  | sel_eqns =>

    let

      val sel_call_list = #sels ctr_spec ~~ #calls ctr_spec;

      val no_calls' = map_filter (try (apsnd (fn No_Corec n => n))) sel_call_list;

      val mutual_calls' = map_filter (try (apsnd (fn Mutual_Corec n => n))) sel_call_list;

      val nested_calls' = map_filter (try (apsnd (fn Nested_Corec n => n))) sel_call_list;

    in

      I

      #> fold (fn (sel, n) => nth_map n (build_corec_arg_no_call sel_eqns sel)) no_calls'

      #> fold (fn (sel, (q, g, h)) =>

        let val (fq, fg, fh) = build_corec_args_mutual_call lthy has_call sel_eqns sel in

          nth_map q fq o nth_map g fg o nth_map h fh end) mutual_calls'

      #> fold (fn (sel, n) => nth_map n

        (build_corec_arg_nested_call lthy has_call sel_eqns sel)) nested_calls'

    end);

fun build_codefs lthy bs mxs has_call arg_Tss (corec_specs : corec_spec list)

    (disc_eqnss : coeqn_data_disc list list) (sel_eqnss : coeqn_data_sel list list) =

  let

    val corecs = map #corec corec_specs;

    val ctr_specss = map #ctr_specs corec_specs;

    val corec_args = hd corecs

      |> fst o split_last o binder_types o fastype_of

      |> map (Const o pair @{const_name undefined})

      |> fold2 (fold o build_corec_arg_disc) ctr_specss disc_eqnss

      |> fold2 (fold o build_corec_args_sel lthy has_call) sel_eqnss ctr_specss;

    fun currys [] t = t

      | currys Ts t = t $ mk_tuple1 (List.rev Ts) (map Bound (length Ts - 1 downto 0))

          |> fold_rev (Term.abs o pair Name.uu) Ts;

(*

val _ = tracing ("corecursor arguments:\n    \<cdot> " ^

 space_implode "\n    \<cdot> " (map (Syntax.string_of_term lthy) corec_args));

*)

    val exclss' =

      disc_eqnss

      |> map (map (fn x => (#fun_args x, #ctr_no x, #prems x, #auto_gen x))

        #> fst o (fn xs => fold_map (fn x => fn ys => ((x, ys), ys @ [x])) xs [])

        #> maps (uncurry (map o pair)

          #> map (fn ((fun_args, c, x, a), (_, c', y, a')) =>

              ((c, c', a orelse a'), (x, s_not (s_conjs y)))

            ||> apfst (map HOLogic.mk_Trueprop) o apsnd HOLogic.mk_Trueprop

            ||> Logic.list_implies

            ||> curry Logic.list_all (map dest_Free fun_args))))

  in

    map (list_comb o rpair corec_args) corecs

    |> map2 (fn Ts => fn t => if length Ts = 0 then t $ HOLogic.unit else t) arg_Tss

    |> map2 currys arg_Tss

    |> Syntax.check_terms lthy

    |> map3 (fn b => fn mx => fn t => ((b, mx), ((Binding.conceal (Thm.def_binding b), []), t)))

      bs mxs

    |> rpair exclss'

  end;

fun mk_real_disc_eqns fun_binding arg_Ts ({ctr_specs, ...} : corec_spec)

    (sel_eqns : coeqn_data_sel list) (disc_eqns : coeqn_data_disc list) =

  if length disc_eqns <> length ctr_specs - 1 then disc_eqns else

    let

      val n = 0 upto length ctr_specs

        |> the o find_first (fn idx => not (exists (equal idx o #ctr_no) disc_eqns));

      val fun_args = (try (#fun_args o hd) disc_eqns, try (#fun_args o hd) sel_eqns)

        |> the_default (map (curry Free Name.uu) arg_Ts) o merge_options;

      val extra_disc_eqn = {

        fun_name = Binding.name_of fun_binding,

        fun_T = arg_Ts ---> body_type (fastype_of (#ctr (hd ctr_specs))),

        fun_args = fun_args,

        ctr = #ctr (nth ctr_specs n),

        ctr_no = n,

        disc = #disc (nth ctr_specs n),

        prems = maps (s_not_conj o #prems) disc_eqns,

        auto_gen = true,

        maybe_ctr_rhs = NONE,

        maybe_code_rhs = NONE,

        user_eqn = undef_const};

    in

      chop n disc_eqns ||> cons extra_disc_eqn |> (op @)

    end;

fun find_corec_calls ctxt has_call basic_ctr_specs ({ctr, sel, rhs_term, ...} : coeqn_data_sel) =

  let

    val sel_no = find_first (equal ctr o #ctr) basic_ctr_specs

      |> find_index (equal sel) o #sels o the;

    fun find t = if has_call t then snd (fold_rev_corec_call ctxt (K cons) [] t []) else [];

  in

    find rhs_term

    |> K |> nth_map sel_no |> AList.map_entry (op =) ctr

  end;

fun add_primcorec_ursive maybe_tac seq fixes specs maybe_of_specs lthy =

  let

    val (bs, mxs) = map_split (apfst fst) fixes;

    val (arg_Ts, res_Ts) = map (strip_type o snd o fst #>> HOLogic.mk_tupleT) fixes |> split_list;

    val fun_names = map Binding.name_of bs;

    val basic_ctr_specss = map (basic_corec_specs_of lthy) res_Ts;

    val has_call = exists_subterm (map (fst #>> Binding.name_of #> Free) fixes |> member (op =));

    val eqns_data =

      fold_map2 (dissect_coeqn lthy seq has_call fun_names basic_ctr_specss) (map snd specs)

        maybe_of_specs []

      |> flat o fst;

    val callssss =

      map_filter (try (fn Sel x => x)) eqns_data

      |> partition_eq ((op =) o pairself #fun_name)

      |> fst o finds (fn (x, ({fun_name, ...} :: _)) => x = fun_name) fun_names

      |> map (flat o snd)

      |> map2 (fold o find_corec_calls lthy has_call) basic_ctr_specss

      |> map2 (curry (op |>)) (map (map (fn {ctr, sels, ...} =>

        (ctr, map (K []) sels))) basic_ctr_specss);

(*

val _ = tracing ("callssss = " ^ @{make_string} callssss);

*)

    val ((n2m, corec_specs', _, coinduct_thm, strong_coinduct_thm, coinduct_thms,

          strong_coinduct_thms), lthy') =

      corec_specs_of bs arg_Ts res_Ts (get_indices fixes) callssss lthy;

    val actual_nn = length bs;

    val corec_specs = take actual_nn corec_specs'; (*###*)

    val ctr_specss = map #ctr_specs corec_specs;

    val disc_eqnss' = map_filter (try (fn Disc x => x)) eqns_data

      |> partition_eq ((op =) o pairself #fun_name)

      |> fst o finds (fn (x, ({fun_name, ...} :: _)) => x = fun_name) fun_names

      |> map (sort ((op <) o pairself #ctr_no |> make_ord) o flat o snd);

    val _ = disc_eqnss' |> map (fn x =>

      let val d = duplicates ((op =) o pairself #ctr_no) x in null d orelse

        primcorec_error_eqns "excess discriminator formula in definition"

          (maps (fn t => filter (equal (#ctr_no t) o #ctr_no) x) d |> map #user_eqn) end);

    val sel_eqnss = map_filter (try (fn Sel x => x)) eqns_data

      |> partition_eq ((op =) o pairself #fun_name)

      |> fst o finds (fn (x, ({fun_name, ...} :: _)) => x = fun_name) fun_names

      |> map (flat o snd);

    val arg_Tss = map (binder_types o snd o fst) fixes;

    val disc_eqnss = map5 mk_real_disc_eqns bs arg_Tss corec_specs sel_eqnss disc_eqnss';

    val (defs, exclss') =

      build_codefs lthy' bs mxs has_call arg_Tss corec_specs disc_eqnss sel_eqnss;

    fun excl_tac (c, c', a) =

      if a orelse c = c' orelse seq then SOME (K (HEADGOAL (mk_primcorec_assumption_tac lthy [])))

      else maybe_tac;

(*

val _ = tracing ("exclusiveness properties:\n    \<cdot> " ^

 space_implode "\n    \<cdot> " (maps (map (Syntax.string_of_term lthy o snd)) exclss'));

*)

    val exclss'' = exclss' |> map (map (fn (idx, t) =>

      (idx, (Option.map (Goal.prove lthy [] [] t #> Thm.close_derivation) (excl_tac idx), t))));

    val taut_thmss = map (map (apsnd (the o fst)) o filter (is_some o fst o snd)) exclss'';

    val (goal_idxss, goalss) = exclss''

      |> map (map (apsnd (rpair [] o snd)) o filter (is_none o fst o snd))

      |> split_list o map split_list;

    fun prove thmss' def_thms' lthy =

      let

        val def_thms = map (snd o snd) def_thms';

        val exclss' = map (op ~~) (goal_idxss ~~ thmss');

        fun mk_exclsss excls n =

          (excls, map (fn k => replicate k [TrueI] @ replicate (n - k) []) (0 upto n - 1))

          |-> fold (fn ((c, c', _), thm) => nth_map c (nth_map c' (K [thm])));

        val exclssss = (exclss' ~~ taut_thmss |> map (op @), fun_names ~~ corec_specs)

          |-> map2 (fn excls => fn (_, {ctr_specs, ...}) => mk_exclsss excls (length ctr_specs));

        fun prove_disc ({ctr_specs, ...} : corec_spec) exclsss

            ({fun_name, fun_T, fun_args, ctr_no, prems, ...} : coeqn_data_disc) =

          if Term.aconv_untyped (#disc (nth ctr_specs ctr_no), @{term "\<lambda>x. x = x"}) then [] else

            let

              val {disc_corec, ...} = nth ctr_specs ctr_no;

              val k = 1 + ctr_no;

              val m = length prems;

              val t =

                list_comb (Free (fun_name, fun_T), map Bound (length fun_args - 1 downto 0))

                |> curry betapply (#disc (nth ctr_specs ctr_no)) (*###*)

                |> HOLogic.mk_Trueprop

                |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems)

                |> curry Logic.list_all (map dest_Free fun_args);

            in

              if prems = [@{term False}] then [] else

              mk_primcorec_disc_tac lthy def_thms disc_corec k m exclsss

              |> K |> Goal.prove lthy [] [] t

              |> Thm.close_derivation

              |> pair (#disc (nth ctr_specs ctr_no))

              |> single

            end;

        fun prove_sel ({nested_maps, nested_map_idents, nested_map_comps, ctr_specs, ...}

            : corec_spec) (disc_eqns : coeqn_data_disc list) exclsss

            ({fun_name, fun_T, fun_args, ctr, sel, rhs_term, ...} : coeqn_data_sel) =

          let

            val SOME ctr_spec = find_first (equal ctr o #ctr) ctr_specs;

            val ctr_no = find_index (equal ctr o #ctr) ctr_specs;

            val prems = the_default (maps (s_not_conj o #prems) disc_eqns)

                (find_first (equal ctr_no o #ctr_no) disc_eqns |> Option.map #prems);

            val sel_corec = find_index (equal sel) (#sels ctr_spec)

              |> nth (#sel_corecs ctr_spec);

            val k = 1 + ctr_no;

            val m = length prems;

            val t =

              list_comb (Free (fun_name, fun_T), map Bound (length fun_args - 1 downto 0))

              |> curry betapply sel

              |> rpair (abstract (List.rev fun_args) rhs_term)

              |> HOLogic.mk_Trueprop o HOLogic.mk_eq

              |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems)

              |> curry Logic.list_all (map dest_Free fun_args);

            val (distincts, _, sel_splits, sel_split_asms) = case_thms_of_term lthy [] rhs_term;

          in

            mk_primcorec_sel_tac lthy def_thms distincts sel_splits sel_split_asms nested_maps

              nested_map_idents nested_map_comps sel_corec k m exclsss

            |> K |> Goal.prove lthy [] [] t

            |> Thm.close_derivation

            |> pair sel

          end;

        fun prove_ctr disc_alist sel_alist (disc_eqns : coeqn_data_disc list)

            (sel_eqns : coeqn_data_sel list) ({ctr, disc, sels, collapse, ...} : corec_ctr_spec) =

          (* don't try to prove theorems when some sel_eqns are missing *)

          if not (exists (equal ctr o #ctr) disc_eqns)

              andalso not (exists (equal ctr o #ctr) sel_eqns)

            orelse

              filter (equal ctr o #ctr) sel_eqns

              |> fst o finds ((op =) o apsnd #sel) sels

              |> exists (null o snd)

          then [] else

            let

              val (fun_name, fun_T, fun_args, prems, maybe_rhs) =

                (find_first (equal ctr o #ctr) disc_eqns, find_first (equal ctr o #ctr) sel_eqns)

                |>> Option.map (fn x => (#fun_name x, #fun_T x, #fun_args x, #prems x,