Datatype.ML

Added primitive recursive functions (Norbert Voelker's code) to the datatype
package.

(*  Title:       HOL/Datatype
    ID:          $Id$
    Author:      Max Breitling / Carsten Clasohm /
                 Norbert Voelker / Tobias Nipkow
    Copyright    1994 TU Muenchen
*)


(*choice between Ci_neg1 and Ci_neg2 axioms depends on number of constructors*)
local

val dtK = 5
val pars = enclose "(" ")";
val brackets = enclose "[" "]";
val mk_list = brackets o commas;

in

local open ThyParse in
val datatype_decls =
  let val tvar = type_var >> (fn s => "dtVar" ^ s);

      val type_var_list = 
        tvar >> (fn s => [s]) || "(" $$-- list1 tvar --$$ ")";
    
      val typ =
         ident                  >> (fn s => "dtTyp([]," ^ quote s ^")")
        ||
         type_var_list -- ident >> (fn (ts, id) => "dtTyp(" ^ mk_list ts ^
  				  "," ^ quote id ^ ")")
        ||
         tvar;
    
      val typ_list = "(" $$-- list1 typ --$$ ")" || empty;
  
      val cons = name -- typ_list -- opt_mixfix;
  
      fun constructs ts =
        ( cons --$$ "|" -- constructs >> op::
         ||
          cons                        >> (fn c => [c])) ts;  
  
      val mk_cons = map (fn ((s, ts), syn) => 
                           pars (commas [s, mk_list ts, syn]));

      (*remove all quotes from a string*)
      val rem_quotes = implode o filter (fn c => c <> "\"") o explode;

      (*generate names of distinct axioms*)
      fun rules_distinct cs tname = 
        let val uqcs = map (fn ((s,_),_) => rem_quotes s) cs;
            (*combine all constructor names with all others w/o duplicates*)
            fun negOne c = map (fn c2 => quote (c ^ "_not_" ^ c2));
            fun neg1 [] = []
              | neg1 (c1 :: cs) = (negOne c1 cs) @ (neg1 cs)
        in if length uqcs < dtK then neg1 uqcs
           else quote (tname ^ "_ord_distinct") ::
                map (fn c => quote (tname ^ "_ord_" ^ c)) uqcs
        end;

       fun rule_names tname cons pre =
         mk_list (map (fn ((s,_),_) => quote(tname ^ pre ^ rem_quotes s)) cons)

       fun rules tname cons pre =
         " map (get_axiom thy) " ^ rule_names tname cons pre       

      (*generate string for calling 'add_datatype'*)
      fun mk_params ((ts, tname), cons) =
       ("val (thy," ^ tname ^ "_add_primrec) =  add_datatype\n" ^
       pars (commas [mk_list ts, quote tname, mk_list (mk_cons cons)]) ^
       " thy\n\
       \val thy=thy",
       "structure " ^ tname ^ " =\n\
       \struct\n\
       \  val inject = map (get_axiom thy) " ^
         mk_list (map (fn ((s,_), _) => quote ("inject_" ^ rem_quotes s)) 
                      (filter_out (null o snd o fst) cons)) ^ ";\n\
       \  val distinct = " ^ (if length cons < dtK then "let val distinct' = " else "")
         ^ "map (get_axiom thy) " ^ mk_list (rules_distinct cons tname) ^ 
         (if length cons < dtK then 
           "  in distinct' @ (map (fn t => sym COMP (t RS contrapos)) distinct') end"
          else "") ^ ";\n\
       \  val induct = get_axiom thy \"" ^ tname ^ "_induct\";\n\
       \  val cases =" ^ rules tname cons "_case_" ^ ";\n\
       \  val recs =" ^ rules tname cons "_rec_" ^ ";\n\
       \  val simps = inject @ distinct @ cases @ recs;\n\
       \  fun induct_tac a = res_inst_tac[(" ^ quote tname ^ ", a)]induct;\n\
       \end;\n")
  in (type_var_list || empty) -- ident --$$ "=" -- constructs >> mk_params end

val primrec_decl =
  let fun mkstrings((fname,tname),axms) =
        let fun prove (name,eqn) =
             "val "^name^"= prove_goalw thy [get_axiom thy \""^fname^"_def\"] "
                 ^ eqn ^"\n\
             \(fn _ => [resolve_tac " ^ tname^".recs 1])"
        in ("|> " ^ tname^"_add_primrec " ^ mk_list (map snd axms),
            cat_lines(map prove axms))
        end
  in ident -- ident -- repeat1 (ident -- string)  >> mkstrings end

end;

(*used for constructor parameters*)
datatype dt_type = dtVar of string |
                   dtTyp of dt_type list * string |
                   dtRek of dt_type list * string;

local open Syntax.Mixfix
      exception Impossible

val is_rek = (fn dtRek _ => true  |  _  => false);

(* ------------------------------------------------------------------------- *)
(* Die Funktionen fuer das Umsetzen von Gleichungen in eine Definition mit   *)
(* dem prim-Rek. Kombinator                                                  *)

(*** Part 1: handling a single equation   ***)
 
(* filter REK type args by correspondence with targs. Reverses order *) 

fun rek_args (args, targs) = 
let fun h (x :: xs, tx :: txs, res) 
           = h(xs,txs,if is_rek tx then x :: res else res )
     |  h ([],[],res) = res
in h (args,targs,[])
end;

(* abstract over all recursive calls of f in t with param v in vs.
   Name in abstraction is variant of v w.r.t. free names in t. 
   Also returns reversed list of new variables names with types. 
   Checks that there are no free occurences of f left. 
*) 

fun abstract_recs f vs t  = 
let val tfrees = add_term_names(t,[]); 
    fun h [] vns t = if fst(dest_Const f) mem add_term_names(t,[]) 
		     then raise Impossible 
		     else (t,vns)
     |  h (v::vs) vns t
        = let val vn = variant tfrees (fst(dest_Free v))
          in  h vs (vn::vns) (Abs(vn, dummyT, abstract_over(f $ v,t)))
          end;
in h vs [] t
end;

(* For every defining equation, I need to abstract over arguments and
   over the recursive calls. Cant do it simply minded in this order, because 
   abstracting over v turns (Free v) into a bound variable, so that
   abstract_recs does not apply anymore.  
   abstract_arecs_funct performs the following steps 
    * abstract over (f xi) (reverse order) 
    * remove outermost length(rargs) abstractions
    * increase loose bound variables index by #cargs
    * apply the carg abstraction (reverse order) 
    * add length(rargs) lambdas. 
    Using lower level operations on term and arithmetic, this could probably
    be made more efficient. 
*) 

(* remove n outermost abstractions from a term *)
fun rem_Abs 0 t = t
 |  rem_Abs n (Abs(s,T,t)) = rem_Abs (n-1) t
;
(* add one abstraction for for every variable in vs *)  
fun add_Abs []      t = t
 |  add_Abs (vname::vs) t = Abs(vname, dummyT, add_Abs vs t)
; 
fun abstract_arecs funct rargs args t = 
let val (arecs,vns) = abstract_recs funct rargs t;
in  add_Abs vns 
    ( list_abs_free
        ( map dest_Free args
        , incr_boundvars (length args) (rem_Abs (length rargs) arecs)))
end;

(*** part 2. Processing of list of equations ***) 

(* Take list of constructors cs and equations eqns. 
   Find for ever element c of cs a corresponding eq in eqns. 
   Check that the function name is unique and there are no double params.  
   Derive term from equation using abstract_arecs and instantiate types. 
   Assume: equation list eqns nonempty
           length(eqns) = length(cs) 
           every constant name identifies a constant and its type. 
   In h: first parameter reqs reflects the remaining equations. 
*)

fun funs_from_eqns cs eqns =
let fun dest_eq ( Const("Trueprop",_) $ (Const ("op =",_)
                 $ (f $ capp) $ right))
	         = (f, strip_comb(capp), right);
    val fname = (fn (Const(f,_),_,_) => f) (dest_eq(hd eqns));
    fun h []   []        []       res = res
     |  h _    (_ :: _)  []       _   = raise Impossible
     |  h _    []        (_ :: _) _   = raise Impossible
     |  h reqs (eq::eqs) (c::cs)  res =
	let
          val (f,(Const(cname_eq,_),args),rhs) = dest_eq eq;
          val (cname,targs,syn) = c;
        in
	  if (cname_eq <> const_name cname syn) then h reqs eqs (c::cs) res
          else
          if fst(dest_Const(f)) = fname
             andalso (duplicates (map (fst o dest_Free) args) = [])
          then let val reqs' = reqs \ eq
               in h reqs' reqs' cs
                    (abstract_arecs f (rek_args(args,targs)) args rhs :: res)
	       end
          else raise Impossible
        end
in (fname, h eqns eqns cs []) end;

(* take datatype and eqns and return a properly type-instantiated 
   application of the prim-rec-combinator which solves eqns.
*)

fun instant_types thy t =
let val rs = Sign.rep_sg(sign_of thy);  
in  fst(Type.infer_types( #tsig rs,#const_tab rs, K None, K None
		        , TVar(("",0),[]), t))
end;

in

fun add_datatype (typevars, tname, cons_list') thy = 
  let (*check if constructor names are unique*)
      fun check_cons (cs : (string * 'b * 'c) list) =
        (case findrep (map #1 cs) of
           [] => true
         | c::_ => error("Constructor \"" ^ c ^ "\" occurs twice"));

      (*search for free type variables and convert recursive *)
      fun analyse_types (cons, typlist, syn) =
            let fun analyse(t as dtVar v) =
                     if t mem typevars then t
                     else error ("Variable " ^ v ^ " is free.")
                  | analyse(dtTyp(typl,s)) =
                     if tname <> s then dtTyp(analyses typl, s)
                     else if typevars = typl then dtRek(typl, s)
                     else error (s ^ " used in different ways")
                  | analyse(dtRek _) = raise Impossible
                 and analyses ts = map analyse ts;
            in (cons, analyses typlist, syn) end;

      (*test if there are elements that are not recursive, i.e. if the type is
        not empty*)
      fun one_not_rek (cs : ('a * dt_type list * 'c) list) = 
        let val contains_no_rek = forall (fn dtRek _ => false | _ => true);
        in exists (contains_no_rek o #2) cs orelse
           error("Empty type not allowed!") end;

      val dummy = check_cons cons_list';
      val cons_list = map analyse_types cons_list';
      val dummy = one_not_rek cons_list;

      (*Pretty printers for type lists;
        pp_typlist1: parentheses, pp_typlist2: brackets*)
      fun pp_typ (dtVar s) = s
        | pp_typ (dtTyp (typvars, id)) =
            if null typvars then id else (pp_typlist1 typvars) ^ id
        | pp_typ (dtRek (typvars, id)) = (pp_typlist1 typvars) ^ id
      and
          pp_typlist' ts = commas (map pp_typ ts)
      and
          pp_typlist1 ts = if null ts then "" else pars (pp_typlist' ts);

      fun pp_typlist2 ts = if null ts then "" else brackets (pp_typlist' ts);

      fun Args(var, delim, n, m) = if n = m then var ^ string_of_int(n) 
                                   else var ^ string_of_int(n) ^ delim ^ 
			    	        Args(var, delim, n+1, m);

      (* Generate syntax translation for case rules *)
      fun calc_xrules c_nr y_nr ((id, typlist, syn) :: cs) = 
            let val name = const_name id syn;
                val arity = length typlist;
                val body  = "z" ^ string_of_int(c_nr);
                val args1 = if arity=0 then ""
                            else pars (Args ("y", ",", y_nr, y_nr+arity-1));
                val args2 = if arity=0 then ""
                            else "% " ^ Args ("y", " ", y_nr, y_nr+arity-1) 
                            ^ ". ";
                val (rest1,rest2) = 
		  if null cs then ("","")
                  else let val (h1, h2) = calc_xrules (c_nr+1) (y_nr+arity) cs
                       in (" | " ^ h1, ", " ^ h2) end;
            in (name ^ args1 ^ " => " ^ body ^ rest1, args2 ^ body ^ rest2) end
        | calc_xrules _ _ [] = raise Impossible;
      
      val xrules =
         let val (first_part, scnd_part) = calc_xrules 1 1 cons_list
         in  [("logic", "case x of " ^ first_part) <->
              ("logic", tname ^ "_case(x, " ^ scnd_part ^ ")" )]
         end;

      (*type declarations for constructors*)
      fun const_type (id, typlist, syn) =
           (id,  
            (if null typlist then "" else pp_typlist2 typlist ^ " => ") ^
             pp_typlist1 typevars ^ tname, syn);

      fun create_typevar (dtVar s) typlist =
            if (dtVar s) mem typlist then 
	      create_typevar (dtVar (s ^ "'")) typlist 
            else s
        | create_typevar _ _ = raise Impossible;

      fun assumpt (dtRek _ :: ts, v :: vs ,found) =
            let val h = if found then ";P(" ^ v ^ ")" else "[| P(" ^ v ^ ")"
            in h ^ (assumpt (ts, vs, true)) end
        | assumpt (t :: ts, v :: vs, found) = assumpt (ts, vs, found)
        | assumpt ([], [], found) = if found then "|] ==>" else ""
        | assumpt _ = raise Impossible;

      (*insert type with suggested name 'varname' into table*)
      fun insert typ varname ((tri as (t, s, n)) :: xs) = 
            if typ = t then (t, s, n+1) :: xs
            else tri :: (if varname = s then insert typ (varname ^ "'") xs
                         else insert typ varname xs)
        | insert typ varname [] = [(typ, varname, 1)];

      fun typid(dtRek(_,id)) = id
        | typid(dtVar s) = implode (tl (explode s))
        | typid(dtTyp(_,id)) = id;

      val insert_types = foldl (fn (tab,typ) => insert typ (typid typ) tab);

      fun update(dtRek _, s, v :: vs, (dtRek _) :: ts) = s :: vs
        | update(t, s, v :: vs, t1 :: ts) = 
            if t=t1 then s :: vs
                    else v :: (update (t, s, vs, ts))
        | update _ = raise Impossible;
      
      fun update_n (dtRek r1, s, v :: vs, (dtRek r2) :: ts, n) =
            if r1 = r2 then (s ^ string_of_int n) :: 
                            (update_n (dtRek r1, s, vs, ts, n+1))
                       else v :: (update_n (dtRek r1, s, vs, ts, n))
        | update_n (t, s, v :: vs, t1 :: ts, n) = 
            if t = t1 then (s ^ string_of_int n) :: 
                           (update_n (t, s, vs, ts, n+1))
                      else v :: (update_n (t, s, vs, ts, n))
        | update_n (_,_,[],[],_) = []
        | update_n _ = raise Impossible;

      (*insert type variables into table*)
      fun convert typs =
        let fun conv(vars, (t, s, n)) =
              if n=1 then update (t, s, vars, typs)
                     else update_n (t, s, vars, typs, 1)
        in foldl conv end;

      fun empty_list n = replicate n "";

      fun t_inducting ((id, typl, syn) :: cs) =
            let val name = const_name id syn;
                val tab = insert_types([],typl);
                val arity = length typl;
                val var_list = convert typl (empty_list arity,tab); 
                val h = if arity = 0 then " P(" ^ name ^ ")"
                        else " !!" ^ (space_implode " " var_list) ^ "." ^
                             (assumpt (typl, var_list, false)) ^ "P(" ^ 
                             name ^ "(" ^ (commas var_list) ^ "))";
                val rest = t_inducting cs;
            in if rest = "" then h else h ^ "; " ^ rest end
        | t_inducting [] = "";

      fun t_induct cl typ_name=
        "[|" ^ t_inducting cl ^ "|] ==> P(" ^ typ_name ^ ")";

      fun case_typlist typevar ((_, typlist, _) :: cs) =
           let val h = if (length typlist) > 0 then 
		         (pp_typlist2 typlist) ^ "=>"
                       else ""
           in "," ^ h ^ typevar ^ (case_typlist typevar cs) end
        | case_typlist _ [] = "";

      val t_case = tname ^ "_case";

      fun case_rules arity n ((id, typlist, syn) :: cs) =
            let val name = const_name id syn;
                val args = if null typlist then ""
  			   else pars(Args("x", ",", 1, length typlist))
            in (t_case ^ "_" ^ id,
                t_case ^ "(" ^ name ^ args ^ "," ^ Args ("f", ",", 1, arity) 
                ^ ") = f" ^ string_of_int(n) ^ args)
               :: (case_rules arity (n+1) cs)
            end
        | case_rules _ _ [] = [];

      val datatype_arity = length typevars;

      val types = [(tname, datatype_arity, NoSyn)];

      val arities = 
        let val term_list = replicate datatype_arity ["term"];
        in [(tname, term_list, ["term"])] end;

      val datatype_name = pp_typlist1 typevars ^ tname;

      val (case_const, rules_case) =
         let val typevar = create_typevar (dtVar "'beta") typevars;
             val arity = length cons_list;
             val dekl = (t_case, "[" ^ pp_typlist1 typevars ^ tname ^
                       case_typlist typevar cons_list ^ "]=>" ^ typevar, NoSyn)
             val rules = case_rules arity 1 cons_list;
         in (dekl, rules) end;



(* -------------------------------------------------------------------- *)
(* Die Funktionen fuer die t_rec - Funktion                             *)
(* Analog zu t_case bis auf Hinzufuegen rek. Aufrufe pro Konstruktor 	*)

      val t_rec = tname ^ "_rec"

fun add_reks typevar ts = 
  let val tv = dtVar typevar; 
      fun h (t::ts) res = h ts (if is_rek(t) then tv::res else res)
	| h [] res  = res        
  in  h ts ts
  end;

fun rec_typlist typevar ((c,ts,_)::cs) = 
    let val h = if (length ts) > 0 
	        then (pp_typlist2 (add_reks typevar ts)) ^ "=>"
                else ""
    in "," ^ h ^ typevar ^ (rec_typlist typevar cs)
    end
  | rec_typlist _ [] = "";

fun arg_reks arity ts = 
  let fun arg_rek (t::ts) n res  = 
        let val h = t_rec ^"(" ^ "x" ^string_of_int(n) 
			       ^"," ^Args("f",",",1,arity) ^")," 
        in arg_rek ts (n+1) (if is_rek(t) then res ^ h else res)
        end 
      | arg_rek [] _ res = res        
  in  arg_rek ts 1 ""
  end;

fun rec_rules arity n ((id,ts,syn)::cs) =
  let val name = const_name id syn;
      val lts = length ts 
      val args = if (lts = 0) then ""
	         else "(" ^ Args("x",",",1,lts) ^ ")" 
      val rargs = if (lts = 0) then ""
	          else "("^ arg_reks arity ts ^ Args("x",",",1,lts) ^")"
  in     
    ( t_rec ^ "_" ^ id
    , t_rec ^ "(" ^ name ^ args ^ "," ^ Args("f",",",1,arity) ^ ") = f"
      ^ string_of_int(n) ^ rargs) 
     :: (rec_rules arity (n+1) cs)
  end
  | rec_rules _ _ [] = [];

val (rec_const,rules_rec) =
   let val typevar = create_typevar (dtVar "'beta") typevars
       val arity = length cons_list
       val dekl = (t_rec,
                    "[" ^ (pp_typlist1 typevars) ^ tname ^
                      (rec_typlist typevar cons_list) ^ "]=>" ^ typevar,
                    NoSyn)
       val rules = rec_rules arity 1 cons_list
       in (dekl,rules)
   end;



      val consts = 
        map const_type cons_list
	@ (if length cons_list < dtK then []
	   else [(tname ^ "_ord", datatype_name ^ "=>nat", NoSyn)])
	@ [case_const,rec_const];

      (*generate 'var_n, ..., var_m'*)
      fun Args(var, delim, n, m) = 
        space_implode delim (map (fn n => var^string_of_int(n)) (n upto m));

      (*generate 'name_1', ..., 'name_n'*)
      fun C_exp(name, n, var) =
        if n > 0 then name ^ pars(Args(var, ",", 1, n)) else name;

      (*generate 'x_n = y_n, ..., x_m = y_m'*)
      fun Arg_eql(n,m) = 
        if n=m then "x" ^ string_of_int(n) ^ "=y" ^ string_of_int(n) 
        else "x" ^ string_of_int(n) ^ "=y" ^ string_of_int(n) ^ " & " ^ 
             Arg_eql(n+1, m);

      fun Ci_ing ((id, typlist, syn) :: cs) =
            let val name = const_name id syn;
                val arity = length typlist;
            in if arity = 0 then Ci_ing cs
               else ("inject_" ^ id,
                     "(" ^ C_exp(name,arity,"x") ^ "=" ^ C_exp(name,arity,"y") 
                     ^ ") = (" ^ Arg_eql (1, arity) ^ ")") :: (Ci_ing cs)
            end
        | Ci_ing [] = [];

      fun Ci_negOne (id1, tl1, syn1) (id2, tl2, syn2) =
           let val name1 = const_name id1 syn1;
               val name2 = const_name id2 syn2;
               val ax = C_exp(name1, length tl1, "x") ^ "~=" ^
                        C_exp(name2, length tl2, "y")
           in (id1 ^ "_not_" ^ id2, ax) end;

      fun Ci_neg1 [] = []
        | Ci_neg1 (c1::cs) = (map (Ci_negOne c1) cs) @ Ci_neg1 cs;

      fun suc_expr n = 
        if n=0 then "0" else "Suc(" ^ suc_expr(n-1) ^ ")";

      fun Ci_neg2() =
        let val ord_t = tname ^ "_ord";
            val cis = cons_list ~~ (0 upto (length cons_list - 1))
            fun Ci_neg2equals ((id, typlist, syn), n) =
              let val name = const_name id syn;
                  val ax = ord_t ^ "(" ^ (C_exp(name, length typlist, "x")) 
                                 ^ ") = " ^ (suc_expr n)
              in (ord_t ^ "_" ^ id, ax) end
        in (ord_t ^ "_distinct", ord_t^"(x) ~= "^ord_t^"(y) ==> x ~= y") ::
           (map Ci_neg2equals cis)
        end;

      val rules_distinct = if length cons_list < dtK then Ci_neg1 cons_list
                           else Ci_neg2();

      val rules_inject = Ci_ing cons_list;

      val rule_induct = (tname ^ "_induct", t_induct cons_list tname);

      val rules = rule_induct ::
                  (rules_inject @ rules_distinct @ rules_case @ rules_rec);

      fun add_primrec eqns thy =
      let val rec_comb = Const(t_rec,dummyT)
          val teqns = map (fn eq => snd(read_axm (sign_of thy) ("",eq))) eqns
          val (fname,rfuns) = funs_from_eqns cons_list teqns
          val rhs = Abs(tname, dummyT,
                        list_comb(rec_comb, Bound 0 :: rev rfuns))
          val def = Const("==",dummyT) $ Const(fname,dummyT) $ rhs
          val tdef = instant_types thy def
      in add_defns_i [(fname ^ "_def", tdef)] thy end;

  in (thy
     |> add_types types
     |> add_arities arities
     |> add_consts consts
     |> add_trrules xrules
     |> add_axioms rules,
     add_primrec)
  end
end
end;