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