moved HOLCF tools to canonical place;
authorwenzelm
Thu May 31 14:01:58 2007 +0200 (2007-05-31)
changeset 231529497234a2743
parent 23151 ed3f6685ff90
child 23153 3cc4a80c4d30
moved HOLCF tools to canonical place;
src/HOLCF/Cfun.thy
src/HOLCF/Domain.thy
src/HOLCF/Fixrec.thy
src/HOLCF/HOLCF.thy
src/HOLCF/IsaMakefile
src/HOLCF/Pcpodef.thy
src/HOLCF/Tools/adm_tac.ML
src/HOLCF/Tools/cont_consts.ML
src/HOLCF/Tools/cont_proc.ML
src/HOLCF/Tools/domain/domain_axioms.ML
src/HOLCF/Tools/domain/domain_extender.ML
src/HOLCF/Tools/domain/domain_library.ML
src/HOLCF/Tools/domain/domain_syntax.ML
src/HOLCF/Tools/domain/domain_theorems.ML
src/HOLCF/Tools/fixrec_package.ML
src/HOLCF/Tools/pcpodef_package.ML
src/HOLCF/adm_tac.ML
src/HOLCF/cont_consts.ML
src/HOLCF/cont_proc.ML
src/HOLCF/domain/axioms.ML
src/HOLCF/domain/extender.ML
src/HOLCF/domain/library.ML
src/HOLCF/domain/syntax.ML
src/HOLCF/domain/theorems.ML
src/HOLCF/fixrec_package.ML
src/HOLCF/pcpodef_package.ML
     1.1 --- a/src/HOLCF/Cfun.thy	Thu May 31 13:24:13 2007 +0200
     1.2 +++ b/src/HOLCF/Cfun.thy	Thu May 31 14:01:58 2007 +0200
     1.3 @@ -9,7 +9,7 @@
     1.4  
     1.5  theory Cfun
     1.6  imports Pcpodef
     1.7 -uses ("cont_proc.ML")
     1.8 +uses ("Tools/cont_proc.ML")
     1.9  begin
    1.10  
    1.11  defaultsort cpo
    1.12 @@ -325,7 +325,7 @@
    1.13  lemmas cont_lemmas1 =
    1.14    cont_const cont_id cont_Rep_CFun2 cont2cont_Rep_CFun cont2cont_LAM
    1.15  
    1.16 -use "cont_proc.ML";
    1.17 +use "Tools/cont_proc.ML";
    1.18  setup ContProc.setup;
    1.19  
    1.20  (*val cont_tac = (fn i => (resolve_tac cont_lemmas i));*)
     2.1 --- a/src/HOLCF/Domain.thy	Thu May 31 13:24:13 2007 +0200
     2.2 +++ b/src/HOLCF/Domain.thy	Thu May 31 14:01:58 2007 +0200
     2.3 @@ -7,15 +7,6 @@
     2.4  
     2.5  theory Domain
     2.6  imports Ssum Sprod Up One Tr Fixrec
     2.7 -(*
     2.8 -files
     2.9 -  ("domain/library.ML")
    2.10 -  ("domain/syntax.ML")
    2.11 -  ("domain/axioms.ML")
    2.12 -  ("domain/theorems.ML")
    2.13 -  ("domain/extender.ML")
    2.14 -  ("domain/interface.ML")
    2.15 -*)
    2.16  begin
    2.17  
    2.18  defaultsort pcpo
     3.1 --- a/src/HOLCF/Fixrec.thy	Thu May 31 13:24:13 2007 +0200
     3.2 +++ b/src/HOLCF/Fixrec.thy	Thu May 31 14:01:58 2007 +0200
     3.3 @@ -7,7 +7,7 @@
     3.4  
     3.5  theory Fixrec
     3.6  imports Sprod Ssum Up One Tr Fix
     3.7 -uses ("fixrec_package.ML")
     3.8 +uses ("Tools/fixrec_package.ML")
     3.9  begin
    3.10  
    3.11  subsection {* Maybe monad type *}
    3.12 @@ -542,7 +542,7 @@
    3.13  
    3.14  subsection {* Initializing the fixrec package *}
    3.15  
    3.16 -use "fixrec_package.ML"
    3.17 +use "Tools/fixrec_package.ML"
    3.18  
    3.19  hide (open) const return bind fail run
    3.20  
     4.1 --- a/src/HOLCF/HOLCF.thy	Thu May 31 13:24:13 2007 +0200
     4.2 +++ b/src/HOLCF/HOLCF.thy	Thu May 31 14:01:58 2007 +0200
     4.3 @@ -9,13 +9,13 @@
     4.4  imports Sprod Ssum Up Lift Discrete One Tr Domain Main
     4.5  uses
     4.6    "holcf_logic.ML"
     4.7 -  "cont_consts.ML"
     4.8 -  "domain/library.ML"
     4.9 -  "domain/syntax.ML"
    4.10 -  "domain/axioms.ML"
    4.11 -  "domain/theorems.ML"
    4.12 -  "domain/extender.ML"
    4.13 -  "adm_tac.ML"
    4.14 +  "Tools/cont_consts.ML"
    4.15 +  "Tools/domain/domain_library.ML"
    4.16 +  "Tools/domain/domain_syntax.ML"
    4.17 +  "Tools/domain/domain_axioms.ML"
    4.18 +  "Tools/domain/domain_theorems.ML"
    4.19 +  "Tools/domain/domain_extender.ML"
    4.20 +  "Tools/adm_tac.ML"
    4.21  
    4.22  begin
    4.23  
     5.1 --- a/src/HOLCF/IsaMakefile	Thu May 31 13:24:13 2007 +0200
     5.2 +++ b/src/HOLCF/IsaMakefile	Thu May 31 14:01:58 2007 +0200
     5.3 @@ -27,15 +27,15 @@
     5.4  HOL:
     5.5  	@cd $(SRC)/HOL; $(ISATOOL) make HOL
     5.6  
     5.7 -$(OUT)/HOLCF: $(OUT)/HOL Adm.thy Cfun.thy Cont.thy	\
     5.8 -  Cprod.thy Discrete.thy Domain.thy Fix.thy Fixrec.thy	\
     5.9 -  Ffun.thy HOLCF.thy Lift.thy One.thy	\
    5.10 -  Pcpo.thy Porder.thy ROOT.ML Sprod.thy	\
    5.11 -  Ssum.thy Tr.thy Pcpodef.thy pcpodef_package.ML	\
    5.12 -  Up.thy adm_tac.ML cont_consts.ML cont_proc.ML fixrec_package.ML	\
    5.13 -  domain/axioms.ML domain/extender.ML domain/library.ML			\
    5.14 -  domain/syntax.ML domain/theorems.ML holcf_logic.ML ex/Stream.thy	\
    5.15 -  document/root.tex
    5.16 +$(OUT)/HOLCF: $(OUT)/HOL Adm.thy Cfun.thy Cont.thy Cprod.thy			\
    5.17 +  Discrete.thy Domain.thy Ffun.thy Fix.thy Fixrec.thy HOLCF.thy Lift.thy	\
    5.18 +  One.thy Pcpo.thy Pcpodef.thy Porder.thy ROOT.ML Sprod.thy Ssum.thy		\
    5.19 +  Tools/adm_tac.ML Tools/cont_consts.ML Tools/cont_proc.ML			\
    5.20 +  Tools/domain/domain_extender.ML Tools/domain/domain_axioms.ML			\
    5.21 +  Tools/domain/domain_library.ML Tools/domain/domain_syntax.ML			\
    5.22 +  Tools/domain/domain_theorems.ML Tools/fixrec_package.ML			\
    5.23 +  Tools/pcpodef_package.ML Tr.thy Up.thy document/root.tex ex/Stream.thy	\
    5.24 +  holcf_logic.ML
    5.25  	@$(ISATOOL) usedir -b -g true -r $(OUT)/HOL HOLCF
    5.26  
    5.27  
     6.1 --- a/src/HOLCF/Pcpodef.thy	Thu May 31 13:24:13 2007 +0200
     6.2 +++ b/src/HOLCF/Pcpodef.thy	Thu May 31 14:01:58 2007 +0200
     6.3 @@ -7,7 +7,7 @@
     6.4  
     6.5  theory Pcpodef
     6.6  imports Adm
     6.7 -uses ("pcpodef_package.ML")
     6.8 +uses ("Tools/pcpodef_package.ML")
     6.9  begin
    6.10  
    6.11  subsection {* Proving a subtype is a partial order *}
    6.12 @@ -266,6 +266,6 @@
    6.13  
    6.14  subsection {* HOLCF type definition package *}
    6.15  
    6.16 -use "pcpodef_package.ML"
    6.17 +use "Tools/pcpodef_package.ML"
    6.18  
    6.19  end
     7.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.2 +++ b/src/HOLCF/Tools/adm_tac.ML	Thu May 31 14:01:58 2007 +0200
     7.3 @@ -0,0 +1,180 @@
     7.4 +(*  ID:         $Id$
     7.5 +    Author:     Stefan Berghofer, TU Muenchen
     7.6 +
     7.7 +Admissibility tactic.
     7.8 +
     7.9 +Checks whether adm_subst theorem is applicable to the current proof
    7.10 +state:
    7.11 +
    7.12 +  [| cont t; adm P |] ==> adm (%x. P (t x))
    7.13 +
    7.14 +"t" is instantiated with a term of chain-finite type, so that
    7.15 +adm_chfin can be applied:
    7.16 +
    7.17 +  adm (P::'a::{chfin,pcpo} => bool)
    7.18 +
    7.19 +*)
    7.20 +
    7.21 +signature ADM =
    7.22 +sig
    7.23 +  val adm_tac: (int -> tactic) -> int -> tactic
    7.24 +end;
    7.25 +
    7.26 +structure Adm: ADM =
    7.27 +struct
    7.28 +
    7.29 +
    7.30 +(*** find_subterms t 0 []
    7.31 +     returns lists of terms with the following properties:
    7.32 +       1. all terms in the list are disjoint subterms of t
    7.33 +       2. all terms contain the variable which is bound at level 0
    7.34 +       3. all occurences of the variable which is bound at level 0
    7.35 +          are "covered" by a term in the list
    7.36 +     a list of integers is associated with every term which describes
    7.37 +     the "path" leading to the subterm (required for instantiation of
    7.38 +     the adm_subst theorem (see functions mk_term, inst_adm_subst_thm))
    7.39 +***)
    7.40 +
    7.41 +fun find_subterms (Bound i) lev path =
    7.42 +      if i = lev then [[(Bound 0, path)]]
    7.43 +      else []
    7.44 +  | find_subterms (t as (Abs (_, _, t2))) lev path =
    7.45 +      if List.filter (fn x => x<=lev)
    7.46 +           (add_loose_bnos (t, 0, [])) = [lev] then
    7.47 +        [(incr_bv (~lev, 0, t), path)]::
    7.48 +        (find_subterms t2 (lev+1) (0::path))
    7.49 +      else find_subterms t2 (lev+1) (0::path)
    7.50 +  | find_subterms (t as (t1 $ t2)) lev path =
    7.51 +      let val ts1 = find_subterms t1 lev (0::path);
    7.52 +          val ts2 = find_subterms t2 lev (1::path);
    7.53 +          fun combine [] y = []
    7.54 +            | combine (x::xs) ys =
    7.55 +                (map (fn z => x @ z) ys) @ (combine xs ys)
    7.56 +      in
    7.57 +        (if List.filter (fn x => x<=lev)
    7.58 +              (add_loose_bnos (t, 0, [])) = [lev] then
    7.59 +           [[(incr_bv (~lev, 0, t), path)]]
    7.60 +         else []) @
    7.61 +        (if ts1 = [] then ts2
    7.62 +         else if ts2 = [] then ts1
    7.63 +         else combine ts1 ts2)
    7.64 +      end
    7.65 +  | find_subterms _ _ _ = [];
    7.66 +
    7.67 +
    7.68 +(*** make term for instantiation of predicate "P" in adm_subst theorem ***)
    7.69 +
    7.70 +fun make_term t path paths lev =
    7.71 +  if path mem paths then Bound lev
    7.72 +  else case t of
    7.73 +      (Abs (s, T, t1)) => Abs (s, T, make_term t1 (0::path) paths (lev+1))
    7.74 +    | (t1 $ t2) => (make_term t1 (0::path) paths lev) $
    7.75 +                   (make_term t2 (1::path) paths lev)
    7.76 +    | t1 => t1;
    7.77 +
    7.78 +
    7.79 +(*** check whether all terms in list are equal ***)
    7.80 +
    7.81 +fun eq_terms [] = true
    7.82 +  | eq_terms (ts as (t, _) :: _) = forall (fn (t2, _) => t2 aconv t) ts;
    7.83 +
    7.84 +
    7.85 +(*figure out internal names*)
    7.86 +val chfin_pcpoS = Sign.intern_sort (the_context ()) ["chfin", "pcpo"];
    7.87 +val cont_name = Sign.intern_const (the_context ()) "cont";
    7.88 +val adm_name = Sign.intern_const (the_context ()) "adm";
    7.89 +
    7.90 +
    7.91 +(*** check whether type of terms in list is chain finite ***)
    7.92 +
    7.93 +fun is_chfin sign T params ((t, _)::_) =
    7.94 +  let val parTs = map snd (rev params)
    7.95 +  in Sign.of_sort sign (fastype_of1 (T::parTs, t), chfin_pcpoS) end;
    7.96 +
    7.97 +
    7.98 +(*** try to prove that terms in list are continuous
    7.99 +     if successful, add continuity theorem to list l ***)
   7.100 +
   7.101 +fun prove_cont tac sign s T prems params (l, ts as ((t, _)::_)) =
   7.102 +  let val parTs = map snd (rev params);
   7.103 +       val contT = (T --> (fastype_of1 (T::parTs, t))) --> HOLogic.boolT;
   7.104 +       fun mk_all [] t = t
   7.105 +         | mk_all ((a,T)::Ts) t = (all T) $ (Abs (a, T, mk_all Ts t));
   7.106 +       val t = HOLogic.mk_Trueprop((Const (cont_name, contT)) $ (Abs(s, T, t)));
   7.107 +       val t' = mk_all params (Logic.list_implies (prems, t));
   7.108 +       val thm = Goal.prove (ProofContext.init sign) [] [] t' (K (tac 1));
   7.109 +  in (ts, thm)::l end
   7.110 +  handle ERROR _ => l;
   7.111 +
   7.112 +
   7.113 +(*** instantiation of adm_subst theorem (a bit tricky) ***)
   7.114 +
   7.115 +fun inst_adm_subst_thm state i params s T subt t paths =
   7.116 +  let val {thy = sign, maxidx, ...} = rep_thm state;
   7.117 +      val j = maxidx+1;
   7.118 +      val parTs = map snd (rev params);
   7.119 +      val rule = Thm.lift_rule (Thm.cprem_of state i) adm_subst;
   7.120 +      val types = valOf o (fst (types_sorts rule));
   7.121 +      val tT = types ("t", j);
   7.122 +      val PT = types ("P", j);
   7.123 +      fun mk_abs [] t = t
   7.124 +        | mk_abs ((a,T)::Ts) t = Abs (a, T, mk_abs Ts t);
   7.125 +      val tt = cterm_of sign (mk_abs (params @ [(s, T)]) subt);
   7.126 +      val Pt = cterm_of sign (mk_abs (params @ [(s, fastype_of1 (T::parTs, subt))])
   7.127 +                     (make_term t [] paths 0));
   7.128 +      val tye = Sign.typ_match sign (tT, #T (rep_cterm tt)) Vartab.empty;
   7.129 +      val tye' = Sign.typ_match sign (PT, #T (rep_cterm Pt)) tye;
   7.130 +      val ctye = map (fn (ixn, (S, T)) =>
   7.131 +        (ctyp_of sign (TVar (ixn, S)), ctyp_of sign T)) (Vartab.dest tye');
   7.132 +      val tv = cterm_of sign (Var (("t", j), Envir.typ_subst_TVars tye' tT));
   7.133 +      val Pv = cterm_of sign (Var (("P", j), Envir.typ_subst_TVars tye' PT));
   7.134 +      val rule' = instantiate (ctye, [(tv, tt), (Pv, Pt)]) rule
   7.135 +  in rule' end;
   7.136 +
   7.137 +
   7.138 +(*** extract subgoal i from proof state ***)
   7.139 +
   7.140 +fun nth_subgoal i thm = List.nth (prems_of thm, i-1);
   7.141 +
   7.142 +
   7.143 +(*** the admissibility tactic ***)
   7.144 +
   7.145 +fun try_dest_adm (Const _ $ (Const (name, _) $ Abs abs)) =
   7.146 +      if name = adm_name then SOME abs else NONE
   7.147 +  | try_dest_adm _ = NONE;
   7.148 +
   7.149 +fun adm_tac tac i state =
   7.150 +  state |>
   7.151 +  let val goali = nth_subgoal i state in
   7.152 +    (case try_dest_adm (Logic.strip_assums_concl goali) of
   7.153 +      NONE => no_tac
   7.154 +    | SOME (s, T, t) =>
   7.155 +        let
   7.156 +          val sign = Thm.theory_of_thm state;
   7.157 +          val prems = Logic.strip_assums_hyp goali;
   7.158 +          val params = Logic.strip_params goali;
   7.159 +          val ts = find_subterms t 0 [];
   7.160 +          val ts' = List.filter eq_terms ts;
   7.161 +          val ts'' = List.filter (is_chfin sign T params) ts';
   7.162 +          val thms = Library.foldl (prove_cont tac sign s T prems params) ([], ts'');
   7.163 +        in
   7.164 +          (case thms of
   7.165 +            ((ts as ((t', _)::_), cont_thm)::_) =>
   7.166 +              let
   7.167 +                val paths = map snd ts;
   7.168 +                val rule = inst_adm_subst_thm state i params s T t' t paths;
   7.169 +              in
   7.170 +                compose_tac (false, rule, 2) i THEN
   7.171 +                rtac cont_thm i THEN
   7.172 +                REPEAT (assume_tac i) THEN
   7.173 +                rtac adm_chfin i
   7.174 +              end 
   7.175 +          | [] => no_tac)
   7.176 +        end)
   7.177 +    end;
   7.178 +
   7.179 +
   7.180 +end;
   7.181 +
   7.182 +
   7.183 +open Adm;
     8.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.2 +++ b/src/HOLCF/Tools/cont_consts.ML	Thu May 31 14:01:58 2007 +0200
     8.3 @@ -0,0 +1,110 @@
     8.4 +(*  Title:      HOLCF/Tools/cont_consts.ML
     8.5 +    ID:         $Id$
     8.6 +    Author:     Tobias Mayr, David von Oheimb, and Markus Wenzel
     8.7 +
     8.8 +HOLCF version of consts: handle continuous function types in mixfix
     8.9 +syntax.
    8.10 +*)
    8.11 +
    8.12 +signature CONT_CONSTS =
    8.13 +sig
    8.14 +  val add_consts: (bstring * string * mixfix) list -> theory -> theory
    8.15 +  val add_consts_i: (bstring * typ * mixfix) list -> theory -> theory
    8.16 +end;
    8.17 +
    8.18 +structure ContConsts: CONT_CONSTS =
    8.19 +struct
    8.20 +
    8.21 +
    8.22 +(* misc utils *)
    8.23 +
    8.24 +open HOLCFLogic;
    8.25 +
    8.26 +fun first  (x,_,_) = x;
    8.27 +fun second (_,x,_) = x;
    8.28 +fun third  (_,_,x) = x;
    8.29 +fun upd_first  f (x,y,z) = (f x,   y,   z);
    8.30 +fun upd_second f (x,y,z) = (  x, f y,   z);
    8.31 +fun upd_third  f (x,y,z) = (  x,   y, f z);
    8.32 +
    8.33 +fun change_arrow 0 T               = T
    8.34 +|   change_arrow n (Type(_,[S,T])) = Type ("fun",[S,change_arrow (n-1) T])
    8.35 +|   change_arrow _ _               = sys_error "cont_consts: change_arrow";
    8.36 +
    8.37 +fun trans_rules name2 name1 n mx = let
    8.38 +  fun argnames _ 0 = []
    8.39 +  |   argnames c n = chr c::argnames (c+1) (n-1);
    8.40 +  val vnames = argnames (ord "A") n;
    8.41 +  val extra_parse_rule = Syntax.ParseRule (Constant name2, Constant name1);
    8.42 +  in [Syntax.ParsePrintRule (Syntax.mk_appl (Constant name2) (map Variable vnames),
    8.43 +                          Library.foldl (fn (t,arg) => (Syntax.mk_appl (Constant "Rep_CFun")
    8.44 +                                                [t,Variable arg]))
    8.45 +                          (Constant name1,vnames))]
    8.46 +     @(case mx of InfixName _ => [extra_parse_rule]
    8.47 +                | InfixlName _ => [extra_parse_rule]
    8.48 +                | InfixrName _ => [extra_parse_rule] | _ => []) end;
    8.49 +
    8.50 +
    8.51 +(* transforming infix/mixfix declarations of constants with type ...->...
    8.52 +   a declaration of such a constant is transformed to a normal declaration with
    8.53 +   an internal name, the same type, and nofix. Additionally, a purely syntactic
    8.54 +   declaration with the original name, type ...=>..., and the original mixfix
    8.55 +   is generated and connected to the other declaration via some translation.
    8.56 +*)
    8.57 +fun fix_mixfix (syn                     , T, mx as Infix           p ) =
    8.58 +               (Syntax.const_name syn mx, T,       InfixName (syn, p))
    8.59 +  | fix_mixfix (syn                     , T, mx as Infixl           p ) =
    8.60 +               (Syntax.const_name syn mx, T,       InfixlName (syn, p))
    8.61 +  | fix_mixfix (syn                     , T, mx as Infixr           p ) =
    8.62 +               (Syntax.const_name syn mx, T,       InfixrName (syn, p))
    8.63 +  | fix_mixfix decl = decl;
    8.64 +fun transform decl = let
    8.65 +        val (c, T, mx) = fix_mixfix decl;
    8.66 +        val c2 = "_cont_" ^ c;
    8.67 +        val n  = Syntax.mixfix_args mx
    8.68 +    in     ((c ,               T,NoSyn),
    8.69 +            (c2,change_arrow n T,mx   ),
    8.70 +            trans_rules c2 c n mx) end;
    8.71 +
    8.72 +fun cfun_arity (Type(n,[_,T])) = if n = cfun_arrow then 1+cfun_arity T else 0
    8.73 +|   cfun_arity _               = 0;
    8.74 +
    8.75 +fun is_contconst (_,_,NoSyn   ) = false
    8.76 +|   is_contconst (_,_,Binder _) = false
    8.77 +|   is_contconst (c,T,mx      ) = cfun_arity T >= Syntax.mixfix_args mx
    8.78 +                         handle ERROR msg => cat_error msg ("in mixfix annotation for " ^
    8.79 +                                               quote (Syntax.const_name c mx));
    8.80 +
    8.81 +
    8.82 +(* add_consts(_i) *)
    8.83 +
    8.84 +fun gen_add_consts prep_typ raw_decls thy =
    8.85 +  let
    8.86 +    val decls = map (upd_second (prep_typ thy)) raw_decls;
    8.87 +    val (contconst_decls, normal_decls) = List.partition is_contconst decls;
    8.88 +    val transformed_decls = map transform contconst_decls;
    8.89 +  in
    8.90 +    thy
    8.91 +    |> Sign.add_consts_i normal_decls
    8.92 +    |> Sign.add_consts_i (map first transformed_decls)
    8.93 +    |> Sign.add_syntax_i (map second transformed_decls)
    8.94 +    |> Sign.add_trrules_i (List.concat (map third transformed_decls))
    8.95 +  end;
    8.96 +
    8.97 +val add_consts = gen_add_consts Sign.read_typ;
    8.98 +val add_consts_i = gen_add_consts Sign.certify_typ;
    8.99 +
   8.100 +
   8.101 +(* outer syntax *)
   8.102 +
   8.103 +local structure P = OuterParse and K = OuterKeyword in
   8.104 +
   8.105 +val constsP =
   8.106 +  OuterSyntax.command "consts" "declare constants (HOLCF)" K.thy_decl
   8.107 +    (Scan.repeat1 P.const >> (Toplevel.theory o add_consts));
   8.108 +
   8.109 +val _ = OuterSyntax.add_parsers [constsP];
   8.110 +
   8.111 +end;
   8.112 +
   8.113 +end;
     9.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.2 +++ b/src/HOLCF/Tools/cont_proc.ML	Thu May 31 14:01:58 2007 +0200
     9.3 @@ -0,0 +1,145 @@
     9.4 +(*  Title:      HOLCF/Tools/cont_proc.ML
     9.5 +    ID:         $Id$
     9.6 +    Author:     Brian Huffman
     9.7 +*)
     9.8 +
     9.9 +signature CONT_PROC =
    9.10 +sig
    9.11 +  val is_lcf_term: term -> bool
    9.12 +  val cont_thms: term -> thm list
    9.13 +  val all_cont_thms: term -> thm list
    9.14 +  val cont_tac: int -> tactic
    9.15 +  val cont_proc: theory -> simproc
    9.16 +  val setup: theory -> theory
    9.17 +end;
    9.18 +
    9.19 +structure ContProc: CONT_PROC =
    9.20 +struct
    9.21 +
    9.22 +(** theory context references **)
    9.23 +
    9.24 +val cont_K = thm "cont_const";
    9.25 +val cont_I = thm "cont_id";
    9.26 +val cont_A = thm "cont2cont_Rep_CFun";
    9.27 +val cont_L = thm "cont2cont_LAM";
    9.28 +val cont_R = thm "cont_Rep_CFun2";
    9.29 +
    9.30 +(* checks whether a term contains no dangling bound variables *)
    9.31 +val is_closed_term =
    9.32 +  let
    9.33 +    fun bound_less i (t $ u) =
    9.34 +          bound_less i t andalso bound_less i u
    9.35 +      | bound_less i (Abs (_, _, t)) = bound_less (i+1) t
    9.36 +      | bound_less i (Bound n) = n < i
    9.37 +      | bound_less i _ = true; (* Const, Free, and Var are OK *)
    9.38 +  in bound_less 0 end;
    9.39 +
    9.40 +(* checks whether a term is written entirely in the LCF sublanguage *)
    9.41 +fun is_lcf_term (Const ("Cfun.Rep_CFun", _) $ t $ u) =
    9.42 +      is_lcf_term t andalso is_lcf_term u
    9.43 +  | is_lcf_term (Const ("Cfun.Abs_CFun", _) $ Abs (_, _, t)) = is_lcf_term t
    9.44 +  | is_lcf_term (Const ("Cfun.Abs_CFun", _) $ _) = false
    9.45 +  | is_lcf_term (Bound _) = true
    9.46 +  | is_lcf_term t = is_closed_term t;
    9.47 +
    9.48 +(*
    9.49 +  efficiently generates a cont thm for every LAM abstraction in a term,
    9.50 +  using forward proof and reusing common subgoals
    9.51 +*)
    9.52 +local
    9.53 +  fun var 0 = [SOME cont_I]
    9.54 +    | var n = NONE :: var (n-1);
    9.55 +
    9.56 +  fun k NONE     = cont_K
    9.57 +    | k (SOME x) = x;
    9.58 +
    9.59 +  fun ap NONE NONE = NONE
    9.60 +    | ap x    y    = SOME (k y RS (k x RS cont_A));
    9.61 +
    9.62 +  fun zip []      []      = []
    9.63 +    | zip []      (y::ys) = (ap NONE y   ) :: zip [] ys
    9.64 +    | zip (x::xs) []      = (ap x    NONE) :: zip xs []
    9.65 +    | zip (x::xs) (y::ys) = (ap x    y   ) :: zip xs ys
    9.66 +
    9.67 +  fun lam [] = ([], cont_K)
    9.68 +    | lam (x::ys) =
    9.69 +    let
    9.70 +      (* should use "standard" for thms that are used multiple times *)
    9.71 +      (* it seems to allow for sharing in explicit proof objects *)
    9.72 +      val x' = standard (k x);
    9.73 +      val Lx = x' RS cont_L;
    9.74 +    in (map (fn y => SOME (k y RS Lx)) ys, x') end;
    9.75 +
    9.76 +  (* first list: cont thm for each dangling bound variable *)
    9.77 +  (* second list: cont thm for each LAM in t *)
    9.78 +  (* if b = false, only return cont thm for outermost LAMs *)
    9.79 +  fun cont_thms1 b (Const ("Cfun.Rep_CFun", _) $ f $ t) =
    9.80 +    let
    9.81 +      val (cs1,ls1) = cont_thms1 b f;
    9.82 +      val (cs2,ls2) = cont_thms1 b t;
    9.83 +    in (zip cs1 cs2, if b then ls1 @ ls2 else []) end
    9.84 +    | cont_thms1 b (Const ("Cfun.Abs_CFun", _) $ Abs (_, _, t)) =
    9.85 +    let
    9.86 +      val (cs, ls) = cont_thms1 b t;
    9.87 +      val (cs', l) = lam cs;
    9.88 +    in (cs', l::ls) end
    9.89 +    | cont_thms1 _ (Bound n) = (var n, [])
    9.90 +    | cont_thms1 _ _ = ([], []);
    9.91 +in
    9.92 +  (* precondition: is_lcf_term t = true *)
    9.93 +  fun cont_thms t = snd (cont_thms1 false t);
    9.94 +  fun all_cont_thms t = snd (cont_thms1 true t);
    9.95 +end;
    9.96 +
    9.97 +(*
    9.98 +  Given the term "cont f", the procedure tries to construct the
    9.99 +  theorem "cont f == True". If this theorem cannot be completely
   9.100 +  solved by the introduction rules, then the procedure returns a
   9.101 +  conditional rewrite rule with the unsolved subgoals as premises.
   9.102 +*)
   9.103 +
   9.104 +local
   9.105 +  val rules = [cont_K, cont_I, cont_R, cont_A, cont_L];
   9.106 +  
   9.107 +  val prev_cont_thms : thm list ref = ref [];
   9.108 +
   9.109 +  fun old_cont_tac i thm =
   9.110 +    case !prev_cont_thms of
   9.111 +      [] => no_tac thm
   9.112 +    | (c::cs) => (prev_cont_thms := cs; rtac c i thm);
   9.113 +
   9.114 +  fun new_cont_tac f' i thm =
   9.115 +    case all_cont_thms f' of
   9.116 +      [] => no_tac thm
   9.117 +    | (c::cs) => (prev_cont_thms := cs; rtac c i thm);
   9.118 +
   9.119 +  fun cont_tac_of_term (Const ("Cont.cont", _) $ f) =
   9.120 +    let
   9.121 +      val f' = Const ("Cfun.Abs_CFun", dummyT) $ f;
   9.122 +    in
   9.123 +      if is_lcf_term f'
   9.124 +      then old_cont_tac ORELSE' new_cont_tac f'
   9.125 +      else REPEAT_ALL_NEW (resolve_tac rules)
   9.126 +    end
   9.127 +    | cont_tac_of_term _ = K no_tac;
   9.128 +in
   9.129 +  val cont_tac =
   9.130 +    SUBGOAL (fn (t, i) => cont_tac_of_term (HOLogic.dest_Trueprop t) i);
   9.131 +end;
   9.132 +
   9.133 +local
   9.134 +  fun solve_cont thy _ t =
   9.135 +    let
   9.136 +      val tr = instantiate' [] [SOME (cterm_of thy t)] Eq_TrueI;
   9.137 +    in Option.map fst (Seq.pull (cont_tac 1 tr)) end
   9.138 +in
   9.139 +  fun cont_proc thy =
   9.140 +    Simplifier.simproc thy "cont_proc" ["cont f"] solve_cont;
   9.141 +end;
   9.142 +
   9.143 +val setup =
   9.144 +  (fn thy =>
   9.145 +    (Simplifier.change_simpset_of thy
   9.146 +      (fn ss => ss addsimprocs [cont_proc thy]); thy));
   9.147 +
   9.148 +end;
    10.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.2 +++ b/src/HOLCF/Tools/domain/domain_axioms.ML	Thu May 31 14:01:58 2007 +0200
    10.3 @@ -0,0 +1,170 @@
    10.4 +(*  Title:      HOLCF/Tools/domain/domain_axioms.ML
    10.5 +    ID:         $Id$
    10.6 +    Author:     David von Oheimb
    10.7 +
    10.8 +Syntax generator for domain command.
    10.9 +*)
   10.10 +
   10.11 +structure Domain_Axioms = struct
   10.12 +
   10.13 +local
   10.14 +
   10.15 +open Domain_Library;
   10.16 +infixr 0 ===>;infixr 0 ==>;infix 0 == ; 
   10.17 +infix 1 ===; infix 1 ~= ; infix 1 <<; infix 1 ~<<;
   10.18 +infix 9 `   ; infix 9 `% ; infix 9 `%%; infixr 9 oo;
   10.19 +
   10.20 +fun calc_axioms comp_dname (eqs : eq list) n (((dname,_),cons) : eq)=
   10.21 +let
   10.22 +
   10.23 +(* ----- axioms and definitions concerning the isomorphism ------------------ *)
   10.24 +
   10.25 +  val dc_abs = %%:(dname^"_abs");
   10.26 +  val dc_rep = %%:(dname^"_rep");
   10.27 +  val x_name'= "x";
   10.28 +  val x_name = idx_name eqs x_name' (n+1);
   10.29 +  val dnam = Sign.base_name dname;
   10.30 +
   10.31 +  val abs_iso_ax = ("abs_iso", mk_trp(dc_rep`(dc_abs`%x_name') === %:x_name'));
   10.32 +  val rep_iso_ax = ("rep_iso", mk_trp(dc_abs`(dc_rep`%x_name') === %:x_name'));
   10.33 +
   10.34 +  val when_def = ("when_def",%%:(dname^"_when") == 
   10.35 +     foldr (uncurry /\ ) (/\x_name'((when_body cons (fn (x,y) =>
   10.36 +				Bound(1+length cons+x-y)))`(dc_rep`Bound 0))) (when_funs cons));
   10.37 +  
   10.38 +  val copy_def = let
   10.39 +    fun idxs z x arg = if is_rec arg
   10.40 +			 then (cproj (Bound z) eqs (rec_of arg))`Bound(z-x)
   10.41 +			 else Bound(z-x);
   10.42 +    fun one_con (con,args) =
   10.43 +        foldr /\# (list_ccomb (%%:con, mapn (idxs (length args)) 1 args)) args;
   10.44 +  in ("copy_def", %%:(dname^"_copy") ==
   10.45 +       /\"f" (list_ccomb (%%:(dname^"_when"), map one_con cons))) end;
   10.46 +
   10.47 +(* -- definitions concerning the constructors, discriminators and selectors - *)
   10.48 +
   10.49 +  fun con_def m n (_,args) = let
   10.50 +    fun idxs z x arg = (if is_lazy arg then fn t => %%:upN`t else I) (Bound(z-x));
   10.51 +    fun parms vs = mk_stuple (mapn (idxs(length vs)) 1 vs);
   10.52 +    fun inj y 1 _ = y
   10.53 +    |   inj y _ 0 = %%:sinlN`y
   10.54 +    |   inj y i j = %%:sinrN`(inj y (i-1) (j-1));
   10.55 +  in foldr /\# (dc_abs`(inj (parms args) m n)) args end;
   10.56 +  
   10.57 +  val con_defs = mapn (fn n => fn (con,args) =>
   10.58 +    (extern_name con ^"_def", %%:con == con_def (length cons) n (con,args))) 0 cons;
   10.59 +  
   10.60 +  val dis_defs = let
   10.61 +	fun ddef (con,_) = (dis_name con ^"_def",%%:(dis_name con) == 
   10.62 +		 list_ccomb(%%:(dname^"_when"),map 
   10.63 +			(fn (con',args) => (foldr /\#
   10.64 +			   (if con'=con then %%:TT_N else %%:FF_N) args)) cons))
   10.65 +	in map ddef cons end;
   10.66 +
   10.67 +  val mat_defs = let
   10.68 +	fun mdef (con,_) = (mat_name con ^"_def",%%:(mat_name con) == 
   10.69 +		 list_ccomb(%%:(dname^"_when"),map 
   10.70 +			(fn (con',args) => (foldr /\#
   10.71 +			   (if con'=con
   10.72 +                               then %%:returnN`(mk_ctuple (map (bound_arg args) args))
   10.73 +                               else %%:failN) args)) cons))
   10.74 +	in map mdef cons end;
   10.75 +
   10.76 +  val pat_defs =
   10.77 +    let
   10.78 +      fun pdef (con,args) =
   10.79 +        let
   10.80 +          val ps = mapn (fn n => fn _ => %:("pat" ^ string_of_int n)) 1 args;
   10.81 +          val xs = map (bound_arg args) args;
   10.82 +          val r = Bound (length args);
   10.83 +          val rhs = case args of [] => %%:returnN ` HOLogic.unit
   10.84 +                                | _ => foldr1 cpair_pat ps ` mk_ctuple xs;
   10.85 +          fun one_con (con',args') = foldr /\# (if con'=con then rhs else %%:failN) args';
   10.86 +        in (pat_name con ^"_def", list_comb (%%:(pat_name con), ps) == 
   10.87 +               list_ccomb(%%:(dname^"_when"), map one_con cons))
   10.88 +        end
   10.89 +    in map pdef cons end;
   10.90 +
   10.91 +  val sel_defs = let
   10.92 +	fun sdef con n arg = Option.map (fn sel => (sel^"_def",%%:sel == 
   10.93 +		 list_ccomb(%%:(dname^"_when"),map 
   10.94 +			(fn (con',args) => if con'<>con then UU else
   10.95 +			 foldr /\# (Bound (length args - n)) args) cons))) (sel_of arg);
   10.96 +	in List.mapPartial I (List.concat(map (fn (con,args) => mapn (sdef con) 1 args) cons)) end;
   10.97 +
   10.98 +
   10.99 +(* ----- axiom and definitions concerning induction ------------------------- *)
  10.100 +
  10.101 +  val reach_ax = ("reach", mk_trp(cproj (%%:fixN`%%(comp_dname^"_copy")) eqs n
  10.102 +					`%x_name === %:x_name));
  10.103 +  val take_def = ("take_def",%%:(dname^"_take") == mk_lam("n",cproj
  10.104 +	     (%%:iterateN $ Bound 0 ` %%:(comp_dname^"_copy") ` UU) eqs n));
  10.105 +  val finite_def = ("finite_def",%%:(dname^"_finite") == mk_lam(x_name,
  10.106 +	mk_ex("n",(%%:(dname^"_take") $ Bound 0)`Bound 1 === Bound 1)));
  10.107 +
  10.108 +in (dnam,
  10.109 +    [abs_iso_ax, rep_iso_ax, reach_ax],
  10.110 +    [when_def, copy_def] @
  10.111 +     con_defs @ dis_defs @ mat_defs @ pat_defs @ sel_defs @
  10.112 +    [take_def, finite_def])
  10.113 +end; (* let *)
  10.114 +
  10.115 +fun infer_props thy = map (apsnd (FixrecPackage.legacy_infer_prop thy));
  10.116 +
  10.117 +fun add_axioms_i x = snd o PureThy.add_axioms_i (map Thm.no_attributes x);
  10.118 +fun add_axioms_infer axms thy = add_axioms_i (infer_props thy axms) thy;
  10.119 +
  10.120 +fun add_defs_i x = snd o (PureThy.add_defs_i false) (map Thm.no_attributes x);
  10.121 +fun add_defs_infer defs thy = add_defs_i (infer_props thy defs) thy;
  10.122 +
  10.123 +in (* local *)
  10.124 +
  10.125 +fun add_axioms (comp_dnam, eqs : eq list) thy' = let
  10.126 +  val comp_dname = Sign.full_name thy' comp_dnam;
  10.127 +  val dnames = map (fst o fst) eqs;
  10.128 +  val x_name = idx_name dnames "x"; 
  10.129 +  fun copy_app dname = %%:(dname^"_copy")`Bound 0;
  10.130 +  val copy_def = ("copy_def" , %%:(comp_dname^"_copy") ==
  10.131 +				    /\"f"(foldr1 cpair (map copy_app dnames)));
  10.132 +  val bisim_def = ("bisim_def",%%:(comp_dname^"_bisim")==mk_lam("R",
  10.133 +    let
  10.134 +      fun one_con (con,args) = let
  10.135 +	val nonrec_args = filter_out is_rec args;
  10.136 +	val    rec_args = List.filter     is_rec args;
  10.137 +	val    recs_cnt = length rec_args;
  10.138 +	val allargs     = nonrec_args @ rec_args
  10.139 +				      @ map (upd_vname (fn s=> s^"'")) rec_args;
  10.140 +	val allvns      = map vname allargs;
  10.141 +	fun vname_arg s arg = if is_rec arg then vname arg^s else vname arg;
  10.142 +	val vns1        = map (vname_arg "" ) args;
  10.143 +	val vns2        = map (vname_arg "'") args;
  10.144 +	val allargs_cnt = length nonrec_args + 2*recs_cnt;
  10.145 +	val rec_idxs    = (recs_cnt-1) downto 0;
  10.146 +	val nonlazy_idxs = map snd (filter_out (fn (arg,_) => is_lazy arg)
  10.147 +					 (allargs~~((allargs_cnt-1) downto 0)));
  10.148 +	fun rel_app i ra = proj (Bound(allargs_cnt+2)) eqs (rec_of ra) $ 
  10.149 +			   Bound (2*recs_cnt-i) $ Bound (recs_cnt-i);
  10.150 +	val capps = foldr mk_conj (mk_conj(
  10.151 +	   Bound(allargs_cnt+1)===list_ccomb(%%:con,map (bound_arg allvns) vns1),
  10.152 +	   Bound(allargs_cnt+0)===list_ccomb(%%:con,map (bound_arg allvns) vns2)))
  10.153 +           (mapn rel_app 1 rec_args);
  10.154 +        in foldr mk_ex (Library.foldr mk_conj 
  10.155 +			      (map (defined o Bound) nonlazy_idxs,capps)) allvns end;
  10.156 +      fun one_comp n (_,cons) =mk_all(x_name(n+1),mk_all(x_name(n+1)^"'",mk_imp(
  10.157 +	 		proj (Bound 2) eqs n $ Bound 1 $ Bound 0,
  10.158 +         		foldr1 mk_disj (mk_conj(Bound 1 === UU,Bound 0 === UU)
  10.159 +					::map one_con cons))));
  10.160 +    in foldr1 mk_conj (mapn one_comp 0 eqs)end ));
  10.161 +  fun add_one (thy,(dnam,axs,dfs)) = thy
  10.162 +	|> Theory.add_path dnam
  10.163 +	|> add_defs_infer dfs
  10.164 +	|> add_axioms_infer axs
  10.165 +	|> Theory.parent_path;
  10.166 +  val thy = Library.foldl add_one (thy', mapn (calc_axioms comp_dname eqs) 0 eqs);
  10.167 +in thy |> Theory.add_path comp_dnam  
  10.168 +       |> add_defs_infer (bisim_def::(if length eqs>1 then [copy_def] else []))
  10.169 +       |> Theory.parent_path
  10.170 +end;
  10.171 +
  10.172 +end; (* local *)
  10.173 +end; (* struct *)
    11.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.2 +++ b/src/HOLCF/Tools/domain/domain_extender.ML	Thu May 31 14:01:58 2007 +0200
    11.3 @@ -0,0 +1,183 @@
    11.4 +(*  Title:      HOLCF/Tools/domain/domain_extender.ML
    11.5 +    ID:         $Id$
    11.6 +    Author:     David von Oheimb
    11.7 +
    11.8 +Theory extender for domain command, including theory syntax.
    11.9 +
   11.10 +###TODO: 
   11.11 +
   11.12 +this definition
   11.13 +domain empty = silly empty
   11.14 +yields
   11.15 +Exception-
   11.16 +   TERM
   11.17 +      ("typ_of_term: bad encoding of type",
   11.18 +         [Abs ("uu", "_", Const ("NONE", "_"))]) raised
   11.19 +but this works fine:
   11.20 +domain Empty = silly Empty
   11.21 +
   11.22 +strange syntax errors are produced for:
   11.23 +domain xx = xx ("x yy")
   11.24 +domain 'a foo = foo (sel::"'a") 
   11.25 +and bar = bar ("'a dummy")
   11.26 +
   11.27 +*)
   11.28 +
   11.29 +signature DOMAIN_EXTENDER =
   11.30 +sig
   11.31 +  val add_domain: string * ((bstring * string list) *
   11.32 +    (string * mixfix * (bool * string option * string) list) list) list
   11.33 +    -> theory -> theory
   11.34 +  val add_domain_i: string * ((bstring * string list) *
   11.35 +    (string * mixfix * (bool * string option * typ) list) list) list
   11.36 +    -> theory -> theory
   11.37 +end;
   11.38 +
   11.39 +structure Domain_Extender: DOMAIN_EXTENDER =
   11.40 +struct
   11.41 +
   11.42 +open Domain_Library;
   11.43 +
   11.44 +(* ----- general testing and preprocessing of constructor list -------------- *)
   11.45 +fun check_and_sort_domain (dtnvs: (string * typ list) list, 
   11.46 +     cons'' : ((string * mixfix * (bool * string option * typ) list) list) list) sg =
   11.47 +  let
   11.48 +    val defaultS = Sign.defaultS sg;
   11.49 +    val test_dupl_typs = (case duplicates (op =) (map fst dtnvs) of 
   11.50 +	[] => false | dups => error ("Duplicate types: " ^ commas_quote dups));
   11.51 +    val test_dupl_cons = (case duplicates (op =) (map first (List.concat cons'')) of 
   11.52 +	[] => false | dups => error ("Duplicate constructors: " 
   11.53 +							 ^ commas_quote dups));
   11.54 +    val test_dupl_sels = (case duplicates (op =) (List.mapPartial second
   11.55 +			       (List.concat (map third (List.concat cons'')))) of
   11.56 +        [] => false | dups => error("Duplicate selectors: "^commas_quote dups));
   11.57 +    val test_dupl_tvars = exists(fn s=>case duplicates (op =) (map(fst o dest_TFree)s)of
   11.58 +	[] => false | dups => error("Duplicate type arguments: " 
   11.59 +		   ^commas_quote dups)) (map snd dtnvs);
   11.60 +    (* test for free type variables, illegal sort constraints on rhs,
   11.61 +	       non-pcpo-types and invalid use of recursive type;
   11.62 +       replace sorts in type variables on rhs *)
   11.63 +    fun analyse_equation ((dname,typevars),cons') = 
   11.64 +      let
   11.65 +	val tvars = map dest_TFree typevars;
   11.66 +	val distinct_typevars = map TFree tvars;
   11.67 +	fun rm_sorts (TFree(s,_)) = TFree(s,[])
   11.68 +	|   rm_sorts (Type(s,ts)) = Type(s,remove_sorts ts)
   11.69 +	|   rm_sorts (TVar(s,_))  = TVar(s,[])
   11.70 +	and remove_sorts l = map rm_sorts l;
   11.71 +	val indirect_ok = ["*","Cfun.->","Ssum.++","Sprod.**","Up.u"]
   11.72 +	fun analyse indirect (TFree(v,s))  = (case AList.lookup (op =) tvars v of 
   11.73 +		    NONE => error ("Free type variable " ^ quote v ^ " on rhs.")
   11.74 +	          | SOME sort => if eq_set_string (s,defaultS) orelse
   11.75 +				    eq_set_string (s,sort    )
   11.76 +				 then TFree(v,sort)
   11.77 +				 else error ("Inconsistent sort constraint" ^
   11.78 +				             " for type variable " ^ quote v))
   11.79 +        |   analyse indirect (t as Type(s,typl)) = (case AList.lookup (op =) dtnvs s of
   11.80 +		NONE          => if s mem indirect_ok
   11.81 +				 then Type(s,map (analyse false) typl)
   11.82 +				 else Type(s,map (analyse true) typl)
   11.83 +	      | SOME typevars => if indirect 
   11.84 +                           then error ("Indirect recursion of type " ^ 
   11.85 +				        quote (string_of_typ sg t))
   11.86 +                           else if dname <> s orelse (** BUG OR FEATURE?: 
   11.87 +                                mutual recursion may use different arguments **)
   11.88 +				   remove_sorts typevars = remove_sorts typl 
   11.89 +				then Type(s,map (analyse true) typl)
   11.90 +				else error ("Direct recursion of type " ^ 
   11.91 +					     quote (string_of_typ sg t) ^ 
   11.92 +					    " with different arguments"))
   11.93 +        |   analyse indirect (TVar _) = Imposs "extender:analyse";
   11.94 +	fun check_pcpo T = if pcpo_type sg T then T
   11.95 +          else error("Constructor argument type is not of sort pcpo: "^string_of_typ sg T);
   11.96 +	val analyse_con = upd_third (map (upd_third (check_pcpo o analyse false)));
   11.97 +      in ((dname,distinct_typevars), map analyse_con cons') end; 
   11.98 +  in ListPair.map analyse_equation (dtnvs,cons'')
   11.99 +  end; (* let *)
  11.100 +
  11.101 +(* ----- calls for building new thy and thms -------------------------------- *)
  11.102 +
  11.103 +fun gen_add_domain prep_typ (comp_dnam, eqs''') thy''' =
  11.104 +  let
  11.105 +    val dtnvs = map ((fn (dname,vs) => 
  11.106 +			 (Sign.full_name thy''' dname, map (Sign.read_typ thy''') vs))
  11.107 +                   o fst) eqs''';
  11.108 +    val cons''' = map snd eqs''';
  11.109 +    fun thy_type  (dname,tvars)  = (Sign.base_name dname, length tvars, NoSyn);
  11.110 +    fun thy_arity (dname,tvars)  = (dname, map (snd o dest_TFree) tvars, pcpoS);
  11.111 +    val thy'' = thy''' |> Theory.add_types     (map thy_type  dtnvs)
  11.112 +		       |> fold (AxClass.axiomatize_arity_i o thy_arity) dtnvs;
  11.113 +    val cons'' = map (map (upd_third (map (upd_third (prep_typ thy''))))) cons''';
  11.114 +    val eqs' = check_and_sort_domain (dtnvs,cons'') thy'';
  11.115 +    val thy' = thy'' |> Domain_Syntax.add_syntax (comp_dnam,eqs');
  11.116 +    val dts  = map (Type o fst) eqs';
  11.117 +    val new_dts = map (fn ((s,Ts),_) => (s, map (fst o dest_TFree) Ts)) eqs';
  11.118 +    fun strip ss = Library.drop (find_index_eq "'" ss +1, ss);
  11.119 +    fun typid (Type  (id,_)) =
  11.120 +          let val c = hd (Symbol.explode (Sign.base_name id))
  11.121 +          in if Symbol.is_letter c then c else "t" end
  11.122 +      | typid (TFree (id,_)   ) = hd (strip (tl (Symbol.explode id)))
  11.123 +      | typid (TVar ((id,_),_)) = hd (tl (Symbol.explode id));
  11.124 +    fun one_con (con,mx,args) =
  11.125 +	((Syntax.const_name con mx),
  11.126 +	 ListPair.map (fn ((lazy,sel,tp),vn) => ((lazy,
  11.127 +					find_index_eq tp dts,
  11.128 +					DatatypeAux.dtyp_of_typ new_dts tp),
  11.129 +					sel,vn))
  11.130 +	     (args,(mk_var_names(map (typid o third) args)))
  11.131 +	 ) : cons;
  11.132 +    val eqs = map (fn (dtnvs,cons') => (dtnvs, map one_con cons')) eqs' : eq list;
  11.133 +    val thy        = thy' |> Domain_Axioms.add_axioms (comp_dnam,eqs);
  11.134 +    val (theorems_thy, (rewss, take_rews)) = (foldl_map (fn (thy0,eq) =>
  11.135 +      Domain_Theorems.theorems (eq,eqs) thy0) (thy,eqs))
  11.136 +      |>>> Domain_Theorems.comp_theorems (comp_dnam, eqs);
  11.137 +  in
  11.138 +    theorems_thy
  11.139 +    |> Theory.add_path (Sign.base_name comp_dnam)
  11.140 +    |> (snd o (PureThy.add_thmss [(("rews", List.concat rewss @ take_rews), [])]))
  11.141 +    |> Theory.parent_path
  11.142 +  end;
  11.143 +
  11.144 +val add_domain_i = gen_add_domain Sign.certify_typ;
  11.145 +val add_domain = gen_add_domain Sign.read_typ;
  11.146 +
  11.147 +
  11.148 +(** outer syntax **)
  11.149 +
  11.150 +local structure P = OuterParse and K = OuterKeyword in
  11.151 +
  11.152 +val dest_decl =
  11.153 +  P.$$$ "(" |-- Scan.optional (P.$$$ "lazy" >> K true) false --
  11.154 +    (P.name >> SOME) -- (P.$$$ "::" |-- P.typ)  --| P.$$$ ")" >> P.triple1
  11.155 +  || P.$$$ "(" |-- P.$$$ "lazy" |-- P.typ --| P.$$$ ")"
  11.156 +       >> (fn t => (true,NONE,t))
  11.157 +  || P.typ >> (fn t => (false,NONE,t));
  11.158 +
  11.159 +val cons_decl =
  11.160 +  P.name -- Scan.repeat dest_decl -- P.opt_mixfix
  11.161 +  >> (fn ((c, ds), mx) => (c, mx, ds));
  11.162 +
  11.163 +val type_var' = (P.type_ident ^^ 
  11.164 +                 Scan.optional (P.$$$ "::" ^^ P.!!! P.sort) "");
  11.165 +val type_args' = type_var' >> single ||
  11.166 +                 P.$$$ "(" |-- P.!!! (P.list1 type_var' --| P.$$$ ")") ||
  11.167 + 		 Scan.succeed [];
  11.168 +
  11.169 +val domain_decl = (type_args' -- P.name >> Library.swap) -- 
  11.170 +                  (P.$$$ "=" |-- P.enum1 "|" cons_decl);
  11.171 +val domains_decl =
  11.172 +  Scan.option (P.$$$ "(" |-- P.name --| P.$$$ ")") -- P.and_list1 domain_decl
  11.173 +  >> (fn (opt_name, doms) =>
  11.174 +      (case opt_name of NONE => space_implode "_" (map (#1 o #1) doms) | SOME s => s, doms));
  11.175 +
  11.176 +val domainP =
  11.177 +  OuterSyntax.command "domain" "define recursive domains (HOLCF)" K.thy_decl
  11.178 +    (domains_decl >> (Toplevel.theory o add_domain));
  11.179 +
  11.180 +
  11.181 +val _ = OuterSyntax.add_keywords ["lazy"];
  11.182 +val _ = OuterSyntax.add_parsers [domainP];
  11.183 +
  11.184 +end; (* local structure *)
  11.185 +
  11.186 +end;
    12.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.2 +++ b/src/HOLCF/Tools/domain/domain_library.ML	Thu May 31 14:01:58 2007 +0200
    12.3 @@ -0,0 +1,230 @@
    12.4 +(*  Title:      HOLCF/Tools/domain/domain_library.ML
    12.5 +    ID:         $Id$
    12.6 +    Author:     David von Oheimb
    12.7 +
    12.8 +Library for domain command.
    12.9 +*)
   12.10 +
   12.11 +
   12.12 +(* ----- general support ---------------------------------------------------- *)
   12.13 +
   12.14 +fun mapn f n []      = []
   12.15 +|   mapn f n (x::xs) = (f n x) :: mapn f (n+1) xs;
   12.16 +
   12.17 +fun foldr'' f (l,f2) = let fun itr []  = raise Fail "foldr''"
   12.18 +			     | itr [a] = f2 a
   12.19 +			     | itr (a::l) = f(a, itr l)
   12.20 +in  itr l  end;
   12.21 +fun map_cumulr f start xs = foldr (fn (x,(ys,res))=>case f(x,res) of (y,res2) =>
   12.22 +						  (y::ys,res2)) ([],start) xs;
   12.23 +
   12.24 +
   12.25 +fun first  (x,_,_) = x; fun second (_,x,_) = x; fun third  (_,_,x) = x;
   12.26 +fun upd_first  f (x,y,z) = (f x,   y,   z);
   12.27 +fun upd_second f (x,y,z) = (  x, f y,   z);
   12.28 +fun upd_third  f (x,y,z) = (  x,   y, f z);
   12.29 +
   12.30 +fun atomize thm = let val r_inst = read_instantiate;
   12.31 +    fun at  thm = case concl_of thm of
   12.32 +      _$(Const("op &",_)$_$_)       => at(thm RS conjunct1)@at(thm RS conjunct2)
   12.33 +    | _$(Const("All" ,_)$Abs(s,_,_))=> at(thm RS (r_inst [("x","?"^s)] spec))
   12.34 +    | _				    => [thm];
   12.35 +in map zero_var_indexes (at thm) end;
   12.36 +
   12.37 +(* ----- specific support for domain ---------------------------------------- *)
   12.38 +
   12.39 +structure Domain_Library = struct
   12.40 +
   12.41 +open HOLCFLogic;
   12.42 +
   12.43 +exception Impossible of string;
   12.44 +fun Imposs msg = raise Impossible ("Domain:"^msg);
   12.45 +
   12.46 +(* ----- name handling ----- *)
   12.47 +
   12.48 +val strip_esc = let fun strip ("'" :: c :: cs) = c :: strip cs
   12.49 +		    |   strip ["'"] = []
   12.50 +		    |   strip (c :: cs) = c :: strip cs
   12.51 +		    |   strip [] = [];
   12.52 +in implode o strip o Symbol.explode end;
   12.53 +
   12.54 +fun extern_name con = case Symbol.explode con of 
   12.55 +		   ("o"::"p"::" "::rest) => implode rest
   12.56 +		   | _ => con;
   12.57 +fun dis_name  con = "is_"^ (extern_name con);
   12.58 +fun dis_name_ con = "is_"^ (strip_esc   con);
   12.59 +fun mat_name  con = "match_"^ (extern_name con);
   12.60 +fun mat_name_ con = "match_"^ (strip_esc   con);
   12.61 +fun pat_name  con = (extern_name con) ^ "_pat";
   12.62 +fun pat_name_ con = (strip_esc   con) ^ "_pat";
   12.63 +
   12.64 +(* make distinct names out of the type list, 
   12.65 +   forbidding "o","n..","x..","f..","P.." as names *)
   12.66 +(* a number string is added if necessary *)
   12.67 +fun mk_var_names ids : string list = let
   12.68 +    fun nonreserved s = if s mem ["n","x","f","P"] then s^"'" else s;
   12.69 +    fun index_vnames(vn::vns,occupied) =
   12.70 +          (case AList.lookup (op =) occupied vn of
   12.71 +             NONE => if vn mem vns
   12.72 +                     then (vn^"1") :: index_vnames(vns,(vn,1)  ::occupied)
   12.73 +                     else  vn      :: index_vnames(vns,          occupied)
   12.74 +           | SOME(i) => (vn^(string_of_int (i+1)))
   12.75 +				   :: index_vnames(vns,(vn,i+1)::occupied))
   12.76 +      | index_vnames([],occupied) = [];
   12.77 +in index_vnames(map nonreserved ids, [("O",0),("o",0)]) end;
   12.78 +
   12.79 +fun pcpo_type sg t = Sign.of_sort sg (Sign.certify_typ sg t, pcpoS);
   12.80 +fun string_of_typ sg = Sign.string_of_typ sg o Sign.certify_typ sg;
   12.81 +
   12.82 +(* ----- constructor list handling ----- *)
   12.83 +
   12.84 +type cons = (string *				(* operator name of constr *)
   12.85 +	    ((bool*int*DatatypeAux.dtyp)*	(*  (lazy,recursive element or ~1) *)
   12.86 +	      string option*			(*   selector name    *)
   12.87 +	      string)				(*   argument name    *)
   12.88 +	    list);				(* argument list      *)
   12.89 +type eq = (string *		(* name      of abstracted type *)
   12.90 +	   typ list) *		(* arguments of abstracted type *)
   12.91 +	  cons list;		(* represented type, as a constructor list *)
   12.92 +
   12.93 +fun rec_of arg  = second (first arg);
   12.94 +fun is_lazy arg = first (first arg);
   12.95 +val sel_of    =       second;
   12.96 +val     vname =       third;
   12.97 +val upd_vname =   upd_third;
   12.98 +fun is_rec         arg = rec_of arg >=0;
   12.99 +fun is_nonlazy_rec arg = is_rec arg andalso not (is_lazy arg);
  12.100 +fun nonlazy     args   = map vname (filter_out is_lazy    args);
  12.101 +fun nonlazy_rec args   = map vname (List.filter is_nonlazy_rec args);
  12.102 +
  12.103 +(* ----- qualified names of HOLCF constants ----- *)
  12.104 +
  12.105 +val lessN      = "Porder.<<"
  12.106 +val UU_N       = "Pcpo.UU";
  12.107 +val admN       = "Adm.adm";
  12.108 +val compactN   = "Adm.compact";
  12.109 +val Rep_CFunN  = "Cfun.Rep_CFun";
  12.110 +val Abs_CFunN  = "Cfun.Abs_CFun";
  12.111 +val ID_N       = "Cfun.ID";
  12.112 +val cfcompN    = "Cfun.cfcomp";
  12.113 +val strictifyN = "Cfun.strictify";
  12.114 +val cpairN     = "Cprod.cpair";
  12.115 +val cfstN      = "Cprod.cfst";
  12.116 +val csndN      = "Cprod.csnd";
  12.117 +val csplitN    = "Cprod.csplit";
  12.118 +val spairN     = "Sprod.spair";
  12.119 +val sfstN      = "Sprod.sfst";
  12.120 +val ssndN      = "Sprod.ssnd";
  12.121 +val ssplitN    = "Sprod.ssplit";
  12.122 +val sinlN      = "Ssum.sinl";
  12.123 +val sinrN      = "Ssum.sinr";
  12.124 +val sscaseN    = "Ssum.sscase";
  12.125 +val upN        = "Up.up";
  12.126 +val fupN       = "Up.fup";
  12.127 +val ONE_N      = "One.ONE";
  12.128 +val TT_N       = "Tr.TT";
  12.129 +val FF_N       = "Tr.FF";
  12.130 +val iterateN   = "Fix.iterate";
  12.131 +val fixN       = "Fix.fix";
  12.132 +val returnN    = "Fixrec.return";
  12.133 +val failN      = "Fixrec.fail";
  12.134 +val cpair_patN = "Fixrec.cpair_pat";
  12.135 +val branchN    = "Fixrec.branch";
  12.136 +
  12.137 +val pcpoN      = "Pcpo.pcpo"
  12.138 +val pcpoS      = [pcpoN];
  12.139 +
  12.140 +
  12.141 +(* ----- support for type and mixfix expressions ----- *)
  12.142 +
  12.143 +infixr 5 -->;
  12.144 +
  12.145 +(* ----- support for term expressions ----- *)
  12.146 +
  12.147 +fun %: s = Free(s,dummyT);
  12.148 +fun %# arg = %:(vname arg);
  12.149 +fun %%: s = Const(s,dummyT);
  12.150 +
  12.151 +local open HOLogic in
  12.152 +val mk_trp = mk_Trueprop;
  12.153 +fun mk_conj (S,T) = conj $ S $ T;
  12.154 +fun mk_disj (S,T) = disj $ S $ T;
  12.155 +fun mk_imp  (S,T) = imp  $ S $ T;
  12.156 +fun mk_lam  (x,T) = Abs(x,dummyT,T);
  12.157 +fun mk_all  (x,P) = HOLogic.mk_all (x,dummyT,P);
  12.158 +fun mk_ex   (x,P) = mk_exists (x,dummyT,P);
  12.159 +fun mk_constrain      (typ,T) = TypeInfer.constrain T typ;
  12.160 +fun mk_constrainall (x,typ,P) = %%:"All" $ (TypeInfer.constrain (mk_lam(x,P)) (typ --> boolT));
  12.161 +end
  12.162 +
  12.163 +fun mk_All  (x,P) = %%:"all" $ mk_lam(x,P); (* meta universal quantification *)
  12.164 +
  12.165 +infixr 0 ===>;  fun S ===> T = %%:"==>" $ S $ T;
  12.166 +infixr 0 ==>;   fun S ==> T = mk_trp S ===> mk_trp T;
  12.167 +infix 0 ==;     fun S ==  T = %%:"==" $ S $ T;
  12.168 +infix 1 ===;    fun S === T = %%:"op =" $ S $ T;
  12.169 +infix 1 ~=;     fun S ~=  T = HOLogic.mk_not (S === T);
  12.170 +infix 1 <<;     fun S <<  T = %%:lessN $ S $ T;
  12.171 +infix 1 ~<<;    fun S ~<< T = HOLogic.mk_not (S << T);
  12.172 +
  12.173 +infix 9 `  ; fun f`  x = %%:Rep_CFunN $ f $ x;
  12.174 +infix 9 `% ; fun f`% s = f` %: s;
  12.175 +infix 9 `%%; fun f`%%s = f` %%:s;
  12.176 +val list_ccomb = Library.foldl (op `); (* continuous version of list_comb *)
  12.177 +fun con_app2 con f args = list_ccomb(%%:con,map f args);
  12.178 +fun con_app con = con_app2 con %#;
  12.179 +fun if_rec  arg f y   = if is_rec arg then f (rec_of arg) else y;
  12.180 +fun app_rec_arg p arg = if_rec arg (fn n => fn x => (p n)`x) I (%# arg);
  12.181 +fun prj _  _  x (   _::[]) _ = x
  12.182 +|   prj f1 _  x (_::y::ys) 0 = f1 x y
  12.183 +|   prj f1 f2 x (y::   ys) j = prj f1 f2 (f2 x y) ys (j-1);
  12.184 +fun  proj x      = prj (fn S => K(%%:"fst" $S)) (fn S => K(%%:"snd" $S)) x;
  12.185 +fun cproj x      = prj (fn S => K(%%:cfstN`S)) (fn S => K(%%:csndN`S)) x;
  12.186 +fun lift tfn = Library.foldr (fn (x,t)=> (mk_trp(tfn x) ===> t));
  12.187 +
  12.188 +fun /\ v T = %%:Abs_CFunN $ mk_lam(v,T);
  12.189 +fun /\# (arg,T) = /\ (vname arg) T;
  12.190 +infixr 9 oo; fun S oo T = %%:cfcompN`S`T;
  12.191 +val UU = %%:UU_N;
  12.192 +fun strict f = f`UU === UU;
  12.193 +fun defined t = t ~= UU;
  12.194 +fun cpair (t,u) = %%:cpairN`t`u;
  12.195 +fun spair (t,u) = %%:spairN`t`u;
  12.196 +fun mk_ctuple [] = HOLogic.unit (* used in match_defs *)
  12.197 +|   mk_ctuple ts = foldr1 cpair ts;
  12.198 +fun mk_stuple [] = %%:ONE_N
  12.199 +|   mk_stuple ts = foldr1 spair ts;
  12.200 +fun mk_ctupleT [] = HOLogic.unitT   (* used in match_defs *)
  12.201 +|   mk_ctupleT Ts = foldr1 HOLogic.mk_prodT Ts;
  12.202 +fun mk_maybeT T = Type ("Fixrec.maybe",[T]);
  12.203 +fun cpair_pat (p1,p2) = %%:cpair_patN $ p1 $ p2;
  12.204 +fun lift_defined f = lift (fn x => defined (f x));
  12.205 +fun bound_arg vns v = Bound(length vns -find_index_eq v vns -1);
  12.206 +
  12.207 +fun cont_eta_contract (Const("Cfun.Abs_CFun",TT) $ Abs(a,T,body)) = 
  12.208 +      (case cont_eta_contract body  of
  12.209 +        body' as (Const("Cfun.Rep_CFun",Ta) $ f $ Bound 0) => 
  12.210 +	  if not (0 mem loose_bnos f) then incr_boundvars ~1 f 
  12.211 +	  else   Const("Cfun.Abs_CFun",TT) $ Abs(a,T,body')
  12.212 +      | body' => Const("Cfun.Abs_CFun",TT) $ Abs(a,T,body'))
  12.213 +|   cont_eta_contract(f$t) = cont_eta_contract f $ cont_eta_contract t
  12.214 +|   cont_eta_contract t    = t;
  12.215 +
  12.216 +fun idx_name dnames s n = s^(if length dnames = 1 then "" else string_of_int n);
  12.217 +fun when_funs cons = if length cons = 1 then ["f"] 
  12.218 +                     else mapn (fn n => K("f"^(string_of_int n))) 1 cons;
  12.219 +fun when_body cons funarg = let
  12.220 +	fun one_fun n (_,[]  ) = /\ "dummy" (funarg(1,n))
  12.221 +	|   one_fun n (_,args) = let
  12.222 +		val l2 = length args;
  12.223 +		fun idxs m arg = (if is_lazy arg then fn x=> %%:fupN` %%:ID_N`x
  12.224 +					         else I) (Bound(l2-m));
  12.225 +		in cont_eta_contract (foldr'' 
  12.226 +			(fn (a,t) => %%:ssplitN`(/\# (a,t)))
  12.227 +			(args,
  12.228 +			fn a=> /\#(a,(list_ccomb(funarg(l2,n),mapn idxs 1 args))))
  12.229 +			) end;
  12.230 +in (if length cons = 1 andalso length(snd(hd cons)) <= 1
  12.231 +    then fn t => %%:strictifyN`t else I)
  12.232 +     (foldr1 (fn (x,y)=> %%:sscaseN`x`y) (mapn one_fun 1 cons)) end;
  12.233 +end; (* struct *)
    13.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.2 +++ b/src/HOLCF/Tools/domain/domain_syntax.ML	Thu May 31 14:01:58 2007 +0200
    13.3 @@ -0,0 +1,151 @@
    13.4 +(*  Title:      HOLCF/Tools/domain/domain_syntax.ML
    13.5 +    ID:         $Id$
    13.6 +    Author:     David von Oheimb
    13.7 +
    13.8 +Syntax generator for domain command.
    13.9 +*)
   13.10 +
   13.11 +structure Domain_Syntax = struct 
   13.12 +
   13.13 +local 
   13.14 +
   13.15 +open Domain_Library;
   13.16 +infixr 5 -->; infixr 6 ->>;
   13.17 +fun calc_syntax dtypeprod ((dname, typevars), 
   13.18 +	(cons': (string * mixfix * (bool * string option * typ) list) list)) =
   13.19 +let
   13.20 +(* ----- constants concerning the isomorphism ------------------------------- *)
   13.21 +
   13.22 +local
   13.23 +  fun opt_lazy (lazy,_,t) = if lazy then mk_uT t else t
   13.24 +  fun prod     (_,_,args) = if args = [] then oneT
   13.25 +			    else foldr1 mk_sprodT (map opt_lazy args);
   13.26 +  fun freetvar s = let val tvar = mk_TFree s in
   13.27 +		   if tvar mem typevars then freetvar ("t"^s) else tvar end;
   13.28 +  fun when_type (_   ,_,args) = foldr (op ->>) (freetvar "t") (map third args);
   13.29 +in
   13.30 +  val dtype  = Type(dname,typevars);
   13.31 +  val dtype2 = foldr1 mk_ssumT (map prod cons');
   13.32 +  val dnam = Sign.base_name dname;
   13.33 +  val const_rep  = (dnam^"_rep" ,              dtype  ->> dtype2, NoSyn);
   13.34 +  val const_abs  = (dnam^"_abs" ,              dtype2 ->> dtype , NoSyn);
   13.35 +  val const_when = (dnam^"_when",foldr (op ->>) (dtype ->> freetvar "t") (map when_type cons'), NoSyn);
   13.36 +  val const_copy = (dnam^"_copy", dtypeprod ->> dtype  ->> dtype , NoSyn);
   13.37 +end;
   13.38 +
   13.39 +(* ----- constants concerning constructors, discriminators, and selectors --- *)
   13.40 +
   13.41 +local
   13.42 +  val escape = let
   13.43 +	fun esc (c::cs) = if c mem ["'","_","(",")","/"] then "'"::c::esc cs
   13.44 +							 else      c::esc cs
   13.45 +	|   esc []      = []
   13.46 +	in implode o esc o Symbol.explode end;
   13.47 +  fun con (name,s,args) = (name,foldr (op ->>) dtype (map third args),s);
   13.48 +  fun dis (con ,s,_   ) = (dis_name_ con, dtype->>trT,
   13.49 +			   Mixfix(escape ("is_" ^ con), [], Syntax.max_pri));
   13.50 +			(* strictly speaking, these constants have one argument,
   13.51 +			   but the mixfix (without arguments) is introduced only
   13.52 +			   to generate parse rules for non-alphanumeric names*)
   13.53 +  fun mat (con ,s,args) = (mat_name_ con, dtype->>mk_maybeT(mk_ctupleT(map third args)),
   13.54 +			   Mixfix(escape ("match_" ^ con), [], Syntax.max_pri));
   13.55 +  fun sel1 (_,sel,typ)  = Option.map (fn s => (s,dtype ->> typ,NoSyn)) sel;
   13.56 +  fun sel (_   ,_,args) = List.mapPartial sel1 args;
   13.57 +  fun freetvar s n      = let val tvar = mk_TFree (s ^ string_of_int n) in
   13.58 +			  if tvar mem typevars then freetvar ("t"^s) n else tvar end;
   13.59 +  fun mk_patT (a,b)     = a ->> mk_maybeT b;
   13.60 +  fun pat_arg_typ n arg = mk_patT (third arg, freetvar "t" n);
   13.61 +  fun pat (con ,s,args) = (pat_name_ con, (mapn pat_arg_typ 1 args) --->
   13.62 +			   mk_patT (dtype, mk_ctupleT (map (freetvar "t") (1 upto length args))),
   13.63 +			   Mixfix(escape (con ^ "_pat"), [], Syntax.max_pri));
   13.64 +
   13.65 +in
   13.66 +  val consts_con = map con cons';
   13.67 +  val consts_dis = map dis cons';
   13.68 +  val consts_mat = map mat cons';
   13.69 +  val consts_pat = map pat cons';
   13.70 +  val consts_sel = List.concat(map sel cons');
   13.71 +end;
   13.72 +
   13.73 +(* ----- constants concerning induction ------------------------------------- *)
   13.74 +
   13.75 +  val const_take   = (dnam^"_take"  , HOLogic.natT-->dtype->>dtype, NoSyn);
   13.76 +  val const_finite = (dnam^"_finite", dtype-->HOLogic.boolT       , NoSyn);
   13.77 +
   13.78 +(* ----- case translation --------------------------------------------------- *)
   13.79 +
   13.80 +local open Syntax in
   13.81 +  local
   13.82 +    fun c_ast con mx = Constant (const_name con mx);
   13.83 +    fun expvar n     = Variable ("e"^(string_of_int n));
   13.84 +    fun argvar n m _ = Variable ("a"^(string_of_int n)^"_"^
   13.85 +				     (string_of_int m));
   13.86 +    fun argvars n args = mapn (argvar n) 1 args;
   13.87 +    fun app s (l,r)  = mk_appl (Constant s) [l,r];
   13.88 +    val cabs = app "_cabs";
   13.89 +    val capp = app "Rep_CFun";
   13.90 +    fun con1 n (con,mx,args) = Library.foldl capp (c_ast con mx, argvars n args);
   13.91 +    fun case1 n (con,mx,args) = app "_case1" (con1 n (con,mx,args), expvar n);
   13.92 +    fun arg1 n (con,_,args) = foldr cabs (expvar n) (argvars n args);
   13.93 +    fun when1 n m = if n = m then arg1 n else K (Constant "UU");
   13.94 +
   13.95 +    fun app_var x = mk_appl (Constant "_var") [x, Variable "rhs"];
   13.96 +    fun app_pat x = mk_appl (Constant "_pat") [x];
   13.97 +    fun args_list [] = Constant "Unity"
   13.98 +    |   args_list xs = foldr1 (app "_args") xs;
   13.99 +  in
  13.100 +    val case_trans = ParsePrintRule
  13.101 +        (app "_case_syntax" (Variable "x", foldr1 (app "_case2") (mapn case1 1 cons')),
  13.102 +         capp (Library.foldl capp (Constant (dnam^"_when"), mapn arg1 1 cons'), Variable "x"));
  13.103 +    
  13.104 +    val abscon_trans = mapn (fn n => fn (con,mx,args) => ParsePrintRule
  13.105 +        (cabs (con1 n (con,mx,args), expvar n),
  13.106 +         Library.foldl capp (Constant (dnam^"_when"), mapn (when1 n) 1 cons'))) 1 cons';
  13.107 +    
  13.108 +    val Case_trans = List.concat (map (fn (con,mx,args) =>
  13.109 +      let
  13.110 +        val cname = c_ast con mx;
  13.111 +        val pname = Constant (pat_name_ con);
  13.112 +        val ns = 1 upto length args;
  13.113 +        val xs = map (fn n => Variable ("x"^(string_of_int n))) ns;
  13.114 +        val ps = map (fn n => Variable ("p"^(string_of_int n))) ns;
  13.115 +        val vs = map (fn n => Variable ("v"^(string_of_int n))) ns;
  13.116 +      in
  13.117 +        [ParseRule (app_pat (Library.foldl capp (cname, xs)),
  13.118 +                    mk_appl pname (map app_pat xs)),
  13.119 +         ParseRule (app_var (Library.foldl capp (cname, xs)),
  13.120 +                    app_var (args_list xs)),
  13.121 +         PrintRule (Library.foldl capp (cname, ListPair.map (app "_match") (ps,vs)),
  13.122 +                    app "_match" (mk_appl pname ps, args_list vs))]
  13.123 +      end) cons');
  13.124 +  end;
  13.125 +end;
  13.126 +
  13.127 +in ([const_rep, const_abs, const_when, const_copy] @ 
  13.128 +     consts_con @ consts_dis @ consts_mat @ consts_pat @ consts_sel @
  13.129 +    [const_take, const_finite],
  13.130 +    (case_trans::(abscon_trans @ Case_trans)))
  13.131 +end; (* let *)
  13.132 +
  13.133 +(* ----- putting all the syntax stuff together ------------------------------ *)
  13.134 +
  13.135 +in (* local *)
  13.136 +
  13.137 +fun add_syntax (comp_dnam,eqs': ((string * typ list) *
  13.138 +	(string * mixfix * (bool * string option * typ) list) list) list) thy'' =
  13.139 +let
  13.140 +  val dtypes  = map (Type o fst) eqs';
  13.141 +  val boolT   = HOLogic.boolT;
  13.142 +  val funprod = foldr1 HOLogic.mk_prodT (map (fn tp => tp ->> tp          ) dtypes);
  13.143 +  val relprod = foldr1 HOLogic.mk_prodT (map (fn tp => tp --> tp --> boolT) dtypes);
  13.144 +  val const_copy   = (comp_dnam^"_copy"  ,funprod ->> funprod, NoSyn);
  13.145 +  val const_bisim  = (comp_dnam^"_bisim" ,relprod --> boolT  , NoSyn);
  13.146 +  val ctt           = map (calc_syntax funprod) eqs';
  13.147 +in thy'' |> ContConsts.add_consts_i (List.concat (map fst ctt) @ 
  13.148 +				    (if length eqs'>1 then [const_copy] else[])@
  13.149 +				    [const_bisim])
  13.150 +	 |> Sign.add_trrules_i (List.concat(map snd ctt))
  13.151 +end; (* let *)
  13.152 +
  13.153 +end; (* local *)
  13.154 +end; (* struct *)
    14.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    14.2 +++ b/src/HOLCF/Tools/domain/domain_theorems.ML	Thu May 31 14:01:58 2007 +0200
    14.3 @@ -0,0 +1,951 @@
    14.4 +(*  Title:      HOLCF/Tools/domain/domain_theorems.ML
    14.5 +    ID:         $Id$
    14.6 +    Author:     David von Oheimb
    14.7 +                New proofs/tactics by Brian Huffman
    14.8 +
    14.9 +Proof generator for domain command.
   14.10 +*)
   14.11 +
   14.12 +val HOLCF_ss = simpset();
   14.13 +
   14.14 +structure Domain_Theorems = struct
   14.15 +
   14.16 +local
   14.17 +
   14.18 +val adm_impl_admw = thm "adm_impl_admw";
   14.19 +val antisym_less_inverse = thm "antisym_less_inverse";
   14.20 +val beta_cfun = thm "beta_cfun";
   14.21 +val cfun_arg_cong = thm "cfun_arg_cong";
   14.22 +val ch2ch_Rep_CFunL = thm "ch2ch_Rep_CFunL";
   14.23 +val ch2ch_Rep_CFunR = thm "ch2ch_Rep_CFunR";
   14.24 +val chain_iterate = thm "chain_iterate";
   14.25 +val compact_ONE = thm "compact_ONE";
   14.26 +val compact_sinl = thm "compact_sinl";
   14.27 +val compact_sinr = thm "compact_sinr";
   14.28 +val compact_spair = thm "compact_spair";
   14.29 +val compact_up = thm "compact_up";
   14.30 +val contlub_cfun_arg = thm "contlub_cfun_arg";
   14.31 +val contlub_cfun_fun = thm "contlub_cfun_fun";
   14.32 +val fix_def2 = thm "fix_def2";
   14.33 +val injection_eq = thm "injection_eq";
   14.34 +val injection_less = thm "injection_less";
   14.35 +val lub_equal = thm "lub_equal";
   14.36 +val monofun_cfun_arg = thm "monofun_cfun_arg";
   14.37 +val retraction_strict = thm "retraction_strict";
   14.38 +val spair_eq = thm "spair_eq";
   14.39 +val spair_less = thm "spair_less";
   14.40 +val sscase1 = thm "sscase1";
   14.41 +val ssplit1 = thm "ssplit1";
   14.42 +val strictify1 = thm "strictify1";
   14.43 +val wfix_ind = thm "wfix_ind";
   14.44 +
   14.45 +open Domain_Library;
   14.46 +infixr 0 ===>;
   14.47 +infixr 0 ==>;
   14.48 +infix 0 == ; 
   14.49 +infix 1 ===;
   14.50 +infix 1 ~= ;
   14.51 +infix 1 <<;
   14.52 +infix 1 ~<<;
   14.53 +infix 9 `   ;
   14.54 +infix 9 `% ;
   14.55 +infix 9 `%%;
   14.56 +infixr 9 oo;
   14.57 +
   14.58 +(* ----- general proof facilities ------------------------------------------- *)
   14.59 +
   14.60 +fun pg'' thy defs t tacs =
   14.61 +  let
   14.62 +    val t' = FixrecPackage.legacy_infer_term thy t;
   14.63 +    val asms = Logic.strip_imp_prems t';
   14.64 +    val prop = Logic.strip_imp_concl t';
   14.65 +    fun tac prems =
   14.66 +      rewrite_goals_tac defs THEN
   14.67 +      EVERY (tacs (map (rewrite_rule defs) prems));
   14.68 +  in Goal.prove_global thy [] asms prop tac end;
   14.69 +
   14.70 +fun pg' thy defs t tacsf =
   14.71 +  let
   14.72 +    fun tacs [] = tacsf
   14.73 +      | tacs prems = cut_facts_tac prems 1 :: tacsf;
   14.74 +  in pg'' thy defs t tacs end;
   14.75 +
   14.76 +fun case_UU_tac rews i v =
   14.77 +  case_tac (v^"=UU") i THEN
   14.78 +  asm_simp_tac (HOLCF_ss addsimps rews) i;
   14.79 +
   14.80 +val chain_tac =
   14.81 +  REPEAT_DETERM o resolve_tac 
   14.82 +    [chain_iterate, ch2ch_Rep_CFunR, ch2ch_Rep_CFunL];
   14.83 +
   14.84 +(* ----- general proofs ----------------------------------------------------- *)
   14.85 +
   14.86 +val all2E = prove_goal HOL.thy "[| !x y . P x y; P x y ==> R |] ==> R"
   14.87 +  (fn prems =>[
   14.88 +    resolve_tac prems 1,
   14.89 +    cut_facts_tac prems 1,
   14.90 +    fast_tac HOL_cs 1]);
   14.91 +
   14.92 +val dist_eqI = prove_goal (the_context ()) "!!x::'a::po. ~ x << y ==> x ~= y" 
   14.93 +  (fn prems =>
   14.94 +    [blast_tac (claset () addDs [antisym_less_inverse]) 1]);
   14.95 +
   14.96 +in
   14.97 +
   14.98 +fun theorems (((dname, _), cons) : eq, eqs : eq list) thy =
   14.99 +let
  14.100 +
  14.101 +val dummy = writeln ("Proving isomorphism properties of domain "^dname^" ...");
  14.102 +val pg = pg' thy;
  14.103 +
  14.104 +(* ----- getting the axioms and definitions --------------------------------- *)
  14.105 +
  14.106 +local
  14.107 +  fun ga s dn = get_thm thy (Name (dn ^ "." ^ s));
  14.108 +in
  14.109 +  val ax_abs_iso  = ga "abs_iso"  dname;
  14.110 +  val ax_rep_iso  = ga "rep_iso"  dname;
  14.111 +  val ax_when_def = ga "when_def" dname;
  14.112 +  fun get_def mk_name (con,_) = ga (mk_name con^"_def") dname;
  14.113 +  val axs_con_def = map (get_def extern_name) cons;
  14.114 +  val axs_dis_def = map (get_def dis_name) cons;
  14.115 +  val axs_mat_def = map (get_def mat_name) cons;
  14.116 +  val axs_pat_def = map (get_def pat_name) cons;
  14.117 +  val axs_sel_def =
  14.118 +    let
  14.119 +      fun def_of_sel sel = ga (sel^"_def") dname;
  14.120 +      fun def_of_arg arg = Option.map def_of_sel (sel_of arg);
  14.121 +      fun defs_of_con (_, args) = List.mapPartial def_of_arg args;
  14.122 +    in
  14.123 +      List.concat (map defs_of_con cons)
  14.124 +    end;
  14.125 +  val ax_copy_def = ga "copy_def" dname;
  14.126 +end; (* local *)
  14.127 +
  14.128 +(* ----- theorems concerning the isomorphism -------------------------------- *)
  14.129 +
  14.130 +val dc_abs  = %%:(dname^"_abs");
  14.131 +val dc_rep  = %%:(dname^"_rep");
  14.132 +val dc_copy = %%:(dname^"_copy");
  14.133 +val x_name = "x";
  14.134 +
  14.135 +val iso_locale = iso_intro OF [ax_abs_iso, ax_rep_iso];
  14.136 +val abs_strict = ax_rep_iso RS (allI RS retraction_strict);
  14.137 +val rep_strict = ax_abs_iso RS (allI RS retraction_strict);
  14.138 +val abs_defin' = iso_locale RS iso_abs_defin';
  14.139 +val rep_defin' = iso_locale RS iso_rep_defin';
  14.140 +val iso_rews = map standard [ax_abs_iso,ax_rep_iso,abs_strict,rep_strict];
  14.141 +
  14.142 +(* ----- generating beta reduction rules from definitions-------------------- *)
  14.143 +
  14.144 +local
  14.145 +  fun arglist (Const _ $ Abs (s, _, t)) =
  14.146 +    let
  14.147 +      val (vars,body) = arglist t;
  14.148 +    in (s :: vars, body) end
  14.149 +    | arglist t = ([], t);
  14.150 +  fun bind_fun vars t = Library.foldr mk_All (vars, t);
  14.151 +  fun bound_vars 0 = []
  14.152 +    | bound_vars i = Bound (i-1) :: bound_vars (i - 1);
  14.153 +in
  14.154 +  fun appl_of_def def =
  14.155 +    let
  14.156 +      val (_ $ con $ lam) = concl_of def;
  14.157 +      val (vars, rhs) = arglist lam;
  14.158 +      val lhs = list_ccomb (con, bound_vars (length vars));
  14.159 +      val appl = bind_fun vars (lhs == rhs);
  14.160 +      val cs = ContProc.cont_thms lam;
  14.161 +      val betas = map (fn c => mk_meta_eq (c RS beta_cfun)) cs;
  14.162 +    in pg (def::betas) appl [rtac reflexive_thm 1] end;
  14.163 +end;
  14.164 +
  14.165 +val when_appl = appl_of_def ax_when_def;
  14.166 +val con_appls = map appl_of_def axs_con_def;
  14.167 +
  14.168 +local
  14.169 +  fun arg2typ n arg =
  14.170 +    let val t = TVar (("'a", n), pcpoS)
  14.171 +    in (n + 1, if is_lazy arg then mk_uT t else t) end;
  14.172 +
  14.173 +  fun args2typ n [] = (n, oneT)
  14.174 +    | args2typ n [arg] = arg2typ n arg
  14.175 +    | args2typ n (arg::args) =
  14.176 +    let
  14.177 +      val (n1, t1) = arg2typ n arg;
  14.178 +      val (n2, t2) = args2typ n1 args
  14.179 +    in (n2, mk_sprodT (t1, t2)) end;
  14.180 +
  14.181 +  fun cons2typ n [] = (n,oneT)
  14.182 +    | cons2typ n [con] = args2typ n (snd con)
  14.183 +    | cons2typ n (con::cons) =
  14.184 +    let
  14.185 +      val (n1, t1) = args2typ n (snd con);
  14.186 +      val (n2, t2) = cons2typ n1 cons
  14.187 +    in (n2, mk_ssumT (t1, t2)) end;
  14.188 +in
  14.189 +  fun cons2ctyp cons = ctyp_of thy (snd (cons2typ 1 cons));
  14.190 +end;
  14.191 +
  14.192 +local 
  14.193 +  val iso_swap = iso_locale RS iso_iso_swap;
  14.194 +  fun one_con (con, args) =
  14.195 +    let
  14.196 +      val vns = map vname args;
  14.197 +      val eqn = %:x_name === con_app2 con %: vns;
  14.198 +      val conj = foldr1 mk_conj (eqn :: map (defined o %:) (nonlazy args));
  14.199 +    in Library.foldr mk_ex (vns, conj) end;
  14.200 +
  14.201 +  val conj_assoc = thm "conj_assoc";
  14.202 +  val exh = foldr1 mk_disj ((%:x_name === UU) :: map one_con cons);
  14.203 +  val thm1 = instantiate' [SOME (cons2ctyp cons)] [] exh_start;
  14.204 +  val thm2 = rewrite_rule (map mk_meta_eq ex_defined_iffs) thm1;
  14.205 +  val thm3 = rewrite_rule [mk_meta_eq conj_assoc] thm2;
  14.206 +
  14.207 +  (* first 3 rules replace "x = UU \/ P" with "rep$x = UU \/ P" *)
  14.208 +  val tacs = [
  14.209 +    rtac disjE 1,
  14.210 +    etac (rep_defin' RS disjI1) 2,
  14.211 +    etac disjI2 2,
  14.212 +    rewrite_goals_tac [mk_meta_eq iso_swap],
  14.213 +    rtac thm3 1];
  14.214 +in
  14.215 +  val exhaust = pg con_appls (mk_trp exh) tacs;
  14.216 +  val casedist =
  14.217 +    standard (rewrite_rule exh_casedists (exhaust RS exh_casedist0));
  14.218 +end;
  14.219 +
  14.220 +local 
  14.221 +  fun bind_fun t = Library.foldr mk_All (when_funs cons, t);
  14.222 +  fun bound_fun i _ = Bound (length cons - i);
  14.223 +  val when_app = list_ccomb (%%:(dname^"_when"), mapn bound_fun 1 cons);
  14.224 +in
  14.225 +  val when_strict =
  14.226 +    let
  14.227 +      val axs = [when_appl, mk_meta_eq rep_strict];
  14.228 +      val goal = bind_fun (mk_trp (strict when_app));
  14.229 +      val tacs = [resolve_tac [sscase1, ssplit1, strictify1] 1];
  14.230 +    in pg axs goal tacs end;
  14.231 +
  14.232 +  val when_apps =
  14.233 +    let
  14.234 +      fun one_when n (con,args) =
  14.235 +        let
  14.236 +          val axs = when_appl :: con_appls;
  14.237 +          val goal = bind_fun (lift_defined %: (nonlazy args, 
  14.238 +                mk_trp (when_app`(con_app con args) ===
  14.239 +                       list_ccomb (bound_fun n 0, map %# args))));
  14.240 +          val tacs = [asm_simp_tac (HOLCF_ss addsimps [ax_abs_iso]) 1];
  14.241 +        in pg axs goal tacs end;
  14.242 +    in mapn one_when 1 cons end;
  14.243 +end;
  14.244 +val when_rews = when_strict :: when_apps;
  14.245 +
  14.246 +(* ----- theorems concerning the constructors, discriminators and selectors - *)
  14.247 +
  14.248 +local
  14.249 +  fun dis_strict (con, _) =
  14.250 +    let
  14.251 +      val goal = mk_trp (strict (%%:(dis_name con)));
  14.252 +    in pg axs_dis_def goal [rtac when_strict 1] end;
  14.253 +
  14.254 +  fun dis_app c (con, args) =
  14.255 +    let
  14.256 +      val lhs = %%:(dis_name c) ` con_app con args;
  14.257 +      val rhs = %%:(if con = c then TT_N else FF_N);
  14.258 +      val goal = lift_defined %: (nonlazy args, mk_trp (lhs === rhs));
  14.259 +      val tacs = [asm_simp_tac (HOLCF_ss addsimps when_rews) 1];
  14.260 +    in pg axs_dis_def goal tacs end;
  14.261 +
  14.262 +  val dis_apps = List.concat (map (fn (c,_) => map (dis_app c) cons) cons);
  14.263 +
  14.264 +  fun dis_defin (con, args) =
  14.265 +    let
  14.266 +      val goal = defined (%:x_name) ==> defined (%%:(dis_name con) `% x_name);
  14.267 +      val tacs =
  14.268 +        [rtac casedist 1,
  14.269 +         contr_tac 1,
  14.270 +         DETERM_UNTIL_SOLVED (CHANGED
  14.271 +          (asm_simp_tac (HOLCF_ss addsimps dis_apps) 1))];
  14.272 +    in pg [] goal tacs end;
  14.273 +
  14.274 +  val dis_stricts = map dis_strict cons;
  14.275 +  val dis_defins = map dis_defin cons;
  14.276 +in
  14.277 +  val dis_rews = dis_stricts @ dis_defins @ dis_apps;
  14.278 +end;
  14.279 +
  14.280 +local
  14.281 +  fun mat_strict (con, _) =
  14.282 +    let
  14.283 +      val goal = mk_trp (strict (%%:(mat_name con)));
  14.284 +      val tacs = [rtac when_strict 1];
  14.285 +    in pg axs_mat_def goal tacs end;
  14.286 +
  14.287 +  val mat_stricts = map mat_strict cons;
  14.288 +
  14.289 +  fun one_mat c (con, args) =
  14.290 +    let
  14.291 +      val lhs = %%:(mat_name c) ` con_app con args;
  14.292 +      val rhs =
  14.293 +        if con = c
  14.294 +        then %%:returnN ` mk_ctuple (map %# args)
  14.295 +        else %%:failN;
  14.296 +      val goal = lift_defined %: (nonlazy args, mk_trp (lhs === rhs));
  14.297 +      val tacs = [asm_simp_tac (HOLCF_ss addsimps when_rews) 1];
  14.298 +    in pg axs_mat_def goal tacs end;
  14.299 +
  14.300 +  val mat_apps =
  14.301 +    List.concat (map (fn (c,_) => map (one_mat c) cons) cons);
  14.302 +in
  14.303 +  val mat_rews = mat_stricts @ mat_apps;
  14.304 +end;
  14.305 +
  14.306 +local
  14.307 +  fun ps args = mapn (fn n => fn _ => %:("pat" ^ string_of_int n)) 1 args;
  14.308 +
  14.309 +  fun pat_lhs (con,args) = %%:branchN $ list_comb (%%:(pat_name con), ps args);
  14.310 +
  14.311 +  fun pat_rhs (con,[]) = %%:returnN ` ((%:"rhs") ` HOLogic.unit)
  14.312 +    | pat_rhs (con,args) =
  14.313 +        (%%:branchN $ foldr1 cpair_pat (ps args))
  14.314 +          `(%:"rhs")`(mk_ctuple (map %# args));
  14.315 +
  14.316 +  fun pat_strict c =
  14.317 +    let
  14.318 +      val axs = branch_def :: axs_pat_def;
  14.319 +      val goal = mk_trp (strict (pat_lhs c ` (%:"rhs")));
  14.320 +      val tacs = [simp_tac (HOLCF_ss addsimps [when_strict]) 1];
  14.321 +    in pg axs goal tacs end;
  14.322 +
  14.323 +  fun pat_app c (con, args) =
  14.324 +    let
  14.325 +      val axs = branch_def :: axs_pat_def;
  14.326 +      val lhs = (pat_lhs c)`(%:"rhs")`(con_app con args);
  14.327 +      val rhs = if con = fst c then pat_rhs c else %%:failN;
  14.328 +      val goal = lift_defined %: (nonlazy args, mk_trp (lhs === rhs));
  14.329 +      val tacs = [asm_simp_tac (HOLCF_ss addsimps when_rews) 1];
  14.330 +    in pg axs goal tacs end;
  14.331 +
  14.332 +  val pat_stricts = map pat_strict cons;
  14.333 +  val pat_apps = List.concat (map (fn c => map (pat_app c) cons) cons);
  14.334 +in
  14.335 +  val pat_rews = pat_stricts @ pat_apps;
  14.336 +end;
  14.337 +
  14.338 +local
  14.339 +  val rev_contrapos = thm "rev_contrapos";
  14.340 +  fun con_strict (con, args) = 
  14.341 +    let
  14.342 +      fun one_strict vn =
  14.343 +        let
  14.344 +          fun f arg = if vname arg = vn then UU else %# arg;
  14.345 +          val goal = mk_trp (con_app2 con f args === UU);
  14.346 +          val tacs = [asm_simp_tac (HOLCF_ss addsimps [abs_strict]) 1];
  14.347 +        in pg con_appls goal tacs end;
  14.348 +    in map one_strict (nonlazy args) end;
  14.349 +
  14.350 +  fun con_defin (con, args) =
  14.351 +    let
  14.352 +      val concl = mk_trp (defined (con_app con args));
  14.353 +      val goal = lift_defined %: (nonlazy args, concl);
  14.354 +      val tacs = [
  14.355 +        rtac rev_contrapos 1,
  14.356 +        eres_inst_tac [("f",dis_name con)] cfun_arg_cong 1,
  14.357 +        asm_simp_tac (HOLCF_ss addsimps dis_rews) 1];
  14.358 +    in pg [] goal tacs end;
  14.359 +in
  14.360 +  val con_stricts = List.concat (map con_strict cons);
  14.361 +  val con_defins = map con_defin cons;
  14.362 +  val con_rews = con_stricts @ con_defins;
  14.363 +end;
  14.364 +
  14.365 +local
  14.366 +  val rules =
  14.367 +    [compact_sinl, compact_sinr, compact_spair, compact_up, compact_ONE];
  14.368 +  fun con_compact (con, args) =
  14.369 +    let
  14.370 +      val concl = mk_trp (%%:compactN $ con_app con args);
  14.371 +      val goal = lift (fn x => %%:compactN $ %#x) (args, concl);
  14.372 +      val tacs = [
  14.373 +        rtac (iso_locale RS iso_compact_abs) 1,
  14.374 +        REPEAT (resolve_tac rules 1 ORELSE atac 1)];
  14.375 +    in pg con_appls goal tacs end;
  14.376 +in
  14.377 +  val con_compacts = map con_compact cons;
  14.378 +end;
  14.379 +
  14.380 +local
  14.381 +  fun one_sel sel =
  14.382 +    pg axs_sel_def (mk_trp (strict (%%:sel)))
  14.383 +      [simp_tac (HOLCF_ss addsimps when_rews) 1];
  14.384 +
  14.385 +  fun sel_strict (_, args) =
  14.386 +    List.mapPartial (Option.map one_sel o sel_of) args;
  14.387 +in
  14.388 +  val sel_stricts = List.concat (map sel_strict cons);
  14.389 +end;
  14.390 +
  14.391 +local
  14.392 +  fun sel_app_same c n sel (con, args) =
  14.393 +    let
  14.394 +      val nlas = nonlazy args;
  14.395 +      val vns = map vname args;
  14.396 +      val vnn = List.nth (vns, n);
  14.397 +      val nlas' = List.filter (fn v => v <> vnn) nlas;
  14.398 +      val lhs = (%%:sel)`(con_app con args);
  14.399 +      val goal = lift_defined %: (nlas', mk_trp (lhs === %:vnn));
  14.400 +      val tacs1 =
  14.401 +        if vnn mem nlas
  14.402 +        then [case_UU_tac (when_rews @ con_stricts) 1 vnn]
  14.403 +        else [];
  14.404 +      val tacs2 = [asm_simp_tac (HOLCF_ss addsimps when_rews) 1];
  14.405 +    in pg axs_sel_def goal (tacs1 @ tacs2) end;
  14.406 +
  14.407 +  fun sel_app_diff c n sel (con, args) =
  14.408 +    let
  14.409 +      val nlas = nonlazy args;
  14.410 +      val goal = mk_trp (%%:sel ` con_app con args === UU);
  14.411 +      val tacs1 = map (case_UU_tac (when_rews @ con_stricts) 1) nlas;
  14.412 +      val tacs2 = [asm_simp_tac (HOLCF_ss addsimps when_rews) 1];
  14.413 +    in pg axs_sel_def goal (tacs1 @ tacs2) end;
  14.414 +
  14.415 +  fun sel_app c n sel (con, args) =
  14.416 +    if con = c
  14.417 +    then sel_app_same c n sel (con, args)
  14.418 +    else sel_app_diff c n sel (con, args);
  14.419 +
  14.420 +  fun one_sel c n sel = map (sel_app c n sel) cons;
  14.421 +  fun one_sel' c n arg = Option.map (one_sel c n) (sel_of arg);
  14.422 +  fun one_con (c, args) =
  14.423 +    List.concat (List.mapPartial I (mapn (one_sel' c) 0 args));
  14.424 +in
  14.425 +  val sel_apps = List.concat (map one_con cons);
  14.426 +end;
  14.427 +
  14.428 +local
  14.429 +  fun sel_defin sel =
  14.430 +    let
  14.431 +      val goal = defined (%:x_name) ==> defined (%%:sel`%x_name);
  14.432 +      val tacs = [
  14.433 +        rtac casedist 1,
  14.434 +        contr_tac 1,
  14.435 +        DETERM_UNTIL_SOLVED (CHANGED
  14.436 +          (asm_simp_tac (HOLCF_ss addsimps sel_apps) 1))];
  14.437 +    in pg [] goal tacs end;
  14.438 +in
  14.439 +  val sel_defins =
  14.440 +    if length cons = 1
  14.441 +    then List.mapPartial (fn arg => Option.map sel_defin (sel_of arg))
  14.442 +                 (filter_out is_lazy (snd (hd cons)))
  14.443 +    else [];
  14.444 +end;
  14.445 +
  14.446 +val sel_rews = sel_stricts @ sel_defins @ sel_apps;
  14.447 +val rev_contrapos = thm "rev_contrapos";
  14.448 +
  14.449 +val distincts_le =
  14.450 +  let
  14.451 +    fun dist (con1, args1) (con2, args2) =
  14.452 +      let
  14.453 +        val goal = lift_defined %: (nonlazy args1,
  14.454 +                        mk_trp (con_app con1 args1 ~<< con_app con2 args2));
  14.455 +        val tacs = [
  14.456 +          rtac rev_contrapos 1,
  14.457 +          eres_inst_tac [("f", dis_name con1)] monofun_cfun_arg 1]
  14.458 +          @ map (case_UU_tac (con_stricts @ dis_rews) 1) (nonlazy args2)
  14.459 +          @ [asm_simp_tac (HOLCF_ss addsimps dis_rews) 1];
  14.460 +      in pg [] goal tacs end;
  14.461 +
  14.462 +    fun distinct (con1, args1) (con2, args2) =
  14.463 +        let
  14.464 +          val arg1 = (con1, args1);
  14.465 +          val arg2 =
  14.466 +            (con2, ListPair.map (fn (arg,vn) => upd_vname (K vn) arg)
  14.467 +              (args2, Name.variant_list (map vname args1) (map vname args2)));
  14.468 +        in [dist arg1 arg2, dist arg2 arg1] end;
  14.469 +    fun distincts []      = []
  14.470 +      | distincts (c::cs) = (map (distinct c) cs) :: distincts cs;
  14.471 +  in distincts cons end;
  14.472 +val dist_les = List.concat (List.concat distincts_le);
  14.473 +val dist_eqs =
  14.474 +  let
  14.475 +    fun distinct (_,args1) ((_,args2), leqs) =
  14.476 +      let
  14.477 +        val (le1,le2) = (hd leqs, hd(tl leqs));
  14.478 +        val (eq1,eq2) = (le1 RS dist_eqI, le2 RS dist_eqI)
  14.479 +      in
  14.480 +        if nonlazy args1 = [] then [eq1, eq1 RS not_sym] else
  14.481 +        if nonlazy args2 = [] then [eq2, eq2 RS not_sym] else
  14.482 +          [eq1, eq2]
  14.483 +      end;
  14.484 +    fun distincts []      = []
  14.485 +      | distincts ((c,leqs)::cs) = List.concat
  14.486 +	            (ListPair.map (distinct c) ((map #1 cs),leqs)) @
  14.487 +		    distincts cs;
  14.488 +  in map standard (distincts (cons ~~ distincts_le)) end;
  14.489 +
  14.490 +local 
  14.491 +  fun pgterm rel con args =
  14.492 +    let
  14.493 +      fun append s = upd_vname (fn v => v^s);
  14.494 +      val (largs, rargs) = (args, map (append "'") args);
  14.495 +      val concl =
  14.496 +        foldr1 mk_conj (ListPair.map rel (map %# largs, map %# rargs));
  14.497 +      val prem = rel (con_app con largs, con_app con rargs);
  14.498 +      val sargs = case largs of [_] => [] | _ => nonlazy args;
  14.499 +      val prop = lift_defined %: (sargs, mk_trp (prem === concl));
  14.500 +    in pg con_appls prop end;
  14.501 +  val cons' = List.filter (fn (_,args) => args<>[]) cons;
  14.502 +in
  14.503 +  val inverts =
  14.504 +    let
  14.505 +      val abs_less = ax_abs_iso RS (allI RS injection_less);
  14.506 +      val tacs =
  14.507 +        [asm_full_simp_tac (HOLCF_ss addsimps [abs_less, spair_less]) 1];
  14.508 +    in map (fn (con, args) => pgterm (op <<) con args tacs) cons' end;
  14.509 +
  14.510 +  val injects =
  14.511 +    let
  14.512 +      val abs_eq = ax_abs_iso RS (allI RS injection_eq);
  14.513 +      val tacs = [asm_full_simp_tac (HOLCF_ss addsimps [abs_eq, spair_eq]) 1];
  14.514 +    in map (fn (con, args) => pgterm (op ===) con args tacs) cons' end;
  14.515 +end;
  14.516 +
  14.517 +(* ----- theorems concerning one induction step ----------------------------- *)
  14.518 +
  14.519 +val copy_strict =
  14.520 +  let
  14.521 +    val goal = mk_trp (strict (dc_copy `% "f"));
  14.522 +    val tacs = [asm_simp_tac (HOLCF_ss addsimps [abs_strict, when_strict]) 1];
  14.523 +  in pg [ax_copy_def] goal tacs end;
  14.524 +
  14.525 +local
  14.526 +  fun copy_app (con, args) =
  14.527 +    let
  14.528 +      val lhs = dc_copy`%"f"`(con_app con args);
  14.529 +      val rhs = con_app2 con (app_rec_arg (cproj (%:"f") eqs)) args;
  14.530 +      val goal = lift_defined %: (nonlazy_rec args, mk_trp (lhs === rhs));
  14.531 +      val args' = List.filter (fn a => not (is_rec a orelse is_lazy a)) args;
  14.532 +      val stricts = abs_strict::when_strict::con_stricts;
  14.533 +      val tacs1 = map (case_UU_tac stricts 1 o vname) args';
  14.534 +      val tacs2 = [asm_simp_tac (HOLCF_ss addsimps when_apps) 1];
  14.535 +    in pg [ax_copy_def] goal (tacs1 @ tacs2) end;
  14.536 +in
  14.537 +  val copy_apps = map copy_app cons;
  14.538 +end;
  14.539 +
  14.540 +local
  14.541 +  fun one_strict (con, args) = 
  14.542 +    let
  14.543 +      val goal = mk_trp (dc_copy`UU`(con_app con args) === UU);
  14.544 +      val rews = copy_strict :: copy_apps @ con_rews;
  14.545 +      val tacs = map (case_UU_tac rews 1) (nonlazy args) @
  14.546 +        [asm_simp_tac (HOLCF_ss addsimps rews) 1];
  14.547 +    in pg [] goal tacs end;
  14.548 +
  14.549 +  fun has_nonlazy_rec (_, args) = exists is_nonlazy_rec args;
  14.550 +in
  14.551 +  val copy_stricts = map one_strict (List.filter has_nonlazy_rec cons);
  14.552 +end;
  14.553 +
  14.554 +val copy_rews = copy_strict :: copy_apps @ copy_stricts;
  14.555 +
  14.556 +in
  14.557 +  thy
  14.558 +    |> Theory.add_path (Sign.base_name dname)
  14.559 +    |> (snd o (PureThy.add_thmss (map Thm.no_attributes [
  14.560 +        ("iso_rews" , iso_rews  ),
  14.561 +        ("exhaust"  , [exhaust] ),
  14.562 +        ("casedist" , [casedist]),
  14.563 +        ("when_rews", when_rews ),
  14.564 +        ("compacts", con_compacts),
  14.565 +        ("con_rews", con_rews),
  14.566 +        ("sel_rews", sel_rews),
  14.567 +        ("dis_rews", dis_rews),
  14.568 +        ("pat_rews", pat_rews),
  14.569 +        ("dist_les", dist_les),
  14.570 +        ("dist_eqs", dist_eqs),
  14.571 +        ("inverts" , inverts ),
  14.572 +        ("injects" , injects ),
  14.573 +        ("copy_rews", copy_rews)])))
  14.574 +    |> (snd o PureThy.add_thmss
  14.575 +        [(("match_rews", mat_rews), [Simplifier.simp_add])])
  14.576 +    |> Theory.parent_path
  14.577 +    |> rpair (iso_rews @ when_rews @ con_rews @ sel_rews @ dis_rews @
  14.578 +        pat_rews @ dist_les @ dist_eqs @ copy_rews)
  14.579 +end; (* let *)
  14.580 +
  14.581 +fun comp_theorems (comp_dnam, eqs: eq list) thy =
  14.582 +let
  14.583 +val dnames = map (fst o fst) eqs;
  14.584 +val conss  = map  snd        eqs;
  14.585 +val comp_dname = Sign.full_name thy comp_dnam;
  14.586 +
  14.587 +val d = writeln("Proving induction properties of domain "^comp_dname^" ...");
  14.588 +val pg = pg' thy;
  14.589 +
  14.590 +(* ----- getting the composite axiom and definitions ------------------------ *)
  14.591 +
  14.592 +local
  14.593 +  fun ga s dn = get_thm thy (Name (dn ^ "." ^ s));
  14.594 +in
  14.595 +  val axs_reach      = map (ga "reach"     ) dnames;
  14.596 +  val axs_take_def   = map (ga "take_def"  ) dnames;
  14.597 +  val axs_finite_def = map (ga "finite_def") dnames;
  14.598 +  val ax_copy2_def   =      ga "copy_def"  comp_dnam;
  14.599 +  val ax_bisim_def   =      ga "bisim_def" comp_dnam;
  14.600 +end;
  14.601 +
  14.602 +local
  14.603 +  fun gt  s dn = get_thm  thy (Name (dn ^ "." ^ s));
  14.604 +  fun gts s dn = get_thms thy (Name (dn ^ "." ^ s));
  14.605 +in
  14.606 +  val cases = map (gt  "casedist" ) dnames;
  14.607 +  val con_rews  = List.concat (map (gts "con_rews" ) dnames);
  14.608 +  val copy_rews = List.concat (map (gts "copy_rews") dnames);
  14.609 +end;
  14.610 +
  14.611 +fun dc_take dn = %%:(dn^"_take");
  14.612 +val x_name = idx_name dnames "x"; 
  14.613 +val P_name = idx_name dnames "P";
  14.614 +val n_eqs = length eqs;
  14.615 +
  14.616 +(* ----- theorems concerning finite approximation and finite induction ------ *)
  14.617 +
  14.618 +local
  14.619 +  val iterate_Cprod_ss = simpset_of (theory "Fix");
  14.620 +  val copy_con_rews  = copy_rews @ con_rews;
  14.621 +  val copy_take_defs =
  14.622 +    (if n_eqs = 1 then [] else [ax_copy2_def]) @ axs_take_def;
  14.623 +  val take_stricts =
  14.624 +    let
  14.625 +      fun one_eq ((dn, args), _) = strict (dc_take dn $ %:"n");
  14.626 +      val goal = mk_trp (foldr1 mk_conj (map one_eq eqs));
  14.627 +      val tacs = [
  14.628 +        induct_tac "n" 1,
  14.629 +        simp_tac iterate_Cprod_ss 1,
  14.630 +        asm_simp_tac (iterate_Cprod_ss addsimps copy_rews) 1];
  14.631 +    in pg copy_take_defs goal tacs end;
  14.632 +
  14.633 +  val take_stricts' = rewrite_rule copy_take_defs take_stricts;
  14.634 +  fun take_0 n dn =
  14.635 +    let
  14.636 +      val goal = mk_trp ((dc_take dn $ %%:"HOL.zero") `% x_name n === UU);
  14.637 +    in pg axs_take_def goal [simp_tac iterate_Cprod_ss 1] end;
  14.638 +  val take_0s = mapn take_0 1 dnames;
  14.639 +  val c_UU_tac = case_UU_tac (take_stricts'::copy_con_rews) 1;
  14.640 +  val take_apps =
  14.641 +    let
  14.642 +      fun mk_eqn dn (con, args) =
  14.643 +        let
  14.644 +          fun mk_take n = dc_take (List.nth (dnames, n)) $ %:"n";
  14.645 +          val lhs = (dc_take dn $ (%%:"Suc" $ %:"n"))`(con_app con args);
  14.646 +          val rhs = con_app2 con (app_rec_arg mk_take) args;
  14.647 +        in Library.foldr mk_all (map vname args, lhs === rhs) end;
  14.648 +      fun mk_eqns ((dn, _), cons) = map (mk_eqn dn) cons;
  14.649 +      val goal = mk_trp (foldr1 mk_conj (List.concat (map mk_eqns eqs)));
  14.650 +      val simps = List.filter (has_fewer_prems 1) copy_rews;
  14.651 +      fun con_tac (con, args) =
  14.652 +        if nonlazy_rec args = []
  14.653 +        then all_tac
  14.654 +        else EVERY (map c_UU_tac (nonlazy_rec args)) THEN
  14.655 +          asm_full_simp_tac (HOLCF_ss addsimps copy_rews) 1;
  14.656 +      fun eq_tacs ((dn, _), cons) = map con_tac cons;
  14.657 +      val tacs =
  14.658 +        simp_tac iterate_Cprod_ss 1 ::
  14.659 +        induct_tac "n" 1 ::
  14.660 +        simp_tac (iterate_Cprod_ss addsimps copy_con_rews) 1 ::
  14.661 +        asm_full_simp_tac (HOLCF_ss addsimps simps) 1 ::
  14.662 +        TRY (safe_tac HOL_cs) ::
  14.663 +        List.concat (map eq_tacs eqs);
  14.664 +    in pg copy_take_defs goal tacs end;
  14.665 +in
  14.666 +  val take_rews = map standard
  14.667 +    (atomize take_stricts @ take_0s @ atomize take_apps);
  14.668 +end; (* local *)
  14.669 +
  14.670 +local
  14.671 +  fun one_con p (con,args) =
  14.672 +    let
  14.673 +      fun ind_hyp arg = %:(P_name (1 + rec_of arg)) $ bound_arg args arg;
  14.674 +      val t1 = mk_trp (%:p $ con_app2 con (bound_arg args) args);
  14.675 +      val t2 = lift ind_hyp (List.filter is_rec args, t1);
  14.676 +      val t3 = lift_defined (bound_arg (map vname args)) (nonlazy args, t2);
  14.677 +    in Library.foldr mk_All (map vname args, t3) end;
  14.678 +
  14.679 +  fun one_eq ((p, cons), concl) =
  14.680 +    mk_trp (%:p $ UU) ===> Logic.list_implies (map (one_con p) cons, concl);
  14.681 +
  14.682 +  fun ind_term concf = Library.foldr one_eq
  14.683 +    (mapn (fn n => fn x => (P_name n, x)) 1 conss,
  14.684 +     mk_trp (foldr1 mk_conj (mapn concf 1 dnames)));
  14.685 +  val take_ss = HOL_ss addsimps take_rews;
  14.686 +  fun quant_tac i = EVERY
  14.687 +    (mapn (fn n => fn _ => res_inst_tac [("x", x_name n)] spec i) 1 dnames);
  14.688 +
  14.689 +  fun ind_prems_tac prems = EVERY
  14.690 +    (List.concat (map (fn cons =>
  14.691 +      (resolve_tac prems 1 ::
  14.692 +        List.concat (map (fn (_,args) => 
  14.693 +          resolve_tac prems 1 ::
  14.694 +          map (K(atac 1)) (nonlazy args) @
  14.695 +          map (K(atac 1)) (List.filter is_rec args))
  14.696 +        cons)))
  14.697 +      conss));
  14.698 +  local 
  14.699 +    (* check whether every/exists constructor of the n-th part of the equation:
  14.700 +       it has a possibly indirectly recursive argument that isn't/is possibly 
  14.701 +       indirectly lazy *)
  14.702 +    fun rec_to quant nfn rfn ns lazy_rec (n,cons) = quant (exists (fn arg => 
  14.703 +          is_rec arg andalso not(rec_of arg mem ns) andalso
  14.704 +          ((rec_of arg =  n andalso nfn(lazy_rec orelse is_lazy arg)) orelse 
  14.705 +            rec_of arg <> n andalso rec_to quant nfn rfn (rec_of arg::ns) 
  14.706 +              (lazy_rec orelse is_lazy arg) (n, (List.nth(conss,rec_of arg))))
  14.707 +          ) o snd) cons;
  14.708 +    fun all_rec_to ns  = rec_to forall not all_rec_to  ns;
  14.709 +    fun warn (n,cons) =
  14.710 +      if all_rec_to [] false (n,cons)
  14.711 +      then (warning ("domain "^List.nth(dnames,n)^" is empty!"); true)
  14.712 +      else false;
  14.713 +    fun lazy_rec_to ns = rec_to exists I  lazy_rec_to ns;
  14.714 +
  14.715 +  in
  14.716 +    val n__eqs = mapn (fn n => fn (_,cons) => (n,cons)) 0 eqs;
  14.717 +    val is_emptys = map warn n__eqs;
  14.718 +    val is_finite = forall (not o lazy_rec_to [] false) n__eqs;
  14.719 +  end;
  14.720 +in (* local *)
  14.721 +  val finite_ind =
  14.722 +    let
  14.723 +      fun concf n dn = %:(P_name n) $ (dc_take dn $ %:"n" `%(x_name n));
  14.724 +      val goal = ind_term concf;
  14.725 +
  14.726 +      fun tacf prems =
  14.727 +        let
  14.728 +          val tacs1 = [
  14.729 +            quant_tac 1,
  14.730 +            simp_tac HOL_ss 1,
  14.731 +            induct_tac "n" 1,
  14.732 +            simp_tac (take_ss addsimps prems) 1,
  14.733 +            TRY (safe_tac HOL_cs)];
  14.734 +          fun arg_tac arg =
  14.735 +            case_UU_tac (prems @ con_rews) 1
  14.736 +              (List.nth (dnames, rec_of arg) ^ "_take n$" ^ vname arg);
  14.737 +          fun con_tacs (con, args) = 
  14.738 +            asm_simp_tac take_ss 1 ::
  14.739 +            map arg_tac (List.filter is_nonlazy_rec args) @
  14.740 +            [resolve_tac prems 1] @
  14.741 +            map (K (atac 1))      (nonlazy args) @
  14.742 +            map (K (etac spec 1)) (List.filter is_rec args);
  14.743 +          fun cases_tacs (cons, cases) =
  14.744 +            res_inst_tac [("x","x")] cases 1 ::
  14.745 +            asm_simp_tac (take_ss addsimps prems) 1 ::
  14.746 +            List.concat (map con_tacs cons);
  14.747 +        in
  14.748 +          tacs1 @ List.concat (map cases_tacs (conss ~~ cases))
  14.749 +        end;
  14.750 +    in pg'' thy [] goal tacf end;
  14.751 +
  14.752 +  val take_lemmas =
  14.753 +    let
  14.754 +      fun take_lemma n (dn, ax_reach) =
  14.755 +        let
  14.756 +          val lhs = dc_take dn $ Bound 0 `%(x_name n);
  14.757 +          val rhs = dc_take dn $ Bound 0 `%(x_name n^"'");
  14.758 +          val concl = mk_trp (%:(x_name n) === %:(x_name n^"'"));
  14.759 +          val goal = mk_All ("n", mk_trp (lhs === rhs)) ===> concl;
  14.760 +          fun tacf prems = [
  14.761 +            res_inst_tac [("t", x_name n    )] (ax_reach RS subst) 1,
  14.762 +            res_inst_tac [("t", x_name n^"'")] (ax_reach RS subst) 1,
  14.763 +            stac fix_def2 1,
  14.764 +            REPEAT (CHANGED
  14.765 +              (rtac (contlub_cfun_arg RS ssubst) 1 THEN chain_tac 1)),
  14.766 +            stac contlub_cfun_fun 1,
  14.767 +            stac contlub_cfun_fun 2,
  14.768 +            rtac lub_equal 3,
  14.769 +            chain_tac 1,
  14.770 +            rtac allI 1,
  14.771 +            resolve_tac prems 1];
  14.772 +        in pg'' thy axs_take_def goal tacf end;
  14.773 +    in mapn take_lemma 1 (dnames ~~ axs_reach) end;
  14.774 +
  14.775 +(* ----- theorems concerning finiteness and induction ----------------------- *)
  14.776 +
  14.777 +  val (finites, ind) =
  14.778 +    if is_finite
  14.779 +    then (* finite case *)
  14.780 +      let 
  14.781 +        fun take_enough dn = mk_ex ("n",dc_take dn $ Bound 0 ` %:"x" === %:"x");
  14.782 +        fun dname_lemma dn =
  14.783 +          let
  14.784 +            val prem1 = mk_trp (defined (%:"x"));
  14.785 +            val disj1 = mk_all ("n", dc_take dn $ Bound 0 ` %:"x" === UU);
  14.786 +            val prem2 = mk_trp (mk_disj (disj1, take_enough dn));
  14.787 +            val concl = mk_trp (take_enough dn);
  14.788 +            val goal = prem1 ===> prem2 ===> concl;
  14.789 +            val tacs = [
  14.790 +              etac disjE 1,
  14.791 +              etac notE 1,
  14.792 +              resolve_tac take_lemmas 1,
  14.793 +              asm_simp_tac take_ss 1,
  14.794 +              atac 1];
  14.795 +          in pg [] goal tacs end;
  14.796 +        val finite_lemmas1a = map dname_lemma dnames;
  14.797 + 
  14.798 +        val finite_lemma1b =
  14.799 +          let
  14.800 +            fun mk_eqn n ((dn, args), _) =
  14.801 +              let
  14.802 +                val disj1 = dc_take dn $ Bound 1 ` Bound 0 === UU;
  14.803 +                val disj2 = dc_take dn $ Bound 1 ` Bound 0 === Bound 0;
  14.804 +              in
  14.805 +                mk_constrainall
  14.806 +                  (x_name n, Type (dn,args), mk_disj (disj1, disj2))
  14.807 +              end;
  14.808 +            val goal =
  14.809 +              mk_trp (mk_all ("n", foldr1 mk_conj (mapn mk_eqn 1 eqs)));
  14.810 +            fun arg_tacs vn = [
  14.811 +              eres_inst_tac [("x", vn)] all_dupE 1,
  14.812 +              etac disjE 1,
  14.813 +              asm_simp_tac (HOL_ss addsimps con_rews) 1,
  14.814 +              asm_simp_tac take_ss 1];
  14.815 +            fun con_tacs (con, args) =
  14.816 +              asm_simp_tac take_ss 1 ::
  14.817 +              List.concat (map arg_tacs (nonlazy_rec args));
  14.818 +            fun foo_tacs n (cons, cases) =
  14.819 +              simp_tac take_ss 1 ::
  14.820 +              rtac allI 1 ::
  14.821 +              res_inst_tac [("x",x_name n)] cases 1 ::
  14.822 +              asm_simp_tac take_ss 1 ::
  14.823 +              List.concat (map con_tacs cons);
  14.824 +            val tacs =
  14.825 +              rtac allI 1 ::
  14.826 +              induct_tac "n" 1 ::
  14.827 +              simp_tac take_ss 1 ::
  14.828 +              TRY (safe_tac (empty_cs addSEs [conjE] addSIs [conjI])) ::
  14.829 +              List.concat (mapn foo_tacs 1 (conss ~~ cases));
  14.830 +          in pg [] goal tacs end;
  14.831 +
  14.832 +        fun one_finite (dn, l1b) =
  14.833 +          let
  14.834 +            val goal = mk_trp (%%:(dn^"_finite") $ %:"x");
  14.835 +            val tacs = [
  14.836 +              case_UU_tac take_rews 1 "x",
  14.837 +              eresolve_tac finite_lemmas1a 1,
  14.838 +              step_tac HOL_cs 1,
  14.839 +              step_tac HOL_cs 1,
  14.840 +              cut_facts_tac [l1b] 1,
  14.841 +              fast_tac HOL_cs 1];
  14.842 +          in pg axs_finite_def goal tacs end;
  14.843 +
  14.844 +        val finites = map one_finite (dnames ~~ atomize finite_lemma1b);
  14.845 +        val ind =
  14.846 +          let
  14.847 +            fun concf n dn = %:(P_name n) $ %:(x_name n);
  14.848 +            fun tacf prems =
  14.849 +              let
  14.850 +                fun finite_tacs (finite, fin_ind) = [
  14.851 +                  rtac(rewrite_rule axs_finite_def finite RS exE)1,
  14.852 +                  etac subst 1,
  14.853 +                  rtac fin_ind 1,
  14.854 +                  ind_prems_tac prems];
  14.855 +              in
  14.856 +                TRY (safe_tac HOL_cs) ::
  14.857 +                List.concat (map finite_tacs (finites ~~ atomize finite_ind))
  14.858 +              end;
  14.859 +          in pg'' thy [] (ind_term concf) tacf end;
  14.860 +      in (finites, ind) end (* let *)
  14.861 +
  14.862 +    else (* infinite case *)
  14.863 +      let
  14.864 +        fun one_finite n dn =
  14.865 +          read_instantiate_sg thy
  14.866 +            [("P",dn^"_finite "^x_name n)] excluded_middle;
  14.867 +        val finites = mapn one_finite 1 dnames;
  14.868 +
  14.869 +        val goal =
  14.870 +          let
  14.871 +            fun one_adm n _ = mk_trp (%%:admN $ %:(P_name n));
  14.872 +            fun concf n dn = %:(P_name n) $ %:(x_name n);
  14.873 +          in Logic.list_implies (mapn one_adm 1 dnames, ind_term concf) end;
  14.874 +        fun tacf prems =
  14.875 +          map (fn ax_reach => rtac (ax_reach RS subst) 1) axs_reach @ [
  14.876 +          quant_tac 1,
  14.877 +          rtac (adm_impl_admw RS wfix_ind) 1,
  14.878 +          REPEAT_DETERM (rtac adm_all2 1),
  14.879 +          REPEAT_DETERM (
  14.880 +            TRY (rtac adm_conj 1) THEN 
  14.881 +            rtac adm_subst 1 THEN 
  14.882 +            cont_tacR 1 THEN resolve_tac prems 1),
  14.883 +          strip_tac 1,
  14.884 +          rtac (rewrite_rule axs_take_def finite_ind) 1,
  14.885 +          ind_prems_tac prems];
  14.886 +        val ind = (pg'' thy [] goal tacf
  14.887 +          handle ERROR _ =>
  14.888 +            (warning "Cannot prove infinite induction rule"; refl));
  14.889 +      in (finites, ind) end;
  14.890 +end; (* local *)
  14.891 +
  14.892 +(* ----- theorem concerning coinduction ------------------------------------- *)
  14.893 +
  14.894 +local
  14.895 +  val xs = mapn (fn n => K (x_name n)) 1 dnames;
  14.896 +  fun bnd_arg n i = Bound(2*(n_eqs - n)-i-1);
  14.897 +  val take_ss = HOL_ss addsimps take_rews;
  14.898 +  val sproj = prj (fn s => K("fst("^s^")")) (fn s => K("snd("^s^")"));
  14.899 +  val coind_lemma =
  14.900 +    let
  14.901 +      fun mk_prj n _ = proj (%:"R") eqs n $ bnd_arg n 0 $ bnd_arg n 1;
  14.902 +      fun mk_eqn n dn =
  14.903 +        (dc_take dn $ %:"n" ` bnd_arg n 0) ===
  14.904 +        (dc_take dn $ %:"n" ` bnd_arg n 1);
  14.905 +      fun mk_all2 (x,t) = mk_all (x, mk_all (x^"'", t));
  14.906 +      val goal =
  14.907 +        mk_trp (mk_imp (%%:(comp_dname^"_bisim") $ %:"R",
  14.908 +          Library.foldr mk_all2 (xs,
  14.909 +            Library.foldr mk_imp (mapn mk_prj 0 dnames,
  14.910 +              foldr1 mk_conj (mapn mk_eqn 0 dnames)))));
  14.911 +      fun x_tacs n x = [
  14.912 +        rotate_tac (n+1) 1,
  14.913 +        etac all2E 1,
  14.914 +        eres_inst_tac [("P1", sproj "R" eqs n^" "^x^" "^x^"'")] (mp RS disjE) 1,
  14.915 +        TRY (safe_tac HOL_cs),
  14.916 +        REPEAT (CHANGED (asm_simp_tac take_ss 1))];
  14.917 +      val tacs = [
  14.918 +        rtac impI 1,
  14.919 +        induct_tac "n" 1,
  14.920 +        simp_tac take_ss 1,
  14.921 +        safe_tac HOL_cs] @
  14.922 +        List.concat (mapn x_tacs 0 xs);
  14.923 +    in pg [ax_bisim_def] goal tacs end;
  14.924 +in
  14.925 +  val coind = 
  14.926 +    let
  14.927 +      fun mk_prj n x = mk_trp (proj (%:"R") eqs n $ %:x $ %:(x^"'"));
  14.928 +      fun mk_eqn x = %:x === %:(x^"'");
  14.929 +      val goal =
  14.930 +        mk_trp (%%:(comp_dname^"_bisim") $ %:"R") ===>
  14.931 +          Logic.list_implies (mapn mk_prj 0 xs,
  14.932 +            mk_trp (foldr1 mk_conj (map mk_eqn xs)));
  14.933 +      val tacs =
  14.934 +        TRY (safe_tac HOL_cs) ::
  14.935 +        List.concat (map (fn take_lemma => [
  14.936 +          rtac take_lemma 1,
  14.937 +          cut_facts_tac [coind_lemma] 1,
  14.938 +          fast_tac HOL_cs 1])
  14.939 +        take_lemmas);
  14.940 +    in pg [] goal tacs end;
  14.941 +end; (* local *)
  14.942 +
  14.943 +in thy |> Theory.add_path comp_dnam
  14.944 +       |> (snd o (PureThy.add_thmss (map Thm.no_attributes [
  14.945 +		("take_rews"  , take_rews  ),
  14.946 +		("take_lemmas", take_lemmas),
  14.947 +		("finites"    , finites    ),
  14.948 +		("finite_ind", [finite_ind]),
  14.949 +		("ind"       , [ind       ]),
  14.950 +		("coind"     , [coind     ])])))
  14.951 +       |> Theory.parent_path |> rpair take_rews
  14.952 +end; (* let *)
  14.953 +end; (* local *)
  14.954 +end; (* struct *)
    15.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    15.2 +++ b/src/HOLCF/Tools/fixrec_package.ML	Thu May 31 14:01:58 2007 +0200
    15.3 @@ -0,0 +1,317 @@
    15.4 +(*  Title:      HOLCF/Tools/fixrec_package.ML
    15.5 +    ID:         $Id$
    15.6 +    Author:     Amber Telfer and Brian Huffman
    15.7 +
    15.8 +Recursive function definition package for HOLCF.
    15.9 +*)
   15.10 +
   15.11 +signature FIXREC_PACKAGE =
   15.12 +sig
   15.13 +  val legacy_infer_term: theory -> term -> term
   15.14 +  val legacy_infer_prop: theory -> term -> term
   15.15 +  val add_fixrec: bool -> ((string * Attrib.src list) * string) list list -> theory -> theory
   15.16 +  val add_fixrec_i: bool -> ((string * attribute list) * term) list list -> theory -> theory
   15.17 +  val add_fixpat: (string * Attrib.src list) * string list -> theory -> theory
   15.18 +  val add_fixpat_i: (string * attribute list) * term list -> theory -> theory
   15.19 +end;
   15.20 +
   15.21 +structure FixrecPackage: FIXREC_PACKAGE =
   15.22 +struct
   15.23 +
   15.24 +(* legacy type inference *)
   15.25 +
   15.26 +fun legacy_infer_term thy t =
   15.27 +  singleton (ProofContext.infer_types (ProofContext.init thy)) (Sign.intern_term thy t);
   15.28 +
   15.29 +fun legacy_infer_prop thy t = legacy_infer_term thy (TypeInfer.constrain t propT);
   15.30 +
   15.31 +
   15.32 +val fix_eq2 = thm "fix_eq2";
   15.33 +val def_fix_ind = thm "def_fix_ind";
   15.34 +
   15.35 +
   15.36 +fun fixrec_err s = error ("fixrec definition error:\n" ^ s);
   15.37 +fun fixrec_eq_err thy s eq =
   15.38 +  fixrec_err (s ^ "\nin\n" ^ quote (Sign.string_of_term thy eq));
   15.39 +
   15.40 +(* ->> is taken from holcf_logic.ML *)
   15.41 +(* TODO: fix dependencies so we can import HOLCFLogic here *)
   15.42 +infixr 6 ->>;
   15.43 +fun S ->> T = Type ("Cfun.->",[S,T]);
   15.44 +
   15.45 +(* extern_name is taken from domain/library.ML *)
   15.46 +fun extern_name con = case Symbol.explode con of 
   15.47 +		   ("o"::"p"::" "::rest) => implode rest
   15.48 +		   | _ => con;
   15.49 +
   15.50 +val mk_trp = HOLogic.mk_Trueprop;
   15.51 +
   15.52 +(* splits a cterm into the right and lefthand sides of equality *)
   15.53 +fun dest_eqs t = HOLogic.dest_eq (HOLogic.dest_Trueprop t);
   15.54 +
   15.55 +(* similar to Thm.head_of, but for continuous application *)
   15.56 +fun chead_of (Const("Cfun.Rep_CFun",_)$f$t) = chead_of f
   15.57 +  | chead_of u = u;
   15.58 +
   15.59 +(* these are helpful functions copied from HOLCF/domain/library.ML *)
   15.60 +fun %: s = Free(s,dummyT);
   15.61 +fun %%: s = Const(s,dummyT);
   15.62 +infix 0 ==;  fun S ==  T = %%:"==" $ S $ T;
   15.63 +infix 1 ===; fun S === T = %%:"op =" $ S $ T;
   15.64 +infix 9 `  ; fun f ` x = %%:"Cfun.Rep_CFun" $ f $ x;
   15.65 +
   15.66 +(* builds the expression (LAM v. rhs) *)
   15.67 +fun big_lambda v rhs = %%:"Cfun.Abs_CFun"$(Term.lambda v rhs);
   15.68 +
   15.69 +(* builds the expression (LAM v1 v2 .. vn. rhs) *)
   15.70 +fun big_lambdas [] rhs = rhs
   15.71 +  | big_lambdas (v::vs) rhs = big_lambda v (big_lambdas vs rhs);
   15.72 +
   15.73 +(* builds the expression (LAM <v1,v2,..,vn>. rhs) *)
   15.74 +fun lambda_ctuple [] rhs = big_lambda (%:"unit") rhs
   15.75 +  | lambda_ctuple (v::[]) rhs = big_lambda v rhs
   15.76 +  | lambda_ctuple (v::vs) rhs =
   15.77 +      %%:"Cprod.csplit"`(big_lambda v (lambda_ctuple vs rhs));
   15.78 +
   15.79 +(* builds the expression <v1,v2,..,vn> *)
   15.80 +fun mk_ctuple [] = %%:"UU"
   15.81 +|   mk_ctuple (t::[]) = t
   15.82 +|   mk_ctuple (t::ts) = %%:"Cprod.cpair"`t`(mk_ctuple ts);
   15.83 +
   15.84 +(*************************************************************************)
   15.85 +(************* fixed-point definitions and unfolding theorems ************)
   15.86 +(*************************************************************************)
   15.87 +
   15.88 +fun add_fixdefs eqs thy =
   15.89 +  let
   15.90 +    val (lhss,rhss) = ListPair.unzip (map dest_eqs eqs);
   15.91 +    val fixpoint = %%:"Fix.fix"`lambda_ctuple lhss (mk_ctuple rhss);
   15.92 +    
   15.93 +    fun one_def (l as Const(n,T)) r =
   15.94 +          let val b = Sign.base_name n in (b, (b^"_def", l == r)) end
   15.95 +      | one_def _ _ = fixrec_err "fixdefs: lhs not of correct form";
   15.96 +    fun defs [] _ = []
   15.97 +      | defs (l::[]) r = [one_def l r]
   15.98 +      | defs (l::ls) r = one_def l (%%:"Cprod.cfst"`r) :: defs ls (%%:"Cprod.csnd"`r);
   15.99 +    val (names, pre_fixdefs) = ListPair.unzip (defs lhss fixpoint);
  15.100 +    
  15.101 +    val fixdefs = map (apsnd (legacy_infer_prop thy)) pre_fixdefs;
  15.102 +    val (fixdef_thms, thy') =
  15.103 +      PureThy.add_defs_i false (map Thm.no_attributes fixdefs) thy;
  15.104 +    val ctuple_fixdef_thm = foldr1 (fn (x,y) => cpair_equalI OF [x,y]) fixdef_thms;
  15.105 +    
  15.106 +    val ctuple_unfold = legacy_infer_term thy' (mk_trp (mk_ctuple lhss === mk_ctuple rhss));
  15.107 +    val ctuple_unfold_thm = Goal.prove_global thy' [] [] ctuple_unfold
  15.108 +          (fn _ => EVERY [rtac (ctuple_fixdef_thm RS fix_eq2 RS trans) 1,
  15.109 +                    simp_tac (simpset_of thy') 1]);
  15.110 +    val ctuple_induct_thm =
  15.111 +          (space_implode "_" names ^ "_induct", ctuple_fixdef_thm RS def_fix_ind);
  15.112 +    
  15.113 +    fun unfolds [] thm = []
  15.114 +      | unfolds (n::[]) thm = [(n^"_unfold", thm)]
  15.115 +      | unfolds (n::ns) thm = let
  15.116 +          val thmL = thm RS cpair_eqD1;
  15.117 +          val thmR = thm RS cpair_eqD2;
  15.118 +        in (n^"_unfold", thmL) :: unfolds ns thmR end;
  15.119 +    val unfold_thms = unfolds names ctuple_unfold_thm;
  15.120 +    val thms = ctuple_induct_thm :: unfold_thms;
  15.121 +    val (_, thy'') = PureThy.add_thms (map Thm.no_attributes thms) thy';
  15.122 +  in
  15.123 +    (thy'', names, fixdef_thms, map snd unfold_thms)
  15.124 +  end;
  15.125 +
  15.126 +(*************************************************************************)
  15.127 +(*********** monadic notation and pattern matching compilation ***********)
  15.128 +(*************************************************************************)
  15.129 +
  15.130 +fun add_names (Const(a,_), bs) = insert (op =) (Sign.base_name a) bs
  15.131 +  | add_names (Free(a,_) , bs) = insert (op =) a bs
  15.132 +  | add_names (f $ u     , bs) = add_names (f, add_names(u, bs))
  15.133 +  | add_names (Abs(a,_,t), bs) = add_names (t, insert (op =) a bs)
  15.134 +  | add_names (_         , bs) = bs;
  15.135 +
  15.136 +fun add_terms ts xs = foldr add_names xs ts;
  15.137 +
  15.138 +(* builds a monadic term for matching a constructor pattern *)
  15.139 +fun pre_build pat rhs vs taken =
  15.140 +  case pat of
  15.141 +    Const("Cfun.Rep_CFun",_)$f$(v as Free(n,T)) =>
  15.142 +      pre_build f rhs (v::vs) taken
  15.143 +  | Const("Cfun.Rep_CFun",_)$f$x =>
  15.144 +      let val (rhs', v, taken') = pre_build x rhs [] taken;
  15.145 +      in pre_build f rhs' (v::vs) taken' end
  15.146 +  | Const(c,T) =>
  15.147 +      let
  15.148 +        val n = Name.variant taken "v";
  15.149 +        fun result_type (Type("Cfun.->",[_,T])) (x::xs) = result_type T xs
  15.150 +          | result_type T _ = T;
  15.151 +        val v = Free(n, result_type T vs);
  15.152 +        val m = "match_"^(extern_name(Sign.base_name c));
  15.153 +        val k = lambda_ctuple vs rhs;
  15.154 +      in
  15.155 +        (%%:"Fixrec.bind"`(%%:m`v)`k, v, n::taken)
  15.156 +      end
  15.157 +  | Free(n,_) => fixrec_err ("expected constructor, found free variable " ^ quote n)
  15.158 +  | _ => fixrec_err "pre_build: invalid pattern";
  15.159 +
  15.160 +(* builds a monadic term for matching a function definition pattern *)
  15.161 +(* returns (name, arity, matcher) *)
  15.162 +fun building pat rhs vs taken =
  15.163 +  case pat of
  15.164 +    Const("Cfun.Rep_CFun", _)$f$(v as Free(n,T)) =>
  15.165 +      building f rhs (v::vs) taken
  15.166 +  | Const("Cfun.Rep_CFun", _)$f$x =>
  15.167 +      let val (rhs', v, taken') = pre_build x rhs [] taken;
  15.168 +      in building f rhs' (v::vs) taken' end
  15.169 +  | Const(name,_) => (name, length vs, big_lambdas vs rhs)
  15.170 +  | _ => fixrec_err "function is not declared as constant in theory";
  15.171 +
  15.172 +fun match_eq eq = 
  15.173 +  let val (lhs,rhs) = dest_eqs eq;
  15.174 +  in building lhs (%%:"Fixrec.return"`rhs) [] (add_terms [eq] []) end;
  15.175 +
  15.176 +(* returns the sum (using +++) of the terms in ms *)
  15.177 +(* also applies "run" to the result! *)
  15.178 +fun fatbar arity ms =
  15.179 +  let
  15.180 +    fun unLAM 0 t = t
  15.181 +      | unLAM n (_$Abs(_,_,t)) = unLAM (n-1) t
  15.182 +      | unLAM _ _ = fixrec_err "fatbar: internal error, not enough LAMs";
  15.183 +    fun reLAM 0 t = t
  15.184 +      | reLAM n t = reLAM (n-1) (%%:"Cfun.Abs_CFun" $ Abs("",dummyT,t));
  15.185 +    fun mplus (x,y) = %%:"Fixrec.mplus"`x`y;
  15.186 +    val msum = foldr1 mplus (map (unLAM arity) ms);
  15.187 +  in
  15.188 +    reLAM arity (%%:"Fixrec.run"`msum)
  15.189 +  end;
  15.190 +
  15.191 +fun unzip3 [] = ([],[],[])
  15.192 +  | unzip3 ((x,y,z)::ts) =
  15.193 +      let val (xs,ys,zs) = unzip3 ts
  15.194 +      in (x::xs, y::ys, z::zs) end;
  15.195 +
  15.196 +(* this is the pattern-matching compiler function *)
  15.197 +fun compile_pats eqs = 
  15.198 +  let
  15.199 +    val ((n::names),(a::arities),mats) = unzip3 (map match_eq eqs);
  15.200 +    val cname = if forall (fn x => n=x) names then n
  15.201 +          else fixrec_err "all equations in block must define the same function";
  15.202 +    val arity = if forall (fn x => a=x) arities then a
  15.203 +          else fixrec_err "all equations in block must have the same arity";
  15.204 +    val rhs = fatbar arity mats;
  15.205 +  in
  15.206 +    mk_trp (%%:cname === rhs)
  15.207 +  end;
  15.208 +
  15.209 +(*************************************************************************)
  15.210 +(********************** Proving associated theorems **********************)
  15.211 +(*************************************************************************)
  15.212 +
  15.213 +(* proves a block of pattern matching equations as theorems, using unfold *)
  15.214 +fun make_simps thy (unfold_thm, eqns) =
  15.215 +  let
  15.216 +    val tacs = [rtac (unfold_thm RS ssubst_lhs) 1, asm_simp_tac (simpset_of thy) 1];
  15.217 +    fun prove_term t = Goal.prove_global thy [] [] t (K (EVERY tacs));
  15.218 +    fun prove_eqn ((name, eqn_t), atts) = ((name, prove_term eqn_t), atts);
  15.219 +  in
  15.220 +    map prove_eqn eqns
  15.221 +  end;
  15.222 +
  15.223 +(*************************************************************************)
  15.224 +(************************* Main fixrec function **************************)
  15.225 +(*************************************************************************)
  15.226 +
  15.227 +fun gen_add_fixrec prep_prop prep_attrib strict blocks thy =
  15.228 +  let
  15.229 +    val eqns = List.concat blocks;
  15.230 +    val lengths = map length blocks;
  15.231 +    
  15.232 +    val ((names, srcss), strings) = apfst split_list (split_list eqns);
  15.233 +    val atts = map (map (prep_attrib thy)) srcss;
  15.234 +    val eqn_ts = map (prep_prop thy) strings;
  15.235 +    val rec_ts = map (fn eq => chead_of (fst (dest_eqs (Logic.strip_imp_concl eq)))
  15.236 +      handle TERM _ => fixrec_eq_err thy "not a proper equation" eq) eqn_ts;
  15.237 +    val (_, eqn_ts') = OldInductivePackage.unify_consts thy rec_ts eqn_ts;
  15.238 +    
  15.239 +    fun unconcat [] _ = []
  15.240 +      | unconcat (n::ns) xs = List.take (xs,n) :: unconcat ns (List.drop (xs,n));
  15.241 +    val pattern_blocks = unconcat lengths (map Logic.strip_imp_concl eqn_ts');
  15.242 +    val compiled_ts = map (legacy_infer_term thy o compile_pats) pattern_blocks;
  15.243 +    val (thy', cnames, fixdef_thms, unfold_thms) = add_fixdefs compiled_ts thy;
  15.244 +  in
  15.245 +    if strict then let (* only prove simp rules if strict = true *)
  15.246 +      val eqn_blocks = unconcat lengths ((names ~~ eqn_ts') ~~ atts);
  15.247 +      val simps = List.concat (map (make_simps thy') (unfold_thms ~~ eqn_blocks));
  15.248 +      val (simp_thms, thy'') = PureThy.add_thms simps thy';
  15.249 +      
  15.250 +      val simp_names = map (fn name => name^"_simps") cnames;
  15.251 +      val simp_attribute = rpair [Simplifier.simp_add];
  15.252 +      val simps' = map simp_attribute (simp_names ~~ unconcat lengths simp_thms);
  15.253 +    in
  15.254 +      (snd o PureThy.add_thmss simps') thy''
  15.255 +    end
  15.256 +    else thy'
  15.257 +  end;
  15.258 +
  15.259 +val add_fixrec = gen_add_fixrec Sign.read_prop Attrib.attribute;
  15.260 +val add_fixrec_i = gen_add_fixrec Sign.cert_prop (K I);
  15.261 +
  15.262 +
  15.263 +(*************************************************************************)
  15.264 +(******************************** Fixpat *********************************)
  15.265 +(*************************************************************************)
  15.266 +
  15.267 +fun fix_pat thy t = 
  15.268 +  let
  15.269 +    val T = fastype_of t;
  15.270 +    val eq = mk_trp (HOLogic.eq_const T $ t $ Var (("x",0),T));
  15.271 +    val cname = case chead_of t of Const(c,_) => c | _ =>
  15.272 +              fixrec_err "function is not declared as constant in theory";
  15.273 +    val unfold_thm = PureThy.get_thm thy (Name (cname^"_unfold"));
  15.274 +    val simp = Goal.prove_global thy [] [] eq
  15.275 +          (fn _ => EVERY [stac unfold_thm 1, simp_tac (simpset_of thy) 1]);
  15.276 +  in simp end;
  15.277 +
  15.278 +fun gen_add_fixpat prep_term prep_attrib ((name, srcs), strings) thy =
  15.279 +  let
  15.280 +    val atts = map (prep_attrib thy) srcs;
  15.281 +    val ts = map (prep_term thy) strings;
  15.282 +    val simps = map (fix_pat thy) ts;
  15.283 +  in
  15.284 +    (snd o PureThy.add_thmss [((name, simps), atts)]) thy
  15.285 +  end;
  15.286 +
  15.287 +val add_fixpat = gen_add_fixpat Sign.read_term Attrib.attribute;
  15.288 +val add_fixpat_i = gen_add_fixpat Sign.cert_term (K I);
  15.289 +
  15.290 +
  15.291 +(*************************************************************************)
  15.292 +(******************************** Parsers ********************************)
  15.293 +(*************************************************************************)
  15.294 +
  15.295 +local structure P = OuterParse and K = OuterKeyword in
  15.296 +
  15.297 +val fixrec_eqn = SpecParse.opt_thm_name ":" -- P.prop;
  15.298 +
  15.299 +val fixrec_strict = P.opt_keyword "permissive" >> not;
  15.300 +
  15.301 +val fixrec_decl = fixrec_strict -- P.and_list1 (Scan.repeat1 fixrec_eqn);
  15.302 +
  15.303 +(* this builds a parser for a new keyword, fixrec, whose functionality 
  15.304 +is defined by add_fixrec *)
  15.305 +val fixrecP =
  15.306 +  OuterSyntax.command "fixrec" "define recursive functions (HOLCF)" K.thy_decl
  15.307 +    (fixrec_decl >> (Toplevel.theory o uncurry add_fixrec));
  15.308 +
  15.309 +(* fixpat parser *)
  15.310 +val fixpat_decl = SpecParse.opt_thm_name ":" -- Scan.repeat1 P.prop;
  15.311 +
  15.312 +val fixpatP =
  15.313 +  OuterSyntax.command "fixpat" "define rewrites for fixrec functions" K.thy_decl
  15.314 +    (fixpat_decl >> (Toplevel.theory o add_fixpat));
  15.315 +
  15.316 +val _ = OuterSyntax.add_parsers [fixrecP, fixpatP];
  15.317 +
  15.318 +end; (* local structure *)
  15.319 +
  15.320 +end; (* struct *)
    16.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    16.2 +++ b/src/HOLCF/Tools/pcpodef_package.ML	Thu May 31 14:01:58 2007 +0200
    16.3 @@ -0,0 +1,213 @@
    16.4 +(*  Title:      HOLCF/Tools/pcpodef_package.ML
    16.5 +    ID:         $Id$
    16.6 +    Author:     Brian Huffman
    16.7 +
    16.8 +Primitive domain definitions for HOLCF, similar to Gordon/HOL-style
    16.9 +typedef.
   16.10 +*)
   16.11 +
   16.12 +signature PCPODEF_PACKAGE =
   16.13 +sig
   16.14 +  val quiet_mode: bool ref
   16.15 +  val pcpodef_proof: (bool * string) * (bstring * string list * mixfix) * string
   16.16 +    * (string * string) option -> theory -> Proof.state
   16.17 +  val pcpodef_proof_i: (bool * string) * (bstring * string list * mixfix) * term
   16.18 +    * (string * string) option -> theory -> Proof.state
   16.19 +  val cpodef_proof: (bool * string) * (bstring * string list * mixfix) * string
   16.20 +    * (string * string) option -> theory -> Proof.state
   16.21 +  val cpodef_proof_i: (bool * string) * (bstring * string list * mixfix) * term
   16.22 +    * (string * string) option -> theory -> Proof.state
   16.23 +end;
   16.24 +
   16.25 +structure PcpodefPackage: PCPODEF_PACKAGE =
   16.26 +struct
   16.27 +
   16.28 +(** theory context references **)
   16.29 +
   16.30 +val typedef_po = thm "typedef_po";
   16.31 +val typedef_cpo = thm "typedef_cpo";
   16.32 +val typedef_pcpo = thm "typedef_pcpo";
   16.33 +val typedef_lub = thm "typedef_lub";
   16.34 +val typedef_thelub = thm "typedef_thelub";
   16.35 +val typedef_compact = thm "typedef_compact";
   16.36 +val cont_Rep = thm "typedef_cont_Rep";
   16.37 +val cont_Abs = thm "typedef_cont_Abs";
   16.38 +val Rep_strict = thm "typedef_Rep_strict";
   16.39 +val Abs_strict = thm "typedef_Abs_strict";
   16.40 +val Rep_defined = thm "typedef_Rep_defined";
   16.41 +val Abs_defined = thm "typedef_Abs_defined";
   16.42 +
   16.43 +
   16.44 +(** type definitions **)
   16.45 +
   16.46 +(* messages *)
   16.47 +
   16.48 +val quiet_mode = ref false;
   16.49 +fun message s = if ! quiet_mode then () else writeln s;
   16.50 +
   16.51 +
   16.52 +(* prepare_cpodef *)
   16.53 +
   16.54 +fun err_in_cpodef msg name =
   16.55 +  cat_error msg ("The error(s) above occurred in cpodef " ^ quote name);
   16.56 +
   16.57 +fun declare_type_name a = Variable.declare_constraints (Logic.mk_type (TFree (a, dummyS)));
   16.58 +
   16.59 +fun adm_const T = Const ("Adm.adm", (T --> HOLogic.boolT) --> HOLogic.boolT);
   16.60 +fun mk_adm (x, T, P) = adm_const T $ absfree (x, T, P);
   16.61 +
   16.62 +fun prepare_pcpodef prep_term pcpo def name (t, vs, mx) raw_set opt_morphs thy =
   16.63 +  let
   16.64 +    val ctxt = ProofContext.init thy;
   16.65 +    val full = Sign.full_name thy;
   16.66 +
   16.67 +    (*rhs*)
   16.68 +    val full_name = full name;
   16.69 +    val set = prep_term (ctxt |> fold declare_type_name vs) raw_set;
   16.70 +    val setT = Term.fastype_of set;
   16.71 +    val rhs_tfrees = term_tfrees set;
   16.72 +    val oldT = HOLogic.dest_setT setT handle TYPE _ =>
   16.73 +      error ("Not a set type: " ^ quote (ProofContext.string_of_typ ctxt setT));
   16.74 +    fun mk_nonempty A =
   16.75 +      HOLogic.mk_exists ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), A));
   16.76 +    fun mk_admissible A =
   16.77 +      mk_adm ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), A));
   16.78 +    fun mk_UU_mem A = HOLogic.mk_mem (Const ("Pcpo.UU", oldT), A);
   16.79 +    val goal = if pcpo
   16.80 +      then HOLogic.mk_Trueprop (HOLogic.mk_conj (mk_UU_mem set, mk_admissible set))
   16.81 +      else HOLogic.mk_Trueprop (HOLogic.mk_conj (mk_nonempty set, mk_admissible set));
   16.82 +
   16.83 +    (*lhs*)
   16.84 +    val defS = Sign.defaultS thy;
   16.85 +    val lhs_tfrees = map (fn v => (v, the_default defS (AList.lookup (op =) rhs_tfrees v))) vs;
   16.86 +    val lhs_sorts = map snd lhs_tfrees;
   16.87 +    val tname = Syntax.type_name t mx;
   16.88 +    val full_tname = full tname;
   16.89 +    val newT = Type (full_tname, map TFree lhs_tfrees);
   16.90 +
   16.91 +    val (Rep_name, Abs_name) = the_default ("Rep_" ^ name, "Abs_" ^ name) opt_morphs;
   16.92 +    val RepC = Const (full Rep_name, newT --> oldT);
   16.93 +    fun lessC T = Const ("Porder.<<", T --> T --> HOLogic.boolT);
   16.94 +    val less_def = ("less_" ^ name ^ "_def", Logic.mk_equals (lessC newT,
   16.95 +      Abs ("x", newT, Abs ("y", newT, lessC oldT $ (RepC $ Bound 1) $ (RepC $ Bound 0)))));
   16.96 +
   16.97 +    fun make_po tac theory = theory
   16.98 +      |> TypedefPackage.add_typedef_i def (SOME name) (t, vs, mx) set opt_morphs tac
   16.99 +      ||> AxClass.prove_arity (full_tname, lhs_sorts, ["Porder.sq_ord"])
  16.100 +           (ClassPackage.intro_classes_tac [])
  16.101 +      ||>> PureThy.add_defs_i true [Thm.no_attributes less_def]
  16.102 +      |-> (fn ((_, {type_definition, set_def, ...}), [less_definition]) =>
  16.103 +          AxClass.prove_arity (full_tname, lhs_sorts, ["Porder.po"])
  16.104 +             (Tactic.rtac (typedef_po OF [type_definition, less_definition]) 1)
  16.105 +           #> pair (type_definition, less_definition, set_def));
  16.106 +
  16.107 +    fun make_cpo admissible (type_def, less_def, set_def) theory =
  16.108 +      let
  16.109 +        val admissible' = fold_rule (the_list set_def) admissible;
  16.110 +        val cpo_thms = [type_def, less_def, admissible'];
  16.111 +      in
  16.112 +        theory
  16.113 +        |> AxClass.prove_arity (full_tname, lhs_sorts, ["Pcpo.cpo"])
  16.114 +          (Tactic.rtac (typedef_cpo OF cpo_thms) 1)
  16.115 +        |> Theory.add_path name
  16.116 +        |> PureThy.add_thms
  16.117 +            ([(("adm_" ^ name, admissible'), []),
  16.118 +              (("cont_" ^ Rep_name, cont_Rep OF cpo_thms), []),
  16.119 +              (("cont_" ^ Abs_name, cont_Abs OF cpo_thms), []),
  16.120 +              (("lub_"     ^ name, typedef_lub     OF cpo_thms), []),
  16.121 +              (("thelub_"  ^ name, typedef_thelub  OF cpo_thms), []),
  16.122 +              (("compact_" ^ name, typedef_compact OF cpo_thms), [])])
  16.123 +        |> snd
  16.124 +        |> Theory.parent_path
  16.125 +      end;
  16.126 +
  16.127 +    fun make_pcpo UUmem (type_def, less_def, set_def) theory =
  16.128 +      let
  16.129 +        val UUmem' = fold_rule (the_list set_def) UUmem;
  16.130 +        val pcpo_thms = [type_def, less_def, UUmem'];
  16.131 +      in
  16.132 +        theory
  16.133 +        |> AxClass.prove_arity (full_tname, lhs_sorts, ["Pcpo.pcpo"])
  16.134 +          (Tactic.rtac (typedef_pcpo OF pcpo_thms) 1)
  16.135 +        |> Theory.add_path name
  16.136 +        |> PureThy.add_thms
  16.137 +            ([((Rep_name ^ "_strict", Rep_strict OF pcpo_thms), []),
  16.138 +              ((Abs_name ^ "_strict", Abs_strict OF pcpo_thms), []),
  16.139 +              ((Rep_name ^ "_defined", Rep_defined OF pcpo_thms), []),
  16.140 +              ((Abs_name ^ "_defined", Abs_defined OF pcpo_thms), [])
  16.141 +              ])
  16.142 +        |> snd
  16.143 +        |> Theory.parent_path
  16.144 +      end;
  16.145 +
  16.146 +    fun pcpodef_result UUmem_admissible theory =
  16.147 +      let
  16.148 +        val UUmem = UUmem_admissible RS conjunct1;
  16.149 +        val admissible = UUmem_admissible RS conjunct2;
  16.150 +      in
  16.151 +        theory
  16.152 +        |> make_po (Tactic.rtac exI 1 THEN Tactic.rtac UUmem 1)
  16.153 +        |-> (fn defs => make_cpo admissible defs #> make_pcpo UUmem defs)
  16.154 +      end;
  16.155 +
  16.156 +    fun cpodef_result nonempty_admissible theory =
  16.157 +      let
  16.158 +        val nonempty = nonempty_admissible RS conjunct1;
  16.159 +        val admissible = nonempty_admissible RS conjunct2;
  16.160 +      in
  16.161 +        theory
  16.162 +        |> make_po (Tactic.rtac nonempty 1)
  16.163 +        |-> make_cpo admissible
  16.164 +      end;
  16.165 +
  16.166 +  in (goal, if pcpo then pcpodef_result else cpodef_result) end
  16.167 +  handle ERROR msg => err_in_cpodef msg name;
  16.168 +
  16.169 +
  16.170 +(* cpodef_proof interface *)
  16.171 +
  16.172 +fun gen_pcpodef_proof prep_term pcpo ((def, name), typ, set, opt_morphs) thy =
  16.173 +  let
  16.174 +    val (goal, pcpodef_result) =
  16.175 +      prepare_pcpodef prep_term pcpo def name typ set opt_morphs thy;
  16.176 +    fun after_qed [[th]] = ProofContext.theory (pcpodef_result th);
  16.177 +  in Proof.theorem_i NONE after_qed [[(goal, [])]] (ProofContext.init thy) end;
  16.178 +
  16.179 +fun pcpodef_proof x = gen_pcpodef_proof ProofContext.read_term true x;
  16.180 +fun pcpodef_proof_i x = gen_pcpodef_proof ProofContext.cert_term true x;
  16.181 +
  16.182 +fun cpodef_proof x = gen_pcpodef_proof ProofContext.read_term false x;
  16.183 +fun cpodef_proof_i x = gen_pcpodef_proof ProofContext.cert_term false x;
  16.184 +
  16.185 +
  16.186 +(** outer syntax **)
  16.187 +
  16.188 +local structure P = OuterParse and K = OuterKeyword in
  16.189 +
  16.190 +(* copied from HOL/Tools/typedef_package.ML *)
  16.191 +val typedef_proof_decl =
  16.192 +  Scan.optional (P.$$$ "(" |--
  16.193 +      ((P.$$$ "open" >> K false) -- Scan.option P.name || P.name >> (fn s => (true, SOME s)))
  16.194 +        --| P.$$$ ")") (true, NONE) --
  16.195 +    (P.type_args -- P.name) -- P.opt_infix -- (P.$$$ "=" |-- P.term) --
  16.196 +    Scan.option (P.$$$ "morphisms" |-- P.!!! (P.name -- P.name));
  16.197 +
  16.198 +fun mk_pcpodef_proof pcpo ((((((def, opt_name), (vs, t)), mx), A), morphs)) =
  16.199 +  (if pcpo then pcpodef_proof else cpodef_proof)
  16.200 +    ((def, the_default (Syntax.type_name t mx) opt_name), (t, vs, mx), A, morphs);
  16.201 +
  16.202 +val pcpodefP =
  16.203 +  OuterSyntax.command "pcpodef" "HOLCF type definition (requires admissibility proof)" K.thy_goal
  16.204 +    (typedef_proof_decl >>
  16.205 +      (Toplevel.print oo (Toplevel.theory_to_proof o mk_pcpodef_proof true)));
  16.206 +
  16.207 +val cpodefP =
  16.208 +  OuterSyntax.command "cpodef" "HOLCF type definition (requires admissibility proof)" K.thy_goal
  16.209 +    (typedef_proof_decl >>
  16.210 +      (Toplevel.print oo (Toplevel.theory_to_proof o mk_pcpodef_proof false)));
  16.211 +
  16.212 +val _ = OuterSyntax.add_parsers [pcpodefP, cpodefP];
  16.213 +
  16.214 +end;
  16.215 +
  16.216 +end;
    17.1 --- a/src/HOLCF/adm_tac.ML	Thu May 31 13:24:13 2007 +0200
    17.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    17.3 @@ -1,180 +0,0 @@
    17.4 -(*  ID:         $Id$
    17.5 -    Author:     Stefan Berghofer, TU Muenchen
    17.6 -
    17.7 -Admissibility tactic.
    17.8 -
    17.9 -Checks whether adm_subst theorem is applicable to the current proof
   17.10 -state:
   17.11 -
   17.12 -  [| cont t; adm P |] ==> adm (%x. P (t x))
   17.13 -
   17.14 -"t" is instantiated with a term of chain-finite type, so that
   17.15 -adm_chfin can be applied:
   17.16 -
   17.17 -  adm (P::'a::{chfin,pcpo} => bool)
   17.18 -
   17.19 -*)
   17.20 -
   17.21 -signature ADM =
   17.22 -sig
   17.23 -  val adm_tac: (int -> tactic) -> int -> tactic
   17.24 -end;
   17.25 -
   17.26 -structure Adm: ADM =
   17.27 -struct
   17.28 -
   17.29 -
   17.30 -(*** find_subterms t 0 []
   17.31 -     returns lists of terms with the following properties:
   17.32 -       1. all terms in the list are disjoint subterms of t
   17.33 -       2. all terms contain the variable which is bound at level 0
   17.34 -       3. all occurences of the variable which is bound at level 0
   17.35 -          are "covered" by a term in the list
   17.36 -     a list of integers is associated with every term which describes
   17.37 -     the "path" leading to the subterm (required for instantiation of
   17.38 -     the adm_subst theorem (see functions mk_term, inst_adm_subst_thm))
   17.39 -***)
   17.40 -
   17.41 -fun find_subterms (Bound i) lev path =
   17.42 -      if i = lev then [[(Bound 0, path)]]
   17.43 -      else []
   17.44 -  | find_subterms (t as (Abs (_, _, t2))) lev path =
   17.45 -      if List.filter (fn x => x<=lev)
   17.46 -           (add_loose_bnos (t, 0, [])) = [lev] then
   17.47 -        [(incr_bv (~lev, 0, t), path)]::
   17.48 -        (find_subterms t2 (lev+1) (0::path))
   17.49 -      else find_subterms t2 (lev+1) (0::path)
   17.50 -  | find_subterms (t as (t1 $ t2)) lev path =
   17.51 -      let val ts1 = find_subterms t1 lev (0::path);
   17.52 -          val ts2 = find_subterms t2 lev (1::path);
   17.53 -          fun combine [] y = []
   17.54 -            | combine (x::xs) ys =
   17.55 -                (map (fn z => x @ z) ys) @ (combine xs ys)
   17.56 -      in
   17.57 -        (if List.filter (fn x => x<=lev)
   17.58 -              (add_loose_bnos (t, 0, [])) = [lev] then
   17.59 -           [[(incr_bv (~lev, 0, t), path)]]
   17.60 -         else []) @
   17.61 -        (if ts1 = [] then ts2
   17.62 -         else if ts2 = [] then ts1
   17.63 -         else combine ts1 ts2)
   17.64 -      end
   17.65 -  | find_subterms _ _ _ = [];
   17.66 -
   17.67 -
   17.68 -(*** make term for instantiation of predicate "P" in adm_subst theorem ***)
   17.69 -
   17.70 -fun make_term t path paths lev =
   17.71 -  if path mem paths then Bound lev
   17.72 -  else case t of
   17.73 -      (Abs (s, T, t1)) => Abs (s, T, make_term t1 (0::path) paths (lev+1))
   17.74 -    | (t1 $ t2) => (make_term t1 (0::path) paths lev) $
   17.75 -                   (make_term t2 (1::path) paths lev)
   17.76 -    | t1 => t1;
   17.77 -
   17.78 -
   17.79 -(*** check whether all terms in list are equal ***)
   17.80 -
   17.81 -fun eq_terms [] = true
   17.82 -  | eq_terms (ts as (t, _) :: _) = forall (fn (t2, _) => t2 aconv t) ts;
   17.83 -
   17.84 -
   17.85 -(*figure out internal names*)
   17.86 -val chfin_pcpoS = Sign.intern_sort (the_context ()) ["chfin", "pcpo"];
   17.87 -val cont_name = Sign.intern_const (the_context ()) "cont";
   17.88 -val adm_name = Sign.intern_const (the_context ()) "adm";
   17.89 -
   17.90 -
   17.91 -(*** check whether type of terms in list is chain finite ***)
   17.92 -
   17.93 -fun is_chfin sign T params ((t, _)::_) =
   17.94 -  let val parTs = map snd (rev params)
   17.95 -  in Sign.of_sort sign (fastype_of1 (T::parTs, t), chfin_pcpoS) end;
   17.96 -
   17.97 -
   17.98 -(*** try to prove that terms in list are continuous
   17.99 -     if successful, add continuity theorem to list l ***)
  17.100 -
  17.101 -fun prove_cont tac sign s T prems params (l, ts as ((t, _)::_)) =
  17.102 -  let val parTs = map snd (rev params);
  17.103 -       val contT = (T --> (fastype_of1 (T::parTs, t))) --> HOLogic.boolT;
  17.104 -       fun mk_all [] t = t
  17.105 -         | mk_all ((a,T)::Ts) t = (all T) $ (Abs (a, T, mk_all Ts t));
  17.106 -       val t = HOLogic.mk_Trueprop((Const (cont_name, contT)) $ (Abs(s, T, t)));
  17.107 -       val t' = mk_all params (Logic.list_implies (prems, t));
  17.108 -       val thm = Goal.prove (ProofContext.init sign) [] [] t' (K (tac 1));
  17.109 -  in (ts, thm)::l end
  17.110 -  handle ERROR _ => l;
  17.111 -
  17.112 -
  17.113 -(*** instantiation of adm_subst theorem (a bit tricky) ***)
  17.114 -
  17.115 -fun inst_adm_subst_thm state i params s T subt t paths =
  17.116 -  let val {thy = sign, maxidx, ...} = rep_thm state;
  17.117 -      val j = maxidx+1;
  17.118 -      val parTs = map snd (rev params);
  17.119 -      val rule = Thm.lift_rule (Thm.cprem_of state i) adm_subst;
  17.120 -      val types = valOf o (fst (types_sorts rule));
  17.121 -      val tT = types ("t", j);
  17.122 -      val PT = types ("P", j);
  17.123 -      fun mk_abs [] t = t
  17.124 -        | mk_abs ((a,T)::Ts) t = Abs (a, T, mk_abs Ts t);
  17.125 -      val tt = cterm_of sign (mk_abs (params @ [(s, T)]) subt);
  17.126 -      val Pt = cterm_of sign (mk_abs (params @ [(s, fastype_of1 (T::parTs, subt))])
  17.127 -                     (make_term t [] paths 0));
  17.128 -      val tye = Sign.typ_match sign (tT, #T (rep_cterm tt)) Vartab.empty;
  17.129 -      val tye' = Sign.typ_match sign (PT, #T (rep_cterm Pt)) tye;
  17.130 -      val ctye = map (fn (ixn, (S, T)) =>
  17.131 -        (ctyp_of sign (TVar (ixn, S)), ctyp_of sign T)) (Vartab.dest tye');
  17.132 -      val tv = cterm_of sign (Var (("t", j), Envir.typ_subst_TVars tye' tT));
  17.133 -      val Pv = cterm_of sign (Var (("P", j), Envir.typ_subst_TVars tye' PT));
  17.134 -      val rule' = instantiate (ctye, [(tv, tt), (Pv, Pt)]) rule
  17.135 -  in rule' end;
  17.136 -
  17.137 -
  17.138 -(*** extract subgoal i from proof state ***)
  17.139 -
  17.140 -fun nth_subgoal i thm = List.nth (prems_of thm, i-1);
  17.141 -
  17.142 -
  17.143 -(*** the admissibility tactic ***)
  17.144 -
  17.145 -fun try_dest_adm (Const _ $ (Const (name, _) $ Abs abs)) =
  17.146 -      if name = adm_name then SOME abs else NONE
  17.147 -  | try_dest_adm _ = NONE;
  17.148 -
  17.149 -fun adm_tac tac i state =
  17.150 -  state |>
  17.151 -  let val goali = nth_subgoal i state in
  17.152 -    (case try_dest_adm (Logic.strip_assums_concl goali) of
  17.153 -      NONE => no_tac
  17.154 -    | SOME (s, T, t) =>
  17.155 -        let
  17.156 -          val sign = Thm.theory_of_thm state;
  17.157 -          val prems = Logic.strip_assums_hyp goali;
  17.158 -          val params = Logic.strip_params goali;
  17.159 -          val ts = find_subterms t 0 [];
  17.160 -          val ts' = List.filter eq_terms ts;
  17.161 -          val ts'' = List.filter (is_chfin sign T params) ts';
  17.162 -          val thms = Library.foldl (prove_cont tac sign s T prems params) ([], ts'');
  17.163 -        in
  17.164 -          (case thms of
  17.165 -            ((ts as ((t', _)::_), cont_thm)::_) =>
  17.166 -              let
  17.167 -                val paths = map snd ts;
  17.168 -                val rule = inst_adm_subst_thm state i params s T t' t paths;
  17.169 -              in
  17.170 -                compose_tac (false, rule, 2) i THEN
  17.171 -                rtac cont_thm i THEN
  17.172 -                REPEAT (assume_tac i) THEN
  17.173 -                rtac adm_chfin i
  17.174 -              end 
  17.175 -          | [] => no_tac)
  17.176 -        end)
  17.177 -    end;
  17.178 -
  17.179 -
  17.180 -end;
  17.181 -
  17.182 -
  17.183 -open Adm;
    18.1 --- a/src/HOLCF/cont_consts.ML	Thu May 31 13:24:13 2007 +0200
    18.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    18.3 @@ -1,110 +0,0 @@
    18.4 -(*  Title:      HOLCF/cont_consts.ML
    18.5 -    ID:         $Id$
    18.6 -    Author:     Tobias Mayr, David von Oheimb, and Markus Wenzel
    18.7 -
    18.8 -HOLCF version of consts: handle continuous function types in mixfix
    18.9 -syntax.
   18.10 -*)
   18.11 -
   18.12 -signature CONT_CONSTS =
   18.13 -sig
   18.14 -  val add_consts: (bstring * string * mixfix) list -> theory -> theory
   18.15 -  val add_consts_i: (bstring * typ * mixfix) list -> theory -> theory
   18.16 -end;
   18.17 -
   18.18 -structure ContConsts: CONT_CONSTS =
   18.19 -struct
   18.20 -
   18.21 -
   18.22 -(* misc utils *)
   18.23 -
   18.24 -open HOLCFLogic;
   18.25 -
   18.26 -fun first  (x,_,_) = x;
   18.27 -fun second (_,x,_) = x;
   18.28 -fun third  (_,_,x) = x;
   18.29 -fun upd_first  f (x,y,z) = (f x,   y,   z);
   18.30 -fun upd_second f (x,y,z) = (  x, f y,   z);
   18.31 -fun upd_third  f (x,y,z) = (  x,   y, f z);
   18.32 -
   18.33 -fun change_arrow 0 T               = T
   18.34 -|   change_arrow n (Type(_,[S,T])) = Type ("fun",[S,change_arrow (n-1) T])
   18.35 -|   change_arrow _ _               = sys_error "cont_consts: change_arrow";
   18.36 -
   18.37 -fun trans_rules name2 name1 n mx = let
   18.38 -  fun argnames _ 0 = []
   18.39 -  |   argnames c n = chr c::argnames (c+1) (n-1);
   18.40 -  val vnames = argnames (ord "A") n;
   18.41 -  val extra_parse_rule = Syntax.ParseRule (Constant name2, Constant name1);
   18.42 -  in [Syntax.ParsePrintRule (Syntax.mk_appl (Constant name2) (map Variable vnames),
   18.43 -                          Library.foldl (fn (t,arg) => (Syntax.mk_appl (Constant "Rep_CFun")
   18.44 -                                                [t,Variable arg]))
   18.45 -                          (Constant name1,vnames))]
   18.46 -     @(case mx of InfixName _ => [extra_parse_rule]
   18.47 -                | InfixlName _ => [extra_parse_rule]
   18.48 -                | InfixrName _ => [extra_parse_rule] | _ => []) end;
   18.49 -
   18.50 -
   18.51 -(* transforming infix/mixfix declarations of constants with type ...->...
   18.52 -   a declaration of such a constant is transformed to a normal declaration with
   18.53 -   an internal name, the same type, and nofix. Additionally, a purely syntactic
   18.54 -   declaration with the original name, type ...=>..., and the original mixfix
   18.55 -   is generated and connected to the other declaration via some translation.
   18.56 -*)
   18.57 -fun fix_mixfix (syn                     , T, mx as Infix           p ) =
   18.58 -               (Syntax.const_name syn mx, T,       InfixName (syn, p))
   18.59 -  | fix_mixfix (syn                     , T, mx as Infixl           p ) =
   18.60 -               (Syntax.const_name syn mx, T,       InfixlName (syn, p))
   18.61 -  | fix_mixfix (syn                     , T, mx as Infixr           p ) =
   18.62 -               (Syntax.const_name syn mx, T,       InfixrName (syn, p))
   18.63 -  | fix_mixfix decl = decl;
   18.64 -fun transform decl = let
   18.65 -        val (c, T, mx) = fix_mixfix decl;
   18.66 -        val c2 = "_cont_" ^ c;
   18.67 -        val n  = Syntax.mixfix_args mx
   18.68 -    in     ((c ,               T,NoSyn),
   18.69 -            (c2,change_arrow n T,mx   ),
   18.70 -            trans_rules c2 c n mx) end;
   18.71 -
   18.72 -fun cfun_arity (Type(n,[_,T])) = if n = cfun_arrow then 1+cfun_arity T else 0
   18.73 -|   cfun_arity _               = 0;
   18.74 -
   18.75 -fun is_contconst (_,_,NoSyn   ) = false
   18.76 -|   is_contconst (_,_,Binder _) = false
   18.77 -|   is_contconst (c,T,mx      ) = cfun_arity T >= Syntax.mixfix_args mx
   18.78 -                         handle ERROR msg => cat_error msg ("in mixfix annotation for " ^
   18.79 -                                               quote (Syntax.const_name c mx));
   18.80 -
   18.81 -
   18.82 -(* add_consts(_i) *)
   18.83 -
   18.84 -fun gen_add_consts prep_typ raw_decls thy =
   18.85 -  let
   18.86 -    val decls = map (upd_second (prep_typ thy)) raw_decls;
   18.87 -    val (contconst_decls, normal_decls) = List.partition is_contconst decls;
   18.88 -    val transformed_decls = map transform contconst_decls;
   18.89 -  in
   18.90 -    thy
   18.91 -    |> Sign.add_consts_i normal_decls
   18.92 -    |> Sign.add_consts_i (map first transformed_decls)
   18.93 -    |> Sign.add_syntax_i (map second transformed_decls)
   18.94 -    |> Sign.add_trrules_i (List.concat (map third transformed_decls))
   18.95 -  end;
   18.96 -
   18.97 -val add_consts = gen_add_consts Sign.read_typ;
   18.98 -val add_consts_i = gen_add_consts Sign.certify_typ;
   18.99 -
  18.100 -
  18.101 -(* outer syntax *)
  18.102 -
  18.103 -local structure P = OuterParse and K = OuterKeyword in
  18.104 -
  18.105 -val constsP =
  18.106 -  OuterSyntax.command "consts" "declare constants (HOLCF)" K.thy_decl
  18.107 -    (Scan.repeat1 P.const >> (Toplevel.theory o add_consts));
  18.108 -
  18.109 -val _ = OuterSyntax.add_parsers [constsP];
  18.110 -
  18.111 -end;
  18.112 -
  18.113 -end;
    19.1 --- a/src/HOLCF/cont_proc.ML	Thu May 31 13:24:13 2007 +0200
    19.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    19.3 @@ -1,145 +0,0 @@
    19.4 -(*  Title:      HOLCF/cont_proc.ML
    19.5 -    ID:         $Id$
    19.6 -    Author:     Brian Huffman
    19.7 -*)
    19.8 -
    19.9 -signature CONT_PROC =
   19.10 -sig
   19.11 -  val is_lcf_term: term -> bool
   19.12 -  val cont_thms: term -> thm list
   19.13 -  val all_cont_thms: term -> thm list
   19.14 -  val cont_tac: int -> tactic
   19.15 -  val cont_proc: theory -> simproc
   19.16 -  val setup: theory -> theory
   19.17 -end;
   19.18 -
   19.19 -structure ContProc: CONT_PROC =
   19.20 -struct
   19.21 -
   19.22 -(** theory context references **)
   19.23 -
   19.24 -val cont_K = thm "cont_const";
   19.25 -val cont_I = thm "cont_id";
   19.26 -val cont_A = thm "cont2cont_Rep_CFun";
   19.27 -val cont_L = thm "cont2cont_LAM";
   19.28 -val cont_R = thm "cont_Rep_CFun2";
   19.29 -
   19.30 -(* checks whether a term contains no dangling bound variables *)
   19.31 -val is_closed_term =
   19.32 -  let
   19.33 -    fun bound_less i (t $ u) =
   19.34 -          bound_less i t andalso bound_less i u
   19.35 -      | bound_less i (Abs (_, _, t)) = bound_less (i+1) t
   19.36 -      | bound_less i (Bound n) = n < i
   19.37 -      | bound_less i _ = true; (* Const, Free, and Var are OK *)
   19.38 -  in bound_less 0 end;
   19.39 -
   19.40 -(* checks whether a term is written entirely in the LCF sublanguage *)
   19.41 -fun is_lcf_term (Const ("Cfun.Rep_CFun", _) $ t $ u) =
   19.42 -      is_lcf_term t andalso is_lcf_term u
   19.43 -  | is_lcf_term (Const ("Cfun.Abs_CFun", _) $ Abs (_, _, t)) = is_lcf_term t
   19.44 -  | is_lcf_term (Const ("Cfun.Abs_CFun", _) $ _) = false
   19.45 -  | is_lcf_term (Bound _) = true
   19.46 -  | is_lcf_term t = is_closed_term t;
   19.47 -
   19.48 -(*
   19.49 -  efficiently generates a cont thm for every LAM abstraction in a term,
   19.50 -  using forward proof and reusing common subgoals
   19.51 -*)
   19.52 -local
   19.53 -  fun var 0 = [SOME cont_I]
   19.54 -    | var n = NONE :: var (n-1);
   19.55 -
   19.56 -  fun k NONE     = cont_K
   19.57 -    | k (SOME x) = x;
   19.58 -
   19.59 -  fun ap NONE NONE = NONE
   19.60 -    | ap x    y    = SOME (k y RS (k x RS cont_A));
   19.61 -
   19.62 -  fun zip []      []      = []
   19.63 -    | zip []      (y::ys) = (ap NONE y   ) :: zip [] ys
   19.64 -    | zip (x::xs) []      = (ap x    NONE) :: zip xs []
   19.65 -    | zip (x::xs) (y::ys) = (ap x    y   ) :: zip xs ys
   19.66 -
   19.67 -  fun lam [] = ([], cont_K)
   19.68 -    | lam (x::ys) =
   19.69 -    let
   19.70 -      (* should use "standard" for thms that are used multiple times *)
   19.71 -      (* it seems to allow for sharing in explicit proof objects *)
   19.72 -      val x' = standard (k x);
   19.73 -      val Lx = x' RS cont_L;
   19.74 -    in (map (fn y => SOME (k y RS Lx)) ys, x') end;
   19.75 -
   19.76 -  (* first list: cont thm for each dangling bound variable *)
   19.77 -  (* second list: cont thm for each LAM in t *)
   19.78 -  (* if b = false, only return cont thm for outermost LAMs *)
   19.79 -  fun cont_thms1 b (Const ("Cfun.Rep_CFun", _) $ f $ t) =
   19.80 -    let
   19.81 -      val (cs1,ls1) = cont_thms1 b f;
   19.82 -      val (cs2,ls2) = cont_thms1 b t;
   19.83 -    in (zip cs1 cs2, if b then ls1 @ ls2 else []) end
   19.84 -    | cont_thms1 b (Const ("Cfun.Abs_CFun", _) $ Abs (_, _, t)) =
   19.85 -    let
   19.86 -      val (cs, ls) = cont_thms1 b t;
   19.87 -      val (cs', l) = lam cs;
   19.88 -    in (cs', l::ls) end
   19.89 -    | cont_thms1 _ (Bound n) = (var n, [])
   19.90 -    | cont_thms1 _ _ = ([], []);
   19.91 -in
   19.92 -  (* precondition: is_lcf_term t = true *)
   19.93 -  fun cont_thms t = snd (cont_thms1 false t);
   19.94 -  fun all_cont_thms t = snd (cont_thms1 true t);
   19.95 -end;
   19.96 -
   19.97 -(*
   19.98 -  Given the term "cont f", the procedure tries to construct the
   19.99 -  theorem "cont f == True". If this theorem cannot be completely
  19.100 -  solved by the introduction rules, then the procedure returns a
  19.101 -  conditional rewrite rule with the unsolved subgoals as premises.
  19.102 -*)
  19.103 -
  19.104 -local
  19.105 -  val rules = [cont_K, cont_I, cont_R, cont_A, cont_L];
  19.106 -  
  19.107 -  val prev_cont_thms : thm list ref = ref [];
  19.108 -
  19.109 -  fun old_cont_tac i thm =
  19.110 -    case !prev_cont_thms of
  19.111 -      [] => no_tac thm
  19.112 -    | (c::cs) => (prev_cont_thms := cs; rtac c i thm);
  19.113 -
  19.114 -  fun new_cont_tac f' i thm =
  19.115 -    case all_cont_thms f' of
  19.116 -      [] => no_tac thm
  19.117 -    | (c::cs) => (prev_cont_thms := cs; rtac c i thm);
  19.118 -
  19.119 -  fun cont_tac_of_term (Const ("Cont.cont", _) $ f) =
  19.120 -    let
  19.121 -      val f' = Const ("Cfun.Abs_CFun", dummyT) $ f;
  19.122 -    in
  19.123 -      if is_lcf_term f'
  19.124 -      then old_cont_tac ORELSE' new_cont_tac f'
  19.125 -      else REPEAT_ALL_NEW (resolve_tac rules)
  19.126 -    end
  19.127 -    | cont_tac_of_term _ = K no_tac;
  19.128 -in
  19.129 -  val cont_tac =
  19.130 -    SUBGOAL (fn (t, i) => cont_tac_of_term (HOLogic.dest_Trueprop t) i);
  19.131 -end;
  19.132 -
  19.133 -local
  19.134 -  fun solve_cont thy _ t =
  19.135 -    let
  19.136 -      val tr = instantiate' [] [SOME (cterm_of thy t)] Eq_TrueI;
  19.137 -    in Option.map fst (Seq.pull (cont_tac 1 tr)) end
  19.138 -in
  19.139 -  fun cont_proc thy =
  19.140 -    Simplifier.simproc thy "cont_proc" ["cont f"] solve_cont;
  19.141 -end;
  19.142 -
  19.143 -val setup =
  19.144 -  (fn thy =>
  19.145 -    (Simplifier.change_simpset_of thy
  19.146 -      (fn ss => ss addsimprocs [cont_proc thy]); thy));
  19.147 -
  19.148 -end;
    20.1 --- a/src/HOLCF/domain/axioms.ML	Thu May 31 13:24:13 2007 +0200
    20.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    20.3 @@ -1,170 +0,0 @@
    20.4 -(*  Title:      HOLCF/domain/axioms.ML
    20.5 -    ID:         $Id$
    20.6 -    Author:     David von Oheimb
    20.7 -
    20.8 -Syntax generator for domain section.
    20.9 -*)
   20.10 -
   20.11 -structure Domain_Axioms = struct
   20.12 -
   20.13 -local
   20.14 -
   20.15 -open Domain_Library;
   20.16 -infixr 0 ===>;infixr 0 ==>;infix 0 == ; 
   20.17 -infix 1 ===; infix 1 ~= ; infix 1 <<; infix 1 ~<<;
   20.18 -infix 9 `   ; infix 9 `% ; infix 9 `%%; infixr 9 oo;
   20.19 -
   20.20 -fun calc_axioms comp_dname (eqs : eq list) n (((dname,_),cons) : eq)=
   20.21 -let
   20.22 -
   20.23 -(* ----- axioms and definitions concerning the isomorphism ------------------ *)
   20.24 -
   20.25 -  val dc_abs = %%:(dname^"_abs");
   20.26 -  val dc_rep = %%:(dname^"_rep");
   20.27 -  val x_name'= "x";
   20.28 -  val x_name = idx_name eqs x_name' (n+1);
   20.29 -  val dnam = Sign.base_name dname;
   20.30 -
   20.31 -  val abs_iso_ax = ("abs_iso", mk_trp(dc_rep`(dc_abs`%x_name') === %:x_name'));
   20.32 -  val rep_iso_ax = ("rep_iso", mk_trp(dc_abs`(dc_rep`%x_name') === %:x_name'));
   20.33 -
   20.34 -  val when_def = ("when_def",%%:(dname^"_when") == 
   20.35 -     foldr (uncurry /\ ) (/\x_name'((when_body cons (fn (x,y) =>
   20.36 -				Bound(1+length cons+x-y)))`(dc_rep`Bound 0))) (when_funs cons));
   20.37 -  
   20.38 -  val copy_def = let
   20.39 -    fun idxs z x arg = if is_rec arg
   20.40 -			 then (cproj (Bound z) eqs (rec_of arg))`Bound(z-x)
   20.41 -			 else Bound(z-x);
   20.42 -    fun one_con (con,args) =
   20.43 -        foldr /\# (list_ccomb (%%:con, mapn (idxs (length args)) 1 args)) args;
   20.44 -  in ("copy_def", %%:(dname^"_copy") ==
   20.45 -       /\"f" (list_ccomb (%%:(dname^"_when"), map one_con cons))) end;
   20.46 -
   20.47 -(* -- definitions concerning the constructors, discriminators and selectors - *)
   20.48 -
   20.49 -  fun con_def m n (_,args) = let
   20.50 -    fun idxs z x arg = (if is_lazy arg then fn t => %%:upN`t else I) (Bound(z-x));
   20.51 -    fun parms vs = mk_stuple (mapn (idxs(length vs)) 1 vs);
   20.52 -    fun inj y 1 _ = y
   20.53 -    |   inj y _ 0 = %%:sinlN`y
   20.54 -    |   inj y i j = %%:sinrN`(inj y (i-1) (j-1));
   20.55 -  in foldr /\# (dc_abs`(inj (parms args) m n)) args end;
   20.56 -  
   20.57 -  val con_defs = mapn (fn n => fn (con,args) =>
   20.58 -    (extern_name con ^"_def", %%:con == con_def (length cons) n (con,args))) 0 cons;
   20.59 -  
   20.60 -  val dis_defs = let
   20.61 -	fun ddef (con,_) = (dis_name con ^"_def",%%:(dis_name con) == 
   20.62 -		 list_ccomb(%%:(dname^"_when"),map 
   20.63 -			(fn (con',args) => (foldr /\#
   20.64 -			   (if con'=con then %%:TT_N else %%:FF_N) args)) cons))
   20.65 -	in map ddef cons end;
   20.66 -
   20.67 -  val mat_defs = let
   20.68 -	fun mdef (con,_) = (mat_name con ^"_def",%%:(mat_name con) == 
   20.69 -		 list_ccomb(%%:(dname^"_when"),map 
   20.70 -			(fn (con',args) => (foldr /\#
   20.71 -			   (if con'=con
   20.72 -                               then %%:returnN`(mk_ctuple (map (bound_arg args) args))
   20.73 -                               else %%:failN) args)) cons))
   20.74 -	in map mdef cons end;
   20.75 -
   20.76 -  val pat_defs =
   20.77 -    let
   20.78 -      fun pdef (con,args) =
   20.79 -        let
   20.80 -          val ps = mapn (fn n => fn _ => %:("pat" ^ string_of_int n)) 1 args;
   20.81 -          val xs = map (bound_arg args) args;
   20.82 -          val r = Bound (length args);
   20.83 -          val rhs = case args of [] => %%:returnN ` HOLogic.unit
   20.84 -                                | _ => foldr1 cpair_pat ps ` mk_ctuple xs;
   20.85 -          fun one_con (con',args') = foldr /\# (if con'=con then rhs else %%:failN) args';
   20.86 -        in (pat_name con ^"_def", list_comb (%%:(pat_name con), ps) == 
   20.87 -               list_ccomb(%%:(dname^"_when"), map one_con cons))
   20.88 -        end
   20.89 -    in map pdef cons end;
   20.90 -
   20.91 -  val sel_defs = let
   20.92 -	fun sdef con n arg = Option.map (fn sel => (sel^"_def",%%:sel == 
   20.93 -		 list_ccomb(%%:(dname^"_when"),map 
   20.94 -			(fn (con',args) => if con'<>con then UU else
   20.95 -			 foldr /\# (Bound (length args - n)) args) cons))) (sel_of arg);
   20.96 -	in List.mapPartial I (List.concat(map (fn (con,args) => mapn (sdef con) 1 args) cons)) end;
   20.97 -
   20.98 -
   20.99 -(* ----- axiom and definitions concerning induction ------------------------- *)
  20.100 -
  20.101 -  val reach_ax = ("reach", mk_trp(cproj (%%:fixN`%%(comp_dname^"_copy")) eqs n
  20.102 -					`%x_name === %:x_name));
  20.103 -  val take_def = ("take_def",%%:(dname^"_take") == mk_lam("n",cproj
  20.104 -	     (%%:iterateN $ Bound 0 ` %%:(comp_dname^"_copy") ` UU) eqs n));
  20.105 -  val finite_def = ("finite_def",%%:(dname^"_finite") == mk_lam(x_name,
  20.106 -	mk_ex("n",(%%:(dname^"_take") $ Bound 0)`Bound 1 === Bound 1)));
  20.107 -
  20.108 -in (dnam,
  20.109 -    [abs_iso_ax, rep_iso_ax, reach_ax],
  20.110 -    [when_def, copy_def] @
  20.111 -     con_defs @ dis_defs @ mat_defs @ pat_defs @ sel_defs @
  20.112 -    [take_def, finite_def])
  20.113 -end; (* let *)
  20.114 -
  20.115 -fun infer_props thy = map (apsnd (FixrecPackage.legacy_infer_prop thy));
  20.116 -
  20.117 -fun add_axioms_i x = snd o PureThy.add_axioms_i (map Thm.no_attributes x);
  20.118 -fun add_axioms_infer axms thy = add_axioms_i (infer_props thy axms) thy;
  20.119 -
  20.120 -fun add_defs_i x = snd o (PureThy.add_defs_i false) (map Thm.no_attributes x);
  20.121 -fun add_defs_infer defs thy = add_defs_i (infer_props thy defs) thy;
  20.122 -
  20.123 -in (* local *)
  20.124 -
  20.125 -fun add_axioms (comp_dnam, eqs : eq list) thy' = let
  20.126 -  val comp_dname = Sign.full_name thy' comp_dnam;
  20.127 -  val dnames = map (fst o fst) eqs;
  20.128 -  val x_name = idx_name dnames "x"; 
  20.129 -  fun copy_app dname = %%:(dname^"_copy")`Bound 0;
  20.130 -  val copy_def = ("copy_def" , %%:(comp_dname^"_copy") ==
  20.131 -				    /\"f"(foldr1 cpair (map copy_app dnames)));
  20.132 -  val bisim_def = ("bisim_def",%%:(comp_dname^"_bisim")==mk_lam("R",
  20.133 -    let
  20.134 -      fun one_con (con,args) = let
  20.135 -	val nonrec_args = filter_out is_rec args;
  20.136 -	val    rec_args = List.filter     is_rec args;
  20.137 -	val    recs_cnt = length rec_args;
  20.138 -	val allargs     = nonrec_args @ rec_args
  20.139 -				      @ map (upd_vname (fn s=> s^"'")) rec_args;
  20.140 -	val allvns      = map vname allargs;
  20.141 -	fun vname_arg s arg = if is_rec arg then vname arg^s else vname arg;
  20.142 -	val vns1        = map (vname_arg "" ) args;
  20.143 -	val vns2        = map (vname_arg "'") args;
  20.144 -	val allargs_cnt = length nonrec_args + 2*recs_cnt;
  20.145 -	val rec_idxs    = (recs_cnt-1) downto 0;
  20.146 -	val nonlazy_idxs = map snd (filter_out (fn (arg,_) => is_lazy arg)
  20.147 -					 (allargs~~((allargs_cnt-1) downto 0)));
  20.148 -	fun rel_app i ra = proj (Bound(allargs_cnt+2)) eqs (rec_of ra) $ 
  20.149 -			   Bound (2*recs_cnt-i) $ Bound (recs_cnt-i);
  20.150 -	val capps = foldr mk_conj (mk_conj(
  20.151 -	   Bound(allargs_cnt+1)===list_ccomb(%%:con,map (bound_arg allvns) vns1),
  20.152 -	   Bound(allargs_cnt+0)===list_ccomb(%%:con,map (bound_arg allvns) vns2)))
  20.153 -           (mapn rel_app 1 rec_args);
  20.154 -        in foldr mk_ex (Library.foldr mk_conj 
  20.155 -			      (map (defined o Bound) nonlazy_idxs,capps)) allvns end;
  20.156 -      fun one_comp n (_,cons) =mk_all(x_name(n+1),mk_all(x_name(n+1)^"'",mk_imp(
  20.157 -	 		proj (Bound 2) eqs n $ Bound 1 $ Bound 0,
  20.158 -         		foldr1 mk_disj (mk_conj(Bound 1 === UU,Bound 0 === UU)
  20.159 -					::map one_con cons))));
  20.160 -    in foldr1 mk_conj (mapn one_comp 0 eqs)end ));
  20.161 -  fun add_one (thy,(dnam,axs,dfs)) = thy
  20.162 -	|> Theory.add_path dnam
  20.163 -	|> add_defs_infer dfs
  20.164 -	|> add_axioms_infer axs
  20.165 -	|> Theory.parent_path;
  20.166 -  val thy = Library.foldl add_one (thy', mapn (calc_axioms comp_dname eqs) 0 eqs);
  20.167 -in thy |> Theory.add_path comp_dnam  
  20.168 -       |> add_defs_infer (bisim_def::(if length eqs>1 then [copy_def] else []))
  20.169 -       |> Theory.parent_path
  20.170 -end;
  20.171 -
  20.172 -end; (* local *)
  20.173 -end; (* struct *)
    21.1 --- a/src/HOLCF/domain/extender.ML	Thu May 31 13:24:13 2007 +0200
    21.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    21.3 @@ -1,183 +0,0 @@
    21.4 -(*  Title:      HOLCF/domain/extender.ML
    21.5 -    ID:         $Id$
    21.6 -    Author:     David von Oheimb
    21.7 -
    21.8 -Theory extender for domain section, including new-style theory syntax.
    21.9 -
   21.10 -###TODO: 
   21.11 -
   21.12 -this definition
   21.13 -domain empty = silly empty
   21.14 -yields
   21.15 -Exception-
   21.16 -   TERM
   21.17 -      ("typ_of_term: bad encoding of type",
   21.18 -         [Abs ("uu", "_", Const ("NONE", "_"))]) raised
   21.19 -but this works fine:
   21.20 -domain Empty = silly Empty
   21.21 -
   21.22 -strange syntax errors are produced for:
   21.23 -domain xx = xx ("x yy")
   21.24 -domain 'a foo = foo (sel::"'a") 
   21.25 -and bar = bar ("'a dummy")
   21.26 -
   21.27 -*)
   21.28 -
   21.29 -signature DOMAIN_EXTENDER =
   21.30 -sig
   21.31 -  val add_domain: string * ((bstring * string list) *
   21.32 -    (string * mixfix * (bool * string option * string) list) list) list
   21.33 -    -> theory -> theory
   21.34 -  val add_domain_i: string * ((bstring * string list) *
   21.35 -    (string * mixfix * (bool * string option * typ) list) list) list
   21.36 -    -> theory -> theory
   21.37 -end;
   21.38 -
   21.39 -structure Domain_Extender: DOMAIN_EXTENDER =
   21.40 -struct
   21.41 -
   21.42 -open Domain_Library;
   21.43 -
   21.44 -(* ----- general testing and preprocessing of constructor list -------------- *)
   21.45 -fun check_and_sort_domain (dtnvs: (string * typ list) list, 
   21.46 -     cons'' : ((string * mixfix * (bool * string option * typ) list) list) list) sg =
   21.47 -  let
   21.48 -    val defaultS = Sign.defaultS sg;
   21.49 -    val test_dupl_typs = (case duplicates (op =) (map fst dtnvs) of 
   21.50 -	[] => false | dups => error ("Duplicate types: " ^ commas_quote dups));
   21.51 -    val test_dupl_cons = (case duplicates (op =) (map first (List.concat cons'')) of 
   21.52 -	[] => false | dups => error ("Duplicate constructors: " 
   21.53 -							 ^ commas_quote dups));
   21.54 -    val test_dupl_sels = (case duplicates (op =) (List.mapPartial second
   21.55 -			       (List.concat (map third (List.concat cons'')))) of
   21.56 -        [] => false | dups => error("Duplicate selectors: "^commas_quote dups));
   21.57 -    val test_dupl_tvars = exists(fn s=>case duplicates (op =) (map(fst o dest_TFree)s)of
   21.58 -	[] => false | dups => error("Duplicate type arguments: " 
   21.59 -		   ^commas_quote dups)) (map snd dtnvs);
   21.60 -    (* test for free type variables, illegal sort constraints on rhs,
   21.61 -	       non-pcpo-types and invalid use of recursive type;
   21.62 -       replace sorts in type variables on rhs *)
   21.63 -    fun analyse_equation ((dname,typevars),cons') = 
   21.64 -      let
   21.65 -	val tvars = map dest_TFree typevars;
   21.66 -	val distinct_typevars = map TFree tvars;
   21.67 -	fun rm_sorts (TFree(s,_)) = TFree(s,[])
   21.68 -	|   rm_sorts (Type(s,ts)) = Type(s,remove_sorts ts)
   21.69 -	|   rm_sorts (TVar(s,_))  = TVar(s,[])
   21.70 -	and remove_sorts l = map rm_sorts l;
   21.71 -	val indirect_ok = ["*","Cfun.->","Ssum.++","Sprod.**","Up.u"]
   21.72 -	fun analyse indirect (TFree(v,s))  = (case AList.lookup (op =) tvars v of 
   21.73 -		    NONE => error ("Free type variable " ^ quote v ^ " on rhs.")
   21.74 -	          | SOME sort => if eq_set_string (s,defaultS) orelse
   21.75 -				    eq_set_string (s,sort    )
   21.76 -				 then TFree(v,sort)
   21.77 -				 else error ("Inconsistent sort constraint" ^
   21.78 -				             " for type variable " ^ quote v))
   21.79 -        |   analyse indirect (t as Type(s,typl)) = (case AList.lookup (op =) dtnvs s of
   21.80 -		NONE          => if s mem indirect_ok
   21.81 -				 then Type(s,map (analyse false) typl)
   21.82 -				 else Type(s,map (analyse true) typl)
   21.83 -	      | SOME typevars => if indirect 
   21.84 -                           then error ("Indirect recursion of type " ^ 
   21.85 -				        quote (string_of_typ sg t))
   21.86 -                           else if dname <> s orelse (** BUG OR FEATURE?: 
   21.87 -                                mutual recursion may use different arguments **)
   21.88 -				   remove_sorts typevars = remove_sorts typl 
   21.89 -				then Type(s,map (analyse true) typl)
   21.90 -				else error ("Direct recursion of type " ^ 
   21.91 -					     quote (string_of_typ sg t) ^ 
   21.92 -					    " with different arguments"))
   21.93 -        |   analyse indirect (TVar _) = Imposs "extender:analyse";
   21.94 -	fun check_pcpo T = if pcpo_type sg T then T
   21.95 -          else error("Constructor argument type is not of sort pcpo: "^string_of_typ sg T);
   21.96 -	val analyse_con = upd_third (map (upd_third (check_pcpo o analyse false)));
   21.97 -      in ((dname,distinct_typevars), map analyse_con cons') end; 
   21.98 -  in ListPair.map analyse_equation (dtnvs,cons'')
   21.99 -  end; (* let *)
  21.100 -
  21.101 -(* ----- calls for building new thy and thms -------------------------------- *)
  21.102 -
  21.103 -fun gen_add_domain prep_typ (comp_dnam, eqs''') thy''' =
  21.104 -  let
  21.105 -    val dtnvs = map ((fn (dname,vs) => 
  21.106 -			 (Sign.full_name thy''' dname, map (Sign.read_typ thy''') vs))
  21.107 -                   o fst) eqs''';
  21.108 -    val cons''' = map snd eqs''';
  21.109 -    fun thy_type  (dname,tvars)  = (Sign.base_name dname, length tvars, NoSyn);
  21.110 -    fun thy_arity (dname,tvars)  = (dname, map (snd o dest_TFree) tvars, pcpoS);
  21.111 -    val thy'' = thy''' |> Theory.add_types     (map thy_type  dtnvs)
  21.112 -		       |> fold (AxClass.axiomatize_arity_i o thy_arity) dtnvs;
  21.113 -    val cons'' = map (map (upd_third (map (upd_third (prep_typ thy''))))) cons''';
  21.114 -    val eqs' = check_and_sort_domain (dtnvs,cons'') thy'';
  21.115 -    val thy' = thy'' |> Domain_Syntax.add_syntax (comp_dnam,eqs');
  21.116 -    val dts  = map (Type o fst) eqs';
  21.117 -    val new_dts = map (fn ((s,Ts),_) => (s, map (fst o dest_TFree) Ts)) eqs';
  21.118 -    fun strip ss = Library.drop (find_index_eq "'" ss +1, ss);
  21.119 -    fun typid (Type  (id,_)) =
  21.120 -          let val c = hd (Symbol.explode (Sign.base_name id))
  21.121 -          in if Symbol.is_letter c then c else "t" end
  21.122 -      | typid (TFree (id,_)   ) = hd (strip (tl (Symbol.explode id)))
  21.123 -      | typid (TVar ((id,_),_)) = hd (tl (Symbol.explode id));
  21.124 -    fun one_con (con,mx,args) =
  21.125 -	((Syntax.const_name con mx),
  21.126 -	 ListPair.map (fn ((lazy,sel,tp),vn) => ((lazy,
  21.127 -					find_index_eq tp dts,
  21.128 -					DatatypeAux.dtyp_of_typ new_dts tp),
  21.129 -					sel,vn))
  21.130 -	     (args,(mk_var_names(map (typid o third) args)))
  21.131 -	 ) : cons;
  21.132 -    val eqs = map (fn (dtnvs,cons') => (dtnvs, map one_con cons')) eqs' : eq list;
  21.133 -    val thy        = thy' |> Domain_Axioms.add_axioms (comp_dnam,eqs);
  21.134 -    val (theorems_thy, (rewss, take_rews)) = (foldl_map (fn (thy0,eq) =>
  21.135 -      Domain_Theorems.theorems (eq,eqs) thy0) (thy,eqs))
  21.136 -      |>>> Domain_Theorems.comp_theorems (comp_dnam, eqs);
  21.137 -  in
  21.138 -    theorems_thy
  21.139 -    |> Theory.add_path (Sign.base_name comp_dnam)
  21.140 -    |> (snd o (PureThy.add_thmss [(("rews", List.concat rewss @ take_rews), [])]))
  21.141 -    |> Theory.parent_path
  21.142 -  end;
  21.143 -
  21.144 -val add_domain_i = gen_add_domain Sign.certify_typ;
  21.145 -val add_domain = gen_add_domain Sign.read_typ;
  21.146 -
  21.147 -
  21.148 -(** outer syntax **)
  21.149 -
  21.150 -local structure P = OuterParse and K = OuterKeyword in
  21.151 -
  21.152 -val dest_decl =
  21.153 -  P.$$$ "(" |-- Scan.optional (P.$$$ "lazy" >> K true) false --
  21.154 -    (P.name >> SOME) -- (P.$$$ "::" |-- P.typ)  --| P.$$$ ")" >> P.triple1
  21.155 -  || P.$$$ "(" |-- P.$$$ "lazy" |-- P.typ --| P.$$$ ")"
  21.156 -       >> (fn t => (true,NONE,t))
  21.157 -  || P.typ >> (fn t => (false,NONE,t));
  21.158 -
  21.159 -val cons_decl =
  21.160 -  P.name -- Scan.repeat dest_decl -- P.opt_mixfix
  21.161 -  >> (fn ((c, ds), mx) => (c, mx, ds));
  21.162 -
  21.163 -val type_var' = (P.type_ident ^^ 
  21.164 -                 Scan.optional (P.$$$ "::" ^^ P.!!! P.sort) "");
  21.165 -val type_args' = type_var' >> single ||
  21.166 -                 P.$$$ "(" |-- P.!!! (P.list1 type_var' --| P.$$$ ")") ||
  21.167 - 		 Scan.succeed [];
  21.168 -
  21.169 -val domain_decl = (type_args' -- P.name >> Library.swap) -- 
  21.170 -                  (P.$$$ "=" |-- P.enum1 "|" cons_decl);
  21.171 -val domains_decl =
  21.172 -  Scan.option (P.$$$ "(" |-- P.name --| P.$$$ ")") -- P.and_list1 domain_decl
  21.173 -  >> (fn (opt_name, doms) =>
  21.174 -      (case opt_name of NONE => space_implode "_" (map (#1 o #1) doms) | SOME s => s, doms));
  21.175 -
  21.176 -val domainP =
  21.177 -  OuterSyntax.command "domain" "define recursive domains (HOLCF)" K.thy_decl
  21.178 -    (domains_decl >> (Toplevel.theory o add_domain));
  21.179 -
  21.180 -
  21.181 -val _ = OuterSyntax.add_keywords ["lazy"];
  21.182 -val _ = OuterSyntax.add_parsers [domainP];
  21.183 -
  21.184 -end; (* local structure *)
  21.185 -
  21.186 -end;
    22.1 --- a/src/HOLCF/domain/library.ML	Thu May 31 13:24:13 2007 +0200
    22.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    22.3 @@ -1,230 +0,0 @@
    22.4 -(*  Title:      HOLCF/domain/library.ML
    22.5 -    ID:         $Id$
    22.6 -    Author:     David von Oheimb
    22.7 -
    22.8 -Library for domain section.
    22.9 -*)
   22.10 -
   22.11 -
   22.12 -(* ----- general support ---------------------------------------------------- *)
   22.13 -
   22.14 -fun mapn f n []      = []
   22.15 -|   mapn f n (x::xs) = (f n x) :: mapn f (n+1) xs;
   22.16 -
   22.17 -fun foldr'' f (l,f2) = let fun itr []  = raise Fail "foldr''"
   22.18 -			     | itr [a] = f2 a
   22.19 -			     | itr (a::l) = f(a, itr l)
   22.20 -in  itr l  end;
   22.21 -fun map_cumulr f start xs = foldr (fn (x,(ys,res))=>case f(x,res) of (y,res2) =>
   22.22 -						  (y::ys,res2)) ([],start) xs;
   22.23 -
   22.24 -
   22.25 -fun first  (x,_,_) = x; fun second (_,x,_) = x; fun third  (_,_,x) = x;
   22.26 -fun upd_first  f (x,y,z) = (f x,   y,   z);
   22.27 -fun upd_second f (x,y,z) = (  x, f y,   z);
   22.28 -fun upd_third  f (x,y,z) = (  x,   y, f z);
   22.29 -
   22.30 -fun atomize thm = let val r_inst = read_instantiate;
   22.31 -    fun at  thm = case concl_of thm of
   22.32 -      _$(Const("op &",_)$_$_)       => at(thm RS conjunct1)@at(thm RS conjunct2)
   22.33 -    | _$(Const("All" ,_)$Abs(s,_,_))=> at(thm RS (r_inst [("x","?"^s)] spec))
   22.34 -    | _				    => [thm];
   22.35 -in map zero_var_indexes (at thm) end;
   22.36 -
   22.37 -(* ----- specific support for domain ---------------------------------------- *)
   22.38 -
   22.39 -structure Domain_Library = struct
   22.40 -
   22.41 -open HOLCFLogic;
   22.42 -
   22.43 -exception Impossible of string;
   22.44 -fun Imposs msg = raise Impossible ("Domain:"^msg);
   22.45 -
   22.46 -(* ----- name handling ----- *)
   22.47 -
   22.48 -val strip_esc = let fun strip ("'" :: c :: cs) = c :: strip cs
   22.49 -		    |   strip ["'"] = []
   22.50 -		    |   strip (c :: cs) = c :: strip cs
   22.51 -		    |   strip [] = [];
   22.52 -in implode o strip o Symbol.explode end;
   22.53 -
   22.54 -fun extern_name con = case Symbol.explode con of 
   22.55 -		   ("o"::"p"::" "::rest) => implode rest
   22.56 -		   | _ => con;
   22.57 -fun dis_name  con = "is_"^ (extern_name con);
   22.58 -fun dis_name_ con = "is_"^ (strip_esc   con);
   22.59 -fun mat_name  con = "match_"^ (extern_name con);
   22.60 -fun mat_name_ con = "match_"^ (strip_esc   con);
   22.61 -fun pat_name  con = (extern_name con) ^ "_pat";
   22.62 -fun pat_name_ con = (strip_esc   con) ^ "_pat";
   22.63 -
   22.64 -(* make distinct names out of the type list, 
   22.65 -   forbidding "o","n..","x..","f..","P.." as names *)
   22.66 -(* a number string is added if necessary *)
   22.67 -fun mk_var_names ids : string list = let
   22.68 -    fun nonreserved s = if s mem ["n","x","f","P"] then s^"'" else s;
   22.69 -    fun index_vnames(vn::vns,occupied) =
   22.70 -          (case AList.lookup (op =) occupied vn of
   22.71 -             NONE => if vn mem vns
   22.72 -                     then (vn^"1") :: index_vnames(vns,(vn,1)  ::occupied)
   22.73 -                     else  vn      :: index_vnames(vns,          occupied)
   22.74 -           | SOME(i) => (vn^(string_of_int (i+1)))
   22.75 -				   :: index_vnames(vns,(vn,i+1)::occupied))
   22.76 -      | index_vnames([],occupied) = [];
   22.77 -in index_vnames(map nonreserved ids, [("O",0),("o",0)]) end;
   22.78 -
   22.79 -fun pcpo_type sg t = Sign.of_sort sg (Sign.certify_typ sg t, pcpoS);
   22.80 -fun string_of_typ sg = Sign.string_of_typ sg o Sign.certify_typ sg;
   22.81 -
   22.82 -(* ----- constructor list handling ----- *)
   22.83 -
   22.84 -type cons = (string *				(* operator name of constr *)
   22.85 -	    ((bool*int*DatatypeAux.dtyp)*	(*  (lazy,recursive element or ~1) *)
   22.86 -	      string option*			(*   selector name    *)
   22.87 -	      string)				(*   argument name    *)
   22.88 -	    list);				(* argument list      *)
   22.89 -type eq = (string *		(* name      of abstracted type *)
   22.90 -	   typ list) *		(* arguments of abstracted type *)
   22.91 -	  cons list;		(* represented type, as a constructor list *)
   22.92 -
   22.93 -fun rec_of arg  = second (first arg);
   22.94 -fun is_lazy arg = first (first arg);
   22.95 -val sel_of    =       second;
   22.96 -val     vname =       third;
   22.97 -val upd_vname =   upd_third;
   22.98 -fun is_rec         arg = rec_of arg >=0;
   22.99 -fun is_nonlazy_rec arg = is_rec arg andalso not (is_lazy arg);
  22.100 -fun nonlazy     args   = map vname (filter_out is_lazy    args);
  22.101 -fun nonlazy_rec args   = map vname (List.filter is_nonlazy_rec args);
  22.102 -
  22.103 -(* ----- qualified names of HOLCF constants ----- *)
  22.104 -
  22.105 -val lessN      = "Porder.<<"
  22.106 -val UU_N       = "Pcpo.UU";
  22.107 -val admN       = "Adm.adm";
  22.108 -val compactN   = "Adm.compact";
  22.109 -val Rep_CFunN  = "Cfun.Rep_CFun";
  22.110 -val Abs_CFunN  = "Cfun.Abs_CFun";
  22.111 -val ID_N       = "Cfun.ID";
  22.112 -val cfcompN    = "Cfun.cfcomp";
  22.113 -val strictifyN = "Cfun.strictify";
  22.114 -val cpairN     = "Cprod.cpair";
  22.115 -val cfstN      = "Cprod.cfst";
  22.116 -val csndN      = "Cprod.csnd";
  22.117 -val csplitN    = "Cprod.csplit";
  22.118 -val spairN     = "Sprod.spair";
  22.119 -val sfstN      = "Sprod.sfst";
  22.120 -val ssndN      = "Sprod.ssnd";
  22.121 -val ssplitN    = "Sprod.ssplit";
  22.122 -val sinlN      = "Ssum.sinl";
  22.123 -val sinrN      = "Ssum.sinr";
  22.124 -val sscaseN    = "Ssum.sscase";
  22.125 -val upN        = "Up.up";
  22.126 -val fupN       = "Up.fup";
  22.127 -val ONE_N      = "One.ONE";
  22.128 -val TT_N       = "Tr.TT";
  22.129 -val FF_N       = "Tr.FF";
  22.130 -val iterateN   = "Fix.iterate";
  22.131 -val fixN       = "Fix.fix";
  22.132 -val returnN    = "Fixrec.return";
  22.133 -val failN      = "Fixrec.fail";
  22.134 -val cpair_patN = "Fixrec.cpair_pat";
  22.135 -val branchN    = "Fixrec.branch";
  22.136 -
  22.137 -val pcpoN      = "Pcpo.pcpo"
  22.138 -val pcpoS      = [pcpoN];
  22.139 -
  22.140 -
  22.141 -(* ----- support for type and mixfix expressions ----- *)
  22.142 -
  22.143 -infixr 5 -->;
  22.144 -
  22.145 -(* ----- support for term expressions ----- *)
  22.146 -
  22.147 -fun %: s = Free(s,dummyT);
  22.148 -fun %# arg = %:(vname arg);
  22.149 -fun %%: s = Const(s,dummyT);
  22.150 -
  22.151 -local open HOLogic in
  22.152 -val mk_trp = mk_Trueprop;
  22.153 -fun mk_conj (S,T) = conj $ S $ T;
  22.154 -fun mk_disj (S,T) = disj $ S $ T;
  22.155 -fun mk_imp  (S,T) = imp  $ S $ T;
  22.156 -fun mk_lam  (x,T) = Abs(x,dummyT,T);
  22.157 -fun mk_all  (x,P) = HOLogic.mk_all (x,dummyT,P);
  22.158 -fun mk_ex   (x,P) = mk_exists (x,dummyT,P);
  22.159 -fun mk_constrain      (typ,T) = TypeInfer.constrain T typ;
  22.160 -fun mk_constrainall (x,typ,P) = %%:"All" $ (TypeInfer.constrain (mk_lam(x,P)) (typ --> boolT));
  22.161 -end
  22.162 -
  22.163 -fun mk_All  (x,P) = %%:"all" $ mk_lam(x,P); (* meta universal quantification *)
  22.164 -
  22.165 -infixr 0 ===>;  fun S ===> T = %%:"==>" $ S $ T;
  22.166 -infixr 0 ==>;   fun S ==> T = mk_trp S ===> mk_trp T;
  22.167 -infix 0 ==;     fun S ==  T = %%:"==" $ S $ T;
  22.168 -infix 1 ===;    fun S === T = %%:"op =" $ S $ T;
  22.169 -infix 1 ~=;     fun S ~=  T = HOLogic.mk_not (S === T);
  22.170 -infix 1 <<;     fun S <<  T = %%:lessN $ S $ T;
  22.171 -infix 1 ~<<;    fun S ~<< T = HOLogic.mk_not (S << T);
  22.172 -
  22.173 -infix 9 `  ; fun f`  x = %%:Rep_CFunN $ f $ x;
  22.174 -infix 9 `% ; fun f`% s = f` %: s;
  22.175 -infix 9 `%%; fun f`%%s = f` %%:s;
  22.176 -val list_ccomb = Library.foldl (op `); (* continuous version of list_comb *)
  22.177 -fun con_app2 con f args = list_ccomb(%%:con,map f args);
  22.178 -fun con_app con = con_app2 con %#;
  22.179 -fun if_rec  arg f y   = if is_rec arg then f (rec_of arg) else y;
  22.180 -fun app_rec_arg p arg = if_rec arg (fn n => fn x => (p n)`x) I (%# arg);
  22.181 -fun prj _  _  x (   _::[]) _ = x
  22.182 -|   prj f1 _  x (_::y::ys) 0 = f1 x y
  22.183 -|   prj f1 f2 x (y::   ys) j = prj f1 f2 (f2 x y) ys (j-1);
  22.184 -fun  proj x      = prj (fn S => K(%%:"fst" $S)) (fn S => K(%%:"snd" $S)) x;
  22.185 -fun cproj x      = prj (fn S => K(%%:cfstN`S)) (fn S => K(%%:csndN`S)) x;
  22.186 -fun lift tfn = Library.foldr (fn (x,t)=> (mk_trp(tfn x) ===> t));
  22.187 -
  22.188 -fun /\ v T = %%:Abs_CFunN $ mk_lam(v,T);
  22.189 -fun /\# (arg,T) = /\ (vname arg) T;
  22.190 -infixr 9 oo; fun S oo T = %%:cfcompN`S`T;
  22.191 -val UU = %%:UU_N;
  22.192 -fun strict f = f`UU === UU;
  22.193 -fun defined t = t ~= UU;
  22.194 -fun cpair (t,u) = %%:cpairN`t`u;
  22.195 -fun spair (t,u) = %%:spairN`t`u;
  22.196 -fun mk_ctuple [] = HOLogic.unit (* used in match_defs *)
  22.197 -|   mk_ctuple ts = foldr1 cpair ts;
  22.198 -fun mk_stuple [] = %%:ONE_N
  22.199 -|   mk_stuple ts = foldr1 spair ts;
  22.200 -fun mk_ctupleT [] = HOLogic.unitT   (* used in match_defs *)
  22.201 -|   mk_ctupleT Ts = foldr1 HOLogic.mk_prodT Ts;
  22.202 -fun mk_maybeT T = Type ("Fixrec.maybe",[T]);
  22.203 -fun cpair_pat (p1,p2) = %%:cpair_patN $ p1 $ p2;
  22.204 -fun lift_defined f = lift (fn x => defined (f x));
  22.205 -fun bound_arg vns v = Bound(length vns -find_index_eq v vns -1);
  22.206 -
  22.207 -fun cont_eta_contract (Const("Cfun.Abs_CFun",TT) $ Abs(a,T,body)) = 
  22.208 -      (case cont_eta_contract body  of
  22.209 -        body' as (Const("Cfun.Rep_CFun",Ta) $ f $ Bound 0) => 
  22.210 -	  if not (0 mem loose_bnos f) then incr_boundvars ~1 f 
  22.211 -	  else   Const("Cfun.Abs_CFun",TT) $ Abs(a,T,body')
  22.212 -      | body' => Const("Cfun.Abs_CFun",TT) $ Abs(a,T,body'))
  22.213 -|   cont_eta_contract(f$t) = cont_eta_contract f $ cont_eta_contract t
  22.214 -|   cont_eta_contract t    = t;
  22.215 -
  22.216 -fun idx_name dnames s n = s^(if length dnames = 1 then "" else string_of_int n);
  22.217 -fun when_funs cons = if length cons = 1 then ["f"] 
  22.218 -                     else mapn (fn n => K("f"^(string_of_int n))) 1 cons;
  22.219 -fun when_body cons funarg = let
  22.220 -	fun one_fun n (_,[]  ) = /\ "dummy" (funarg(1,n))
  22.221 -	|   one_fun n (_,args) = let
  22.222 -		val l2 = length args;
  22.223 -		fun idxs m arg = (if is_lazy arg then fn x=> %%:fupN` %%:ID_N`x
  22.224 -					         else I) (Bound(l2-m));
  22.225 -		in cont_eta_contract (foldr'' 
  22.226 -			(fn (a,t) => %%:ssplitN`(/\# (a,t)))
  22.227 -			(args,
  22.228 -			fn a=> /\#(a,(list_ccomb(funarg(l2,n),mapn idxs 1 args))))
  22.229 -			) end;
  22.230 -in (if length cons = 1 andalso length(snd(hd cons)) <= 1
  22.231 -    then fn t => %%:strictifyN`t else I)
  22.232 -     (foldr1 (fn (x,y)=> %%:sscaseN`x`y) (mapn one_fun 1 cons)) end;
  22.233 -end; (* struct *)
    23.1 --- a/src/HOLCF/domain/syntax.ML	Thu May 31 13:24:13 2007 +0200
    23.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    23.3 @@ -1,151 +0,0 @@
    23.4 -(*  Title:      HOLCF/domain/syntax.ML
    23.5 -    ID:         $Id$
    23.6 -    Author:     David von Oheimb
    23.7 -
    23.8 -Syntax generator for domain section.
    23.9 -*)
   23.10 -
   23.11 -structure Domain_Syntax = struct 
   23.12 -
   23.13 -local 
   23.14 -
   23.15 -open Domain_Library;
   23.16 -infixr 5 -->; infixr 6 ->>;
   23.17 -fun calc_syntax dtypeprod ((dname, typevars), 
   23.18 -	(cons': (string * mixfix * (bool * string option * typ) list) list)) =
   23.19 -let
   23.20 -(* ----- constants concerning the isomorphism ------------------------------- *)
   23.21 -
   23.22 -local
   23.23 -  fun opt_lazy (lazy,_,t) = if lazy then mk_uT t else t
   23.24 -  fun prod     (_,_,args) = if args = [] then oneT
   23.25 -			    else foldr1 mk_sprodT (map opt_lazy args);
   23.26 -  fun freetvar s = let val tvar = mk_TFree s in
   23.27 -		   if tvar mem typevars then freetvar ("t"^s) else tvar end;
   23.28 -  fun when_type (_   ,_,args) = foldr (op ->>) (freetvar "t") (map third args);
   23.29 -in
   23.30 -  val dtype  = Type(dname,typevars);
   23.31 -  val dtype2 = foldr1 mk_ssumT (map prod cons');
   23.32 -  val dnam = Sign.base_name dname;
   23.33 -  val const_rep  = (dnam^"_rep" ,              dtype  ->> dtype2, NoSyn);
   23.34 -  val const_abs  = (dnam^"_abs" ,              dtype2 ->> dtype , NoSyn);
   23.35 -  val const_when = (dnam^"_when",foldr (op ->>) (dtype ->> freetvar "t") (map when_type cons'), NoSyn);
   23.36 -  val const_copy = (dnam^"_copy", dtypeprod ->> dtype  ->> dtype , NoSyn);
   23.37 -end;
   23.38 -
   23.39 -(* ----- constants concerning constructors, discriminators, and selectors --- *)
   23.40 -
   23.41 -local
   23.42 -  val escape = let
   23.43 -	fun esc (c::cs) = if c mem ["'","_","(",")","/"] then "'"::c::esc cs
   23.44 -							 else      c::esc cs
   23.45 -	|   esc []      = []
   23.46 -	in implode o esc o Symbol.explode end;
   23.47 -  fun con (name,s,args) = (name,foldr (op ->>) dtype (map third args),s);
   23.48 -  fun dis (con ,s,_   ) = (dis_name_ con, dtype->>trT,
   23.49 -			   Mixfix(escape ("is_" ^ con), [], Syntax.max_pri));
   23.50 -			(* strictly speaking, these constants have one argument,
   23.51 -			   but the mixfix (without arguments) is introduced only
   23.52 -			   to generate parse rules for non-alphanumeric names*)
   23.53 -  fun mat (con ,s,args) = (mat_name_ con, dtype->>mk_maybeT(mk_ctupleT(map third args)),
   23.54 -			   Mixfix(escape ("match_" ^ con), [], Syntax.max_pri));
   23.55 -  fun sel1 (_,sel,typ)  = Option.map (fn s => (s,dtype ->> typ,NoSyn)) sel;
   23.56 -  fun sel (_   ,_,args) = List.mapPartial sel1 args;
   23.57 -  fun freetvar s n      = let val tvar = mk_TFree (s ^ string_of_int n) in
   23.58 -			  if tvar mem typevars then freetvar ("t"^s) n else tvar end;
   23.59 -  fun mk_patT (a,b)     = a ->> mk_maybeT b;
   23.60 -  fun pat_arg_typ n arg = mk_patT (third arg, freetvar "t" n);
   23.61 -  fun pat (con ,s,args) = (pat_name_ con, (mapn pat_arg_typ 1 args) --->
   23.62 -			   mk_patT (dtype, mk_ctupleT (map (freetvar "t") (1 upto length args))),
   23.63 -			   Mixfix(escape (con ^ "_pat"), [], Syntax.max_pri));
   23.64 -
   23.65 -in
   23.66 -  val consts_con = map con cons';
   23.67 -  val consts_dis = map dis cons';
   23.68 -  val consts_mat = map mat cons';
   23.69 -  val consts_pat = map pat cons';
   23.70 -  val consts_sel = List.concat(map sel cons');
   23.71 -end;
   23.72 -
   23.73 -(* ----- constants concerning induction ------------------------------------- *)
   23.74 -
   23.75 -  val const_take   = (dnam^"_take"  , HOLogic.natT-->dtype->>dtype, NoSyn);
   23.76 -  val const_finite = (dnam^"_finite", dtype-->HOLogic.boolT       , NoSyn);
   23.77 -
   23.78 -(* ----- case translation --------------------------------------------------- *)
   23.79 -
   23.80 -local open Syntax in
   23.81 -  local
   23.82 -    fun c_ast con mx = Constant (const_name con mx);
   23.83 -    fun expvar n     = Variable ("e"^(string_of_int n));
   23.84 -    fun argvar n m _ = Variable ("a"^(string_of_int n)^"_"^
   23.85 -				     (string_of_int m));
   23.86 -    fun argvars n args = mapn (argvar n) 1 args;
   23.87 -    fun app s (l,r)  = mk_appl (Constant s) [l,r];
   23.88 -    val cabs = app "_cabs";
   23.89 -    val capp = app "Rep_CFun";
   23.90 -    fun con1 n (con,mx,args) = Library.foldl capp (c_ast con mx, argvars n args);
   23.91 -    fun case1 n (con,mx,args) = app "_case1" (con1 n (con,mx,args), expvar n);
   23.92 -    fun arg1 n (con,_,args) = foldr cabs (expvar n) (argvars n args);
   23.93 -    fun when1 n m = if n = m then arg1 n else K (Constant "UU");
   23.94 -
   23.95 -    fun app_var x = mk_appl (Constant "_var") [x, Variable "rhs"];
   23.96 -    fun app_pat x = mk_appl (Constant "_pat") [x];
   23.97 -    fun args_list [] = Constant "Unity"
   23.98 -    |   args_list xs = foldr1 (app "_args") xs;
   23.99 -  in
  23.100 -    val case_trans = ParsePrintRule
  23.101 -        (app "_case_syntax" (Variable "x", foldr1 (app "_case2") (mapn case1 1 cons')),
  23.102 -         capp (Library.foldl capp (Constant (dnam^"_when"), mapn arg1 1 cons'), Variable "x"));
  23.103 -    
  23.104 -    val abscon_trans = mapn (fn n => fn (con,mx,args) => ParsePrintRule
  23.105 -        (cabs (con1 n (con,mx,args), expvar n),
  23.106 -         Library.foldl capp (Constant (dnam^"_when"), mapn (when1 n) 1 cons'))) 1 cons';
  23.107 -    
  23.108 -    val Case_trans = List.concat (map (fn (con,mx,args) =>
  23.109 -      let
  23.110 -        val cname = c_ast con mx;
  23.111 -        val pname = Constant (pat_name_ con);
  23.112 -        val ns = 1 upto length args;
  23.113 -        val xs = map (fn n => Variable ("x"^(string_of_int n))) ns;
  23.114 -        val ps = map (fn n => Variable ("p"^(string_of_int n))) ns;
  23.115 -        val vs = map (fn n => Variable ("v"^(string_of_int n))) ns;
  23.116 -      in
  23.117 -        [ParseRule (app_pat (Library.foldl capp (cname, xs)),
  23.118 -                    mk_appl pname (map app_pat xs)),
  23.119 -         ParseRule (app_var (Library.foldl capp (cname, xs)),
  23.120 -                    app_var (args_list xs)),
  23.121 -         PrintRule (Library.foldl capp (cname, ListPair.map (app "_match") (ps,vs)),
  23.122 -                    app "_match" (mk_appl pname ps, args_list vs))]
  23.123 -      end) cons');
  23.124 -  end;
  23.125 -end;
  23.126 -
  23.127 -in ([const_rep, const_abs, const_when, const_copy] @ 
  23.128 -     consts_con @ consts_dis @ consts_mat @ consts_pat @ consts_sel @
  23.129 -    [const_take, const_finite],
  23.130 -    (case_trans::(abscon_trans @ Case_trans)))
  23.131 -end; (* let *)
  23.132 -
  23.133 -(* ----- putting all the syntax stuff together ------------------------------ *)
  23.134 -
  23.135 -in (* local *)
  23.136 -
  23.137 -fun add_syntax (comp_dnam,eqs': ((string * typ list) *
  23.138 -	(string * mixfix * (bool * string option * typ) list) list) list) thy'' =
  23.139 -let
  23.140 -  val dtypes  = map (Type o fst) eqs';
  23.141 -  val boolT   = HOLogic.boolT;
  23.142 -  val funprod = foldr1 HOLogic.mk_prodT (map (fn tp => tp ->> tp          ) dtypes);
  23.143 -  val relprod = foldr1 HOLogic.mk_prodT (map (fn tp => tp --> tp --> boolT) dtypes);
  23.144 -  val const_copy   = (comp_dnam^"_copy"  ,funprod ->> funprod, NoSyn);
  23.145 -  val const_bisim  = (comp_dnam^"_bisim" ,relprod --> boolT  , NoSyn);
  23.146 -  val ctt           = map (calc_syntax funprod) eqs';
  23.147 -in thy'' |> ContConsts.add_consts_i (List.concat (map fst ctt) @ 
  23.148 -				    (if length eqs'>1 then [const_copy] else[])@
  23.149 -				    [const_bisim])
  23.150 -	 |> Sign.add_trrules_i (List.concat(map snd ctt))
  23.151 -end; (* let *)
  23.152 -
  23.153 -end; (* local *)
  23.154 -end; (* struct *)
    24.1 --- a/src/HOLCF/domain/theorems.ML	Thu May 31 13:24:13 2007 +0200
    24.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    24.3 @@ -1,951 +0,0 @@
    24.4 -(*  Title:      HOLCF/domain/theorems.ML
    24.5 -    ID:         $Id$
    24.6 -    Author:     David von Oheimb
    24.7 -                New proofs/tactics by Brian Huffman
    24.8 -
    24.9 -Proof generator for domain section.
   24.10 -*)
   24.11 -
   24.12 -val HOLCF_ss = simpset();
   24.13 -
   24.14 -structure Domain_Theorems = struct
   24.15 -
   24.16 -local
   24.17 -
   24.18 -val adm_impl_admw = thm "adm_impl_admw";
   24.19 -val antisym_less_inverse = thm "antisym_less_inverse";
   24.20 -val beta_cfun = thm "beta_cfun";
   24.21 -val cfun_arg_cong = thm "cfun_arg_cong";
   24.22 -val ch2ch_Rep_CFunL = thm "ch2ch_Rep_CFunL";
   24.23 -val ch2ch_Rep_CFunR = thm "ch2ch_Rep_CFunR";
   24.24 -val chain_iterate = thm "chain_iterate";
   24.25 -val compact_ONE = thm "compact_ONE";
   24.26 -val compact_sinl = thm "compact_sinl";
   24.27 -val compact_sinr = thm "compact_sinr";
   24.28 -val compact_spair = thm "compact_spair";
   24.29 -val compact_up = thm "compact_up";
   24.30 -val contlub_cfun_arg = thm "contlub_cfun_arg";
   24.31 -val contlub_cfun_fun = thm "contlub_cfun_fun";
   24.32 -val fix_def2 = thm "fix_def2";
   24.33 -val injection_eq = thm "injection_eq";
   24.34 -val injection_less = thm "injection_less";
   24.35 -val lub_equal = thm "lub_equal";
   24.36 -val monofun_cfun_arg = thm "monofun_cfun_arg";
   24.37 -val retraction_strict = thm "retraction_strict";
   24.38 -val spair_eq = thm "spair_eq";
   24.39 -val spair_less = thm "spair_less";
   24.40 -val sscase1 = thm "sscase1";
   24.41 -val ssplit1 = thm "ssplit1";
   24.42 -val strictify1 = thm "strictify1";
   24.43 -val wfix_ind = thm "wfix_ind";
   24.44 -
   24.45 -open Domain_Library;
   24.46 -infixr 0 ===>;
   24.47 -infixr 0 ==>;
   24.48 -infix 0 == ; 
   24.49 -infix 1 ===;
   24.50 -infix 1 ~= ;
   24.51 -infix 1 <<;
   24.52 -infix 1 ~<<;
   24.53 -infix 9 `   ;
   24.54 -infix 9 `% ;
   24.55 -infix 9 `%%;
   24.56 -infixr 9 oo;
   24.57 -
   24.58 -(* ----- general proof facilities ------------------------------------------- *)
   24.59 -
   24.60 -fun pg'' thy defs t tacs =
   24.61 -  let
   24.62 -    val t' = FixrecPackage.legacy_infer_term thy t;
   24.63 -    val asms = Logic.strip_imp_prems t';
   24.64 -    val prop = Logic.strip_imp_concl t';
   24.65 -    fun tac prems =
   24.66 -      rewrite_goals_tac defs THEN
   24.67 -      EVERY (tacs (map (rewrite_rule defs) prems));
   24.68 -  in Goal.prove_global thy [] asms prop tac end;
   24.69 -
   24.70 -fun pg' thy defs t tacsf =
   24.71 -  let
   24.72 -    fun tacs [] = tacsf
   24.73 -      | tacs prems = cut_facts_tac prems 1 :: tacsf;
   24.74 -  in pg'' thy defs t tacs end;
   24.75 -
   24.76 -fun case_UU_tac rews i v =
   24.77 -  case_tac (v^"=UU") i THEN
   24.78 -  asm_simp_tac (HOLCF_ss addsimps rews) i;
   24.79 -
   24.80 -val chain_tac =
   24.81 -  REPEAT_DETERM o resolve_tac 
   24.82 -    [chain_iterate, ch2ch_Rep_CFunR, ch2ch_Rep_CFunL];
   24.83 -
   24.84 -(* ----- general proofs ----------------------------------------------------- *)
   24.85 -
   24.86 -val all2E = prove_goal HOL.thy "[| !x y . P x y; P x y ==> R |] ==> R"
   24.87 -  (fn prems =>[
   24.88 -    resolve_tac prems 1,
   24.89 -    cut_facts_tac prems 1,
   24.90 -    fast_tac HOL_cs 1]);
   24.91 -
   24.92 -val dist_eqI = prove_goal (the_context ()) "!!x::'a::po. ~ x << y ==> x ~= y" 
   24.93 -  (fn prems =>
   24.94 -    [blast_tac (claset () addDs [antisym_less_inverse]) 1]);
   24.95 -
   24.96 -in
   24.97 -
   24.98 -fun theorems (((dname, _), cons) : eq, eqs : eq list) thy =
   24.99 -let
  24.100 -
  24.101 -val dummy = writeln ("Proving isomorphism properties of domain "^dname^" ...");
  24.102 -val pg = pg' thy;
  24.103 -
  24.104 -(* ----- getting the axioms and definitions --------------------------------- *)
  24.105 -
  24.106 -local
  24.107 -  fun ga s dn = get_thm thy (Name (dn ^ "." ^ s));
  24.108 -in
  24.109 -  val ax_abs_iso  = ga "abs_iso"  dname;
  24.110 -  val ax_rep_iso  = ga "rep_iso"  dname;
  24.111 -  val ax_when_def = ga "when_def" dname;
  24.112 -  fun get_def mk_name (con,_) = ga (mk_name con^"_def") dname;
  24.113 -  val axs_con_def = map (get_def extern_name) cons;
  24.114 -  val axs_dis_def = map (get_def dis_name) cons;
  24.115 -  val axs_mat_def = map (get_def mat_name) cons;
  24.116 -  val axs_pat_def = map (get_def pat_name) cons;
  24.117 -  val axs_sel_def =
  24.118 -    let
  24.119 -      fun def_of_sel sel = ga (sel^"_def") dname;
  24.120 -      fun def_of_arg arg = Option.map def_of_sel (sel_of arg);
  24.121 -      fun defs_of_con (_, args) = List.mapPartial def_of_arg args;
  24.122 -    in
  24.123 -      List.concat (map defs_of_con cons)
  24.124 -    end;
  24.125 -  val ax_copy_def = ga "copy_def" dname;
  24.126 -end; (* local *)
  24.127 -
  24.128 -(* ----- theorems concerning the isomorphism -------------------------------- *)
  24.129 -
  24.130 -val dc_abs  = %%:(dname^"_abs");
  24.131 -val dc_rep  = %%:(dname^"_rep");
  24.132 -val dc_copy = %%:(dname^"_copy");
  24.133 -val x_name = "x";
  24.134 -
  24.135 -val iso_locale = iso_intro OF [ax_abs_iso, ax_rep_iso];
  24.136 -val abs_strict = ax_rep_iso RS (allI RS retraction_strict);
  24.137 -val rep_strict = ax_abs_iso RS (allI RS retraction_strict);
  24.138 -val abs_defin' = iso_locale RS iso_abs_defin';
  24.139 -val rep_defin' = iso_locale RS iso_rep_defin';
  24.140 -val iso_rews = map standard [ax_abs_iso,ax_rep_iso,abs_strict,rep_strict];
  24.141 -
  24.142 -(* ----- generating beta reduction rules from definitions-------------------- *)
  24.143 -
  24.144 -local
  24.145 -  fun arglist (Const _ $ Abs (s, _, t)) =
  24.146 -    let
  24.147 -      val (vars,body) = arglist t;
  24.148 -    in (s :: vars, body) end
  24.149 -    | arglist t = ([], t);
  24.150 -  fun bind_fun vars t = Library.foldr mk_All (vars, t);
  24.151 -  fun bound_vars 0 = []
  24.152 -    | bound_vars i = Bound (i-1) :: bound_vars (i - 1);
  24.153 -in
  24.154 -  fun appl_of_def def =
  24.155 -    let
  24.156 -      val (_ $ con $ lam) = concl_of def;
  24.157 -      val (vars, rhs) = arglist lam;
  24.158 -      val lhs = list_ccomb (con, bound_vars (length vars));
  24.159 -      val appl = bind_fun vars (lhs == rhs);
  24.160 -      val cs = ContProc.cont_thms lam;
  24.161 -      val betas = map (fn c => mk_meta_eq (c RS beta_cfun)) cs;
  24.162 -    in pg (def::betas) appl [rtac reflexive_thm 1] end;
  24.163 -end;
  24.164 -
  24.165 -val when_appl = appl_of_def ax_when_def;
  24.166 -val con_appls = map appl_of_def axs_con_def;
  24.167 -
  24.168 -local
  24.169 -  fun arg2typ n arg =
  24.170 -    let val t = TVar (("'a", n), pcpoS)
  24.171 -    in (n + 1, if is_lazy arg then mk_uT t else t) end;
  24.172 -
  24.173 -  fun args2typ n [] = (n, oneT)
  24.174 -    | args2typ n [arg] = arg2typ n arg
  24.175 -    | args2typ n (arg::args) =
  24.176 -    let
  24.177 -      val (n1, t1) = arg2typ n arg;
  24.178 -      val (n2, t2) = args2typ n1 args
  24.179 -    in (n2, mk_sprodT (t1, t2)) end;
  24.180 -
  24.181 -  fun cons2typ n [] = (n,oneT)
  24.182 -    | cons2typ n [con] = args2typ n (snd con)
  24.183 -    | cons2typ n (con::cons) =
  24.184 -    let
  24.185 -      val (n1, t1) = args2typ n (snd con);
  24.186 -      val (n2, t2) = cons2typ n1 cons
  24.187 -    in (n2, mk_ssumT (t1, t2)) end;
  24.188 -in
  24.189 -  fun cons2ctyp cons = ctyp_of thy (snd (cons2typ 1 cons));
  24.190 -end;
  24.191 -
  24.192 -local 
  24.193 -  val iso_swap = iso_locale RS iso_iso_swap;
  24.194 -  fun one_con (con, args) =
  24.195 -    let
  24.196 -      val vns = map vname args;
  24.197 -      val eqn = %:x_name === con_app2 con %: vns;
  24.198 -      val conj = foldr1 mk_conj (eqn :: map (defined o %:) (nonlazy args));
  24.199 -    in Library.foldr mk_ex (vns, conj) end;
  24.200 -
  24.201 -  val conj_assoc = thm "conj_assoc";
  24.202 -  val exh = foldr1 mk_disj ((%:x_name === UU) :: map one_con cons);
  24.203 -  val thm1 = instantiate' [SOME (cons2ctyp cons)] [] exh_start;
  24.204 -  val thm2 = rewrite_rule (map mk_meta_eq ex_defined_iffs) thm1;
  24.205 -  val thm3 = rewrite_rule [mk_meta_eq conj_assoc] thm2;
  24.206 -
  24.207 -  (* first 3 rules replace "x = UU \/ P" with "rep$x = UU \/ P" *)
  24.208 -  val tacs = [
  24.209 -    rtac disjE 1,
  24.210 -    etac (rep_defin' RS disjI1) 2,
  24.211 -    etac disjI2 2,
  24.212 -    rewrite_goals_tac [mk_meta_eq iso_swap],
  24.213 -    rtac thm3 1];
  24.214 -in
  24.215 -  val exhaust = pg con_appls (mk_trp exh) tacs;
  24.216 -  val casedist =
  24.217 -    standard (rewrite_rule exh_casedists (exhaust RS exh_casedist0));
  24.218 -end;
  24.219 -
  24.220 -local 
  24.221 -  fun bind_fun t = Library.foldr mk_All (when_funs cons, t);
  24.222 -  fun bound_fun i _ = Bound (length cons - i);
  24.223 -  val when_app = list_ccomb (%%:(dname^"_when"), mapn bound_fun 1 cons);
  24.224 -in
  24.225 -  val when_strict =
  24.226 -    let
  24.227 -      val axs = [when_appl, mk_meta_eq rep_strict];
  24.228 -      val goal = bind_fun (mk_trp (strict when_app));
  24.229 -      val tacs = [resolve_tac [sscase1, ssplit1, strictify1] 1];
  24.230 -    in pg axs goal tacs end;
  24.231 -
  24.232 -  val when_apps =
  24.233 -    let
  24.234 -      fun one_when n (con,args) =
  24.235 -        let
  24.236 -          val axs = when_appl :: con_appls;
  24.237 -          val goal = bind_fun (lift_defined %: (nonlazy args, 
  24.238 -                mk_trp (when_app`(con_app con args) ===
  24.239 -                       list_ccomb (bound_fun n 0, map %# args))));
  24.240 -          val tacs = [asm_simp_tac (HOLCF_ss addsimps [ax_abs_iso]) 1];
  24.241 -        in pg axs goal tacs end;
  24.242 -    in mapn one_when 1 cons end;
  24.243 -end;
  24.244 -val when_rews = when_strict :: when_apps;
  24.245 -
  24.246 -(* ----- theorems concerning the constructors, discriminators and selectors - *)
  24.247 -
  24.248 -local
  24.249 -  fun dis_strict (con, _) =
  24.250 -    let
  24.251 -      val goal = mk_trp (strict (%%:(dis_name con)));
  24.252 -    in pg axs_dis_def goal [rtac when_strict 1] end;
  24.253 -
  24.254 -  fun dis_app c (con, args) =
  24.255 -    let
  24.256 -      val lhs = %%:(dis_name c) ` con_app con args;
  24.257 -      val rhs = %%:(if con = c then TT_N else FF_N);
  24.258 -      val goal = lift_defined %: (nonlazy args, mk_trp (lhs === rhs));
  24.259 -      val tacs = [asm_simp_tac (HOLCF_ss addsimps when_rews) 1];
  24.260 -    in pg axs_dis_def goal tacs end;
  24.261 -
  24.262 -  val dis_apps = List.concat (map (fn (c,_) => map (dis_app c) cons) cons);
  24.263 -
  24.264 -  fun dis_defin (con, args) =
  24.265 -    let
  24.266 -      val goal = defined (%:x_name) ==> defined (%%:(dis_name con) `% x_name);
  24.267 -      val tacs =
  24.268 -        [rtac casedist 1,
  24.269 -         contr_tac 1,
  24.270 -         DETERM_UNTIL_SOLVED (CHANGED
  24.271 -          (asm_simp_tac (HOLCF_ss addsimps dis_apps) 1))];
  24.272 -    in pg [] goal tacs end;
  24.273 -
  24.274 -  val dis_stricts = map dis_strict cons;
  24.275 -  val dis_defins = map dis_defin cons;
  24.276 -in
  24.277 -  val dis_rews = dis_stricts @ dis_defins @ dis_apps;
  24.278 -end;
  24.279 -
  24.280 -local
  24.281 -  fun mat_strict (con, _) =
  24.282 -    let
  24.283 -      val goal = mk_trp (strict (%%:(mat_name con)));
  24.284 -      val tacs = [rtac when_strict 1];
  24.285 -    in pg axs_mat_def goal tacs end;
  24.286 -
  24.287 -  val mat_stricts = map mat_strict cons;
  24.288 -
  24.289 -  fun one_mat c (con, args) =
  24.290 -    let
  24.291 -      val lhs = %%:(mat_name c) ` con_app con args;
  24.292 -      val rhs =
  24.293 -        if con = c
  24.294 -        then %%:returnN ` mk_ctuple (map %# args)
  24.295 -        else %%:failN;
  24.296 -      val goal = lift_defined %: (nonlazy args, mk_trp (lhs === rhs));
  24.297 -      val tacs = [asm_simp_tac (HOLCF_ss addsimps when_rews) 1];
  24.298 -    in pg axs_mat_def goal tacs end;
  24.299 -
  24.300 -  val mat_apps =
  24.301 -    List.concat (map (fn (c,_) => map (one_mat c) cons) cons);
  24.302 -in
  24.303 -  val mat_rews = mat_stricts @ mat_apps;
  24.304 -end;
  24.305 -
  24.306 -local
  24.307 -  fun ps args = mapn (fn n => fn _ => %:("pat" ^ string_of_int n)) 1 args;
  24.308 -
  24.309 -  fun pat_lhs (con,args) = %%:branchN $ list_comb (%%:(pat_name con), ps args);
  24.310 -
  24.311 -  fun pat_rhs (con,[]) = %%:returnN ` ((%:"rhs") ` HOLogic.unit)
  24.312 -    | pat_rhs (con,args) =
  24.313 -        (%%:branchN $ foldr1 cpair_pat (ps args))
  24.314 -          `(%:"rhs")`(mk_ctuple (map %# args));
  24.315 -
  24.316 -  fun pat_strict c =
  24.317 -    let
  24.318 -      val axs = branch_def :: axs_pat_def;
  24.319 -      val goal = mk_trp (strict (pat_lhs c ` (%:"rhs")));
  24.320 -      val tacs = [simp_tac (HOLCF_ss addsimps [when_strict]) 1];
  24.321 -    in pg axs goal tacs end;
  24.322 -
  24.323 -  fun pat_app c (con, args) =
  24.324 -    let
  24.325 -      val axs = branch_def :: axs_pat_def;
  24.326 -      val lhs = (pat_lhs c)`(%:"rhs")`(con_app con args);
  24.327 -      val rhs = if con = fst c then pat_rhs c else %%:failN;
  24.328 -      val goal = lift_defined %: (nonlazy args, mk_trp (lhs === rhs));
  24.329 -      val tacs = [asm_simp_tac (HOLCF_ss addsimps when_rews) 1];
  24.330 -    in pg axs goal tacs end;
  24.331 -
  24.332 -  val pat_stricts = map pat_strict cons;
  24.333 -  val pat_apps = List.concat (map (fn c => map (pat_app c) cons) cons);
  24.334 -in
  24.335 -  val pat_rews = pat_stricts @ pat_apps;
  24.336 -end;
  24.337 -
  24.338 -local
  24.339 -  val rev_contrapos = thm "rev_contrapos";
  24.340 -  fun con_strict (con, args) = 
  24.341 -    let
  24.342 -      fun one_strict vn =
  24.343 -        let
  24.344 -          fun f arg = if vname arg = vn then UU else %# arg;
  24.345 -          val goal = mk_trp (con_app2 con f args === UU);
  24.346 -          val tacs = [asm_simp_tac (HOLCF_ss addsimps [abs_strict]) 1];
  24.347 -        in pg con_appls goal tacs end;
  24.348 -    in map one_strict (nonlazy args) end;
  24.349 -
  24.350 -  fun con_defin (con, args) =
  24.351 -    let
  24.352 -      val concl = mk_trp (defined (con_app con args));
  24.353 -      val goal = lift_defined %: (nonlazy args, concl);
  24.354 -      val tacs = [
  24.355 -        rtac rev_contrapos 1,
  24.356 -        eres_inst_tac [("f",dis_name con)] cfun_arg_cong 1,
  24.357 -        asm_simp_tac (HOLCF_ss addsimps dis_rews) 1];
  24.358 -    in pg [] goal tacs end;
  24.359 -in
  24.360 -  val con_stricts = List.concat (map con_strict cons);
  24.361 -  val con_defins = map con_defin cons;
  24.362 -  val con_rews = con_stricts @ con_defins;
  24.363 -end;
  24.364 -
  24.365 -local
  24.366 -  val rules =
  24.367 -    [compact_sinl, compact_sinr, compact_spair, compact_up, compact_ONE];
  24.368 -  fun con_compact (con, args) =
  24.369 -    let
  24.370 -      val concl = mk_trp (%%:compactN $ con_app con args);
  24.371 -      val goal = lift (fn x => %%:compactN $ %#x) (args, concl);
  24.372 -      val tacs = [
  24.373 -        rtac (iso_locale RS iso_compact_abs) 1,
  24.374 -        REPEAT (resolve_tac rules 1 ORELSE atac 1)];
  24.375 -    in pg con_appls goal tacs end;
  24.376 -in
  24.377 -  val con_compacts = map con_compact cons;
  24.378 -end;
  24.379 -
  24.380 -local
  24.381 -  fun one_sel sel =
  24.382 -    pg axs_sel_def (mk_trp (strict (%%:sel)))
  24.383 -      [simp_tac (HOLCF_ss addsimps when_rews) 1];
  24.384 -
  24.385 -  fun sel_strict (_, args) =
  24.386 -    List.mapPartial (Option.map one_sel o sel_of) args;
  24.387 -in
  24.388 -  val sel_stricts = List.concat (map sel_strict cons);
  24.389 -end;
  24.390 -
  24.391 -local
  24.392 -  fun sel_app_same c n sel (con, args) =
  24.393 -    let
  24.394 -      val nlas = nonlazy args;
  24.395 -      val vns = map vname args;
  24.396 -      val vnn = List.nth (vns, n);
  24.397 -      val nlas' = List.filter (fn v => v <> vnn) nlas;
  24.398 -      val lhs = (%%:sel)`(con_app con args);
  24.399 -      val goal = lift_defined %: (nlas', mk_trp (lhs === %:vnn));
  24.400 -      val tacs1 =
  24.401 -        if vnn mem nlas
  24.402 -        then [case_UU_tac (when_rews @ con_stricts) 1 vnn]
  24.403 -        else [];
  24.404 -      val tacs2 = [asm_simp_tac (HOLCF_ss addsimps when_rews) 1];
  24.405 -    in pg axs_sel_def goal (tacs1 @ tacs2) end;
  24.406 -
  24.407 -  fun sel_app_diff c n sel (con, args) =
  24.408 -    let
  24.409 -      val nlas = nonlazy args;
  24.410 -      val goal = mk_trp (%%:sel ` con_app con args === UU);
  24.411 -      val tacs1 = map (case_UU_tac (when_rews @ con_stricts) 1) nlas;
  24.412 -      val tacs2 = [asm_simp_tac (HOLCF_ss addsimps when_rews) 1];
  24.413 -    in pg axs_sel_def goal (tacs1 @ tacs2) end;
  24.414 -
  24.415 -  fun sel_app c n sel (con, args) =
  24.416 -    if con = c
  24.417 -    then sel_app_same c n sel (con, args)
  24.418 -    else sel_app_diff c n sel (con, args);
  24.419 -
  24.420 -  fun one_sel c n sel = map (sel_app c n sel) cons;
  24.421 -  fun one_sel' c n arg = Option.map (one_sel c n) (sel_of arg);
  24.422 -  fun one_con (c, args) =
  24.423 -    List.concat (List.mapPartial I (mapn (one_sel' c) 0 args));
  24.424 -in
  24.425 -  val sel_apps = List.concat (map one_con cons);
  24.426 -end;
  24.427 -
  24.428 -local
  24.429 -  fun sel_defin sel =
  24.430 -    let
  24.431 -      val goal = defined (%:x_name) ==> defined (%%:sel`%x_name);
  24.432 -      val tacs = [
  24.433 -        rtac casedist 1,
  24.434 -        contr_tac 1,
  24.435 -        DETERM_UNTIL_SOLVED (CHANGED
  24.436 -          (asm_simp_tac (HOLCF_ss addsimps sel_apps) 1))];
  24.437 -    in pg [] goal tacs end;
  24.438 -in
  24.439 -  val sel_defins =
  24.440 -    if length cons = 1
  24.441 -    then List.mapPartial (fn arg => Option.map sel_defin (sel_of arg))
  24.442 -                 (filter_out is_lazy (snd (hd cons)))
  24.443 -    else [];
  24.444 -end;
  24.445 -
  24.446 -val sel_rews = sel_stricts @ sel_defins @ sel_apps;
  24.447 -val rev_contrapos = thm "rev_contrapos";
  24.448 -
  24.449 -val distincts_le =
  24.450 -  let
  24.451 -    fun dist (con1, args1) (con2, args2) =
  24.452 -      let
  24.453 -        val goal = lift_defined %: (nonlazy args1,
  24.454 -                        mk_trp (con_app con1 args1 ~<< con_app con2 args2));
  24.455 -        val tacs = [
  24.456 -          rtac rev_contrapos 1,
  24.457 -          eres_inst_tac [("f", dis_name con1)] monofun_cfun_arg 1]
  24.458 -          @ map (case_UU_tac (con_stricts @ dis_rews) 1) (nonlazy args2)
  24.459 -          @ [asm_simp_tac (HOLCF_ss addsimps dis_rews) 1];
  24.460 -      in pg [] goal tacs end;
  24.461 -
  24.462 -    fun distinct (con1, args1) (con2, args2) =
  24.463 -        let
  24.464 -          val arg1 = (con1, args1);
  24.465 -          val arg2 =
  24.466 -            (con2, ListPair.map (fn (arg,vn) => upd_vname (K vn) arg)
  24.467 -              (args2, Name.variant_list (map vname args1) (map vname args2)));
  24.468 -        in [dist arg1 arg2, dist arg2 arg1] end;
  24.469 -    fun distincts []      = []
  24.470 -      | distincts (c::cs) = (map (distinct c) cs) :: distincts cs;
  24.471 -  in distincts cons end;
  24.472 -val dist_les = List.concat (List.concat distincts_le);
  24.473 -val dist_eqs =
  24.474 -  let
  24.475 -    fun distinct (_,args1) ((_,args2), leqs) =
  24.476 -      let
  24.477 -        val (le1,le2) = (hd leqs, hd(tl leqs));
  24.478 -        val (eq1,eq2) = (le1 RS dist_eqI, le2 RS dist_eqI)
  24.479 -      in
  24.480 -        if nonlazy args1 = [] then [eq1, eq1 RS not_sym] else
  24.481 -        if nonlazy args2 = [] then [eq2, eq2 RS not_sym] else
  24.482 -          [eq1, eq2]
  24.483 -      end;
  24.484 -    fun distincts []      = []
  24.485 -      | distincts ((c,leqs)::cs) = List.concat
  24.486 -	            (ListPair.map (distinct c) ((map #1 cs),leqs)) @
  24.487 -		    distincts cs;
  24.488 -  in map standard (distincts (cons ~~ distincts_le)) end;
  24.489 -
  24.490 -local 
  24.491 -  fun pgterm rel con args =
  24.492 -    let
  24.493 -      fun append s = upd_vname (fn v => v^s);
  24.494 -      val (largs, rargs) = (args, map (append "'") args);
  24.495 -      val concl =
  24.496 -        foldr1 mk_conj (ListPair.map rel (map %# largs, map %# rargs));
  24.497 -      val prem = rel (con_app con largs, con_app con rargs);
  24.498 -      val sargs = case largs of [_] => [] | _ => nonlazy args;
  24.499 -      val prop = lift_defined %: (sargs, mk_trp (prem === concl));
  24.500 -    in pg con_appls prop end;
  24.501 -  val cons' = List.filter (fn (_,args) => args<>[]) cons;
  24.502 -in
  24.503 -  val inverts =
  24.504 -    let
  24.505 -      val abs_less = ax_abs_iso RS (allI RS injection_less);
  24.506 -      val tacs =
  24.507 -        [asm_full_simp_tac (HOLCF_ss addsimps [abs_less, spair_less]) 1];
  24.508 -    in map (fn (con, args) => pgterm (op <<) con args tacs) cons' end;
  24.509 -
  24.510 -  val injects =
  24.511 -    let
  24.512 -      val abs_eq = ax_abs_iso RS (allI RS injection_eq);
  24.513 -      val tacs = [asm_full_simp_tac (HOLCF_ss addsimps [abs_eq, spair_eq]) 1];
  24.514 -    in map (fn (con, args) => pgterm (op ===) con args tacs) cons' end;
  24.515 -end;
  24.516 -
  24.517 -(* ----- theorems concerning one induction step ----------------------------- *)
  24.518 -
  24.519 -val copy_strict =
  24.520 -  let
  24.521 -    val goal = mk_trp (strict (dc_copy `% "f"));
  24.522 -    val tacs = [asm_simp_tac (HOLCF_ss addsimps [abs_strict, when_strict]) 1];
  24.523 -  in pg [ax_copy_def] goal tacs end;
  24.524 -
  24.525 -local
  24.526 -  fun copy_app (con, args) =
  24.527 -    let
  24.528 -      val lhs = dc_copy`%"f"`(con_app con args);
  24.529 -      val rhs = con_app2 con (app_rec_arg (cproj (%:"f") eqs)) args;
  24.530 -      val goal = lift_defined %: (nonlazy_rec args, mk_trp (lhs === rhs));
  24.531 -      val args' = List.filter (fn a => not (is_rec a orelse is_lazy a)) args;
  24.532 -      val stricts = abs_strict::when_strict::con_stricts;
  24.533 -      val tacs1 = map (case_UU_tac stricts 1 o vname) args';
  24.534 -      val tacs2 = [asm_simp_tac (HOLCF_ss addsimps when_apps) 1];
  24.535 -    in pg [ax_copy_def] goal (tacs1 @ tacs2) end;
  24.536 -in
  24.537 -  val copy_apps = map copy_app cons;
  24.538 -end;
  24.539 -
  24.540 -local
  24.541 -  fun one_strict (con, args) = 
  24.542 -    let
  24.543 -      val goal = mk_trp (dc_copy`UU`(con_app con args) === UU);
  24.544 -      val rews = copy_strict :: copy_apps @ con_rews;
  24.545 -      val tacs = map (case_UU_tac rews 1) (nonlazy args) @
  24.546 -        [asm_simp_tac (HOLCF_ss addsimps rews) 1];
  24.547 -    in pg [] goal tacs end;
  24.548 -
  24.549 -  fun has_nonlazy_rec (_, args) = exists is_nonlazy_rec args;
  24.550 -in
  24.551 -  val copy_stricts = map one_strict (List.filter has_nonlazy_rec cons);
  24.552 -end;
  24.553 -
  24.554 -val copy_rews = copy_strict :: copy_apps @ copy_stricts;
  24.555 -
  24.556 -in
  24.557 -  thy
  24.558 -    |> Theory.add_path (Sign.base_name dname)
  24.559 -    |> (snd o (PureThy.add_thmss (map Thm.no_attributes [
  24.560 -        ("iso_rews" , iso_rews  ),
  24.561 -        ("exhaust"  , [exhaust] ),
  24.562 -        ("casedist" , [casedist]),
  24.563 -        ("when_rews", when_rews ),
  24.564 -        ("compacts", con_compacts),
  24.565 -        ("con_rews", con_rews),
  24.566 -        ("sel_rews", sel_rews),
  24.567 -        ("dis_rews", dis_rews),
  24.568 -        ("pat_rews", pat_rews),
  24.569 -        ("dist_les", dist_les),
  24.570 -        ("dist_eqs", dist_eqs),
  24.571 -        ("inverts" , inverts ),
  24.572 -        ("injects" , injects ),
  24.573 -        ("copy_rews", copy_rews)])))
  24.574 -    |> (snd o PureThy.add_thmss
  24.575 -        [(("match_rews", mat_rews), [Simplifier.simp_add])])
  24.576 -    |> Theory.parent_path
  24.577 -    |> rpair (iso_rews @ when_rews @ con_rews @ sel_rews @ dis_rews @
  24.578 -        pat_rews @ dist_les @ dist_eqs @ copy_rews)
  24.579 -end; (* let *)
  24.580 -
  24.581 -fun comp_theorems (comp_dnam, eqs: eq list) thy =
  24.582 -let
  24.583 -val dnames = map (fst o fst) eqs;
  24.584 -val conss  = map  snd        eqs;
  24.585 -val comp_dname = Sign.full_name thy comp_dnam;
  24.586 -
  24.587 -val d = writeln("Proving induction properties of domain "^comp_dname^" ...");
  24.588 -val pg = pg' thy;
  24.589 -
  24.590 -(* ----- getting the composite axiom and definitions ------------------------ *)
  24.591 -
  24.592 -local
  24.593 -  fun ga s dn = get_thm thy (Name (dn ^ "." ^ s));
  24.594 -in
  24.595 -  val axs_reach      = map (ga "reach"     ) dnames;
  24.596 -  val axs_take_def   = map (ga "take_def"  ) dnames;
  24.597 -  val axs_finite_def = map (ga "finite_def") dnames;
  24.598 -  val ax_copy2_def   =      ga "copy_def"  comp_dnam;
  24.599 -  val ax_bisim_def   =      ga "bisim_def" comp_dnam;
  24.600 -end;
  24.601 -
  24.602 -local
  24.603 -  fun gt  s dn = get_thm  thy (Name (dn ^ "." ^ s));
  24.604 -  fun gts s dn = get_thms thy (Name (dn ^ "." ^ s));
  24.605 -in
  24.606 -  val cases = map (gt  "casedist" ) dnames;
  24.607 -  val con_rews  = List.concat (map (gts "con_rews" ) dnames);
  24.608 -  val copy_rews = List.concat (map (gts "copy_rews") dnames);
  24.609 -end;
  24.610 -
  24.611 -fun dc_take dn = %%:(dn^"_take");
  24.612 -val x_name = idx_name dnames "x"; 
  24.613 -val P_name = idx_name dnames "P";
  24.614 -val n_eqs = length eqs;
  24.615 -
  24.616 -(* ----- theorems concerning finite approximation and finite induction ------ *)
  24.617 -
  24.618 -local
  24.619 -  val iterate_Cprod_ss = simpset_of (theory "Fix");
  24.620 -  val copy_con_rews  = copy_rews @ con_rews;
  24.621 -  val copy_take_defs =
  24.622 -    (if n_eqs = 1 then [] else [ax_copy2_def]) @ axs_take_def;
  24.623 -  val take_stricts =
  24.624 -    let
  24.625 -      fun one_eq ((dn, args), _) = strict (dc_take dn $ %:"n");
  24.626 -      val goal = mk_trp (foldr1 mk_conj (map one_eq eqs));
  24.627 -      val tacs = [
  24.628 -        induct_tac "n" 1,
  24.629 -        simp_tac iterate_Cprod_ss 1,
  24.630 -        asm_simp_tac (iterate_Cprod_ss addsimps copy_rews) 1];
  24.631 -    in pg copy_take_defs goal tacs end;
  24.632 -
  24.633 -  val take_stricts' = rewrite_rule copy_take_defs take_stricts;
  24.634 -  fun take_0 n dn =
  24.635 -    let
  24.636 -      val goal = mk_trp ((dc_take dn $ %%:"HOL.zero") `% x_name n === UU);
  24.637 -    in pg axs_take_def goal [simp_tac iterate_Cprod_ss 1] end;
  24.638 -  val take_0s = mapn take_0 1 dnames;
  24.639 -  val c_UU_tac = case_UU_tac (take_stricts'::copy_con_rews) 1;
  24.640 -  val take_apps =
  24.641 -    let
  24.642 -      fun mk_eqn dn (con, args) =
  24.643 -        let
  24.644 -          fun mk_take n = dc_take (List.nth (dnames, n)) $ %:"n";
  24.645 -          val lhs = (dc_take dn $ (%%:"Suc" $ %:"n"))`(con_app con args);
  24.646 -          val rhs = con_app2 con (app_rec_arg mk_take) args;
  24.647 -        in Library.foldr mk_all (map vname args, lhs === rhs) end;
  24.648 -      fun mk_eqns ((dn, _), cons) = map (mk_eqn dn) cons;
  24.649 -      val goal = mk_trp (foldr1 mk_conj (List.concat (map mk_eqns eqs)));
  24.650 -      val simps = List.filter (has_fewer_prems 1) copy_rews;
  24.651 -      fun con_tac (con, args) =
  24.652 -        if nonlazy_rec args = []
  24.653 -        then all_tac
  24.654 -        else EVERY (map c_UU_tac (nonlazy_rec args)) THEN
  24.655 -          asm_full_simp_tac (HOLCF_ss addsimps copy_rews) 1;
  24.656 -      fun eq_tacs ((dn, _), cons) = map con_tac cons;
  24.657 -      val tacs =
  24.658 -        simp_tac iterate_Cprod_ss 1 ::
  24.659 -        induct_tac "n" 1 ::
  24.660 -        simp_tac (iterate_Cprod_ss addsimps copy_con_rews) 1 ::
  24.661 -        asm_full_simp_tac (HOLCF_ss addsimps simps) 1 ::
  24.662 -        TRY (safe_tac HOL_cs) ::
  24.663 -        List.concat (map eq_tacs eqs);
  24.664 -    in pg copy_take_defs goal tacs end;
  24.665 -in
  24.666 -  val take_rews = map standard
  24.667 -    (atomize take_stricts @ take_0s @ atomize take_apps);
  24.668 -end; (* local *)
  24.669 -
  24.670 -local
  24.671 -  fun one_con p (con,args) =
  24.672 -    let
  24.673 -      fun ind_hyp arg = %:(P_name (1 + rec_of arg)) $ bound_arg args arg;
  24.674 -      val t1 = mk_trp (%:p $ con_app2 con (bound_arg args) args);
  24.675 -      val t2 = lift ind_hyp (List.filter is_rec args, t1);
  24.676 -      val t3 = lift_defined (bound_arg (map vname args)) (nonlazy args, t2);
  24.677 -    in Library.foldr mk_All (map vname args, t3) end;
  24.678 -
  24.679 -  fun one_eq ((p, cons), concl) =
  24.680 -    mk_trp (%:p $ UU) ===> Logic.list_implies (map (one_con p) cons, concl);
  24.681 -
  24.682 -  fun ind_term concf = Library.foldr one_eq
  24.683 -    (mapn (fn n => fn x => (P_name n, x)) 1 conss,
  24.684 -     mk_trp (foldr1 mk_conj (mapn concf 1 dnames)));
  24.685 -  val take_ss = HOL_ss addsimps take_rews;
  24.686 -  fun quant_tac i = EVERY
  24.687 -    (mapn (fn n => fn _ => res_inst_tac [("x", x_name n)] spec i) 1 dnames);
  24.688 -
  24.689 -  fun ind_prems_tac prems = EVERY
  24.690 -    (List.concat (map (fn cons =>
  24.691 -      (resolve_tac prems 1 ::
  24.692 -        List.concat (map (fn (_,args) => 
  24.693 -          resolve_tac prems 1 ::
  24.694 -          map (K(atac 1)) (nonlazy args) @
  24.695 -          map (K(atac 1)) (List.filter is_rec args))
  24.696 -        cons)))
  24.697 -      conss));
  24.698 -  local 
  24.699 -    (* check whether every/exists constructor of the n-th part of the equation:
  24.700 -       it has a possibly indirectly recursive argument that isn't/is possibly 
  24.701 -       indirectly lazy *)
  24.702 -    fun rec_to quant nfn rfn ns lazy_rec (n,cons) = quant (exists (fn arg => 
  24.703 -          is_rec arg andalso not(rec_of arg mem ns) andalso
  24.704 -          ((rec_of arg =  n andalso nfn(lazy_rec orelse is_lazy arg)) orelse 
  24.705 -            rec_of arg <> n andalso rec_to quant nfn rfn (rec_of arg::ns) 
  24.706 -              (lazy_rec orelse is_lazy arg) (n, (List.nth(conss,rec_of arg))))
  24.707 -          ) o snd) cons;
  24.708 -    fun all_rec_to ns  = rec_to forall not all_rec_to  ns;
  24.709 -    fun warn (n,cons) =
  24.710 -      if all_rec_to [] false (n,cons)
  24.711 -      then (warning ("domain "^List.nth(dnames,n)^" is empty!"); true)
  24.712 -      else false;
  24.713 -    fun lazy_rec_to ns = rec_to exists I  lazy_rec_to ns;
  24.714 -
  24.715 -  in
  24.716 -    val n__eqs = mapn (fn n => fn (_,cons) => (n,cons)) 0 eqs;
  24.717 -    val is_emptys = map warn n__eqs;
  24.718 -    val is_finite = forall (not o lazy_rec_to [] false) n__eqs;
  24.719 -  end;
  24.720 -in (* local *)
  24.721 -  val finite_ind =
  24.722 -    let
  24.723 -      fun concf n dn = %:(P_name n) $ (dc_take dn $ %:"n" `%(x_name n));
  24.724 -      val goal = ind_term concf;
  24.725 -
  24.726 -      fun tacf prems =
  24.727 -        let
  24.728 -          val tacs1 = [
  24.729 -            quant_tac 1,
  24.730 -            simp_tac HOL_ss 1,
  24.731 -            induct_tac "n" 1,
  24.732 -            simp_tac (take_ss addsimps prems) 1,
  24.733 -            TRY (safe_tac HOL_cs)];
  24.734 -          fun arg_tac arg =
  24.735 -            case_UU_tac (prems @ con_rews) 1
  24.736 -              (List.nth (dnames, rec_of arg) ^ "_take n$" ^ vname arg);
  24.737 -          fun con_tacs (con, args) = 
  24.738 -            asm_simp_tac take_ss 1 ::
  24.739 -            map arg_tac (List.filter is_nonlazy_rec args) @
  24.740 -            [resolve_tac prems 1] @
  24.741 -            map (K (atac 1))      (nonlazy args) @
  24.742 -            map (K (etac spec 1)) (List.filter is_rec args);
  24.743 -          fun cases_tacs (cons, cases) =
  24.744 -            res_inst_tac [("x","x")] cases 1 ::
  24.745 -            asm_simp_tac (take_ss addsimps prems) 1 ::
  24.746 -            List.concat (map con_tacs cons);
  24.747 -        in
  24.748 -          tacs1 @ List.concat (map cases_tacs (conss ~~ cases))
  24.749 -        end;
  24.750 -    in pg'' thy [] goal tacf end;
  24.751 -
  24.752 -  val take_lemmas =
  24.753 -    let
  24.754 -      fun take_lemma n (dn, ax_reach) =
  24.755 -        let
  24.756 -          val lhs = dc_take dn $ Bound 0 `%(x_name n);
  24.757 -          val rhs = dc_take dn $ Bound 0 `%(x_name n^"'");
  24.758 -          val concl = mk_trp (%:(x_name n) === %:(x_name n^"'"));
  24.759 -          val goal = mk_All ("n", mk_trp (lhs === rhs)) ===> concl;
  24.760 -          fun tacf prems = [
  24.761 -            res_inst_tac [("t", x_name n    )] (ax_reach RS subst) 1,
  24.762 -            res_inst_tac [("t", x_name n^"'")] (ax_reach RS subst) 1,
  24.763 -            stac fix_def2 1,
  24.764 -            REPEAT (CHANGED
  24.765 -              (rtac (contlub_cfun_arg RS ssubst) 1 THEN chain_tac 1)),
  24.766 -            stac contlub_cfun_fun 1,
  24.767 -            stac contlub_cfun_fun 2,
  24.768 -            rtac lub_equal 3,
  24.769 -            chain_tac 1,
  24.770 -            rtac allI 1,
  24.771 -            resolve_tac prems 1];
  24.772 -        in pg'' thy axs_take_def goal tacf end;
  24.773 -    in mapn take_lemma 1 (dnames ~~ axs_reach) end;
  24.774 -
  24.775 -(* ----- theorems concerning finiteness and induction ----------------------- *)
  24.776 -
  24.777 -  val (finites, ind) =
  24.778 -    if is_finite
  24.779 -    then (* finite case *)
  24.780 -      let 
  24.781 -        fun take_enough dn = mk_ex ("n",dc_take dn $ Bound 0 ` %:"x" === %:"x");
  24.782 -        fun dname_lemma dn =
  24.783 -          let
  24.784 -            val prem1 = mk_trp (defined (%:"x"));
  24.785 -            val disj1 = mk_all ("n", dc_take dn $ Bound 0 ` %:"x" === UU);
  24.786 -            val prem2 = mk_trp (mk_disj (disj1, take_enough dn));
  24.787 -            val concl = mk_trp (take_enough dn);
  24.788 -            val goal = prem1 ===> prem2 ===> concl;
  24.789 -            val tacs = [
  24.790 -              etac disjE 1,
  24.791 -              etac notE 1,
  24.792 -              resolve_tac take_lemmas 1,
  24.793 -              asm_simp_tac take_ss 1,
  24.794 -              atac 1];
  24.795 -          in pg [] goal tacs end;
  24.796 -        val finite_lemmas1a = map dname_lemma dnames;
  24.797 - 
  24.798 -        val finite_lemma1b =
  24.799 -          let
  24.800 -            fun mk_eqn n ((dn, args), _) =
  24.801 -              let
  24.802 -                val disj1 = dc_take dn $ Bound 1 ` Bound 0 === UU;
  24.803 -                val disj2 = dc_take dn $ Bound 1 ` Bound 0 === Bound 0;
  24.804 -              in
  24.805 -                mk_constrainall
  24.806 -                  (x_name n, Type (dn,args), mk_disj (disj1, disj2))
  24.807 -              end;
  24.808 -            val goal =
  24.809 -              mk_trp (mk_all ("n", foldr1 mk_conj (mapn mk_eqn 1 eqs)));
  24.810 -            fun arg_tacs vn = [
  24.811 -              eres_inst_tac [("x", vn)] all_dupE 1,
  24.812 -              etac disjE 1,
  24.813 -              asm_simp_tac (HOL_ss addsimps con_rews) 1,
  24.814 -              asm_simp_tac take_ss 1];
  24.815 -            fun con_tacs (con, args) =
  24.816 -              asm_simp_tac take_ss 1 ::
  24.817 -              List.concat (map arg_tacs (nonlazy_rec args));
  24.818 -            fun foo_tacs n (cons, cases) =
  24.819 -              simp_tac take_ss 1 ::
  24.820 -              rtac allI 1 ::
  24.821 -              res_inst_tac [("x",x_name n)] cases 1 ::
  24.822 -              asm_simp_tac take_ss 1 ::
  24.823 -              List.concat (map con_tacs cons);
  24.824 -            val tacs =
  24.825 -              rtac allI 1 ::
  24.826 -              induct_tac "n" 1 ::
  24.827 -              simp_tac take_ss 1 ::
  24.828 -              TRY (safe_tac (empty_cs addSEs [conjE] addSIs [conjI])) ::
  24.829 -              List.concat (mapn foo_tacs 1 (conss ~~ cases));
  24.830 -          in pg [] goal tacs end;
  24.831 -
  24.832 -        fun one_finite (dn, l1b) =
  24.833 -          let
  24.834 -            val goal = mk_trp (%%:(dn^"_finite") $ %:"x");
  24.835 -            val tacs = [
  24.836 -              case_UU_tac take_rews 1 "x",
  24.837 -              eresolve_tac finite_lemmas1a 1,
  24.838 -              step_tac HOL_cs 1,
  24.839 -              step_tac HOL_cs 1,
  24.840 -              cut_facts_tac [l1b] 1,
  24.841 -              fast_tac HOL_cs 1];
  24.842 -          in pg axs_finite_def goal tacs end;
  24.843 -
  24.844 -        val finites = map one_finite (dnames ~~ atomize finite_lemma1b);
  24.845 -        val ind =
  24.846 -          let
  24.847 -            fun concf n dn = %:(P_name n) $ %:(x_name n);
  24.848 -            fun tacf prems =
  24.849 -              let
  24.850 -                fun finite_tacs (finite, fin_ind) = [
  24.851 -                  rtac(rewrite_rule axs_finite_def finite RS exE)1,
  24.852 -                  etac subst 1,
  24.853 -                  rtac fin_ind 1,
  24.854 -                  ind_prems_tac prems];
  24.855 -              in
  24.856 -                TRY (safe_tac HOL_cs) ::
  24.857 -                List.concat (map finite_tacs (finites ~~ atomize finite_ind))
  24.858 -              end;
  24.859 -          in pg'' thy [] (ind_term concf) tacf end;
  24.860 -      in (finites, ind) end (* let *)
  24.861 -
  24.862 -    else (* infinite case *)
  24.863 -      let
  24.864 -        fun one_finite n dn =
  24.865 -          read_instantiate_sg thy
  24.866 -            [("P",dn^"_finite "^x_name n)] excluded_middle;
  24.867 -        val finites = mapn one_finite 1 dnames;
  24.868 -
  24.869 -        val goal =
  24.870 -          let
  24.871 -            fun one_adm n _ = mk_trp (%%:admN $ %:(P_name n));
  24.872 -            fun concf n dn = %:(P_name n) $ %:(x_name n);
  24.873 -          in Logic.list_implies (mapn one_adm 1 dnames, ind_term concf) end;
  24.874 -        fun tacf prems =
  24.875 -          map (fn ax_reach => rtac (ax_reach RS subst) 1) axs_reach @ [
  24.876 -          quant_tac 1,
  24.877 -          rtac (adm_impl_admw RS wfix_ind) 1,
  24.878 -          REPEAT_DETERM (rtac adm_all2 1),
  24.879 -          REPEAT_DETERM (
  24.880 -            TRY (rtac adm_conj 1) THEN 
  24.881 -            rtac adm_subst 1 THEN 
  24.882 -            cont_tacR 1 THEN resolve_tac prems 1),
  24.883 -          strip_tac 1,
  24.884 -          rtac (rewrite_rule axs_take_def finite_ind) 1,
  24.885 -          ind_prems_tac prems];
  24.886 -        val ind = (pg'' thy [] goal tacf
  24.887 -          handle ERROR _ =>
  24.888 -            (warning "Cannot prove infinite induction rule"; refl));
  24.889 -      in (finites, ind) end;
  24.890 -end; (* local *)
  24.891 -
  24.892 -(* ----- theorem concerning coinduction ------------------------------------- *)
  24.893 -
  24.894 -local
  24.895 -  val xs = mapn (fn n => K (x_name n)) 1 dnames;
  24.896 -  fun bnd_arg n i = Bound(2*(n_eqs - n)-i-1);
  24.897 -  val take_ss = HOL_ss addsimps take_rews;
  24.898 -  val sproj = prj (fn s => K("fst("^s^")")) (fn s => K("snd("^s^")"));
  24.899 -  val coind_lemma =
  24.900 -    let
  24.901 -      fun mk_prj n _ = proj (%:"R") eqs n $ bnd_arg n 0 $ bnd_arg n 1;
  24.902 -      fun mk_eqn n dn =
  24.903 -        (dc_take dn $ %:"n" ` bnd_arg n 0) ===
  24.904 -        (dc_take dn $ %:"n" ` bnd_arg n 1);
  24.905 -      fun mk_all2 (x,t) = mk_all (x, mk_all (x^"'", t));
  24.906 -      val goal =
  24.907 -        mk_trp (mk_imp (%%:(comp_dname^"_bisim") $ %:"R",
  24.908 -          Library.foldr mk_all2 (xs,
  24.909 -            Library.foldr mk_imp (mapn mk_prj 0 dnames,
  24.910 -              foldr1 mk_conj (mapn mk_eqn 0 dnames)))));
  24.911 -      fun x_tacs n x = [
  24.912 -        rotate_tac (n+1) 1,
  24.913 -        etac all2E 1,
  24.914 -        eres_inst_tac [("P1", sproj "R" eqs n^" "^x^" "^x^"'")] (mp RS disjE) 1,
  24.915 -        TRY (safe_tac HOL_cs),
  24.916 -        REPEAT (CHANGED (asm_simp_tac take_ss 1))];
  24.917 -      val tacs = [
  24.918 -        rtac impI 1,
  24.919 -        induct_tac "n" 1,
  24.920 -        simp_tac take_ss 1,
  24.921 -        safe_tac HOL_cs] @
  24.922 -        List.concat (mapn x_tacs 0 xs);
  24.923 -    in pg [ax_bisim_def] goal tacs end;
  24.924 -in
  24.925 -  val coind = 
  24.926 -    let
  24.927 -      fun mk_prj n x = mk_trp (proj (%:"R") eqs n $ %:x $ %:(x^"'"));
  24.928 -      fun mk_eqn x = %:x === %:(x^"'");
  24.929 -      val goal =
  24.930 -        mk_trp (%%:(comp_dname^"_bisim") $ %:"R") ===>
  24.931 -          Logic.list_implies (mapn mk_prj 0 xs,
  24.932 -            mk_trp (foldr1 mk_conj (map mk_eqn xs)));
  24.933 -      val tacs =
  24.934 -        TRY (safe_tac HOL_cs) ::
  24.935 -        List.concat (map (fn take_lemma => [
  24.936 -          rtac take_lemma 1,
  24.937 -          cut_facts_tac [coind_lemma] 1,
  24.938 -          fast_tac HOL_cs 1])
  24.939 -        take_lemmas);
  24.940 -    in pg [] goal tacs end;
  24.941 -end; (* local *)
  24.942 -
  24.943 -in thy |> Theory.add_path comp_dnam
  24.944 -       |> (snd o (PureThy.add_thmss (map Thm.no_attributes [
  24.945 -		("take_rews"  , take_rews  ),
  24.946 -		("take_lemmas", take_lemmas),
  24.947 -		("finites"    , finites    ),
  24.948 -		("finite_ind", [finite_ind]),
  24.949 -		("ind"       , [ind       ]),
  24.950 -		("coind"     , [coind     ])])))
  24.951 -       |> Theory.parent_path |> rpair take_rews
  24.952 -end; (* let *)
  24.953 -end; (* local *)
  24.954 -end; (* struct *)
    25.1 --- a/src/HOLCF/fixrec_package.ML	Thu May 31 13:24:13 2007 +0200
    25.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    25.3 @@ -1,317 +0,0 @@
    25.4 -(*  Title:      HOLCF/fixrec_package.ML
    25.5 -    ID:         $Id$
    25.6 -    Author:     Amber Telfer and Brian Huffman
    25.7 -
    25.8 -Recursive function definition package for HOLCF.
    25.9 -*)
   25.10 -
   25.11 -signature FIXREC_PACKAGE =
   25.12 -sig
   25.13 -  val legacy_infer_term: theory -> term -> term
   25.14 -  val legacy_infer_prop: theory -> term -> term
   25.15 -  val add_fixrec: bool -> ((string * Attrib.src list) * string) list list -> theory -> theory
   25.16 -  val add_fixrec_i: bool -> ((string * attribute list) * term) list list -> theory -> theory
   25.17 -  val add_fixpat: (string * Attrib.src list) * string list -> theory -> theory
   25.18 -  val add_fixpat_i: (string * attribute list) * term list -> theory -> theory
   25.19 -end;
   25.20 -
   25.21 -structure FixrecPackage: FIXREC_PACKAGE =
   25.22 -struct
   25.23 -
   25.24 -(* legacy type inference *)
   25.25 -
   25.26 -fun legacy_infer_term thy t =
   25.27 -  singleton (ProofContext.infer_types (ProofContext.init thy)) (Sign.intern_term thy t);
   25.28 -
   25.29 -fun legacy_infer_prop thy t = legacy_infer_term thy (TypeInfer.constrain t propT);
   25.30 -
   25.31 -
   25.32 -val fix_eq2 = thm "fix_eq2";
   25.33 -val def_fix_ind = thm "def_fix_ind";
   25.34 -
   25.35 -
   25.36 -fun fixrec_err s = error ("fixrec definition error:\n" ^ s);
   25.37 -fun fixrec_eq_err thy s eq =
   25.38 -  fixrec_err (s ^ "\nin\n" ^ quote (Sign.string_of_term thy eq));
   25.39 -
   25.40 -(* ->> is taken from holcf_logic.ML *)
   25.41 -(* TODO: fix dependencies so we can import HOLCFLogic here *)
   25.42 -infixr 6 ->>;
   25.43 -fun S ->> T = Type ("Cfun.->",[S,T]);
   25.44 -
   25.45 -(* extern_name is taken from domain/library.ML *)
   25.46 -fun extern_name con = case Symbol.explode con of 
   25.47 -		   ("o"::"p"::" "::rest) => implode rest
   25.48 -		   | _ => con;
   25.49 -
   25.50 -val mk_trp = HOLogic.mk_Trueprop;
   25.51 -
   25.52 -(* splits a cterm into the right and lefthand sides of equality *)
   25.53 -fun dest_eqs t = HOLogic.dest_eq (HOLogic.dest_Trueprop t);
   25.54 -
   25.55 -(* similar to Thm.head_of, but for continuous application *)
   25.56 -fun chead_of (Const("Cfun.Rep_CFun",_)$f$t) = chead_of f
   25.57 -  | chead_of u = u;
   25.58 -
   25.59 -(* these are helpful functions copied from HOLCF/domain/library.ML *)
   25.60 -fun %: s = Free(s,dummyT);
   25.61 -fun %%: s = Const(s,dummyT);
   25.62 -infix 0 ==;  fun S ==  T = %%:"==" $ S $ T;
   25.63 -infix 1 ===; fun S === T = %%:"op =" $ S $ T;
   25.64 -infix 9 `  ; fun f ` x = %%:"Cfun.Rep_CFun" $ f $ x;
   25.65 -
   25.66 -(* builds the expression (LAM v. rhs) *)
   25.67 -fun big_lambda v rhs = %%:"Cfun.Abs_CFun"$(Term.lambda v rhs);
   25.68 -
   25.69 -(* builds the expression (LAM v1 v2 .. vn. rhs) *)
   25.70 -fun big_lambdas [] rhs = rhs
   25.71 -  | big_lambdas (v::vs) rhs = big_lambda v (big_lambdas vs rhs);
   25.72 -
   25.73 -(* builds the expression (LAM <v1,v2,..,vn>. rhs) *)
   25.74 -fun lambda_ctuple [] rhs = big_lambda (%:"unit") rhs
   25.75 -  | lambda_ctuple (v::[]) rhs = big_lambda v rhs
   25.76 -  | lambda_ctuple (v::vs) rhs =
   25.77 -      %%:"Cprod.csplit"`(big_lambda v (lambda_ctuple vs rhs));
   25.78 -
   25.79 -(* builds the expression <v1,v2,..,vn> *)
   25.80 -fun mk_ctuple [] = %%:"UU"
   25.81 -|   mk_ctuple (t::[]) = t
   25.82 -|   mk_ctuple (t::ts) = %%:"Cprod.cpair"`t`(mk_ctuple ts);
   25.83 -
   25.84 -(*************************************************************************)
   25.85 -(************* fixed-point definitions and unfolding theorems ************)
   25.86 -(*************************************************************************)
   25.87 -
   25.88 -fun add_fixdefs eqs thy =
   25.89 -  let
   25.90 -    val (lhss,rhss) = ListPair.unzip (map dest_eqs eqs);
   25.91 -    val fixpoint = %%:"Fix.fix"`lambda_ctuple lhss (mk_ctuple rhss);
   25.92 -    
   25.93 -    fun one_def (l as Const(n,T)) r =
   25.94 -          let val b = Sign.base_name n in (b, (b^"_def", l == r)) end
   25.95 -      | one_def _ _ = fixrec_err "fixdefs: lhs not of correct form";
   25.96 -    fun defs [] _ = []
   25.97 -      | defs (l::[]) r = [one_def l r]
   25.98 -      | defs (l::ls) r = one_def l (%%:"Cprod.cfst"`r) :: defs ls (%%:"Cprod.csnd"`r);
   25.99 -    val (names, pre_fixdefs) = ListPair.unzip (defs lhss fixpoint);
  25.100 -    
  25.101 -    val fixdefs = map (apsnd (legacy_infer_prop thy)) pre_fixdefs;
  25.102 -    val (fixdef_thms, thy') =
  25.103 -      PureThy.add_defs_i false (map Thm.no_attributes fixdefs) thy;
  25.104 -    val ctuple_fixdef_thm = foldr1 (fn (x,y) => cpair_equalI OF [x,y]) fixdef_thms;
  25.105 -    
  25.106 -    val ctuple_unfold = legacy_infer_term thy' (mk_trp (mk_ctuple lhss === mk_ctuple rhss));
  25.107 -    val ctuple_unfold_thm = Goal.prove_global thy' [] [] ctuple_unfold
  25.108 -          (fn _ => EVERY [rtac (ctuple_fixdef_thm RS fix_eq2 RS trans) 1,
  25.109 -                    simp_tac (simpset_of thy') 1]);
  25.110 -    val ctuple_induct_thm =
  25.111 -          (space_implode "_" names ^ "_induct", ctuple_fixdef_thm RS def_fix_ind);
  25.112 -    
  25.113 -    fun unfolds [] thm = []
  25.114 -      | unfolds (n::[]) thm = [(n^"_unfold", thm)]
  25.115 -      | unfolds (n::ns) thm = let
  25.116 -          val thmL = thm RS cpair_eqD1;
  25.117 -          val thmR = thm RS cpair_eqD2;
  25.118 -        in (n^"_unfold", thmL) :: unfolds ns thmR end;
  25.119 -    val unfold_thms = unfolds names ctuple_unfold_thm;
  25.120 -    val thms = ctuple_induct_thm :: unfold_thms;
  25.121 -    val (_, thy'') = PureThy.add_thms (map Thm.no_attributes thms) thy';
  25.122 -  in
  25.123 -    (thy'', names, fixdef_thms, map snd unfold_thms)
  25.124 -  end;
  25.125 -
  25.126 -(*************************************************************************)
  25.127 -(*********** monadic notation and pattern matching compilation ***********)
  25.128 -(*************************************************************************)
  25.129 -
  25.130 -fun add_names (Const(a,_), bs) = insert (op =) (Sign.base_name a) bs
  25.131 -  | add_names (Free(a,_) , bs) = insert (op =) a bs
  25.132 -  | add_names (f $ u     , bs) = add_names (f, add_names(u, bs))
  25.133 -  | add_names (Abs(a,_,t), bs) = add_names (t, insert (op =) a bs)
  25.134 -  | add_names (_         , bs) = bs;
  25.135 -
  25.136 -fun add_terms ts xs = foldr add_names xs ts;
  25.137 -
  25.138 -(* builds a monadic term for matching a constructor pattern *)
  25.139 -fun pre_build pat rhs vs taken =
  25.140 -  case pat of
  25.141 -    Const("Cfun.Rep_CFun",_)$f$(v as Free(n,T)) =>
  25.142 -      pre_build f rhs (v::vs) taken
  25.143 -  | Const("Cfun.Rep_CFun",_)$f$x =>
  25.144 -      let val (rhs', v, taken') = pre_build x rhs [] taken;
  25.145 -      in pre_build f rhs' (v::vs) taken' end
  25.146 -  | Const(c,T) =>
  25.147 -      let
  25.148 -        val n = Name.variant taken "v";
  25.149 -        fun result_type (Type("Cfun.->",[_,T])) (x::xs) = result_type T xs
  25.150 -          | result_type T _ = T;
  25.151 -        val v = Free(n, result_type T vs);
  25.152 -        val m = "match_"^(extern_name(Sign.base_name c));
  25.153 -        val k = lambda_ctuple vs rhs;
  25.154 -      in
  25.155 -        (%%:"Fixrec.bind"`(%%:m`v)`k, v, n::taken)
  25.156 -      end
  25.157 -  | Free(n,_) => fixrec_err ("expected constructor, found free variable " ^ quote n)
  25.158 -  | _ => fixrec_err "pre_build: invalid pattern";
  25.159 -
  25.160 -(* builds a monadic term for matching a function definition pattern *)
  25.161 -(* returns (name, arity, matcher) *)
  25.162 -fun building pat rhs vs taken =
  25.163 -  case pat of
  25.164 -    Const("Cfun.Rep_CFun", _)$f$(v as Free(n,T)) =>
  25.165 -      building f rhs (v::vs) taken
  25.166 -  | Const("Cfun.Rep_CFun", _)$f$x =>
  25.167 -      let val (rhs', v, taken') = pre_build x rhs [] taken;
  25.168 -      in building f rhs' (v::vs) taken' end
  25.169 -  | Const(name,_) => (name, length vs, big_lambdas vs rhs)
  25.170 -  | _ => fixrec_err "function is not declared as constant in theory";
  25.171 -
  25.172 -fun match_eq eq = 
  25.173 -  let val (lhs,rhs) = dest_eqs eq;
  25.174 -  in building lhs (%%:"Fixrec.return"`rhs) [] (add_terms [eq] []) end;
  25.175 -
  25.176 -(* returns the sum (using +++) of the terms in ms *)
  25.177 -(* also applies "run" to the result! *)
  25.178 -fun fatbar arity ms =
  25.179 -  let
  25.180 -    fun unLAM 0 t = t
  25.181 -      | unLAM n (_$Abs(_,_,t)) = unLAM (n-1) t
  25.182 -      | unLAM _ _ = fixrec_err "fatbar: internal error, not enough LAMs";
  25.183 -    fun reLAM 0 t = t
  25.184 -      | reLAM n t = reLAM (n-1) (%%:"Cfun.Abs_CFun" $ Abs("",dummyT,t));
  25.185 -    fun mplus (x,y) = %%:"Fixrec.mplus"`x`y;
  25.186 -    val msum = foldr1 mplus (map (unLAM arity) ms);
  25.187 -  in
  25.188 -    reLAM arity (%%:"Fixrec.run"`msum)
  25.189 -  end;
  25.190 -
  25.191 -fun unzip3 [] = ([],[],[])
  25.192 -  | unzip3 ((x,y,z)::ts) =
  25.193 -      let val (xs,ys,zs) = unzip3 ts
  25.194 -      in (x::xs, y::ys, z::zs) end;
  25.195 -
  25.196 -(* this is the pattern-matching compiler function *)
  25.197 -fun compile_pats eqs = 
  25.198 -  let
  25.199 -    val ((n::names),(a::arities),mats) = unzip3 (map match_eq eqs);
  25.200 -    val cname = if forall (fn x => n=x) names then n
  25.201 -          else fixrec_err "all equations in block must define the same function";
  25.202 -    val arity = if forall (fn x => a=x) arities then a
  25.203 -          else fixrec_err "all equations in block must have the same arity";
  25.204 -    val rhs = fatbar arity mats;
  25.205 -  in
  25.206 -    mk_trp (%%:cname === rhs)
  25.207 -  end;
  25.208 -
  25.209 -(*************************************************************************)
  25.210 -(********************** Proving associated theorems **********************)
  25.211 -(*************************************************************************)
  25.212 -
  25.213 -(* proves a block of pattern matching equations as theorems, using unfold *)
  25.214 -fun make_simps thy (unfold_thm, eqns) =
  25.215 -  let
  25.216 -    val tacs = [rtac (unfold_thm RS ssubst_lhs) 1, asm_simp_tac (simpset_of thy) 1];
  25.217 -    fun prove_term t = Goal.prove_global thy [] [] t (K (EVERY tacs));
  25.218 -    fun prove_eqn ((name, eqn_t), atts) = ((name, prove_term eqn_t), atts);
  25.219 -  in
  25.220 -    map prove_eqn eqns
  25.221 -  end;
  25.222 -
  25.223 -(*************************************************************************)
  25.224 -(************************* Main fixrec function **************************)
  25.225 -(*************************************************************************)
  25.226 -
  25.227 -fun gen_add_fixrec prep_prop prep_attrib strict blocks thy =
  25.228 -  let
  25.229 -    val eqns = List.concat blocks;
  25.230 -    val lengths = map length blocks;
  25.231 -    
  25.232 -    val ((names, srcss), strings) = apfst split_list (split_list eqns);
  25.233 -    val atts = map (map (prep_attrib thy)) srcss;
  25.234 -    val eqn_ts = map (prep_prop thy) strings;
  25.235 -    val rec_ts = map (fn eq => chead_of (fst (dest_eqs (Logic.strip_imp_concl eq)))
  25.236 -      handle TERM _ => fixrec_eq_err thy "not a proper equation" eq) eqn_ts;
  25.237 -    val (_, eqn_ts') = OldInductivePackage.unify_consts thy rec_ts eqn_ts;
  25.238 -    
  25.239 -    fun unconcat [] _ = []
  25.240 -      | unconcat (n::ns) xs = List.take (xs,n) :: unconcat ns (List.drop (xs,n));
  25.241 -    val pattern_blocks = unconcat lengths (map Logic.strip_imp_concl eqn_ts');
  25.242 -    val compiled_ts = map (legacy_infer_term thy o compile_pats) pattern_blocks;
  25.243 -    val (thy', cnames, fixdef_thms, unfold_thms) = add_fixdefs compiled_ts thy;
  25.244 -  in
  25.245 -    if strict then let (* only prove simp rules if strict = true *)
  25.246 -      val eqn_blocks = unconcat lengths ((names ~~ eqn_ts') ~~ atts);
  25.247 -      val simps = List.concat (map (make_simps thy') (unfold_thms ~~ eqn_blocks));
  25.248 -      val (simp_thms, thy'') = PureThy.add_thms simps thy';
  25.249 -      
  25.250 -      val simp_names = map (fn name => name^"_simps") cnames;
  25.251 -      val simp_attribute = rpair [Simplifier.simp_add];
  25.252 -      val simps' = map simp_attribute (simp_names ~~ unconcat lengths simp_thms);
  25.253 -    in
  25.254 -      (snd o PureThy.add_thmss simps') thy''
  25.255 -    end
  25.256 -    else thy'
  25.257 -  end;
  25.258 -
  25.259 -val add_fixrec = gen_add_fixrec Sign.read_prop Attrib.attribute;
  25.260 -val add_fixrec_i = gen_add_fixrec Sign.cert_prop (K I);
  25.261 -
  25.262 -
  25.263 -(*************************************************************************)
  25.264 -(******************************** Fixpat *********************************)
  25.265 -(*************************************************************************)
  25.266 -
  25.267 -fun fix_pat thy t = 
  25.268 -  let
  25.269 -    val T = fastype_of t;
  25.270 -    val eq = mk_trp (HOLogic.eq_const T $ t $ Var (("x",0),T));
  25.271 -    val cname = case chead_of t of Const(c,_) => c | _ =>
  25.272 -              fixrec_err "function is not declared as constant in theory";
  25.273 -    val unfold_thm = PureThy.get_thm thy (Name (cname^"_unfold"));
  25.274 -    val simp = Goal.prove_global thy [] [] eq
  25.275 -          (fn _ => EVERY [stac unfold_thm 1, simp_tac (simpset_of thy) 1]);
  25.276 -  in simp end;
  25.277 -
  25.278 -fun gen_add_fixpat prep_term prep_attrib ((name, srcs), strings) thy =
  25.279 -  let
  25.280 -    val atts = map (prep_attrib thy) srcs;
  25.281 -    val ts = map (prep_term thy) strings;
  25.282 -    val simps = map (fix_pat thy) ts;
  25.283 -  in
  25.284 -    (snd o PureThy.add_thmss [((name, simps), atts)]) thy
  25.285 -  end;
  25.286 -
  25.287 -val add_fixpat = gen_add_fixpat Sign.read_term Attrib.attribute;
  25.288 -val add_fixpat_i = gen_add_fixpat Sign.cert_term (K I);
  25.289 -
  25.290 -
  25.291 -(*************************************************************************)
  25.292 -(******************************** Parsers ********************************)
  25.293 -(*************************************************************************)
  25.294 -
  25.295 -local structure P = OuterParse and K = OuterKeyword in
  25.296 -
  25.297 -val fixrec_eqn = SpecParse.opt_thm_name ":" -- P.prop;
  25.298 -
  25.299 -val fixrec_strict = P.opt_keyword "permissive" >> not;
  25.300 -
  25.301 -val fixrec_decl = fixrec_strict -- P.and_list1 (Scan.repeat1 fixrec_eqn);
  25.302 -
  25.303 -(* this builds a parser for a new keyword, fixrec, whose functionality 
  25.304 -is defined by add_fixrec *)
  25.305 -val fixrecP =
  25.306 -  OuterSyntax.command "fixrec" "define recursive functions (HOLCF)" K.thy_decl
  25.307 -    (fixrec_decl >> (Toplevel.theory o uncurry add_fixrec));
  25.308 -
  25.309 -(* fixpat parser *)
  25.310 -val fixpat_decl = SpecParse.opt_thm_name ":" -- Scan.repeat1 P.prop;
  25.311 -
  25.312 -val fixpatP =
  25.313 -  OuterSyntax.command "fixpat" "define rewrites for fixrec functions" K.thy_decl
  25.314 -    (fixpat_decl >> (Toplevel.theory o add_fixpat));
  25.315 -
  25.316 -val _ = OuterSyntax.add_parsers [fixrecP, fixpatP];
  25.317 -
  25.318 -end; (* local structure *)
  25.319 -
  25.320 -end; (* struct *)
    26.1 --- a/src/HOLCF/pcpodef_package.ML	Thu May 31 13:24:13 2007 +0200
    26.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    26.3 @@ -1,213 +0,0 @@
    26.4 -(*  Title:      HOLCF/pcpodef_package.ML
    26.5 -    ID:         $Id$
    26.6 -    Author:     Brian Huffman
    26.7 -
    26.8 -Primitive domain definitions for HOLCF, similar to Gordon/HOL-style
    26.9 -typedef.
   26.10 -*)
   26.11 -
   26.12 -signature PCPODEF_PACKAGE =
   26.13 -sig
   26.14 -  val quiet_mode: bool ref
   26.15 -  val pcpodef_proof: (bool * string) * (bstring * string list * mixfix) * string
   26.16 -    * (string * string) option -> theory -> Proof.state
   26.17 -  val pcpodef_proof_i: (bool * string) * (bstring * string list * mixfix) * term
   26.18 -    * (string * string) option -> theory -> Proof.state
   26.19 -  val cpodef_proof: (bool * string) * (bstring * string list * mixfix) * string
   26.20 -    * (string * string) option -> theory -> Proof.state
   26.21 -  val cpodef_proof_i: (bool * string) * (bstring * string list * mixfix) * term
   26.22 -    * (string * string) option -> theory -> Proof.state
   26.23 -end;
   26.24 -
   26.25 -structure PcpodefPackage: PCPODEF_PACKAGE =
   26.26 -struct
   26.27 -
   26.28 -(** theory context references **)
   26.29 -
   26.30 -val typedef_po = thm "typedef_po";
   26.31 -val typedef_cpo = thm "typedef_cpo";
   26.32 -val typedef_pcpo = thm "typedef_pcpo";
   26.33 -val typedef_lub = thm "typedef_lub";
   26.34 -val typedef_thelub = thm "typedef_thelub";
   26.35 -val typedef_compact = thm "typedef_compact";
   26.36 -val cont_Rep = thm "typedef_cont_Rep";
   26.37 -val cont_Abs = thm "typedef_cont_Abs";
   26.38 -val Rep_strict = thm "typedef_Rep_strict";
   26.39 -val Abs_strict = thm "typedef_Abs_strict";
   26.40 -val Rep_defined = thm "typedef_Rep_defined";
   26.41 -val Abs_defined = thm "typedef_Abs_defined";
   26.42 -
   26.43 -
   26.44 -(** type definitions **)
   26.45 -
   26.46 -(* messages *)
   26.47 -
   26.48 -val quiet_mode = ref false;
   26.49 -fun message s = if ! quiet_mode then () else writeln s;
   26.50 -
   26.51 -
   26.52 -(* prepare_cpodef *)
   26.53 -
   26.54 -fun err_in_cpodef msg name =
   26.55 -  cat_error msg ("The error(s) above occurred in cpodef " ^ quote name);
   26.56 -
   26.57 -fun declare_type_name a = Variable.declare_constraints (Logic.mk_type (TFree (a, dummyS)));
   26.58 -
   26.59 -fun adm_const T = Const ("Adm.adm", (T --> HOLogic.boolT) --> HOLogic.boolT);
   26.60 -fun mk_adm (x, T, P) = adm_const T $ absfree (x, T, P);
   26.61 -
   26.62 -fun prepare_pcpodef prep_term pcpo def name (t, vs, mx) raw_set opt_morphs thy =
   26.63 -  let
   26.64 -    val ctxt = ProofContext.init thy;
   26.65 -    val full = Sign.full_name thy;
   26.66 -
   26.67 -    (*rhs*)
   26.68 -    val full_name = full name;
   26.69 -    val set = prep_term (ctxt |> fold declare_type_name vs) raw_set;
   26.70 -    val setT = Term.fastype_of set;
   26.71 -    val rhs_tfrees = term_tfrees set;
   26.72 -    val oldT = HOLogic.dest_setT setT handle TYPE _ =>
   26.73 -      error ("Not a set type: " ^ quote (ProofContext.string_of_typ ctxt setT));
   26.74 -    fun mk_nonempty A =
   26.75 -      HOLogic.mk_exists ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), A));
   26.76 -    fun mk_admissible A =
   26.77 -      mk_adm ("x", oldT, HOLogic.mk_mem (Free ("x", oldT), A));
   26.78 -    fun mk_UU_mem A = HOLogic.mk_mem (Const ("Pcpo.UU", oldT), A);
   26.79 -    val goal = if pcpo
   26.80 -      then HOLogic.mk_Trueprop (HOLogic.mk_conj (mk_UU_mem set, mk_admissible set))
   26.81 -      else HOLogic.mk_Trueprop (HOLogic.mk_conj (mk_nonempty set, mk_admissible set));
   26.82 -
   26.83 -    (*lhs*)
   26.84 -    val defS = Sign.defaultS thy;
   26.85 -    val lhs_tfrees = map (fn v => (v, the_default defS (AList.lookup (op =) rhs_tfrees v))) vs;
   26.86 -    val lhs_sorts = map snd lhs_tfrees;
   26.87 -    val tname = Syntax.type_name t mx;
   26.88 -    val full_tname = full tname;
   26.89 -    val newT = Type (full_tname, map TFree lhs_tfrees);
   26.90 -
   26.91 -    val (Rep_name, Abs_name) = the_default ("Rep_" ^ name, "Abs_" ^ name) opt_morphs;
   26.92 -    val RepC = Const (full Rep_name, newT --> oldT);
   26.93 -    fun lessC T = Const ("Porder.<<", T --> T --> HOLogic.boolT);
   26.94 -    val less_def = ("less_" ^ name ^ "_def", Logic.mk_equals (lessC newT,
   26.95 -      Abs ("x", newT, Abs ("y", newT, lessC oldT $ (RepC $ Bound 1) $ (RepC $ Bound 0)))));
   26.96 -
   26.97 -    fun make_po tac theory = theory
   26.98 -      |> TypedefPackage.add_typedef_i def (SOME name) (t, vs, mx) set opt_morphs tac
   26.99 -      ||> AxClass.prove_arity (full_tname, lhs_sorts, ["Porder.sq_ord"])
  26.100 -           (ClassPackage.intro_classes_tac [])
  26.101 -      ||>> PureThy.add_defs_i true [Thm.no_attributes less_def]
  26.102 -      |-> (fn ((_, {type_definition, set_def, ...}), [less_definition]) =>
  26.103 -          AxClass.prove_arity (full_tname, lhs_sorts, ["Porder.po"])
  26.104 -             (Tactic.rtac (typedef_po OF [type_definition, less_definition]) 1)
  26.105 -           #> pair (type_definition, less_definition, set_def));
  26.106 -
  26.107 -    fun make_cpo admissible (type_def, less_def, set_def) theory =
  26.108 -      let
  26.109 -        val admissible' = fold_rule (the_list set_def) admissible;
  26.110 -        val cpo_thms = [type_def, less_def, admissible'];
  26.111 -      in
  26.112 -        theory
  26.113 -        |> AxClass.prove_arity (full_tname, lhs_sorts, ["Pcpo.cpo"])
  26.114 -          (Tactic.rtac (typedef_cpo OF cpo_thms) 1)
  26.115 -        |> Theory.add_path name
  26.116 -        |> PureThy.add_thms
  26.117 -            ([(("adm_" ^ name, admissible'), []),
  26.118 -              (("cont_" ^ Rep_name, cont_Rep OF cpo_thms), []),
  26.119 -              (("cont_" ^ Abs_name, cont_Abs OF cpo_thms), []),
  26.120 -              (("lub_"     ^ name, typedef_lub     OF cpo_thms), []),
  26.121 -              (("thelub_"  ^ name, typedef_thelub  OF cpo_thms), []),
  26.122 -              (("compact_" ^ name, typedef_compact OF cpo_thms), [])])
  26.123 -        |> snd
  26.124 -        |> Theory.parent_path
  26.125 -      end;
  26.126 -
  26.127 -    fun make_pcpo UUmem (type_def, less_def, set_def) theory =
  26.128 -      let
  26.129 -        val UUmem' = fold_rule (the_list set_def) UUmem;
  26.130 -        val pcpo_thms = [type_def, less_def, UUmem'];
  26.131 -      in
  26.132 -        theory
  26.133 -        |> AxClass.prove_arity (full_tname, lhs_sorts, ["Pcpo.pcpo"])
  26.134 -          (Tactic.rtac (typedef_pcpo OF pcpo_thms) 1)
  26.135 -        |> Theory.add_path name
  26.136 -        |> PureThy.add_thms
  26.137 -            ([((Rep_name ^ "_strict", Rep_strict OF pcpo_thms), []),
  26.138 -              ((Abs_name ^ "_strict", Abs_strict OF pcpo_thms), []),
  26.139 -              ((Rep_name ^ "_defined", Rep_defined OF pcpo_thms), []),
  26.140 -              ((Abs_name ^ "_defined", Abs_defined OF pcpo_thms), [])
  26.141 -              ])
  26.142 -        |> snd
  26.143 -        |> Theory.parent_path
  26.144 -      end;
  26.145 -
  26.146 -    fun pcpodef_result UUmem_admissible theory =
  26.147 -      let
  26.148 -        val UUmem = UUmem_admissible RS conjunct1;
  26.149 -        val admissible = UUmem_admissible RS conjunct2;
  26.150 -      in
  26.151 -        theory
  26.152 -        |> make_po (Tactic.rtac exI 1 THEN Tactic.rtac UUmem 1)
  26.153 -        |-> (fn defs => make_cpo admissible defs #> make_pcpo UUmem defs)
  26.154 -      end;
  26.155 -
  26.156 -    fun cpodef_result nonempty_admissible theory =
  26.157 -      let
  26.158 -        val nonempty = nonempty_admissible RS conjunct1;
  26.159 -        val admissible = nonempty_admissible RS conjunct2;
  26.160 -      in
  26.161 -        theory
  26.162 -        |> make_po (Tactic.rtac nonempty 1)
  26.163 -        |-> make_cpo admissible
  26.164 -      end;
  26.165 -
  26.166 -  in (goal, if pcpo then pcpodef_result else cpodef_result) end
  26.167 -  handle ERROR msg => err_in_cpodef msg name;
  26.168 -
  26.169 -
  26.170 -(* cpodef_proof interface *)
  26.171 -
  26.172 -fun gen_pcpodef_proof prep_term pcpo ((def, name), typ, set, opt_morphs) thy =
  26.173 -  let
  26.174 -    val (goal, pcpodef_result) =
  26.175 -      prepare_pcpodef prep_term pcpo def name typ set opt_morphs thy;
  26.176 -    fun after_qed [[th]] = ProofContext.theory (pcpodef_result th);
  26.177 -  in Proof.theorem_i NONE after_qed [[(goal, [])]] (ProofContext.init thy) end;
  26.178 -
  26.179 -fun pcpodef_proof x = gen_pcpodef_proof ProofContext.read_term true x;
  26.180 -fun pcpodef_proof_i x = gen_pcpodef_proof ProofContext.cert_term true x;
  26.181 -
  26.182 -fun cpodef_proof x = gen_pcpodef_proof ProofContext.read_term false x;
  26.183 -fun cpodef_proof_i x = gen_pcpodef_proof ProofContext.cert_term false x;
  26.184 -
  26.185 -
  26.186 -(** outer syntax **)
  26.187 -
  26.188 -local structure P = OuterParse and K = OuterKeyword in
  26.189 -
  26.190 -(* copied from HOL/Tools/typedef_package.ML *)
  26.191 -val typedef_proof_decl =
  26.192 -  Scan.optional (P.$$$ "(" |--
  26.193 -      ((P.$$$ "open" >> K false) -- Scan.option P.name || P.name >> (fn s => (true, SOME s)))
  26.194 -        --| P.$$$ ")") (true, NONE) --
  26.195 -    (P.type_args -- P.name) -- P.opt_infix -- (P.$$$ "=" |-- P.term) --
  26.196 -    Scan.option (P.$$$ "morphisms" |-- P.!!! (P.name -- P.name));
  26.197 -
  26.198 -fun mk_pcpodef_proof pcpo ((((((def, opt_name), (vs, t)), mx), A), morphs)) =
  26.199 -  (if pcpo then pcpodef_proof else cpodef_proof)
  26.200 -    ((def, the_default (Syntax.type_name t mx) opt_name), (t, vs, mx), A, morphs);
  26.201 -
  26.202 -val pcpodefP =
  26.203 -  OuterSyntax.command "pcpodef" "HOLCF type definition (requires admissibility proof)" K.thy_goal
  26.204 -    (typedef_proof_decl >>
  26.205 -      (Toplevel.print oo (Toplevel.theory_to_proof o mk_pcpodef_proof true)));
  26.206 -
  26.207 -val cpodefP =
  26.208 -  OuterSyntax.command "cpodef" "HOLCF type definition (requires admissibility proof)" K.thy_goal
  26.209 -    (typedef_proof_decl >>
  26.210 -      (Toplevel.print oo (Toplevel.theory_to_proof o mk_pcpodef_proof false)));
  26.211 -
  26.212 -val _ = OuterSyntax.add_parsers [pcpodefP, cpodefP];
  26.213 -
  26.214 -end;
  26.215 -
  26.216 -end;