src/Tools/isac/ProgLang/Prog_Expr.thy
author wneuper <walther.neuper@jku.at>
Tue, 16 Nov 2021 18:26:57 +0100
changeset 60417 00ba9518dc35
parent 60405 d4ebe139100d
child 60422 6a5f3a2e6d3a
permissions -rw-r--r--
unify parse 4: eliminate parse, simple cases
     1 (* title:  ProgLang/Prog_Expr.thy
     2            functions for expressions (which do NOT contain Prog_Tac and Tactical, by definition))
     3    author: Walther Neuper, Aug.2019
     4    (c) copyright due to lincense terms.
     5 *)
     6 
     7 theory Prog_Expr
     8   imports Calculate ListC Program
     9 begin
    10 
    11 text \<open>Abstract:
    12   Specific constants are defined for pre-conditions of programs and for program-expressions.
    13   The constants are connected with ML functions for evaluation of respective expressions
    14   (all named eval_*), such that Isac's rewrite engine can handle it.
    15 \<close>
    16 
    17 subsection \<open>consts of functions in pre-conditions and program-expressions\<close>
    18 consts
    19   lhs             :: "bool => real"           (*of an equality*)
    20   rhs             :: "bool => real"           (*of an equality*)
    21   Vars            :: "'a => real list"        (*get the variables of a term *)
    22   matches         :: "['a, 'a] => bool"
    23   matchsub        :: "['a, 'a] => bool"
    24   some_occur_in  :: "[real list, 'a] => bool" ("some'_of _ occur'_in _")
    25   occurs_in       :: "[real     , 'a] => bool" ("_ occurs'_in _")
    26 
    27   abs              :: "real => real"            ("(|| _ ||)")
    28   (* ~~~ FIXXXME Isabelle2002 has abs already !!!*)
    29   absset           :: "real set => real"        ("(||| _ |||)")
    30   is_atom         :: "real => bool"            ("_ is'_atom" 10)
    31   is_num         :: "real => bool"             ("_ is'_num" 10)
    32   is_even         :: "real => bool"            ("_ is'_even" 10)
    33 		
    34   (* identity on term level*)
    35   ident            :: "['a, 'a] => bool"        ("(_ =!=/ _)" [51, 51] 50)
    36   argument_in     :: "real => real"            ("argument'_in _" 10)
    37   sameFunId        :: "[real, bool] => bool"    (* "same_funid _ _" 10
    38 	                    WN0609 changed the id, because ".. _ _" inhibits currying *)
    39   filter_sameFunId:: "[real, bool list] => bool list" ("filter'_sameFunId _ _" 10)
    40   boollist2sum     :: "bool list => real"
    41   lastI            :: "'a list \<Rightarrow> 'a"
    42 
    43 subsection \<open>ML code for functions in pre-conditions and program-expressions\<close>
    44 ML \<open>
    45 signature PROG_EXPR =
    46   sig
    47     val eval_lhs: 'a -> string -> term -> 'b -> (string * term) option
    48     val eval_matches: string -> string -> term -> theory -> (string * term) option
    49     val matchsub: theory -> term -> term -> bool
    50     val eval_matchsub: string -> string -> term -> theory -> (string * term) option
    51     val eval_rhs: 'a -> string -> term -> 'b -> (string * term) option
    52     val eval_var: string -> string -> term -> theory -> (string * term) option
    53 
    54     val or2list: term -> term
    55 
    56     val occurs_in: term -> term -> bool
    57     val eval_occurs_in: 'a -> string -> term -> 'b -> (string * term) option
    58     val some_occur_in: term list -> term -> bool
    59     val eval_some_occur_in: 'a -> string -> term -> 'b -> (string * term) option
    60     val eval_is_atom: string -> string -> term -> 'a -> (string * term) option
    61     val eval_is_num: string -> string -> term -> 'a -> (string * term) option
    62     val even: int -> bool
    63     val eval_is_even: string -> string -> term -> 'a -> (string * term) option
    64     val eval_equ: string -> string -> term -> 'a -> (string * term) option
    65     val eval_ident: string -> string -> term -> theory -> (string * term) option
    66     val eval_equal: string -> string -> term -> theory -> (string * term) option
    67     val eval_cancel: string -> string -> term -> 'a -> (string * term) option
    68     val eval_argument_in: string -> string -> term -> 'a -> (string * term) option
    69     val same_funid: term -> term -> bool
    70     val eval_sameFunId: string -> string -> term -> 'a -> (string * term) option
    71     val eval_filter_sameFunId: string -> string -> term -> 'a -> (string * term) option
    72     val list2sum: term list -> term
    73     val eval_boollist2sum: string -> string -> term -> 'a -> (string * term) option
    74 
    75     val mk_thmid_f: string -> (int * int) * (int * int) -> (int * int) * (int * int) -> string
    76   end
    77 
    78 (**)
    79 structure Prog_Expr(**): PROG_EXPR =(**)
    80 struct
    81 (**)
    82 
    83 (*+ for Or_to_List +*)
    84 fun or2list (Const (\<^const_name>\<open>True\<close>,_)) = ((*tracing"### or2list True";*) UniversalList)
    85   | or2list (Const (\<^const_name>\<open>False\<close>,_)) = ((*tracing"### or2list False";*) EmptyList)
    86   | or2list (t as Const (\<^const_name>\<open>HOL.eq\<close>,_) $ _ $ _) = TermC.list2isalist HOLogic.boolT [t]
    87   | or2list ors =
    88     let
    89       fun get ls (Const (\<^const_name>\<open>disj\<close>,_) $ o1 $ o2) =
    90 	        (case o2 of
    91 	         	Const (\<^const_name>\<open>disj\<close>,_) $ _ $ _ => get (ls @ [o1]) o2
    92 	        | _ => ls @ [o1, o2])
    93         | get _ t = raise TERM ("or2list: missing pattern in fun.def", [t])
    94     in (((TermC.list2isalist HOLogic.boolT) o (get [])) ors) end
    95 
    96 
    97 (** evaluation on the meta-level **)
    98 
    99 (*. evaluate the predicate matches (match on whole term only) .*)
   100 (*("matches",("Prog_Expr.matches", eval_matches "#matches_")):calc*)
   101 fun eval_matches (_:string) "Prog_Expr.matches" (t as Const (\<^const_name>\<open>Prog_Expr.matches\<close>, _) $ pat $ tst) thy = 
   102     if TermC.matches thy tst pat
   103     then 
   104       let
   105         val prop = HOLogic.Trueprop $ (TermC.mk_equality (t, @{term True}))
   106 	    in SOME (UnparseC.term_in_thy thy prop, prop) end
   107     else 
   108       let 
   109         val prop = HOLogic.Trueprop $ (TermC.mk_equality (t, @{term False}))
   110 	    in SOME (UnparseC.term_in_thy thy prop, prop) end
   111   | eval_matches _ _ _ _ = NONE; 
   112 
   113 (*.does a pattern match some subterm ?.*)
   114 fun matchsub thy t pat =  
   115   let
   116     fun matchs (t as Const _) = TermC.matches thy t pat
   117 	      | matchs (t as Free _) = TermC.matches thy t pat
   118 	      | matchs (t as Var _) = TermC.matches thy t pat
   119 	      | matchs (Bound _) = false
   120 	      | matchs (t as Abs (_, _, body)) = 
   121 	          if TermC.matches thy t pat then true else TermC.matches thy body pat
   122 	      | matchs (t as f1 $ f2) =
   123 	          if TermC.matches thy t pat then true 
   124 	            else if matchs f1 then true else matchs f2
   125   in matchs t end;
   126 
   127 (*("matchsub",("Prog_Expr.matchsub", eval_matchsub "#matchsub_")):calc*)
   128 fun eval_matchsub (_:string) "Prog_Expr.matchsub"
   129       (t as Const (\<^const_name>\<open>Prog_Expr.matchsub\<close>, _) $ pat $ tst) thy = 
   130     if matchsub thy tst pat
   131     then 
   132       let val prop = HOLogic.Trueprop $ (TermC.mk_equality (t, @{term True}))
   133       in SOME (UnparseC.term_in_thy thy prop, prop) end
   134     else 
   135       let val prop = HOLogic.Trueprop $ (TermC.mk_equality (t, @{term False}))
   136       in SOME (UnparseC.term_in_thy thy prop, prop) end
   137   | eval_matchsub _ _ _ _ = NONE; 
   138 
   139 (*get the variables in an isabelle-term*)
   140 (*("Vars"    ,("Prog_Expr.Vars"    , eval_var "#Vars_")):calc*)
   141 fun eval_var (thmid:string) "Prog_Expr.Vars" (t as (Const _ $ arg)) thy = 
   142     let 
   143       val t' = ((TermC.list2isalist HOLogic.realT) o TermC.vars) t;
   144       val thmId = thmid ^ UnparseC.term_in_thy thy arg;
   145     in SOME (thmId, HOLogic.Trueprop $ (TermC.mk_equality (t, t'))) end
   146   | eval_var _ _ _ _ = NONE;
   147 
   148 (*("lhs"    ,("Prog_Expr.lhs"    , eval_lhs "")):calc*)
   149 fun eval_lhs _ "Prog_Expr.lhs" (t as (Const (\<^const_name>\<open>lhs\<close>,_) $ (Const (\<^const_name>\<open>HOL.eq\<close>,_) $ l $ _))) _ = 
   150     SOME ((UnparseC.term t) ^ " = " ^ (UnparseC.term l),
   151 	  HOLogic.Trueprop $ (TermC.mk_equality (t, l)))
   152   | eval_lhs _ _ _ _ = NONE;
   153 (*
   154 > val t = (Thm.term_of o the o (parse thy)) "lhs (1 * x \<up> 2 = 0)";
   155 > val SOME (id,t') = eval_lhs 0 0 t 0;
   156 val id = "Prog_Expr.lhs (1 * x \<up> 2 = 0) = 1 * x \<up> 2" : string
   157 > term2str t';
   158 val it = "Prog_Expr.lhs (1 * x \<up> 2 = 0) = 1 * x \<up> 2" : string
   159 *)
   160 
   161 fun rhs (Const (\<^const_name>\<open>HOL.eq\<close>,_) $ _ $ r) = r
   162   | rhs t = raise ERROR("rhs called with (" ^ UnparseC.term t ^ ")");
   163 (*("rhs"    ,("Prog_Expr.rhs"    , eval_rhs "")):calc*)
   164 fun eval_rhs _ "Prog_Expr.rhs" (t as (Const (\<^const_name>\<open>rhs\<close>,_) $ (Const (\<^const_name>\<open>HOL.eq\<close>,_) $ _ $ r))) _ = 
   165     SOME (UnparseC.term t ^ " = " ^ UnparseC.term r,
   166 	  HOLogic.Trueprop $ (TermC.mk_equality (t, r)))
   167   | eval_rhs _ _ _ _ = NONE;
   168 (*\\------------------------- from Prog_Expr.thy-------------------------------------------------//*)
   169 
   170 (*//------------------------- from Atools.thy------------------------------------------------\\*)
   171 fun occurs_in v t = member op = (((map strip_thy) o TermC.ids2str) t) (Term.term_name v);
   172 
   173 (*("occurs_in", ("Prog_Expr.occurs_in", Prog_Expr.eval_occurs_in ""))*)
   174 fun eval_occurs_in _ "Prog_Expr.occurs_in" (p as (Const (\<^const_name>\<open>occurs_in\<close>, _) $ v $ t)) _ =
   175     ((*tracing("#>@ eval_occurs_in: v= "^(UnparseC.term v));
   176      tracing("#>@ eval_occurs_in: t= "^(UnparseC.term t));*)
   177      if occurs_in v t
   178     then SOME ((UnparseC.term p) ^ " = True",
   179 	  HOLogic.Trueprop $ (TermC.mk_equality (p, @{term True})))
   180     else SOME ((UnparseC.term p) ^ " = False",
   181 	  HOLogic.Trueprop $ (TermC.mk_equality (p, @{term False}))))
   182   | eval_occurs_in _ _ _ _ = NONE;
   183 
   184 (*some of the (bound) variables (eg. in an eqsys) "vs" occur in term "t"*)   
   185 fun some_occur_in vs t = 
   186     let fun occurs_in' a b = occurs_in b a
   187     in foldl or_ (false, map (occurs_in' t) vs) end;
   188 
   189 (*("some_occur_in", ("Prog_Expr.some_occur_in", 
   190 			eval_some_occur_in "#eval_some_occur_in_"))*)
   191 fun eval_some_occur_in _ "Prog_Expr.some_occur_in"
   192 			  (p as (Const (\<^const_name>\<open>some_occur_in\<close>,_) $ vs $ t)) _ =
   193     if some_occur_in (TermC.isalist2list vs) t
   194     then SOME ((UnparseC.term p) ^ " = True",
   195 	       HOLogic.Trueprop $ (TermC.mk_equality (p, @{term True})))
   196     else SOME ((UnparseC.term p) ^ " = False",
   197 	       HOLogic.Trueprop $ (TermC.mk_equality (p, @{term False})))
   198   | eval_some_occur_in _ _ _ _ = NONE;
   199 
   200 (*("is_atom",("Prog_Expr.is_atom", Prog_Expr.eval_is_atom "#is_atom_"))*)
   201 fun eval_is_atom (thmid:string) "Prog_Expr.is_atom" (t as (Const _ $ arg)) _ = 
   202     if TermC.is_atom arg
   203     then SOME (TermC.mk_thmid thmid (TermC.string_of_atom arg) "", 
   204 			HOLogic.Trueprop $ (TermC.mk_equality (t, @{term True})))
   205     else SOME (TermC.mk_thmid thmid (TermC.string_of_atom arg) "", 
   206 		  HOLogic.Trueprop $ (TermC.mk_equality (t, @{term False})))
   207   | eval_is_atom _ _ _ _ = NONE;
   208 
   209 (*("is_num",("Prog_Expr.is_num", Prog_Expr.eval_is_num "#is_num_"))*)
   210 fun eval_is_num (thmid:string) "Prog_Expr.is_num" (t as (Const _ $ arg)) _ = 
   211     if TermC.is_num arg
   212     then SOME (TermC.mk_thmid thmid (TermC.string_of_atom arg) "", 
   213 			HOLogic.Trueprop $ (TermC.mk_equality (t, @{term True})))
   214     else SOME (TermC.mk_thmid thmid (TermC.string_of_atom arg) "", 
   215 		  HOLogic.Trueprop $ (TermC.mk_equality (t, @{term False})))
   216   | eval_is_num _ _ _ _ = NONE;
   217 
   218 fun even i = (i div 2) * 2 = i;
   219 (*("is_even",("Prog_Expr.is_even", eval_is_even "#is_even_"))*)
   220 fun eval_is_even (thmid:string) "Prog_Expr.is_even" (t as (Const _ $ arg)) _ = 
   221     if TermC.is_num arg
   222     then
   223       let
   224         val i = arg |> HOLogic.dest_number |> snd
   225       in
   226 	      if even i 
   227         then SOME (TermC.mk_thmid thmid (string_of_int i) "", 
   228 				  HOLogic.Trueprop $ (TermC.mk_equality (t, @{term True})))
   229 	      else SOME (TermC.mk_thmid thmid "" "", 
   230 			    HOLogic.Trueprop $ (TermC.mk_equality (t, @{term False})))
   231       end
   232     else NONE
   233   | eval_is_even _ _ _ _ = NONE; 
   234 
   235 (*. evaluate binary, associative, commutative operators: *,+,^ .*)
   236 (*("PLUS"    ,(\<^const_name>\<open>plus\<close>        , (**)eval_binop "#add_")),
   237   ("TIMES"   ,(\<^const_name>\<open>times\<close>        , (**)eval_binop "#mult_")),
   238   ("POWER"  ,(\<^const_name>\<open>realpow\<close>  , (**)eval_binop "#power_"))*)
   239 
   240 (* val (thmid,op_,t as(Const (op0,t0) $ Free (n1,t1) $ Free(n2,t2)),thy) =
   241        ("xxxxxx",op_,t,thy);
   242    *)
   243 fun mk_thmid_f thmid ((v11, v12), (p11, p12)) ((v21, v22), (p21, p22)) = (* dropped *)
   244   thmid ^ "Float ((" ^ 
   245   (string_of_int v11)^", "^(string_of_int v12)^"), ("^
   246   (string_of_int p11)^", "^(string_of_int p12)^")) __ (("^
   247   (string_of_int v21)^", "^(string_of_int v22)^"), ("^
   248   (string_of_int p21)^", "^(string_of_int p22)^"))";
   249 
   250 (*.evaluate < and <= for numerals.*)
   251 (*("le"      ,(\<^const_name>\<open>less\<close>        , Prog_Expr.eval_equ "#less_")),
   252   ("leq"     ,(\<^const_name>\<open>less_eq\<close>       , Prog_Expr.eval_equ "#less_equal_"))*)
   253 
   254 fun eval_equ (thmid:string) (_(*op_*)) (t as (Const (op0, _)) $ t1 $ t2) _ =
   255     if TermC.is_num t1 andalso TermC.is_num t2 then
   256       let
   257         val n1 = t1 |> HOLogic.dest_number |> snd 
   258         val n2 = t2 |> HOLogic.dest_number |> snd 
   259       in
   260         if Eval.calc_equ (strip_thy op0) (n1, n2)
   261         then SOME (TermC.mk_thmid thmid (string_of_int n1) (string_of_int n2), 
   262     	    HOLogic.Trueprop $ (TermC.mk_equality (t, @{term True})))
   263         else SOME (TermC.mk_thmid thmid (string_of_int n1) (string_of_int n2),  
   264     	   HOLogic.Trueprop $ (TermC.mk_equality (t, @{term False})))
   265       end
   266     else NONE
   267   | eval_equ _ _ _ _ = NONE;
   268 
   269 
   270 (*evaluate identity
   271 > reflI;
   272 val it = "(?t = ?t) = True"
   273 > val t = str2term "x = 0";
   274 > val NONE = rewrite_ thy Rewrite_Ord.dummy_ord Rule_Set.empty false reflI t;
   275 
   276 > val t = str2term "1 = 0";
   277 > val NONE = rewrite_ thy Rewrite_Ord.dummy_ord Rule_Set.empty false reflI t;
   278 ----------- thus needs Rule.Eval !
   279 > val t = str2term "0 = 0";
   280 > val SOME (t',_) = rewrite_ thy Rewrite_Ord.dummy_ord Rule_Set.empty false reflI t;
   281 > UnparseC.term t';
   282 val it = \<^const_name>\<open>True\<close>
   283 
   284 val t = str2term "Not (x = 0)";
   285 atomt t; UnparseC.term t;
   286 *** -------------
   287 *** Const ( Not)
   288 *** . Const ( op =)
   289 *** . . Free ( x, )
   290 *** . . Free ( 0, )
   291 val it = "x ~= 0" : string*)
   292 
   293 (*.evaluate identity on the term-level, =!= ,i.e. without evaluation of 
   294   the arguments: thus special handling by 'fun eval_binop'*)
   295 (*("ident"   ,("Prog_Expr.ident", Prog_Expr.eval_ident "#ident_")):calc*)
   296 fun eval_ident (thmid:string) "Prog_Expr.ident" (t as 
   297 	       (Const _(*op0, t0*) $ t1 $ t2 )) thy = 
   298   if t1 = t2
   299   then SOME (TermC.mk_thmid thmid 
   300 	              ("(" ^ (UnparseC.term_in_thy thy t1) ^ ")")
   301 	              ("(" ^ (UnparseC.term_in_thy thy t2) ^ ")"), 
   302 	     HOLogic.Trueprop $ (TermC.mk_equality (t, @{term True})))
   303   else SOME (TermC.mk_thmid thmid  
   304 	              ("(" ^ (UnparseC.term_in_thy thy t1) ^ ")")
   305 	              ("(" ^ (UnparseC.term_in_thy thy t2) ^ ")"),  
   306 	     HOLogic.Trueprop $ (TermC.mk_equality (t, @{term False})))
   307   | eval_ident _ _ _ _ = NONE;
   308 (* TODO
   309 > val t = str2term "x =!= 0";
   310 > val SOME (str, t') = eval_ident "ident_" "b" t thy;
   311 > UnparseC.term t';
   312 val str = "ident_(x)_(0)" : string
   313 val it = "(x =!= 0) = False" : string                                
   314 > val t = str2term "1 =!= 0";
   315 > val SOME (str, t') = eval_ident "ident_" "b" t thy;
   316 > UnparseC.term t';
   317 val str = "ident_(1)_(0)" : string 
   318 val it = "(1 =!= 0) = False" : string                                       
   319 > val t = str2term "0 =!= 0";
   320 > val SOME (str, t') = eval_ident "ident_" "b" t thy;
   321 > UnparseC.term t';
   322 val str = "ident_(0)_(0)" : string
   323 val it = "(0 =!= 0) = True" : string
   324 *)
   325 
   326 
   327 (* evaluate identity of terms, which stay ready for further evaluation;
   328   thus returns False only for atoms *)
   329 (*("equal"   ,(\<^const_name>\<open>HOL.eq\<close>, Prog_Expr.eval_equal "#equal_")):calc*)
   330 fun eval_equal (thmid : string) \<^const_name>\<open>HOL.eq\<close> (t as (Const _(*op0,t0*) $ t1 $ t2 )) thy = 
   331   if t1 = t2
   332   then
   333     SOME (TermC.mk_thmid thmid
   334       ("(" ^ UnparseC.term_in_thy thy t1 ^ ")") ("(" ^ UnparseC.term_in_thy thy t2 ^ ")"), 
   335       HOLogic.Trueprop $ (TermC.mk_equality (t, @{term True})))
   336   else
   337     (case (TermC.is_atom t1, TermC.is_atom t2) of
   338       (true, true) =>
   339         if TermC.variable_constant_pair (t1, t2)
   340         then NONE
   341         else SOME (TermC.mk_thmid thmid
   342           ("(" ^ UnparseC.term_in_thy thy t1 ^ ")") ("(" ^ UnparseC.term_in_thy thy t2 ^ ")"),
   343           HOLogic.Trueprop $ (TermC.mk_equality (t, @{term False})))
   344     | _ => NONE)                                              (* NOT is_atom t1,t2 --> rew_sub *)
   345   | eval_equal _ _ _ _ = NONE;                                                   (* error-exit *)
   346 
   347 (*. evaluate HOL.divide .*)
   348 (*("DIVIDE" ,("Rings.divide_class.divide"  , eval_cancel "#divide_e"))*)
   349 fun eval_cancel thmid "Rings.divide_class.divide" (t as (Const _ $ t1 $ t2)) _ = 
   350     if TermC.is_num t1 andalso TermC.is_num t2 then
   351       let
   352         val (T, _) = HOLogic.dest_number t1;
   353         val (i1, i2) = (Eval.int_of_numeral t1, Eval.int_of_numeral t2);
   354         val res_int as (d, (i1', i2')) = Eval.cancel_int (i1, i2);
   355       in
   356         if abs d = 1 andalso (abs i1, abs i2) = (abs i1', abs i2') then NONE
   357         else
   358           let
   359             val res = TermC.mk_frac T res_int;
   360             val prop = HOLogic.Trueprop $ (HOLogic.mk_eq (t, res));
   361           in SOME (TermC.mk_thmid thmid (string_of_int i1) (string_of_int i2), prop) end
   362       end
   363     else NONE
   364   | eval_cancel _ _ _ _ = NONE;
   365 
   366 (* get the argument from a function-definition *)
   367 (*("argument_in" ,("Prog_Expr.argument_in", Prog_Expr.eval_argument_in "Prog_Expr.argument_in"))*)
   368 fun eval_argument_in _ "Prog_Expr.argument_in" 
   369 		 (t as (Const ("Prog_Expr.argument_in", _) $ (_(*f*) $ arg))) _ =
   370     if TermC.is_atom arg (*could be something to be simplified before*)
   371     then
   372       SOME (UnparseC.term t ^ " = " ^ UnparseC.term arg,
   373 	      HOLogic.Trueprop $ (TermC.mk_equality (t, arg)))
   374     else NONE
   375   | eval_argument_in _ _ _ _ = NONE;
   376 
   377 (* check if the function-identifier of the first argument matches 
   378    the function-identifier of the lhs of the second argument *)
   379 (*("sameFunId" ,("Prog_Expr.sameFunId", eval_same_funid "Prog_Expr.sameFunId"))*)
   380 fun eval_sameFunId _ "Prog_Expr.sameFunId" 
   381 		     (p as Const ("Prog_Expr.sameFunId",_) $  (f1 $ _) $ (Const (\<^const_name>\<open>HOL.eq\<close>, _) $ (f2 $ _) $ _)) _ =
   382     if f1 = f2 
   383     then SOME ((UnparseC.term p) ^ " = True",
   384 	       HOLogic.Trueprop $ (TermC.mk_equality (p, @{term True})))
   385     else SOME ((UnparseC.term p) ^ " = False",
   386 	       HOLogic.Trueprop $ (TermC.mk_equality (p, @{term False})))
   387 | eval_sameFunId _ _ _ _ = NONE;
   388 
   389 
   390 (*.from a list of fun-definitions "f x = ..." as 2nd argument
   391    filter the elements with the same fun-identfier in "f y"
   392    as the fst argument;
   393    this is, because Isabelles filter takes more than 1 sec.*)
   394 fun same_funid f1 (Const (\<^const_name>\<open>HOL.eq\<close>, _) $ (f2 $ _) $ _) = f1 = f2
   395   | same_funid f1 t = raise ERROR ("same_funid called with t = ("
   396 		  ^ UnparseC.term f1 ^ ") (" ^ UnparseC.term t ^ ")");
   397 (*("filter_sameFunId" ,("Prog_Expr.filter_sameFunId",
   398 		   eval_filter_sameFunId "Prog_Expr.filter_sameFunId"))*)
   399 fun eval_filter_sameFunId _ "Prog_Expr.filter_sameFunId" 
   400 		     (p as Const ("Prog_Expr.filter_sameFunId",_) $ 
   401 			(fid $ _) $ fs) _ =
   402     let val fs' = ((TermC.list2isalist HOLogic.boolT) o 
   403 		   (filter (same_funid fid))) (TermC.isalist2list fs)
   404     in SOME (UnparseC.term (TermC.mk_equality (p, fs')),
   405 	       HOLogic.Trueprop $ (TermC.mk_equality (p, fs'))) end
   406 | eval_filter_sameFunId _ _ _ _ = NONE;
   407 
   408 (* make a list of terms to a sum *)
   409 fun list2sum [] = raise ERROR ("list2sum called with []")
   410   | list2sum [s] = s
   411   | list2sum (s::ss) = 
   412     let
   413       fun sum su [s'] = Const (\<^const_name>\<open>plus\<close>,
   414            [HOLogic.realT,HOLogic.realT] ---> HOLogic.realT) $ su $ s'
   415     	  | sum su (s'::ss') = sum (Const (\<^const_name>\<open>plus\<close>,
   416            [HOLogic.realT,HOLogic.realT] ---> HOLogic.realT) $ su $ s') ss'
   417     	  | sum _ _ = raise ERROR "list2sum: pattern in fun.def is missing" 
   418     in sum s ss end;
   419 
   420 (* make a list of equalities to the sum of the lhs *)
   421 (*("boollist2sum"    ,("Prog_Expr.boollist2sum"    , eval_boollist2sum "")):calc*)
   422 fun eval_boollist2sum _ "Prog_Expr.boollist2sum" 
   423 		  (p as Const ("Prog_Expr.boollist2sum", _) $ (l as Const (\<^const_name>\<open>Cons\<close>, _) $ _ $ _)) _ =
   424     let
   425       val isal = TermC.isalist2list l
   426 	    val lhss = map TermC.lhs isal
   427 	    val sum = list2sum lhss
   428     in
   429       SOME ((UnparseC.term p) ^ " = " ^ (UnparseC.term sum),
   430 	      HOLogic.Trueprop $ (TermC.mk_equality (p, sum)))
   431     end
   432   | eval_boollist2sum _ _ _ _ = NONE;
   433 
   434 (**) end (*struct*)
   435 \<close> text \<open>
   436 open Prog_Expr
   437 \<close> ML \<open>
   438 \<close> ML \<open>
   439 \<close>
   440 
   441 subsection \<open>extend rule-set for evaluating pre-conditions and program-expressions\<close>
   442 ML \<open>
   443 val prog_expr = Rule_Set.append_rules "prog_expr" prog_expr [\<^rule_eval>\<open>Prog_Expr.rhs\<close> (Prog_Expr.eval_rhs "")];
   444 \<close> ML \<open>
   445 \<close> ML \<open>
   446 \<close>
   447 
   448 subsection \<open>setup for rule-sets and ML-functions\<close>
   449 
   450 rule_set_knowledge prog_expr = prog_expr
   451 
   452 calculation lhs = \<open>Prog_Expr.eval_lhs ""\<close>
   453 calculation rhs = \<open>Prog_Expr.eval_rhs ""\<close>
   454 calculation Vars = \<open>Prog_Expr.eval_var "#Vars_"\<close>
   455 calculation matches = \<open>Prog_Expr.eval_matches "#matches_"\<close>
   456 calculation matchsub = \<open>Prog_Expr.eval_matchsub "#matchsub_"\<close>
   457 
   458 calculation some_occur_in = \<open>Prog_Expr.eval_some_occur_in "#some_occur_in_"\<close>
   459 calculation occurs_in = \<open>Prog_Expr.eval_occurs_in "#occurs_in_"\<close>
   460 calculation is_atom = \<open>Prog_Expr.eval_is_atom "#is_atom_"\<close>
   461 calculation is_num = \<open>Prog_Expr.eval_is_num "#is_num_"\<close>
   462 calculation is_even = \<open>Prog_Expr.eval_is_even "#is_even_"\<close>
   463 ML \<open>
   464 \<close> ML \<open>
   465 \<close> ML \<open>
   466 \<close>
   467 
   468 end