src/HOL/Tools/Predicate_Compile/predicate_compile_core.ML
author haftmann
Sat, 28 Dec 2013 21:06:24 +0100
changeset 54872 af81b2357e08
parent 53380 08f3491c50bf
child 55399 5c8e91f884af
child 55437 3fd63b92ea3b
permissions -rw-r--r--
postpone dis"useful" lemmas
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
33265
01c9c6dbd890 proper headers;
wenzelm
parents: 33256
diff changeset
     1
(*  Title:      HOL/Tools/Predicate_Compile/predicate_compile_core.ML
01c9c6dbd890 proper headers;
wenzelm
parents: 33256
diff changeset
     2
    Author:     Lukas Bulwahn, TU Muenchen
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
     3
33265
01c9c6dbd890 proper headers;
wenzelm
parents: 33256
diff changeset
     4
A compiler from predicates specified by intro/elim rules to equations.
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
     5
*)
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
     6
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
     7
signature PREDICATE_COMPILE_CORE =
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
     8
sig
50057
57209cfbf16b prefer explicit Random.seed
haftmann
parents: 50056
diff changeset
     9
  type seed = Random_Engine.seed
36048
1d2faa488166 clarifying the Predicate_Compile_Core signature
bulwahn
parents: 36046
diff changeset
    10
  type mode = Predicate_Compile_Aux.mode
1d2faa488166 clarifying the Predicate_Compile_Core signature
bulwahn
parents: 36046
diff changeset
    11
  type options = Predicate_Compile_Aux.options
1d2faa488166 clarifying the Predicate_Compile_Core signature
bulwahn
parents: 36046
diff changeset
    12
  type compilation = Predicate_Compile_Aux.compilation
1d2faa488166 clarifying the Predicate_Compile_Core signature
bulwahn
parents: 36046
diff changeset
    13
  type compilation_funs = Predicate_Compile_Aux.compilation_funs
1d2faa488166 clarifying the Predicate_Compile_Core signature
bulwahn
parents: 36046
diff changeset
    14
  
33478
b70fe083694d moved values command from core to predicate compile
bulwahn
parents: 33476
diff changeset
    15
  val setup : theory -> theory
36048
1d2faa488166 clarifying the Predicate_Compile_Core signature
bulwahn
parents: 36046
diff changeset
    16
  val code_pred : options -> string -> Proof.context -> Proof.state
1d2faa488166 clarifying the Predicate_Compile_Core signature
bulwahn
parents: 36046
diff changeset
    17
  val code_pred_cmd : options -> string -> Proof.context -> Proof.state
1d2faa488166 clarifying the Predicate_Compile_Core signature
bulwahn
parents: 36046
diff changeset
    18
  val values_cmd : string list -> mode option list option
1d2faa488166 clarifying the Predicate_Compile_Core signature
bulwahn
parents: 36046
diff changeset
    19
    -> ((string option * bool) * (compilation * int list)) -> int -> string -> Toplevel.state -> unit
40053
3fa49ea76cbb using a signature in core_data and moving some more functions to core_data
bulwahn
parents: 40052
diff changeset
    20
42141
2c255ba8f299 changing values_timeout from a static option to a dynamic option as required for testing with SML/NJ
bulwahn
parents: 42094
diff changeset
    21
  val values_timeout : real Config.T
2c255ba8f299 changing values_timeout from a static option to a dynamic option as required for testing with SML/NJ
bulwahn
parents: 42094
diff changeset
    22
  
37007
116670499530 changing operations for accessing data to work with contexts
bulwahn
parents: 37006
diff changeset
    23
  val print_stored_rules : Proof.context -> unit
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
    24
  val print_all_modes : compilation -> Proof.context -> unit
39388
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
    25
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
    26
  val put_pred_result : (unit -> term Predicate.pred) -> Proof.context -> Proof.context
50057
57209cfbf16b prefer explicit Random.seed
haftmann
parents: 50056
diff changeset
    27
  val put_pred_random_result : (unit -> seed -> term Predicate.pred * seed) ->
39388
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
    28
    Proof.context -> Proof.context
51126
df86080de4cb reform of predicate compiler / quickcheck theories:
haftmann
parents: 50057
diff changeset
    29
  val put_dseq_result : (unit -> term Limited_Sequence.dseq) -> Proof.context -> Proof.context
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
    30
  val put_dseq_random_result : (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> term Limited_Sequence.dseq * seed) ->
39388
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
    31
    Proof.context -> Proof.context
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
    32
  val put_new_dseq_result : (unit -> Code_Numeral.natural -> term Lazy_Sequence.lazy_sequence) ->
40102
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
    33
    Proof.context -> Proof.context
39388
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
    34
  val put_lseq_random_result :
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
    35
    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> Code_Numeral.natural -> term Lazy_Sequence.lazy_sequence) ->
39388
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
    36
    Proof.context -> Proof.context
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
    37
  val put_lseq_random_stats_result :
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
    38
    (unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> Code_Numeral.natural -> (term * Code_Numeral.natural) Lazy_Sequence.lazy_sequence) ->
39388
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
    39
    Proof.context -> Proof.context
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
    40
33628
ed2111a5c3ed renaming code_pred_intros to code_pred_intro
bulwahn
parents: 33626
diff changeset
    41
  val code_pred_intro_attrib : attribute
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
    42
  (* used by Quickcheck_Generator *) 
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
    43
  (* temporary for testing of the compilation *)
36048
1d2faa488166 clarifying the Predicate_Compile_Core signature
bulwahn
parents: 36046
diff changeset
    44
  val add_equations : options -> string list -> theory -> theory
1d2faa488166 clarifying the Predicate_Compile_Core signature
bulwahn
parents: 36046
diff changeset
    45
  val add_depth_limited_random_equations : options -> string list -> theory -> theory
1d2faa488166 clarifying the Predicate_Compile_Core signature
bulwahn
parents: 36046
diff changeset
    46
  val add_random_dseq_equations : options -> string list -> theory -> theory
1d2faa488166 clarifying the Predicate_Compile_Core signature
bulwahn
parents: 36046
diff changeset
    47
  val add_new_random_dseq_equations : options -> string list -> theory -> theory
40103
ef73a90ab6e6 adding generator quickcheck
bulwahn
parents: 40102
diff changeset
    48
  val add_generator_dseq_equations : options -> string list -> theory -> theory
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
    49
  val add_generator_cps_equations : options -> string list -> theory -> theory
33473
3b275a0bf18c adding tracing function for evaluated code; annotated compilation in the predicate compiler
bulwahn
parents: 33377
diff changeset
    50
  val mk_tracing : string -> term -> term
39310
17ef4415b17c removing obsolete argument in prepare_intrs; passing context instead of theory in prepare_intrs
bulwahn
parents: 39299
diff changeset
    51
  val prepare_intrs : options -> Proof.context -> string list -> thm list ->
38957
2eb265efa1b0 exporting mode analysis for use in prolog generation
bulwahn
parents: 38864
diff changeset
    52
    ((string * typ) list * string list * string list * (string * mode list) list *
2eb265efa1b0 exporting mode analysis for use in prolog generation
bulwahn
parents: 38864
diff changeset
    53
      (string *  (Term.term list * Predicate_Compile_Aux.indprem list) list) list)
39761
c2a76ec6e2d9 renaming use_random to use_generators in the predicate compiler
bulwahn
parents: 39760
diff changeset
    54
  type mode_analysis_options =
c2a76ec6e2d9 renaming use_random to use_generators in the predicate compiler
bulwahn
parents: 39760
diff changeset
    55
   {use_generators : bool,
c2a76ec6e2d9 renaming use_random to use_generators in the predicate compiler
bulwahn
parents: 39760
diff changeset
    56
    reorder_premises : bool,
c2a76ec6e2d9 renaming use_random to use_generators in the predicate compiler
bulwahn
parents: 39760
diff changeset
    57
    infer_pos_and_neg_modes : bool}  
38957
2eb265efa1b0 exporting mode analysis for use in prolog generation
bulwahn
parents: 38864
diff changeset
    58
  datatype mode_derivation = Mode_App of mode_derivation * mode_derivation | Context of mode
39310
17ef4415b17c removing obsolete argument in prepare_intrs; passing context instead of theory in prepare_intrs
bulwahn
parents: 39299
diff changeset
    59
    | Mode_Pair of mode_derivation * mode_derivation | Term of mode
39461
0ed0f015d140 adding mode inference to prolog compilation; separate between (ad-hoc) code modifications and system_configuration; adapting quickcheck
bulwahn
parents: 39403
diff changeset
    60
  val head_mode_of : mode_derivation -> mode
38957
2eb265efa1b0 exporting mode analysis for use in prolog generation
bulwahn
parents: 38864
diff changeset
    61
  type moded_clause = term list * (Predicate_Compile_Aux.indprem * mode_derivation) list
2eb265efa1b0 exporting mode analysis for use in prolog generation
bulwahn
parents: 38864
diff changeset
    62
  type 'a pred_mode_table = (string * ((bool * mode) * 'a) list) list
2eb265efa1b0 exporting mode analysis for use in prolog generation
bulwahn
parents: 38864
diff changeset
    63
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
    64
end;
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
    65
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
    66
structure Predicate_Compile_Core : PREDICATE_COMPILE_CORE =
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
    67
struct
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
    68
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
    69
type random_seed = Random_Engine.seed
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
    70
32668
b2de45007537 added first prototype of the extended predicate compiler
bulwahn
parents: 32667
diff changeset
    71
open Predicate_Compile_Aux;
40052
ea46574ca815 splitting large core file into core_data, mode_inference and predicate_compile_proof
bulwahn
parents: 40051
diff changeset
    72
open Core_Data;
ea46574ca815 splitting large core file into core_data, mode_inference and predicate_compile_proof
bulwahn
parents: 40051
diff changeset
    73
open Mode_Inference;
ea46574ca815 splitting large core file into core_data, mode_inference and predicate_compile_proof
bulwahn
parents: 40051
diff changeset
    74
open Predicate_Compile_Proof;
33108
9d9afd478016 added test for higher-order function inductification; added debug messages
bulwahn
parents: 33106
diff changeset
    75
50057
57209cfbf16b prefer explicit Random.seed
haftmann
parents: 50056
diff changeset
    76
type seed = Random_Engine.seed;
57209cfbf16b prefer explicit Random.seed
haftmann
parents: 50056
diff changeset
    77
57209cfbf16b prefer explicit Random.seed
haftmann
parents: 50056
diff changeset
    78
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
    79
(** fundamentals **)
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
    80
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
    81
(* syntactic operations *)
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
    82
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
    83
fun mk_eq (x, xs) =
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
    84
  let fun mk_eqs _ [] = []
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
    85
        | mk_eqs a (b::cs) =
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
    86
            HOLogic.mk_eq (Free (a, fastype_of b), b) :: mk_eqs a cs
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
    87
  in mk_eqs x xs end;
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
    88
33473
3b275a0bf18c adding tracing function for evaluated code; annotated compilation in the predicate compiler
bulwahn
parents: 33377
diff changeset
    89
fun mk_tracing s t =
3b275a0bf18c adding tracing function for evaluated code; annotated compilation in the predicate compiler
bulwahn
parents: 33377
diff changeset
    90
  Const(@{const_name Code_Evaluation.tracing},
3b275a0bf18c adding tracing function for evaluated code; annotated compilation in the predicate compiler
bulwahn
parents: 33377
diff changeset
    91
    @{typ String.literal} --> (fastype_of t) --> (fastype_of t)) $ (HOLogic.mk_literal s) $ t
3b275a0bf18c adding tracing function for evaluated code; annotated compilation in the predicate compiler
bulwahn
parents: 33377
diff changeset
    92
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
    93
(* representation of inferred clauses with modes *)
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
    94
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
    95
type moded_clause = term list * (indprem * mode_derivation) list
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
    96
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
    97
type 'a pred_mode_table = (string * ((bool * mode) * 'a) list) list
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
    98
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
    99
(* diagnostic display functions *)
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   100
37004
c62f743e37d4 removing unused argument in print_modes function
bulwahn
parents: 37003
diff changeset
   101
fun print_modes options modes =
33251
4b13ab778b78 added option show_modes to predicate compiler
bulwahn
parents: 33250
diff changeset
   102
  if show_modes options then
33326
7d0288d90535 improved handling of alternative rules; added test cases for alternative rules; normalized tracing in the predicate compiler
bulwahn
parents: 33268
diff changeset
   103
    tracing ("Inferred modes:\n" ^
33251
4b13ab778b78 added option show_modes to predicate compiler
bulwahn
parents: 33250
diff changeset
   104
      cat_lines (map (fn (s, ms) => s ^ ": " ^ commas (map
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
   105
        (fn (p, m) => string_of_mode m ^ (if p then "pos" else "neg")) ms)) modes))
33251
4b13ab778b78 added option show_modes to predicate compiler
bulwahn
parents: 33250
diff changeset
   106
  else ()
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   107
37004
c62f743e37d4 removing unused argument in print_modes function
bulwahn
parents: 37003
diff changeset
   108
fun print_pred_mode_table string_of_entry pred_mode_table =
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   109
  let
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   110
    fun print_mode pred ((_, mode), entry) =  "mode : " ^ string_of_mode mode
33619
d93a3cb55068 first steps towards a new mode datastructure; new syntax for mode annotations and new output of modes
bulwahn
parents: 33526
diff changeset
   111
      ^ string_of_entry pred mode entry
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   112
    fun print_pred (pred, modes) =
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   113
      "predicate " ^ pred ^ ": " ^ cat_lines (map (print_mode pred) modes)
33326
7d0288d90535 improved handling of alternative rules; added test cases for alternative rules; normalized tracing in the predicate compiler
bulwahn
parents: 33268
diff changeset
   114
    val _ = tracing (cat_lines (map print_pred pred_mode_table))
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   115
  in () end;
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   116
37005
842a73dc6d0e changing compilation to work only with contexts; adapting quickcheck
bulwahn
parents: 37004
diff changeset
   117
fun print_compiled_terms options ctxt =
33139
9c01ee6f8ee9 added skip_proof option; playing with compilation of depth-limited predicates
bulwahn
parents: 33138
diff changeset
   118
  if show_compilation options then
37005
842a73dc6d0e changing compilation to work only with contexts; adapting quickcheck
bulwahn
parents: 37004
diff changeset
   119
    print_pred_mode_table (fn _ => fn _ => Syntax.string_of_term ctxt)
33139
9c01ee6f8ee9 added skip_proof option; playing with compilation of depth-limited predicates
bulwahn
parents: 33138
diff changeset
   120
  else K ()
9c01ee6f8ee9 added skip_proof option; playing with compilation of depth-limited predicates
bulwahn
parents: 33138
diff changeset
   121
37007
116670499530 changing operations for accessing data to work with contexts
bulwahn
parents: 37006
diff changeset
   122
fun print_stored_rules ctxt =
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   123
  let
42361
23f352990944 modernized structure Proof_Context;
wenzelm
parents: 42141
diff changeset
   124
    val preds = Graph.keys (PredData.get (Proof_Context.theory_of ctxt))
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   125
    fun print pred () = let
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   126
      val _ = writeln ("predicate: " ^ pred)
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   127
      val _ = writeln ("introrules: ")
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   128
      val _ = fold (fn thm => fn _ => writeln (Display.string_of_thm ctxt thm))
37007
116670499530 changing operations for accessing data to work with contexts
bulwahn
parents: 37006
diff changeset
   129
        (rev (intros_of ctxt pred)) ()
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   130
    in
37007
116670499530 changing operations for accessing data to work with contexts
bulwahn
parents: 37006
diff changeset
   131
      if (has_elim ctxt pred) then
116670499530 changing operations for accessing data to work with contexts
bulwahn
parents: 37006
diff changeset
   132
        writeln ("elimrule: " ^ Display.string_of_thm ctxt (the_elim_of ctxt pred))
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   133
      else
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   134
        writeln ("no elimrule defined")
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   135
    end
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   136
  in
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   137
    fold print preds ()
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   138
  end;
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   139
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
   140
fun print_all_modes compilation ctxt =
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   141
  let
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   142
    val _ = writeln ("Inferred modes:")
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   143
    fun print (pred, modes) u =
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   144
      let
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   145
        val _ = writeln ("predicate: " ^ pred)
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   146
        val _ = writeln ("modes: " ^ (commas (map string_of_mode modes)))
33619
d93a3cb55068 first steps towards a new mode datastructure; new syntax for mode annotations and new output of modes
bulwahn
parents: 33526
diff changeset
   147
      in u end
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   148
  in
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
   149
    fold print (all_modes_of compilation ctxt) ()
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   150
  end
33129
3085da75ed54 changed import_intros to handle parameters differently; changed handling of higher-order function compilation; reverted MicroJava change; tuned
bulwahn
parents: 33128
diff changeset
   151
33132
07efd452a698 moved argument expected_modes into options; improved mode check to only check mode of the named predicate
bulwahn
parents: 33131
diff changeset
   152
(* validity checks *)
07efd452a698 moved argument expected_modes into options; improved mode check to only check mode of the named predicate
bulwahn
parents: 33131
diff changeset
   153
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   154
fun check_expected_modes options _ modes =
33752
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   155
  case expected_modes options of
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   156
    SOME (s, ms) => (case AList.lookup (op =) modes s of
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   157
      SOME modes =>
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   158
        let
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
   159
          val modes' = map snd modes
33752
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   160
        in
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   161
          if not (eq_set eq_mode (ms, modes')) then
33752
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   162
            error ("expected modes were not inferred:\n"
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   163
            ^ "  inferred modes for " ^ s ^ ": " ^ commas (map string_of_mode modes')  ^ "\n"
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   164
            ^ "  expected modes for " ^ s ^ ": " ^ commas (map string_of_mode ms))
33752
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   165
          else ()
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   166
        end
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   167
      | NONE => ())
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   168
  | NONE => ()
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   169
40138
432a776c4aee options as first argument to check functions
bulwahn
parents: 40135
diff changeset
   170
fun check_proposed_modes options preds modes errors =
39382
c797f3ab2ae1 proposed modes for code_pred now supports modes for mutual predicates
bulwahn
parents: 39310
diff changeset
   171
  map (fn (s, _) => case proposed_modes options s of
c797f3ab2ae1 proposed modes for code_pred now supports modes for mutual predicates
bulwahn
parents: 39310
diff changeset
   172
    SOME ms => (case AList.lookup (op =) modes s of
33752
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   173
      SOME inferred_ms =>
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   174
        let
39201
234e6ef4ff67 using the proposed modes for starting the fixpoint iteration in the mode analysis
bulwahn
parents: 39194
diff changeset
   175
          val preds_without_modes = map fst (filter (null o snd) modes)
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
   176
          val modes' = map snd inferred_ms
33752
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   177
        in
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   178
          if not (eq_set eq_mode (ms, modes')) then
33752
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   179
            error ("expected modes were not inferred:\n"
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   180
            ^ "  inferred modes for " ^ s ^ ": " ^ commas (map string_of_mode modes')  ^ "\n"
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   181
            ^ "  expected modes for " ^ s ^ ": " ^ commas (map string_of_mode ms) ^ "\n"
39383
ddfafa97da2f adding option show_invalid_clauses for a more detailed message when modes are not inferred
bulwahn
parents: 39382
diff changeset
   182
            ^ (if show_invalid_clauses options then
ddfafa97da2f adding option show_invalid_clauses for a more detailed message when modes are not inferred
bulwahn
parents: 39382
diff changeset
   183
            ("For the following clauses, the following modes could not be inferred: " ^ "\n"
ddfafa97da2f adding option show_invalid_clauses for a more detailed message when modes are not inferred
bulwahn
parents: 39382
diff changeset
   184
            ^ cat_lines errors) else "") ^
33752
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   185
            (if not (null preds_without_modes) then
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   186
              "\n" ^ "No mode inferred for the predicates " ^ commas preds_without_modes
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   187
            else ""))
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   188
          else ()
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   189
        end
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
   190
      | NONE => ())
39382
c797f3ab2ae1 proposed modes for code_pred now supports modes for mutual predicates
bulwahn
parents: 39310
diff changeset
   191
  | NONE => ()) preds
33132
07efd452a698 moved argument expected_modes into options; improved mode check to only check mode of the named predicate
bulwahn
parents: 33131
diff changeset
   192
39651
2e06dad03dd3 adding check if user-given modes match type of predicates; removed useless function expand_tuples_elim
bulwahn
parents: 39649
diff changeset
   193
fun check_matches_type ctxt predname T ms =
2e06dad03dd3 adding check if user-given modes match type of predicates; removed useless function expand_tuples_elim
bulwahn
parents: 39649
diff changeset
   194
  let
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   195
    fun check (Fun (m1, m2)) (Type("fun", [T1,T2])) = check m1 T1 andalso check m2 T2
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   196
      | check m (Type("fun", _)) = (m = Input orelse m = Output)
39651
2e06dad03dd3 adding check if user-given modes match type of predicates; removed useless function expand_tuples_elim
bulwahn
parents: 39649
diff changeset
   197
      | check (Pair (m1, m2)) (Type (@{type_name Product_Type.prod}, [T1, T2])) =
2e06dad03dd3 adding check if user-given modes match type of predicates; removed useless function expand_tuples_elim
bulwahn
parents: 39649
diff changeset
   198
          check m1 T1 andalso check m2 T2 
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   199
      | check Input _ = true
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   200
      | check Output _ = true
39651
2e06dad03dd3 adding check if user-given modes match type of predicates; removed useless function expand_tuples_elim
bulwahn
parents: 39649
diff changeset
   201
      | check Bool @{typ bool} = true
2e06dad03dd3 adding check if user-given modes match type of predicates; removed useless function expand_tuples_elim
bulwahn
parents: 39649
diff changeset
   202
      | check _ _ = false
39763
03f95582ef63 weakening check for higher-order relations, but adding check for consistent modes
bulwahn
parents: 39762
diff changeset
   203
    fun check_consistent_modes ms =
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   204
      if forall (fn Fun _ => true | _ => false) ms then
39763
03f95582ef63 weakening check for higher-order relations, but adding check for consistent modes
bulwahn
parents: 39762
diff changeset
   205
        pairself check_consistent_modes (split_list (map (fn Fun (m1, m2) => (m1, m2)) ms))
03f95582ef63 weakening check for higher-order relations, but adding check for consistent modes
bulwahn
parents: 39762
diff changeset
   206
        |> (fn (res1, res2) => res1 andalso res2) 
03f95582ef63 weakening check for higher-order relations, but adding check for consistent modes
bulwahn
parents: 39762
diff changeset
   207
      else if forall (fn Input => true | Output => true | Pair _ => true | _ => false) ms then
03f95582ef63 weakening check for higher-order relations, but adding check for consistent modes
bulwahn
parents: 39762
diff changeset
   208
        true
03f95582ef63 weakening check for higher-order relations, but adding check for consistent modes
bulwahn
parents: 39762
diff changeset
   209
      else if forall (fn Bool => true | _ => false) ms then
03f95582ef63 weakening check for higher-order relations, but adding check for consistent modes
bulwahn
parents: 39762
diff changeset
   210
        true
03f95582ef63 weakening check for higher-order relations, but adding check for consistent modes
bulwahn
parents: 39762
diff changeset
   211
      else
03f95582ef63 weakening check for higher-order relations, but adding check for consistent modes
bulwahn
parents: 39762
diff changeset
   212
        false
39651
2e06dad03dd3 adding check if user-given modes match type of predicates; removed useless function expand_tuples_elim
bulwahn
parents: 39649
diff changeset
   213
    val _ = map
2e06dad03dd3 adding check if user-given modes match type of predicates; removed useless function expand_tuples_elim
bulwahn
parents: 39649
diff changeset
   214
      (fn mode =>
39763
03f95582ef63 weakening check for higher-order relations, but adding check for consistent modes
bulwahn
parents: 39762
diff changeset
   215
        if length (strip_fun_mode mode) = length (binder_types T)
03f95582ef63 weakening check for higher-order relations, but adding check for consistent modes
bulwahn
parents: 39762
diff changeset
   216
          andalso (forall (uncurry check) (strip_fun_mode mode ~~ binder_types T)) then ()
39651
2e06dad03dd3 adding check if user-given modes match type of predicates; removed useless function expand_tuples_elim
bulwahn
parents: 39649
diff changeset
   217
        else error (string_of_mode mode ^ " is not a valid mode for " ^ Syntax.string_of_typ ctxt T
2e06dad03dd3 adding check if user-given modes match type of predicates; removed useless function expand_tuples_elim
bulwahn
parents: 39649
diff changeset
   218
        ^ " at predicate " ^ predname)) ms
39763
03f95582ef63 weakening check for higher-order relations, but adding check for consistent modes
bulwahn
parents: 39762
diff changeset
   219
    val _ =
03f95582ef63 weakening check for higher-order relations, but adding check for consistent modes
bulwahn
parents: 39762
diff changeset
   220
     if check_consistent_modes ms then ()
03f95582ef63 weakening check for higher-order relations, but adding check for consistent modes
bulwahn
parents: 39762
diff changeset
   221
     else error (commas (map string_of_mode ms) ^
03f95582ef63 weakening check for higher-order relations, but adding check for consistent modes
bulwahn
parents: 39762
diff changeset
   222
       " are inconsistent modes for predicate " ^ predname)
39651
2e06dad03dd3 adding check if user-given modes match type of predicates; removed useless function expand_tuples_elim
bulwahn
parents: 39649
diff changeset
   223
  in
2e06dad03dd3 adding check if user-given modes match type of predicates; removed useless function expand_tuples_elim
bulwahn
parents: 39649
diff changeset
   224
    ms
2e06dad03dd3 adding check if user-given modes match type of predicates; removed useless function expand_tuples_elim
bulwahn
parents: 39649
diff changeset
   225
  end
2e06dad03dd3 adding check if user-given modes match type of predicates; removed useless function expand_tuples_elim
bulwahn
parents: 39649
diff changeset
   226
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   227
(* compilation modifiers *)
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   228
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   229
structure Comp_Mod =
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   230
struct
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   231
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   232
datatype comp_modifiers = Comp_Modifiers of
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   233
{
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   234
  compilation : compilation,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   235
  function_name_prefix : string,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   236
  compfuns : compilation_funs,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   237
  mk_random : typ -> term list -> term,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   238
  modify_funT : typ -> typ,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   239
  additional_arguments : string list -> term list,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   240
  wrap_compilation : compilation_funs -> string -> typ -> mode -> term list -> term -> term,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   241
  transform_additional_arguments : indprem -> term list -> term list
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   242
}
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   243
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   244
fun dest_comp_modifiers (Comp_Modifiers c) = c
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   245
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   246
val compilation = #compilation o dest_comp_modifiers
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   247
val function_name_prefix = #function_name_prefix o dest_comp_modifiers
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   248
val compfuns = #compfuns o dest_comp_modifiers
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   249
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   250
val mk_random = #mk_random o dest_comp_modifiers
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   251
val funT_of' = funT_of o compfuns
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   252
val modify_funT = #modify_funT o dest_comp_modifiers
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   253
fun funT_of comp mode = modify_funT comp o funT_of' comp mode
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   254
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   255
val additional_arguments = #additional_arguments o dest_comp_modifiers
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   256
val wrap_compilation = #wrap_compilation o dest_comp_modifiers
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   257
val transform_additional_arguments = #transform_additional_arguments o dest_comp_modifiers
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   258
40049
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   259
fun set_compfuns compfuns' (Comp_Modifiers {compilation, function_name_prefix, compfuns, mk_random,
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   260
    modify_funT, additional_arguments, wrap_compilation, transform_additional_arguments}) =
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   261
    (Comp_Modifiers {compilation = compilation, function_name_prefix = function_name_prefix,
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   262
    compfuns = compfuns', mk_random = mk_random, modify_funT = modify_funT,
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   263
    additional_arguments = additional_arguments, wrap_compilation = wrap_compilation,
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   264
    transform_additional_arguments = transform_additional_arguments})
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   265
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   266
end;
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   267
40051
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   268
fun unlimited_compfuns_of true New_Pos_Random_DSeq =
40049
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   269
    New_Pos_Random_Sequence_CompFuns.depth_unlimited_compfuns
40051
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   270
  | unlimited_compfuns_of false New_Pos_Random_DSeq =
40049
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   271
    New_Neg_Random_Sequence_CompFuns.depth_unlimited_compfuns
40051
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   272
  | unlimited_compfuns_of true Pos_Generator_DSeq =
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   273
    New_Pos_DSequence_CompFuns.depth_unlimited_compfuns
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   274
  | unlimited_compfuns_of false Pos_Generator_DSeq =
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   275
    New_Neg_DSequence_CompFuns.depth_unlimited_compfuns
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   276
  | unlimited_compfuns_of _ c =
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   277
    raise Fail ("No unlimited compfuns for compilation " ^ string_of_compilation c)
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   278
40049
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   279
fun limited_compfuns_of true Predicate_Compile_Aux.New_Pos_Random_DSeq =
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   280
    New_Pos_Random_Sequence_CompFuns.depth_limited_compfuns
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   281
  | limited_compfuns_of false Predicate_Compile_Aux.New_Pos_Random_DSeq =
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   282
    New_Neg_Random_Sequence_CompFuns.depth_limited_compfuns
40051
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   283
  | limited_compfuns_of true Pos_Generator_DSeq =
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   284
    New_Pos_DSequence_CompFuns.depth_limited_compfuns
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   285
  | limited_compfuns_of false Pos_Generator_DSeq =
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   286
    New_Neg_DSequence_CompFuns.depth_limited_compfuns
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   287
  | limited_compfuns_of _ c =
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   288
    raise Fail ("No limited compfuns for compilation " ^ string_of_compilation c)
40049
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   289
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   290
val depth_limited_comp_modifiers = Comp_Mod.Comp_Modifiers
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   291
  {
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   292
  compilation = Depth_Limited,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   293
  function_name_prefix = "depth_limited_",
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   294
  compfuns = Predicate_Comp_Funs.compfuns,
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   295
  mk_random = (fn _ => error "no random generation"),
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   296
  additional_arguments = fn names =>
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   297
    let
43324
2b47822868e4 discontinued Name.variant to emphasize that this is old-style / indirect;
wenzelm
parents: 43253
diff changeset
   298
      val depth_name = singleton (Name.variant_list names) "depth"
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   299
    in [Free (depth_name, @{typ natural})] end,
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   300
  modify_funT = (fn T => let val (Ts, U) = strip_type T
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   301
  val Ts' = [@{typ natural}] in (Ts @ Ts') ---> U end),
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   302
  wrap_compilation =
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   303
    fn compfuns => fn s => fn T => fn mode => fn additional_arguments => fn compilation =>
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   304
    let
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   305
      val [depth] = additional_arguments
40139
6a53d57fa902 renaming split_modeT' to split_modeT
bulwahn
parents: 40138
diff changeset
   306
      val (_, Ts) = split_modeT mode (binder_types T)
45461
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
   307
      val T' = mk_monadT compfuns (HOLogic.mk_tupleT Ts)
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   308
      val if_const = Const (@{const_name "If"}, @{typ bool} --> T' --> T' --> T')
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   309
    in
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   310
      if_const $ HOLogic.mk_eq (depth, @{term "0 :: natural"})
45461
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
   311
        $ mk_empty compfuns (dest_monadT compfuns T')
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   312
        $ compilation
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   313
    end,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   314
  transform_additional_arguments =
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   315
    fn _ => fn additional_arguments =>
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   316
    let
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   317
      val [depth] = additional_arguments
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   318
      val depth' =
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   319
        Const (@{const_name Groups.minus}, @{typ "natural => natural => natural"})
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   320
          $ depth $ Const (@{const_name Groups.one}, @{typ "natural"})
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   321
    in [depth'] end
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   322
  }
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   323
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   324
val random_comp_modifiers = Comp_Mod.Comp_Modifiers
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   325
  {
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   326
  compilation = Random,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   327
  function_name_prefix = "random_",
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   328
  compfuns = Predicate_Comp_Funs.compfuns,
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   329
  mk_random = (fn T => fn additional_arguments =>
51126
df86080de4cb reform of predicate compiler / quickcheck theories:
haftmann
parents: 50057
diff changeset
   330
  list_comb (Const(@{const_name Random_Pred.iter},
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   331
  [@{typ natural}, @{typ natural}, @{typ Random.seed}] ---> 
45461
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
   332
    Predicate_Comp_Funs.mk_monadT T), additional_arguments)),
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   333
  modify_funT = (fn T =>
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   334
    let
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   335
      val (Ts, U) = strip_type T
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   336
      val Ts' = [@{typ natural}, @{typ natural}, @{typ Random.seed}]
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   337
    in (Ts @ Ts') ---> U end),
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   338
  additional_arguments = (fn names =>
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   339
    let
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   340
      val [nrandom, size, seed] = Name.variant_list names ["nrandom", "size", "seed"]
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   341
    in
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   342
      [Free (nrandom, @{typ natural}), Free (size, @{typ natural}),
51126
df86080de4cb reform of predicate compiler / quickcheck theories:
haftmann
parents: 50057
diff changeset
   343
        Free (seed, @{typ Random.seed})]
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   344
    end),
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   345
  wrap_compilation = K (K (K (K (K I))))
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   346
    : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   347
  transform_additional_arguments = K I : (indprem -> term list -> term list)
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   348
  }
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   349
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   350
val depth_limited_random_comp_modifiers = Comp_Mod.Comp_Modifiers
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   351
  {
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   352
  compilation = Depth_Limited_Random,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   353
  function_name_prefix = "depth_limited_random_",
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   354
  compfuns = Predicate_Comp_Funs.compfuns,
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   355
  mk_random = (fn T => fn additional_arguments =>
51126
df86080de4cb reform of predicate compiler / quickcheck theories:
haftmann
parents: 50057
diff changeset
   356
  list_comb (Const(@{const_name Random_Pred.iter},
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   357
  [@{typ natural}, @{typ natural}, @{typ Random.seed}] ---> 
45461
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
   358
    Predicate_Comp_Funs.mk_monadT T), tl additional_arguments)),
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   359
  modify_funT = (fn T =>
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   360
    let
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   361
      val (Ts, U) = strip_type T
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   362
      val Ts' = [@{typ natural}, @{typ natural}, @{typ natural},
51126
df86080de4cb reform of predicate compiler / quickcheck theories:
haftmann
parents: 50057
diff changeset
   363
        @{typ Random.seed}]
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   364
    in (Ts @ Ts') ---> U end),
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   365
  additional_arguments = (fn names =>
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   366
    let
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   367
      val [depth, nrandom, size, seed] = Name.variant_list names ["depth", "nrandom", "size", "seed"]
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   368
    in
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   369
      [Free (depth, @{typ natural}), Free (nrandom, @{typ natural}),
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   370
        Free (size, @{typ natural}), Free (seed, @{typ Random.seed})]
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   371
    end),
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   372
  wrap_compilation =
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   373
  fn compfuns => fn _ => fn T => fn mode => fn additional_arguments => fn compilation =>
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   374
    let
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   375
      val depth = hd (additional_arguments)
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   376
      val (_, Ts) = split_map_modeT (fn m => fn T => (SOME (funT_of compfuns m T), NONE))
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   377
        mode (binder_types T)
45461
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
   378
      val T' = mk_monadT compfuns (HOLogic.mk_tupleT Ts)
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   379
      val if_const = Const (@{const_name "If"}, @{typ bool} --> T' --> T' --> T')
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   380
    in
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   381
      if_const $ HOLogic.mk_eq (depth, @{term "0 :: natural"})
45461
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
   382
        $ mk_empty compfuns (dest_monadT compfuns T')
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   383
        $ compilation
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   384
    end,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   385
  transform_additional_arguments =
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   386
    fn _ => fn additional_arguments =>
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   387
    let
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   388
      val [depth, nrandom, size, seed] = additional_arguments
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   389
      val depth' =
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   390
        Const (@{const_name Groups.minus}, @{typ "natural => natural => natural"})
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   391
          $ depth $ Const (@{const_name Groups.one}, @{typ "natural"})
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   392
    in [depth', nrandom, size, seed] end
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   393
}
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   394
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   395
val predicate_comp_modifiers = Comp_Mod.Comp_Modifiers
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   396
  {
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   397
  compilation = Pred,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   398
  function_name_prefix = "",
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   399
  compfuns = Predicate_Comp_Funs.compfuns,
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   400
  mk_random = (fn _ => error "no random generation"),
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   401
  modify_funT = I,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   402
  additional_arguments = K [],
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   403
  wrap_compilation = K (K (K (K (K I))))
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   404
   : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   405
  transform_additional_arguments = K I : (indprem -> term list -> term list)
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   406
  }
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   407
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   408
val dseq_comp_modifiers = Comp_Mod.Comp_Modifiers
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   409
  {
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   410
  compilation = DSeq,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   411
  function_name_prefix = "dseq_",
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   412
  compfuns = DSequence_CompFuns.compfuns,
40051
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   413
  mk_random = (fn _ => error "no random generation in dseq"),
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   414
  modify_funT = I,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   415
  additional_arguments = K [],
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   416
  wrap_compilation = K (K (K (K (K I))))
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   417
   : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   418
  transform_additional_arguments = K I : (indprem -> term list -> term list)
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   419
  }
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   420
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   421
val pos_random_dseq_comp_modifiers = Comp_Mod.Comp_Modifiers
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   422
  {
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   423
  compilation = Pos_Random_DSeq,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   424
  function_name_prefix = "random_dseq_",
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   425
  compfuns = Random_Sequence_CompFuns.compfuns,
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   426
  mk_random = (fn T => fn _ =>
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   427
  let
51126
df86080de4cb reform of predicate compiler / quickcheck theories:
haftmann
parents: 50057
diff changeset
   428
    val random = Const (@{const_name Quickcheck_Random.random},
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   429
      @{typ natural} --> @{typ Random.seed} -->
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   430
        HOLogic.mk_prodT (HOLogic.mk_prodT (T, @{typ "unit => term"}), @{typ Random.seed}))
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   431
  in
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   432
    Const (@{const_name Random_Sequence.Random}, (@{typ natural} --> @{typ Random.seed} -->
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   433
      HOLogic.mk_prodT (HOLogic.mk_prodT (T, @{typ "unit => term"}), @{typ Random.seed})) -->
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   434
      Random_Sequence_CompFuns.mk_random_dseqT T) $ random
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   435
  end),
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   436
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   437
  modify_funT = I,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   438
  additional_arguments = K [],
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   439
  wrap_compilation = K (K (K (K (K I))))
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   440
   : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   441
  transform_additional_arguments = K I : (indprem -> term list -> term list)
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   442
  }
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   443
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   444
val neg_random_dseq_comp_modifiers = Comp_Mod.Comp_Modifiers
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   445
  {
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   446
  compilation = Neg_Random_DSeq,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   447
  function_name_prefix = "random_dseq_neg_",
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   448
  compfuns = Random_Sequence_CompFuns.compfuns,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   449
  mk_random = (fn _ => error "no random generation"),
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   450
  modify_funT = I,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   451
  additional_arguments = K [],
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   452
  wrap_compilation = K (K (K (K (K I))))
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   453
   : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   454
  transform_additional_arguments = K I : (indprem -> term list -> term list)
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   455
  }
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   456
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   457
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   458
val new_pos_random_dseq_comp_modifiers = Comp_Mod.Comp_Modifiers
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   459
  {
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   460
  compilation = New_Pos_Random_DSeq,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   461
  function_name_prefix = "new_random_dseq_",
40049
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   462
  compfuns = New_Pos_Random_Sequence_CompFuns.depth_limited_compfuns,
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   463
  mk_random = (fn T => fn _ =>
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   464
  let
51126
df86080de4cb reform of predicate compiler / quickcheck theories:
haftmann
parents: 50057
diff changeset
   465
    val random = Const (@{const_name Quickcheck_Random.random},
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   466
      @{typ natural} --> @{typ Random.seed} -->
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   467
        HOLogic.mk_prodT (HOLogic.mk_prodT (T, @{typ "unit => term"}), @{typ Random.seed}))
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   468
  in
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   469
    Const (@{const_name Random_Sequence.pos_Random}, (@{typ natural} --> @{typ Random.seed} -->
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   470
      HOLogic.mk_prodT (HOLogic.mk_prodT (T, @{typ "unit => term"}), @{typ Random.seed})) -->
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   471
      New_Pos_Random_Sequence_CompFuns.mk_pos_random_dseqT T) $ random
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   472
  end),
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   473
  modify_funT = I,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   474
  additional_arguments = K [],
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   475
  wrap_compilation = K (K (K (K (K I))))
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   476
   : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   477
  transform_additional_arguments = K I : (indprem -> term list -> term list)
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   478
  }
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   479
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   480
val new_neg_random_dseq_comp_modifiers = Comp_Mod.Comp_Modifiers
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   481
  {
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   482
  compilation = New_Neg_Random_DSeq,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   483
  function_name_prefix = "new_random_dseq_neg_",
40049
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   484
  compfuns = New_Neg_Random_Sequence_CompFuns.depth_limited_compfuns,
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   485
  mk_random = (fn _ => error "no random generation"),
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   486
  modify_funT = I,
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   487
  additional_arguments = K [],
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   488
  wrap_compilation = K (K (K (K (K I))))
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   489
   : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   490
  transform_additional_arguments = K I : (indprem -> term list -> term list)
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   491
  }
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   492
40051
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   493
val pos_generator_dseq_comp_modifiers = Comp_Mod.Comp_Modifiers
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   494
  {
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   495
  compilation = Pos_Generator_DSeq,
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   496
  function_name_prefix = "generator_dseq_",
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   497
  compfuns = New_Pos_DSequence_CompFuns.depth_limited_compfuns,
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   498
  mk_random =
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   499
    (fn T => fn _ =>
45214
66ba67adafab modernizing predicate_compile_quickcheck
bulwahn
parents: 44241
diff changeset
   500
      Const (@{const_name "Lazy_Sequence.small_lazy_class.small_lazy"},
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   501
        @{typ "natural"} --> Type (@{type_name "Lazy_Sequence.lazy_sequence"}, [T]))),
40051
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   502
  modify_funT = I,
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   503
  additional_arguments = K [],
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   504
  wrap_compilation = K (K (K (K (K I))))
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   505
   : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   506
  transform_additional_arguments = K I : (indprem -> term list -> term list)
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   507
  }
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   508
  
40051
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   509
val neg_generator_dseq_comp_modifiers = Comp_Mod.Comp_Modifiers
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   510
  {
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   511
  compilation = Neg_Generator_DSeq,
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   512
  function_name_prefix = "generator_dseq_neg_",
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   513
  compfuns = New_Neg_DSequence_CompFuns.depth_limited_compfuns,
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   514
  mk_random = (fn _ => error "no random generation"),
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   515
  modify_funT = I,
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   516
  additional_arguments = K [],
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   517
  wrap_compilation = K (K (K (K (K I))))
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   518
   : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   519
  transform_additional_arguments = K I : (indprem -> term list -> term list)
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   520
  }
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   521
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   522
val pos_generator_cps_comp_modifiers = Comp_Mod.Comp_Modifiers
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   523
  {
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   524
  compilation = Pos_Generator_CPS,
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   525
  function_name_prefix = "generator_cps_pos_",
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   526
  compfuns = Pos_Bounded_CPS_Comp_Funs.compfuns,
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   527
  mk_random =
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   528
    (fn T => fn _ =>
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   529
       Const (@{const_name "Quickcheck_Exhaustive.exhaustive"},
45750
17100f4ce0b5 adding genuine flag to predicate_compile_quickcheck and prolog_quickcheck (cf. 5e46c225370e);
bulwahn
parents: 45592
diff changeset
   530
       (T --> @{typ "(bool * term list) option"}) -->
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
   531
         @{typ "natural => (bool * term list) option"})),
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   532
  modify_funT = I,
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   533
  additional_arguments = K [],
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   534
  wrap_compilation = K (K (K (K (K I))))
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   535
   : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   536
  transform_additional_arguments = K I : (indprem -> term list -> term list)
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   537
  }  
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   538
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   539
val neg_generator_cps_comp_modifiers = Comp_Mod.Comp_Modifiers
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   540
  {
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   541
  compilation = Neg_Generator_CPS,
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   542
  function_name_prefix = "generator_cps_neg_",
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   543
  compfuns = Neg_Bounded_CPS_Comp_Funs.compfuns,
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   544
  mk_random = (fn _ => error "No enumerators"),
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   545
  modify_funT = I,
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   546
  additional_arguments = K [],
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   547
  wrap_compilation = K (K (K (K (K I))))
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   548
   : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   549
  transform_additional_arguments = K I : (indprem -> term list -> term list)
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   550
  }
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   551
  
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   552
fun negative_comp_modifiers_of comp_modifiers =
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   553
    (case Comp_Mod.compilation comp_modifiers of
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   554
      Pos_Random_DSeq => neg_random_dseq_comp_modifiers
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   555
    | Neg_Random_DSeq => pos_random_dseq_comp_modifiers
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   556
    | New_Pos_Random_DSeq => new_neg_random_dseq_comp_modifiers
40051
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   557
    | New_Neg_Random_DSeq => new_pos_random_dseq_comp_modifiers 
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   558
    | Pos_Generator_DSeq => neg_generator_dseq_comp_modifiers
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
   559
    | Neg_Generator_DSeq => pos_generator_dseq_comp_modifiers
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   560
    | Pos_Generator_CPS => neg_generator_cps_comp_modifiers
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   561
    | Neg_Generator_CPS => pos_generator_cps_comp_modifiers
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   562
    | _ => comp_modifiers)
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   563
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   564
(* term construction *)
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   565
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   566
fun mk_v (names, vs) s T = (case AList.lookup (op =) vs s of
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   567
      NONE => (Free (s, T), (names, (s, [])::vs))
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   568
    | SOME xs =>
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   569
        let
43324
2b47822868e4 discontinued Name.variant to emphasize that this is old-style / indirect;
wenzelm
parents: 43253
diff changeset
   570
          val s' = singleton (Name.variant_list names) s;
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   571
          val v = Free (s', T)
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   572
        in
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   573
          (v, (s'::names, AList.update (op =) (s, v::xs) vs))
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   574
        end);
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   575
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   576
fun distinct_v (Free (s, T)) nvs = mk_v nvs s T
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   577
  | distinct_v (t $ u) nvs =
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   578
      let
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   579
        val (t', nvs') = distinct_v t nvs;
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   580
        val (u', nvs'') = distinct_v u nvs';
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   581
      in (t' $ u', nvs'') end
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   582
  | distinct_v x nvs = (x, nvs);
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   583
33147
180dc60bd88c improving the compilation with higher-order arguments in the predicate compiler
bulwahn
parents: 33146
diff changeset
   584
39648
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   585
(** specific rpred functions -- move them to the correct place in this file *)
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   586
fun mk_Eval_of (P as (Free _), T) mode =
44241
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
   587
  let
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
   588
    fun mk_bounds (Type (@{type_name Product_Type.prod}, [T1, T2])) i =
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
   589
          let
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
   590
            val (bs2, i') = mk_bounds T2 i 
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
   591
            val (bs1, i'') = mk_bounds T1 i'
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
   592
          in
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
   593
            (HOLogic.pair_const T1 T2 $ bs1 $ bs2, i'' + 1)
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
   594
          end
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   595
      | mk_bounds _ i = (Bound i, i + 1)
44241
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
   596
    fun mk_prod ((t1, T1), (t2, T2)) = (HOLogic.pair_const T1 T2 $ t1 $ t2, HOLogic.mk_prodT (T1, T2))
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
   597
    fun mk_tuple [] = (HOLogic.unit, HOLogic.unitT)
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
   598
      | mk_tuple tTs = foldr1 mk_prod tTs
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
   599
    fun mk_split_abs (T as Type (@{type_name Product_Type.prod}, [T1, T2])) t =
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
   600
          absdummy T
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
   601
            (HOLogic.split_const (T1, T2, @{typ bool}) $ (mk_split_abs T1 (mk_split_abs T2 t)))
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
   602
      | mk_split_abs T t = absdummy T t
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
   603
    val args = rev (fst (fold_map mk_bounds (rev (binder_types T)) 0))
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
   604
    val (inargs, outargs) = split_mode mode args
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   605
    val (_, outTs) = split_map_modeT (fn _ => fn T => (SOME T, NONE)) mode (binder_types T)
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
   606
    val inner_term = Predicate_Comp_Funs.mk_Eval (list_comb (P, inargs), fst (mk_tuple (outargs ~~ outTs)))
44241
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
   607
  in
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
   608
    fold_rev mk_split_abs (binder_types T) inner_term
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
   609
  end
33147
180dc60bd88c improving the compilation with higher-order arguments in the predicate compiler
bulwahn
parents: 33146
diff changeset
   610
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   611
fun compile_arg compilation_modifiers _ _ param_modes arg = 
33147
180dc60bd88c improving the compilation with higher-order arguments in the predicate compiler
bulwahn
parents: 33146
diff changeset
   612
  let
180dc60bd88c improving the compilation with higher-order arguments in the predicate compiler
bulwahn
parents: 33146
diff changeset
   613
    fun map_params (t as Free (f, T)) =
39648
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   614
      (case (AList.lookup (op =) param_modes f) of
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   615
          SOME mode =>
33147
180dc60bd88c improving the compilation with higher-order arguments in the predicate compiler
bulwahn
parents: 33146
diff changeset
   616
            let
39648
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   617
              val T' = Comp_Mod.funT_of compilation_modifiers mode T
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   618
            in
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   619
              mk_Eval_of (Free (f, T'), T) mode
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   620
            end
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   621
        | NONE => t)
33147
180dc60bd88c improving the compilation with higher-order arguments in the predicate compiler
bulwahn
parents: 33146
diff changeset
   622
      | map_params t = t
39648
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   623
  in
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   624
    map_aterms map_params arg
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   625
  end
33147
180dc60bd88c improving the compilation with higher-order arguments in the predicate compiler
bulwahn
parents: 33146
diff changeset
   626
39648
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   627
fun compile_match compilation_modifiers additional_arguments ctxt param_modes
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   628
      eqs eqs' out_ts success_t =
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   629
  let
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   630
    val compfuns = Comp_Mod.compfuns compilation_modifiers
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   631
    val eqs'' = maps mk_eq eqs @ eqs'
33147
180dc60bd88c improving the compilation with higher-order arguments in the predicate compiler
bulwahn
parents: 33146
diff changeset
   632
    val eqs'' =
39648
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   633
      map (compile_arg compilation_modifiers additional_arguments ctxt param_modes) eqs''
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   634
    val names = fold Term.add_free_names (success_t :: eqs'' @ out_ts) [];
43324
2b47822868e4 discontinued Name.variant to emphasize that this is old-style / indirect;
wenzelm
parents: 43253
diff changeset
   635
    val name = singleton (Name.variant_list names) "x";
2b47822868e4 discontinued Name.variant to emphasize that this is old-style / indirect;
wenzelm
parents: 43253
diff changeset
   636
    val name' = singleton (Name.variant_list (name :: names)) "y";
33148
0808f7d0d0d7 removed tuple functions from the predicate compiler
bulwahn
parents: 33147
diff changeset
   637
    val T = HOLogic.mk_tupleT (map fastype_of out_ts);
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   638
    val U = fastype_of success_t;
45461
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
   639
    val U' = dest_monadT compfuns U;
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   640
    val v = Free (name, T);
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   641
    val v' = Free (name', T);
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   642
  in
51673
4dfa00e264d8 separate data used for case translation from the datatype package
traytel
parents: 51672
diff changeset
   643
    lambda v (Case_Translation.make_case ctxt Case_Translation.Quiet Name.context v
33148
0808f7d0d0d7 removed tuple functions from the predicate compiler
bulwahn
parents: 33147
diff changeset
   644
      [(HOLogic.mk_tuple out_ts,
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   645
        if null eqs'' then success_t
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   646
        else Const (@{const_name HOL.If}, HOLogic.boolT --> U --> U --> U) $
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   647
          foldr1 HOLogic.mk_conj eqs'' $ success_t $
45461
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
   648
            mk_empty compfuns U'),
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
   649
       (v', mk_empty compfuns U')])
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   650
  end;
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   651
39648
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   652
fun compile_expr compilation_modifiers ctxt (t, deriv) param_modes additional_arguments =
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   653
  let
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   654
    val compfuns = Comp_Mod.compfuns compilation_modifiers
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   655
    fun expr_of (t, deriv) =
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   656
      (case (t, deriv) of
39648
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   657
        (t, Term Input) => SOME (compile_arg compilation_modifiers additional_arguments ctxt param_modes t)
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   658
      | (_, Term Output) => NONE
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   659
      | (Const (name, T), Context mode) =>
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
   660
        (case alternative_compilation_of ctxt name mode of
36038
385f706eff24 generalized alternative functions to alternative compilation to handle arithmetic functions better
bulwahn
parents: 36037
diff changeset
   661
          SOME alt_comp => SOME (alt_comp compfuns T)
36034
ee84eac07290 added book-keeping, registration and compilation with alternative functions for predicates in the predicate compiler
bulwahn
parents: 36031
diff changeset
   662
        | NONE =>
ee84eac07290 added book-keeping, registration and compilation with alternative functions for predicates in the predicate compiler
bulwahn
parents: 36031
diff changeset
   663
          SOME (Const (function_name_of (Comp_Mod.compilation compilation_modifiers)
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
   664
            ctxt name mode,
36034
ee84eac07290 added book-keeping, registration and compilation with alternative functions for predicates in the predicate compiler
bulwahn
parents: 36031
diff changeset
   665
            Comp_Mod.funT_of compilation_modifiers mode T)))
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   666
      | (Free (s, T), Context m) =>
39785
05c4e9ecf5f6 improving the compilation to handle predicate arguments in higher-order argument positions
bulwahn
parents: 39783
diff changeset
   667
        (case (AList.lookup (op =) param_modes s) of
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   668
          SOME _ => SOME (Free (s, Comp_Mod.funT_of compilation_modifiers m T))
39785
05c4e9ecf5f6 improving the compilation to handle predicate arguments in higher-order argument positions
bulwahn
parents: 39783
diff changeset
   669
        | NONE =>
05c4e9ecf5f6 improving the compilation to handle predicate arguments in higher-order argument positions
bulwahn
parents: 39783
diff changeset
   670
        let
05c4e9ecf5f6 improving the compilation to handle predicate arguments in higher-order argument positions
bulwahn
parents: 39783
diff changeset
   671
          val bs = map (pair "x") (binder_types (fastype_of t))
05c4e9ecf5f6 improving the compilation to handle predicate arguments in higher-order argument positions
bulwahn
parents: 39783
diff changeset
   672
          val bounds = map Bound (rev (0 upto (length bs) - 1))
46219
426ed18eba43 discontinued old-style Term.list_abs in favour of plain Term.abs;
wenzelm
parents: 45906
diff changeset
   673
        in SOME (fold_rev Term.abs bs (mk_if compfuns (list_comb (t, bounds)))) end)
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   674
      | (t, Context _) =>
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   675
        let
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   676
          val bs = map (pair "x") (binder_types (fastype_of t))
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   677
          val bounds = map Bound (rev (0 upto (length bs) - 1))
46219
426ed18eba43 discontinued old-style Term.list_abs in favour of plain Term.abs;
wenzelm
parents: 45906
diff changeset
   678
        in SOME (fold_rev Term.abs bs (mk_if compfuns (list_comb (t, bounds)))) end
37391
476270a6c2dc tuned quotes, antiquotations and whitespace
haftmann
parents: 37146
diff changeset
   679
      | (Const (@{const_name Pair}, _) $ t1 $ t2, Mode_Pair (d1, d2)) =>
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   680
        (case (expr_of (t1, d1), expr_of (t2, d2)) of
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   681
          (NONE, NONE) => NONE
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   682
        | (NONE, SOME t) => SOME t
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   683
        | (SOME t, NONE) => SOME t
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   684
        | (SOME t1, SOME t2) => SOME (HOLogic.mk_prod (t1, t2)))
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   685
      | (t1 $ t2, Mode_App (deriv1, deriv2)) =>
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   686
        (case (expr_of (t1, deriv1), expr_of (t2, deriv2)) of
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   687
          (SOME t, NONE) => SOME t
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   688
         | (SOME t, SOME u) => SOME (t $ u)
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   689
         | _ => error "something went wrong here!"))
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   690
  in
35879
99818df5b8f5 reviving the classical depth-limited computation in the predicate compiler
bulwahn
parents: 35845
diff changeset
   691
    list_comb (the (expr_of (t, deriv)), additional_arguments)
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   692
  end
33145
1a22f7ca1dfc removed dead code; added examples
bulwahn
parents: 33144
diff changeset
   693
39648
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   694
fun compile_clause compilation_modifiers ctxt all_vs param_modes additional_arguments
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   695
  inp (in_ts, out_ts) moded_ps =
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   696
  let
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   697
    val compfuns = Comp_Mod.compfuns compilation_modifiers
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   698
    val compile_match = compile_match compilation_modifiers
39648
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   699
      additional_arguments ctxt param_modes
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   700
    val (in_ts', (all_vs', eqs)) =
35891
3122bdd95275 contextifying the compilation of the predicate compiler
bulwahn
parents: 35889
diff changeset
   701
      fold_map (collect_non_invertible_subterms ctxt) in_ts (all_vs, []);
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   702
    fun compile_prems out_ts' vs names [] =
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   703
          let
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   704
            val (out_ts'', (names', eqs')) =
35891
3122bdd95275 contextifying the compilation of the predicate compiler
bulwahn
parents: 35889
diff changeset
   705
              fold_map (collect_non_invertible_subterms ctxt) out_ts' (names, []);
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   706
            val (out_ts''', (_, constr_vs)) = fold_map distinct_v
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   707
              out_ts'' (names', map (rpair []) vs);
39762
02fb709ab3cb handling higher-order relations in output terms; improving proof procedure; added test case
bulwahn
parents: 39761
diff changeset
   708
            val processed_out_ts = map (compile_arg compilation_modifiers additional_arguments
02fb709ab3cb handling higher-order relations in output terms; improving proof procedure; added test case
bulwahn
parents: 39761
diff changeset
   709
              ctxt param_modes) out_ts
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   710
          in
33147
180dc60bd88c improving the compilation with higher-order arguments in the predicate compiler
bulwahn
parents: 33146
diff changeset
   711
            compile_match constr_vs (eqs @ eqs') out_ts'''
39762
02fb709ab3cb handling higher-order relations in output terms; improving proof procedure; added test case
bulwahn
parents: 39761
diff changeset
   712
              (mk_single compfuns (HOLogic.mk_tuple processed_out_ts))
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   713
          end
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   714
      | compile_prems out_ts vs names ((p, deriv) :: ps) =
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   715
          let
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   716
            val vs' = distinct (op =) (flat (vs :: map term_vs out_ts));
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   717
            val (out_ts', (names', eqs)) =
35891
3122bdd95275 contextifying the compilation of the predicate compiler
bulwahn
parents: 35889
diff changeset
   718
              fold_map (collect_non_invertible_subterms ctxt) out_ts (names, [])
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   719
            val (out_ts'', (names'', constr_vs')) = fold_map distinct_v
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   720
              out_ts' ((names', map (rpair []) vs))
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   721
            val mode = head_mode_of deriv
33143
730a2e8a6ec6 modularized the compilation in the predicate compiler
bulwahn
parents: 33141
diff changeset
   722
            val additional_arguments' =
33330
d6eb7f19bfc6 encapsulating records with datatype constructors and adding type annotations to make SML/NJ happy
bulwahn
parents: 33328
diff changeset
   723
              Comp_Mod.transform_additional_arguments compilation_modifiers p additional_arguments
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   724
            val (compiled_clause, rest) = case p of
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   725
               Prem t =>
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   726
                 let
33138
e2e23987c59a reinvestigating the compilation of the random computation in the predicate compiler
bulwahn
parents: 33137
diff changeset
   727
                   val u =
39648
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   728
                     compile_expr compilation_modifiers ctxt (t, deriv) param_modes additional_arguments'
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   729
                   val (_, out_ts''') = split_mode mode (snd (strip_comb t))
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   730
                   val rest = compile_prems out_ts''' vs' names'' ps
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   731
                 in
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   732
                   (u, rest)
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   733
                 end
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   734
             | Negprem t =>
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   735
                 let
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   736
                   val neg_compilation_modifiers =
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   737
                     negative_comp_modifiers_of compilation_modifiers
33143
730a2e8a6ec6 modularized the compilation in the predicate compiler
bulwahn
parents: 33141
diff changeset
   738
                   val u = mk_not compfuns
39648
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   739
                     (compile_expr neg_compilation_modifiers ctxt (t, deriv) param_modes additional_arguments')
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   740
                   val (_, out_ts''') = split_mode mode (snd (strip_comb t))
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   741
                   val rest = compile_prems out_ts''' vs' names'' ps
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   742
                 in
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   743
                   (u, rest)
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   744
                 end
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   745
             | Sidecond t =>
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   746
                 let
36019
64bbbd858c39 generalizing the compilation process of the predicate compiler
bulwahn
parents: 36018
diff changeset
   747
                   val t = compile_arg compilation_modifiers additional_arguments
39648
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   748
                     ctxt param_modes t
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   749
                   val rest = compile_prems [] vs' names'' ps;
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   750
                 in
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   751
                   (mk_if compfuns t, rest)
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   752
                 end
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   753
             | Generator (v, T) =>
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   754
                 let
35880
2623b23e41fc a new simpler random compilation for the predicate compiler
bulwahn
parents: 35879
diff changeset
   755
                   val u = Comp_Mod.mk_random compilation_modifiers T additional_arguments
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   756
                   val rest = compile_prems [Free (v, T)]  vs' names'' ps;
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   757
                 in
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   758
                   (u, rest)
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   759
                 end
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   760
          in
33147
180dc60bd88c improving the compilation with higher-order arguments in the predicate compiler
bulwahn
parents: 33146
diff changeset
   761
            compile_match constr_vs' eqs out_ts''
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   762
              (mk_bind compfuns (compiled_clause, rest))
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   763
          end
39648
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   764
    val prem_t = compile_prems in_ts' (map fst param_modes) all_vs' moded_ps;
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   765
  in
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   766
    mk_bind compfuns (mk_single compfuns inp, prem_t)
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   767
  end
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   768
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   769
(* switch detection *)
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   770
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   771
(** argument position of an inductive predicates and the executable functions **)
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   772
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   773
type position = int * int list
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   774
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   775
fun input_positions_pair Input = [[]]
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   776
  | input_positions_pair Output = []
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   777
  | input_positions_pair (Fun _) = []
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   778
  | input_positions_pair (Pair (m1, m2)) =
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   779
    map (cons 1) (input_positions_pair m1) @ map (cons 2) (input_positions_pair m2)
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   780
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   781
fun input_positions_of_mode mode = flat (map_index
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   782
   (fn (i, Input) => [(i, [])]
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   783
   | (_, Output) => []
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   784
   | (_, Fun _) => []
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   785
   | (i, m as Pair _) => map (pair i) (input_positions_pair m))
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   786
     (Predicate_Compile_Aux.strip_fun_mode mode))
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   787
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   788
fun argument_position_pair _ [] = []
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   789
  | argument_position_pair (Pair (Fun _, m2)) (2 :: is) = argument_position_pair m2 is
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   790
  | argument_position_pair (Pair (m1, m2)) (i :: is) =
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   791
    (if eq_mode (m1, Output) andalso i = 2 then
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   792
      argument_position_pair m2 is
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   793
    else if eq_mode (m2, Output) andalso i = 1 then
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   794
      argument_position_pair m1 is
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   795
    else (i :: argument_position_pair (if i = 1 then m1 else m2) is))
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   796
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   797
fun argument_position_of mode (i, is) =
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   798
  (i - (length (filter (fn Output => true | Fun _ => true | _ => false)
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   799
    (List.take (strip_fun_mode mode, i)))),
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   800
  argument_position_pair (nth (strip_fun_mode mode) i) is)
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   801
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   802
fun nth_pair [] t = t
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   803
  | nth_pair (1 :: is) (Const (@{const_name Pair}, _) $ t1 $ _) = nth_pair is t1
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   804
  | nth_pair (2 :: is) (Const (@{const_name Pair}, _) $ _ $ t2) = nth_pair is t2
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   805
  | nth_pair _ _ = raise Fail "unexpected input for nth_tuple"
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   806
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   807
(** switch detection analysis **)
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   808
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   809
fun find_switch_test ctxt (i, is) (ts, _) =
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   810
  let
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   811
    val t = nth_pair is (nth ts i)
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   812
    val T = fastype_of t
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   813
  in
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   814
    case T of
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   815
      TFree _ => NONE
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   816
    | Type (Tcon, _) =>
45906
0aaeb5520f2f tuned signature;
wenzelm
parents: 45891
diff changeset
   817
      (case Datatype.get_constrs (Proof_Context.theory_of ctxt) Tcon of
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   818
        NONE => NONE
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   819
      | SOME cs =>
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   820
        (case strip_comb t of
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   821
          (Var _, []) => NONE
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   822
        | (Free _, []) => NONE
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   823
        | (Const (c, T), _) => if AList.defined (op =) cs c then SOME (c, T) else NONE))
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   824
  end
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   825
37005
842a73dc6d0e changing compilation to work only with contexts; adapting quickcheck
bulwahn
parents: 37004
diff changeset
   826
fun partition_clause ctxt pos moded_clauses =
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   827
  let
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   828
    fun insert_list eq (key, value) = AList.map_default eq (key, []) (cons value)
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   829
    fun find_switch_test' moded_clause (cases, left) =
37005
842a73dc6d0e changing compilation to work only with contexts; adapting quickcheck
bulwahn
parents: 37004
diff changeset
   830
      case find_switch_test ctxt pos moded_clause of
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   831
        SOME (c, T) => (insert_list (op =) ((c, T), moded_clause) cases, left)
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   832
      | NONE => (cases, moded_clause :: left)
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   833
  in
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   834
    fold find_switch_test' moded_clauses ([], [])
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   835
  end
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   836
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   837
datatype switch_tree =
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   838
  Atom of moded_clause list | Node of (position * ((string * typ) * switch_tree) list) * switch_tree
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   839
37005
842a73dc6d0e changing compilation to work only with contexts; adapting quickcheck
bulwahn
parents: 37004
diff changeset
   840
fun mk_switch_tree ctxt mode moded_clauses =
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   841
  let
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   842
    fun select_best_switch moded_clauses input_position best_switch =
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   843
      let
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   844
        val ord = option_ord (rev_order o int_ord o (pairself (length o snd o snd)))
37005
842a73dc6d0e changing compilation to work only with contexts; adapting quickcheck
bulwahn
parents: 37004
diff changeset
   845
        val partition = partition_clause ctxt input_position moded_clauses
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   846
        val switch = if (length (fst partition) > 1) then SOME (input_position, partition) else NONE
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   847
      in
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   848
        case ord (switch, best_switch) of LESS => best_switch
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   849
          | EQUAL => best_switch | GREATER => switch
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   850
      end
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   851
    fun detect_switches moded_clauses =
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   852
      case fold (select_best_switch moded_clauses) (input_positions_of_mode mode) NONE of
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   853
        SOME (best_pos, (switched_on, left_clauses)) =>
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   854
          Node ((best_pos, map (apsnd detect_switches) switched_on),
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   855
            detect_switches left_clauses)
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   856
      | NONE => Atom moded_clauses
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   857
  in
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   858
    detect_switches moded_clauses
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   859
  end
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   860
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   861
(** compilation of detected switches **)
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   862
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   863
fun destruct_constructor_pattern (pat, obj) =
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   864
  (case strip_comb pat of
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
   865
    (Free _, []) => cons (pat, obj)
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   866
  | (Const (c, T), pat_args) =>
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   867
    (case strip_comb obj of
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   868
      (Const (c', T'), obj_args) =>
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   869
        (if c = c' andalso T = T' then
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   870
          fold destruct_constructor_pattern (pat_args ~~ obj_args)
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   871
        else raise Fail "pattern and object mismatch")
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   872
    | _ => raise Fail "unexpected object")
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   873
  | _ => raise Fail "unexpected pattern")
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   874
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   875
39648
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   876
fun compile_switch compilation_modifiers ctxt all_vs param_modes additional_arguments mode
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   877
  in_ts' outTs switch_tree =
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   878
  let
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   879
    val compfuns = Comp_Mod.compfuns compilation_modifiers
42361
23f352990944 modernized structure Proof_Context;
wenzelm
parents: 42141
diff changeset
   880
    val thy = Proof_Context.theory_of ctxt
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   881
    fun compile_switch_tree _ _ (Atom []) = NONE
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   882
      | compile_switch_tree all_vs ctxt_eqs (Atom moded_clauses) =
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   883
        let
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   884
          val in_ts' = map (Pattern.rewrite_term thy ctxt_eqs []) in_ts'
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   885
          fun compile_clause' (ts, moded_ps) =
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   886
            let
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   887
              val (ts, out_ts) = split_mode mode ts
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   888
              val subst = fold destruct_constructor_pattern (in_ts' ~~ ts) []
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   889
              val (fsubst, pat') = List.partition (fn (_, Free _) => true | _ => false) subst
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   890
              val moded_ps' = (map o apfst o map_indprem)
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   891
                (Pattern.rewrite_term thy (map swap fsubst) []) moded_ps
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   892
              val inp = HOLogic.mk_tuple (map fst pat')
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   893
              val in_ts' = map (Pattern.rewrite_term thy (map swap fsubst) []) (map snd pat')
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   894
              val out_ts' = map (Pattern.rewrite_term thy (map swap fsubst) []) out_ts
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   895
            in
39648
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   896
              compile_clause compilation_modifiers ctxt all_vs param_modes additional_arguments
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   897
                inp (in_ts', out_ts') moded_ps'
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   898
            end
45461
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
   899
        in SOME (foldr1 (mk_plus compfuns) (map compile_clause' moded_clauses)) end
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   900
    | compile_switch_tree all_vs ctxt_eqs (Node ((position, switched_clauses), left_clauses)) =
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   901
      let
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   902
        val (i, is) = argument_position_of mode position
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   903
        val inp_var = nth_pair is (nth in_ts' i)
43324
2b47822868e4 discontinued Name.variant to emphasize that this is old-style / indirect;
wenzelm
parents: 43253
diff changeset
   904
        val x = singleton (Name.variant_list all_vs) "x"
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   905
        val xt = Free (x, fastype_of inp_var)
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   906
        fun compile_single_case ((c, T), switched) =
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   907
          let
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   908
            val Ts = binder_types T
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   909
            val argnames = Name.variant_list (x :: all_vs)
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   910
              (map (fn i => "c" ^ string_of_int i) (1 upto length Ts))
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   911
            val args = map2 (curry Free) argnames Ts
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   912
            val pattern = list_comb (Const (c, T), args)
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   913
            val ctxt_eqs' = (inp_var, pattern) :: ctxt_eqs
45461
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
   914
            val compilation = the_default (mk_empty compfuns (HOLogic.mk_tupleT outTs))
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   915
              (compile_switch_tree (argnames @ x :: all_vs) ctxt_eqs' switched)
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   916
        in
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   917
          (pattern, compilation)
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   918
        end
51673
4dfa00e264d8 separate data used for case translation from the datatype package
traytel
parents: 51672
diff changeset
   919
        val switch = Case_Translation.make_case ctxt Case_Translation.Quiet Name.context inp_var
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   920
          ((map compile_single_case switched_clauses) @
45461
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
   921
            [(xt, mk_empty compfuns (HOLogic.mk_tupleT outTs))])
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   922
      in
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   923
        case compile_switch_tree all_vs ctxt_eqs left_clauses of
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   924
          NONE => SOME switch
45461
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
   925
        | SOME left_comp => SOME (mk_plus compfuns (switch, left_comp))
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   926
      end
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   927
  in
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   928
    compile_switch_tree all_vs [] switch_tree
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   929
  end
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   930
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   931
(* compilation of predicates *)
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   932
37005
842a73dc6d0e changing compilation to work only with contexts; adapting quickcheck
bulwahn
parents: 37004
diff changeset
   933
fun compile_pred options compilation_modifiers ctxt all_vs param_vs s T (pol, mode) moded_cls =
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   934
  let
40050
638ce4dabe53 for now safely but unpractically assume no predicate is terminating
bulwahn
parents: 40049
diff changeset
   935
    val is_terminating = false (* FIXME: requires an termination analysis *)  
40049
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   936
    val compilation_modifiers =
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   937
      (if pol then compilation_modifiers else
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   938
        negative_comp_modifiers_of compilation_modifiers)
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   939
      |> (if is_depth_limited_compilation (Comp_Mod.compilation compilation_modifiers) then
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   940
           (if is_terminating then
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   941
             (Comp_Mod.set_compfuns (unlimited_compfuns_of pol (Comp_Mod.compilation compilation_modifiers)))
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   942
           else
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   943
             (Comp_Mod.set_compfuns (limited_compfuns_of pol (Comp_Mod.compilation compilation_modifiers))))
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
   944
         else I)
35879
99818df5b8f5 reviving the classical depth-limited computation in the predicate compiler
bulwahn
parents: 35845
diff changeset
   945
    val additional_arguments = Comp_Mod.additional_arguments compilation_modifiers
33482
5029ec373036 strictly respecting the line margin in the predicate compiler core
bulwahn
parents: 33479
diff changeset
   946
      (all_vs @ param_vs)
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   947
    val compfuns = Comp_Mod.compfuns compilation_modifiers
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   948
    fun is_param_type (T as Type ("fun",[_ , T'])) =
45461
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
   949
      is_some (try (dest_monadT compfuns) T) orelse is_param_type T'
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
   950
      | is_param_type T = is_some (try (dest_monadT compfuns) T)
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   951
    val (inpTs, outTs) = split_map_modeT (fn m => fn T => (SOME (funT_of compfuns m T), NONE)) mode
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   952
      (binder_types T)
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   953
    val funT = Comp_Mod.funT_of compilation_modifiers mode T
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   954
    val (in_ts, _) = fold_map (fold_map_aterms_prodT (curry HOLogic.mk_prod)
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   955
      (fn T => fn (param_vs, names) =>
36018
096ec83348f3 added new compilation to predicate_compiler
bulwahn
parents: 36004
diff changeset
   956
        if is_param_type T then
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   957
          (Free (hd param_vs, T), (tl param_vs, names))
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   958
        else
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   959
          let
43324
2b47822868e4 discontinued Name.variant to emphasize that this is old-style / indirect;
wenzelm
parents: 43253
diff changeset
   960
            val new = singleton (Name.variant_list names) "x"
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   961
          in (Free (new, T), (param_vs, new :: names)) end)) inpTs
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   962
        (param_vs, (all_vs @ param_vs))
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   963
    val in_ts' = map_filter (map_filter_prod
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   964
      (fn t as Free (x, _) => if member (op =) param_vs x then NONE else SOME t | t => SOME t)) in_ts
39648
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   965
    val param_modes = param_vs ~~ ho_arg_modes_of mode
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   966
    val compilation =
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   967
      if detect_switches options then
45461
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
   968
        the_default (mk_empty compfuns (HOLogic.mk_tupleT outTs))
39648
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   969
          (compile_switch compilation_modifiers ctxt all_vs param_modes additional_arguments mode
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   970
            in_ts' outTs (mk_switch_tree ctxt mode moded_cls))
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   971
      else
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   972
        let
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   973
          val cl_ts =
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   974
            map (fn (ts, moded_prems) => 
39648
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   975
              compile_clause compilation_modifiers ctxt all_vs param_modes additional_arguments
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
   976
                (HOLogic.mk_tuple in_ts') (split_mode mode ts) moded_prems) moded_cls;
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   977
        in
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   978
          Comp_Mod.wrap_compilation compilation_modifiers compfuns s T mode additional_arguments
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   979
            (if null cl_ts then
45461
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
   980
              mk_empty compfuns (HOLogic.mk_tupleT outTs)
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   981
            else
45461
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
   982
              foldr1 (mk_plus compfuns) cl_ts)
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
   983
        end
33143
730a2e8a6ec6 modularized the compilation in the predicate compiler
bulwahn
parents: 33141
diff changeset
   984
    val fun_const =
35891
3122bdd95275 contextifying the compilation of the predicate compiler
bulwahn
parents: 35889
diff changeset
   985
      Const (function_name_of (Comp_Mod.compilation compilation_modifiers)
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
   986
      ctxt s mode, funT)
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   987
  in
33143
730a2e8a6ec6 modularized the compilation in the predicate compiler
bulwahn
parents: 33141
diff changeset
   988
    HOLogic.mk_Trueprop
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   989
      (HOLogic.mk_eq (list_comb (fun_const, in_ts @ additional_arguments), compilation))
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   990
  end;
33143
730a2e8a6ec6 modularized the compilation in the predicate compiler
bulwahn
parents: 33141
diff changeset
   991
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   992
(* Definition of executable functions and their intro and elim rules *)
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
   993
37591
d3daea901123 merged constants "split" and "prod_case"
haftmann
parents: 37558
diff changeset
   994
fun strip_split_abs (Const (@{const_name prod_case}, _) $ t) = strip_split_abs t
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   995
  | strip_split_abs (Abs (_, _, t)) = strip_split_abs t
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   996
  | strip_split_abs t = t
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
   997
37678
0040bafffdef "prod" and "sum" replace "*" and "+" respectively
haftmann
parents: 37591
diff changeset
   998
fun mk_args is_eval (m as Pair (m1, m2), T as Type (@{type_name Product_Type.prod}, [T1, T2])) names =
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
   999
    if eq_mode (m, Input) orelse eq_mode (m, Output) then
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1000
      let
43324
2b47822868e4 discontinued Name.variant to emphasize that this is old-style / indirect;
wenzelm
parents: 43253
diff changeset
  1001
        val x = singleton (Name.variant_list names) "x"
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1002
      in
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1003
        (Free (x, T), x :: names)
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1004
      end
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1005
    else
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1006
      let
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1007
        val (t1, names') = mk_args is_eval (m1, T1) names
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1008
        val (t2, names'') = mk_args is_eval (m2, T2) names'
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1009
      in
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1010
        (HOLogic.mk_prod (t1, t2), names'')
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1011
      end
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1012
  | mk_args is_eval ((m as Fun _), T) names =
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1013
    let
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1014
      val funT = funT_of Predicate_Comp_Funs.compfuns m T
43324
2b47822868e4 discontinued Name.variant to emphasize that this is old-style / indirect;
wenzelm
parents: 43253
diff changeset
  1015
      val x = singleton (Name.variant_list names) "x"
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1016
      val (args, _) = fold_map (mk_args is_eval) (strip_fun_mode m ~~ binder_types T) (x :: names)
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1017
      val (inargs, outargs) = split_map_mode (fn _ => fn t => (SOME t, NONE)) m args
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1018
      val t = fold_rev HOLogic.tupled_lambda args (Predicate_Comp_Funs.mk_Eval
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1019
        (list_comb (Free (x, funT), inargs), HOLogic.mk_tuple outargs))
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1020
    in
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1021
      (if is_eval then t else Free (x, funT), x :: names)
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1022
    end
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1023
  | mk_args is_eval (_, T) names =
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1024
    let
43324
2b47822868e4 discontinued Name.variant to emphasize that this is old-style / indirect;
wenzelm
parents: 43253
diff changeset
  1025
      val x = singleton (Name.variant_list names) "x"
33268
02de0317f66f eliminated hard tabulators, guessing at each author's individual tab-width;
wenzelm
parents: 33265
diff changeset
  1026
    in
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1027
      (Free (x, T), x :: names)
33268
02de0317f66f eliminated hard tabulators, guessing at each author's individual tab-width;
wenzelm
parents: 33265
diff changeset
  1028
    end
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1029
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
  1030
fun create_intro_elim_rule ctxt mode defthm mode_id funT pred =
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1031
  let
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1032
    val funtrm = Const (mode_id, funT)
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1033
    val Ts = binder_types (fastype_of pred)
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1034
    val (args, argnames) = fold_map (mk_args true) (strip_fun_mode mode ~~ Ts) []
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1035
    fun strip_eval _ t =
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1036
      let
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1037
        val t' = strip_split_abs t
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1038
        val (r, _) = Predicate_Comp_Funs.dest_Eval t'
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1039
      in (SOME (fst (strip_comb r)), NONE) end
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1040
    val (inargs, outargs) = split_map_mode strip_eval mode args
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1041
    val eval_hoargs = ho_args_of mode args
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1042
    val hoargTs = ho_argsT_of mode Ts
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1043
    val hoarg_names' =
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1044
      Name.variant_list argnames ((map (fn i => "x" ^ string_of_int i)) (1 upto (length hoargTs)))
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1045
    val hoargs' = map2 (curry Free) hoarg_names' hoargTs
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1046
    val args' = replace_ho_args mode hoargs' args
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1047
    val predpropI = HOLogic.mk_Trueprop (list_comb (pred, args'))
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1048
    val predpropE = HOLogic.mk_Trueprop (list_comb (pred, args))
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1049
    val param_eqs = map2 (HOLogic.mk_Trueprop oo (curry HOLogic.mk_eq)) eval_hoargs hoargs'
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1050
    val funpropE = HOLogic.mk_Trueprop (Predicate_Comp_Funs.mk_Eval (list_comb (funtrm, inargs),
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1051
                    if null outargs then Free("y", HOLogic.unitT) else HOLogic.mk_tuple outargs))
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1052
    val funpropI = HOLogic.mk_Trueprop (Predicate_Comp_Funs.mk_Eval (list_comb (funtrm, inargs),
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1053
                     HOLogic.mk_tuple outargs))
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1054
    val introtrm = Logic.list_implies (predpropI :: param_eqs, funpropI)
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1055
    val simprules = [defthm, @{thm eval_pred},
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1056
      @{thm "split_beta"}, @{thm "fst_conv"}, @{thm "snd_conv"}, @{thm pair_collapse}]
51717
9e7d1c139569 simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents: 51673
diff changeset
  1057
    val unfolddef_tac =
9e7d1c139569 simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents: 51673
diff changeset
  1058
      Simplifier.asm_full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps simprules) 1
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
  1059
    val introthm = Goal.prove ctxt
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1060
      (argnames @ hoarg_names' @ ["y"]) [] introtrm (fn _ => unfolddef_tac)
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1061
    val P = HOLogic.mk_Trueprop (Free ("P", HOLogic.boolT));
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1062
    val elimtrm = Logic.list_implies ([funpropE, Logic.mk_implies (predpropE, P)], P)
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
  1063
    val elimthm = Goal.prove ctxt
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1064
      (argnames @ ["y", "P"]) [] elimtrm (fn _ => unfolddef_tac)
35884
362bfc2ca0ee adding proof procedure for cases rule with tuples; adding introduction rule for negated premises; improving proof procedure with negated premises
bulwahn
parents: 35881
diff changeset
  1065
    val opt_neg_introthm =
362bfc2ca0ee adding proof procedure for cases rule with tuples; adding introduction rule for negated premises; improving proof procedure with negated premises
bulwahn
parents: 35881
diff changeset
  1066
      if is_all_input mode then
362bfc2ca0ee adding proof procedure for cases rule with tuples; adding introduction rule for negated premises; improving proof procedure with negated premises
bulwahn
parents: 35881
diff changeset
  1067
        let
362bfc2ca0ee adding proof procedure for cases rule with tuples; adding introduction rule for negated premises; improving proof procedure with negated premises
bulwahn
parents: 35881
diff changeset
  1068
          val neg_predpropI = HOLogic.mk_Trueprop (HOLogic.mk_not (list_comb (pred, args')))
362bfc2ca0ee adding proof procedure for cases rule with tuples; adding introduction rule for negated premises; improving proof procedure with negated premises
bulwahn
parents: 35881
diff changeset
  1069
          val neg_funpropI =
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1070
            HOLogic.mk_Trueprop (Predicate_Comp_Funs.mk_Eval
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1071
              (Predicate_Comp_Funs.mk_not (list_comb (funtrm, inargs)), HOLogic.unit))
35884
362bfc2ca0ee adding proof procedure for cases rule with tuples; adding introduction rule for negated premises; improving proof procedure with negated premises
bulwahn
parents: 35881
diff changeset
  1072
          val neg_introtrm = Logic.list_implies (neg_predpropI :: param_eqs, neg_funpropI)
362bfc2ca0ee adding proof procedure for cases rule with tuples; adding introduction rule for negated premises; improving proof procedure with negated premises
bulwahn
parents: 35881
diff changeset
  1073
          val tac =
51717
9e7d1c139569 simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents: 51673
diff changeset
  1074
            Simplifier.asm_full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps
35884
362bfc2ca0ee adding proof procedure for cases rule with tuples; adding introduction rule for negated premises; improving proof procedure with negated premises
bulwahn
parents: 35881
diff changeset
  1075
              (@{thm if_False} :: @{thm Predicate.not_pred_eq} :: simprules)) 1
362bfc2ca0ee adding proof procedure for cases rule with tuples; adding introduction rule for negated premises; improving proof procedure with negated premises
bulwahn
parents: 35881
diff changeset
  1076
            THEN rtac @{thm Predicate.singleI} 1
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
  1077
        in SOME (Goal.prove ctxt (argnames @ hoarg_names') []
35884
362bfc2ca0ee adding proof procedure for cases rule with tuples; adding introduction rule for negated premises; improving proof procedure with negated premises
bulwahn
parents: 35881
diff changeset
  1078
            neg_introtrm (fn _ => tac))
362bfc2ca0ee adding proof procedure for cases rule with tuples; adding introduction rule for negated premises; improving proof procedure with negated premises
bulwahn
parents: 35881
diff changeset
  1079
        end
362bfc2ca0ee adding proof procedure for cases rule with tuples; adding introduction rule for negated premises; improving proof procedure with negated premises
bulwahn
parents: 35881
diff changeset
  1080
      else NONE
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1081
  in
35884
362bfc2ca0ee adding proof procedure for cases rule with tuples; adding introduction rule for negated premises; improving proof procedure with negated premises
bulwahn
parents: 35881
diff changeset
  1082
    ((introthm, elimthm), opt_neg_introthm)
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1083
  end
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1084
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
  1085
fun create_constname_of_mode options thy prefix name _ mode = 
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1086
  let
33626
42f69386943a new names for predicate functions in the predicate compiler
bulwahn
parents: 33623
diff changeset
  1087
    val system_proposal = prefix ^ (Long_Name.base_name name)
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1088
      ^ "_" ^ ascii_string_of_mode mode
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1089
    val name = the_default system_proposal (proposed_names options name mode)
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1090
  in
33620
b6bf2dc5aed7 added interface of user proposals for names of generated constants
bulwahn
parents: 33619
diff changeset
  1091
    Sign.full_bname thy name
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1092
  end;
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1093
33620
b6bf2dc5aed7 added interface of user proposals for names of generated constants
bulwahn
parents: 33619
diff changeset
  1094
fun create_definitions options preds (name, modes) thy =
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1095
  let
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1096
    val compfuns = Predicate_Comp_Funs.compfuns
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1097
    val T = AList.lookup (op =) preds name |> the
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1098
    fun create_definition mode thy =
33752
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
  1099
      let
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
  1100
        val mode_cname = create_constname_of_mode options thy "" name T mode
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
  1101
        val mode_cbasename = Long_Name.base_name mode_cname
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1102
        val funT = funT_of compfuns mode T
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1103
        val (args, _) = fold_map (mk_args true) ((strip_fun_mode mode) ~~ (binder_types T)) []
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
  1104
        fun strip_eval _ t =
33752
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
  1105
          let
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1106
            val t' = strip_split_abs t
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1107
            val (r, _) = Predicate_Comp_Funs.dest_Eval t'
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1108
          in (SOME (fst (strip_comb r)), NONE) end
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1109
        val (inargs, outargs) = split_map_mode strip_eval mode args
39756
6c8e83d94536 consolidated tupled_lambda; moved to structure HOLogic
krauss
parents: 39685
diff changeset
  1110
        val predterm = fold_rev HOLogic.tupled_lambda inargs
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1111
          (Predicate_Comp_Funs.mk_Enum (HOLogic.tupled_lambda (HOLogic.mk_tuple outargs)
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1112
            (list_comb (Const (name, T), args))))
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1113
        val lhs = Const (mode_cname, funT)
33752
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
  1114
        val def = Logic.mk_equals (lhs, predterm)
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
  1115
        val ([definition], thy') = thy |>
9aa8e961f850 adopting proposed_modes; adding a new dimension of complexity for nicer error messages; tuned
bulwahn
parents: 33671
diff changeset
  1116
          Sign.add_consts_i [(Binding.name mode_cbasename, funT, NoSyn)] |>
46909
3c73a121a387 more explicit indication of def names;
wenzelm
parents: 46614
diff changeset
  1117
          Global_Theory.add_defs false [((Binding.name (Thm.def_name mode_cbasename), def), [])]
42361
23f352990944 modernized structure Proof_Context;
wenzelm
parents: 42141
diff changeset
  1118
        val ctxt' = Proof_Context.init_global thy'
35884
362bfc2ca0ee adding proof procedure for cases rule with tuples; adding introduction rule for negated premises; improving proof procedure with negated premises
bulwahn
parents: 35881
diff changeset
  1119
        val rules as ((intro, elim), _) =
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
  1120
          create_intro_elim_rule ctxt' mode definition mode_cname funT (Const (name, T))
52788
da1fdbfebd39 type theory is purely value-oriented;
wenzelm
parents: 51717
diff changeset
  1121
        in
da1fdbfebd39 type theory is purely value-oriented;
wenzelm
parents: 51717
diff changeset
  1122
          thy'
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1123
          |> set_function_name Pred name mode mode_cname
35884
362bfc2ca0ee adding proof procedure for cases rule with tuples; adding introduction rule for negated premises; improving proof procedure with negated premises
bulwahn
parents: 35881
diff changeset
  1124
          |> add_predfun_data name mode (definition, rules)
39557
fe5722fce758 renamed structure PureThy to Pure_Thy and moved most content to Global_Theory, to emphasize that this is global-only;
wenzelm
parents: 39545
diff changeset
  1125
          |> Global_Theory.store_thm (Binding.name (mode_cbasename ^ "I"), intro) |> snd
fe5722fce758 renamed structure PureThy to Pure_Thy and moved most content to Global_Theory, to emphasize that this is global-only;
wenzelm
parents: 39545
diff changeset
  1126
          |> Global_Theory.store_thm (Binding.name (mode_cbasename ^ "E"), elim)  |> snd
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1127
        end;
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1128
  in
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1129
    thy |> defined_function_of Pred name |> fold create_definition modes
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1130
  end;
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1131
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
  1132
fun define_functions comp_modifiers _ options preds (name, modes) thy =
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1133
  let
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1134
    val T = AList.lookup (op =) preds name |> the
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1135
    fun create_definition mode thy =
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1136
      let
33485
0df4f6e46e5e made definition of functions generically for the different instances
bulwahn
parents: 33484
diff changeset
  1137
        val function_name_prefix = Comp_Mod.function_name_prefix comp_modifiers
33620
b6bf2dc5aed7 added interface of user proposals for names of generated constants
bulwahn
parents: 33619
diff changeset
  1138
        val mode_cname = create_constname_of_mode options thy function_name_prefix name T mode
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1139
        val funT = Comp_Mod.funT_of comp_modifiers mode T
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1140
      in
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1141
        thy |> Sign.add_consts_i [(Binding.name (Long_Name.base_name mode_cname), funT, NoSyn)]
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1142
        |> set_function_name (Comp_Mod.compilation comp_modifiers) name mode mode_cname
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1143
      end;
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1144
  in
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1145
    thy
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1146
    |> defined_function_of (Comp_Mod.compilation comp_modifiers) name
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1147
    |> fold create_definition modes
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1148
  end;
32672
90f3ce5d27ae added first version of quickcheck based on the predicate compiler; added a few quickcheck examples
bulwahn
parents: 32671
diff changeset
  1149
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1150
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1151
(* composition of mode inference, definition, compilation and proof *)
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1152
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1153
(** auxillary combinators for table of preds and modes **)
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1154
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1155
fun map_preds_modes f preds_modes_table =
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1156
  map (fn (pred, modes) =>
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1157
    (pred, map (fn (mode, value) => (mode, f pred mode value)) modes)) preds_modes_table
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1158
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1159
fun join_preds_modes table1 table2 =
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1160
  map_preds_modes (fn pred => fn mode => fn value =>
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1161
    (value, the (AList.lookup (op =) (the (AList.lookup (op =) table2 pred)) mode))) table1
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
  1162
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1163
fun maps_modes preds_modes_table =
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1164
  map (fn (pred, modes) =>
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
  1165
    (pred, map (fn (_, value) => value) modes)) preds_modes_table
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
  1166
37005
842a73dc6d0e changing compilation to work only with contexts; adapting quickcheck
bulwahn
parents: 37004
diff changeset
  1167
fun compile_preds options comp_modifiers ctxt all_vs param_vs preds moded_clauses =
842a73dc6d0e changing compilation to work only with contexts; adapting quickcheck
bulwahn
parents: 37004
diff changeset
  1168
  map_preds_modes (fn pred => compile_pred options comp_modifiers ctxt all_vs param_vs pred
33143
730a2e8a6ec6 modularized the compilation in the predicate compiler
bulwahn
parents: 33141
diff changeset
  1169
      (the (AList.lookup (op =) preds pred))) moded_clauses
730a2e8a6ec6 modularized the compilation in the predicate compiler
bulwahn
parents: 33141
diff changeset
  1170
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1171
fun prove options thy clauses preds moded_clauses compiled_terms =
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1172
  map_preds_modes (prove_pred options thy clauses preds)
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1173
    (join_preds_modes moded_clauses compiled_terms)
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1174
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
  1175
fun prove_by_skip _ thy _ _ _ compiled_terms =
35021
c839a4c670c6 renamed old-style Drule.standard to Drule.export_without_context, to emphasize that this is in no way a standard operation;
wenzelm
parents: 34974
diff changeset
  1176
  map_preds_modes
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
  1177
    (fn _ => fn _ => fn t => Drule.export_without_context (Skip_Proof.make_thm thy t))
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1178
    compiled_terms
33106
7a1636c3ffc9 extended core of predicate compiler to expand tuples in introduction rules
bulwahn
parents: 32740
diff changeset
  1179
33376
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1180
(* preparation of introduction rules into special datastructures *)
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
  1181
fun dest_prem ctxt params t =
33106
7a1636c3ffc9 extended core of predicate compiler to expand tuples in introduction rules
bulwahn
parents: 32740
diff changeset
  1182
  (case strip_comb t of
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
  1183
    (v as Free _, _) => if member (op =) params v then Prem t else Sidecond t
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
  1184
  | (c as Const (@{const_name Not}, _), [t]) => (case dest_prem ctxt params t of
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1185
      Prem t => Negprem t
33482
5029ec373036 strictly respecting the line margin in the predicate compiler core
bulwahn
parents: 33479
diff changeset
  1186
    | Negprem _ => error ("Double negation not allowed in premise: " ^
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
  1187
        Syntax.string_of_term ctxt (c $ t)) 
33106
7a1636c3ffc9 extended core of predicate compiler to expand tuples in introduction rules
bulwahn
parents: 32740
diff changeset
  1188
    | Sidecond t => Sidecond (c $ t))
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
  1189
  | (Const (s, _), _) =>
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
  1190
    if is_registered ctxt s then Prem t else Sidecond t
33106
7a1636c3ffc9 extended core of predicate compiler to expand tuples in introduction rules
bulwahn
parents: 32740
diff changeset
  1191
  | _ => Sidecond t)
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1192
39310
17ef4415b17c removing obsolete argument in prepare_intrs; passing context instead of theory in prepare_intrs
bulwahn
parents: 39299
diff changeset
  1193
fun prepare_intrs options ctxt prednames intros =
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1194
  let
42361
23f352990944 modernized structure Proof_Context;
wenzelm
parents: 42141
diff changeset
  1195
    val thy = Proof_Context.theory_of ctxt
33126
bb8806eb5da7 importing of polymorphic introduction rules with different schematic variable names
bulwahn
parents: 33124
diff changeset
  1196
    val intrs = map prop_of intros
33146
bf852ef586f2 now the predicate compilere handles the predicate without introduction rules better as before
bulwahn
parents: 33145
diff changeset
  1197
    val preds = map (fn c => Const (c, Sign.the_const_type thy c)) prednames
bf852ef586f2 now the predicate compilere handles the predicate without introduction rules better as before
bulwahn
parents: 33145
diff changeset
  1198
    val (preds, intrs) = unify_consts thy preds intrs
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
  1199
    val ([preds, intrs], _) = fold_burrow (Variable.import_terms false) [preds, intrs] ctxt
33126
bb8806eb5da7 importing of polymorphic introduction rules with different schematic variable names
bulwahn
parents: 33124
diff changeset
  1200
    val preds = map dest_Const preds
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1201
    val all_vs = terms_vs intrs
39201
234e6ef4ff67 using the proposed modes for starting the fixpoint iteration in the mode analysis
bulwahn
parents: 39194
diff changeset
  1202
    fun generate_modes s T =
234e6ef4ff67 using the proposed modes for starting the fixpoint iteration in the mode analysis
bulwahn
parents: 39194
diff changeset
  1203
      if member (op =) (no_higher_order_predicate options) s then
234e6ef4ff67 using the proposed modes for starting the fixpoint iteration in the mode analysis
bulwahn
parents: 39194
diff changeset
  1204
        all_smodes_of_typ T
234e6ef4ff67 using the proposed modes for starting the fixpoint iteration in the mode analysis
bulwahn
parents: 39194
diff changeset
  1205
      else
234e6ef4ff67 using the proposed modes for starting the fixpoint iteration in the mode analysis
bulwahn
parents: 39194
diff changeset
  1206
        all_modes_of_typ T
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1207
    val all_modes = 
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1208
      map (fn (s, T) =>
39382
c797f3ab2ae1 proposed modes for code_pred now supports modes for mutual predicates
bulwahn
parents: 39310
diff changeset
  1209
        (s, case proposed_modes options s of
39651
2e06dad03dd3 adding check if user-given modes match type of predicates; removed useless function expand_tuples_elim
bulwahn
parents: 39649
diff changeset
  1210
            SOME ms => check_matches_type ctxt s T ms
39201
234e6ef4ff67 using the proposed modes for starting the fixpoint iteration in the mode analysis
bulwahn
parents: 39194
diff changeset
  1211
          | NONE => generate_modes s T)) preds
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1212
    val params =
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1213
      case intrs of
33146
bf852ef586f2 now the predicate compilere handles the predicate without introduction rules better as before
bulwahn
parents: 33145
diff changeset
  1214
        [] =>
bf852ef586f2 now the predicate compilere handles the predicate without introduction rules better as before
bulwahn
parents: 33145
diff changeset
  1215
          let
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1216
            val T = snd (hd preds)
39764
1cf2088cf035 only modes but not types are used to destruct terms and types; this allows to interpret arguments that are predicates simply as input
bulwahn
parents: 39763
diff changeset
  1217
            val one_mode = hd (the (AList.lookup (op =) all_modes (fst (hd preds))))
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1218
            val paramTs =
39764
1cf2088cf035 only modes but not types are used to destruct terms and types; this allows to interpret arguments that are predicates simply as input
bulwahn
parents: 39763
diff changeset
  1219
              ho_argsT_of one_mode (binder_types T)
33482
5029ec373036 strictly respecting the line margin in the predicate compiler core
bulwahn
parents: 33479
diff changeset
  1220
            val param_names = Name.variant_list [] (map (fn i => "p" ^ string_of_int i)
5029ec373036 strictly respecting the line margin in the predicate compiler core
bulwahn
parents: 33479
diff changeset
  1221
              (1 upto length paramTs))
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1222
          in
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1223
            map2 (curry Free) param_names paramTs
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1224
          end
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1225
      | (intr :: _) =>
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1226
        let
39764
1cf2088cf035 only modes but not types are used to destruct terms and types; this allows to interpret arguments that are predicates simply as input
bulwahn
parents: 39763
diff changeset
  1227
          val (p, args) = strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl intr))
1cf2088cf035 only modes but not types are used to destruct terms and types; this allows to interpret arguments that are predicates simply as input
bulwahn
parents: 39763
diff changeset
  1228
          val one_mode = hd (the (AList.lookup (op =) all_modes (fst (dest_Const p))))
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1229
        in
39764
1cf2088cf035 only modes but not types are used to destruct terms and types; this allows to interpret arguments that are predicates simply as input
bulwahn
parents: 39763
diff changeset
  1230
          ho_args_of one_mode args
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1231
        end
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1232
    val param_vs = map (fst o dest_Free) params
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1233
    fun add_clause intr clauses =
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1234
      let
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
  1235
        val (Const (name, _), ts) = strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl intr))
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
  1236
        val prems = map (dest_prem ctxt params o HOLogic.dest_Trueprop) (Logic.strip_imp_prems intr)
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1237
      in
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1238
        AList.update op = (name, these (AList.lookup op = clauses name) @
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1239
          [(ts, prems)]) clauses
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1240
      end;
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1241
    val clauses = fold add_clause intrs []
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1242
  in
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1243
    (preds, all_vs, param_vs, all_modes, clauses)
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1244
  end;
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1245
33376
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1246
(* sanity check of introduction rules *)
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1247
(* TODO: rethink check with new modes *)
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1248
(*
33106
7a1636c3ffc9 extended core of predicate compiler to expand tuples in introduction rules
bulwahn
parents: 32740
diff changeset
  1249
fun check_format_of_intro_rule thy intro =
7a1636c3ffc9 extended core of predicate compiler to expand tuples in introduction rules
bulwahn
parents: 32740
diff changeset
  1250
  let
7a1636c3ffc9 extended core of predicate compiler to expand tuples in introduction rules
bulwahn
parents: 32740
diff changeset
  1251
    val concl = Logic.strip_imp_concl (prop_of intro)
7a1636c3ffc9 extended core of predicate compiler to expand tuples in introduction rules
bulwahn
parents: 32740
diff changeset
  1252
    val (p, args) = strip_comb (HOLogic.dest_Trueprop concl)
33629
5f35cf91c6a4 improving code quality thanks to Florian's code review
bulwahn
parents: 33628
diff changeset
  1253
    val params = fst (chop (nparams_of thy (fst (dest_Const p))) args)
33106
7a1636c3ffc9 extended core of predicate compiler to expand tuples in introduction rules
bulwahn
parents: 32740
diff changeset
  1254
    fun check_arg arg = case HOLogic.strip_tupleT (fastype_of arg) of
7a1636c3ffc9 extended core of predicate compiler to expand tuples in introduction rules
bulwahn
parents: 32740
diff changeset
  1255
      (Ts as _ :: _ :: _) =>
33629
5f35cf91c6a4 improving code quality thanks to Florian's code review
bulwahn
parents: 33628
diff changeset
  1256
        if length (HOLogic.strip_tuple arg) = length Ts then
5f35cf91c6a4 improving code quality thanks to Florian's code review
bulwahn
parents: 33628
diff changeset
  1257
          true
33114
4785ef554dcc added further examples; added mode to code_pred command; tuned; some temporary things in Predicate_Compile_ex
bulwahn
parents: 33113
diff changeset
  1258
        else
33629
5f35cf91c6a4 improving code quality thanks to Florian's code review
bulwahn
parents: 33628
diff changeset
  1259
          error ("Format of introduction rule is invalid: tuples must be expanded:"
5f35cf91c6a4 improving code quality thanks to Florian's code review
bulwahn
parents: 33628
diff changeset
  1260
          ^ (Syntax.string_of_term_global thy arg) ^ " in " ^
5f35cf91c6a4 improving code quality thanks to Florian's code review
bulwahn
parents: 33628
diff changeset
  1261
          (Display.string_of_thm_global thy intro)) 
33106
7a1636c3ffc9 extended core of predicate compiler to expand tuples in introduction rules
bulwahn
parents: 32740
diff changeset
  1262
      | _ => true
7a1636c3ffc9 extended core of predicate compiler to expand tuples in introduction rules
bulwahn
parents: 32740
diff changeset
  1263
    val prems = Logic.strip_imp_prems (prop_of intro)
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1264
    fun check_prem (Prem t) = forall check_arg args
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1265
      | check_prem (Negprem t) = forall check_arg args
33106
7a1636c3ffc9 extended core of predicate compiler to expand tuples in introduction rules
bulwahn
parents: 32740
diff changeset
  1266
      | check_prem _ = true
7a1636c3ffc9 extended core of predicate compiler to expand tuples in introduction rules
bulwahn
parents: 32740
diff changeset
  1267
  in
7a1636c3ffc9 extended core of predicate compiler to expand tuples in introduction rules
bulwahn
parents: 32740
diff changeset
  1268
    forall check_arg args andalso
7a1636c3ffc9 extended core of predicate compiler to expand tuples in introduction rules
bulwahn
parents: 32740
diff changeset
  1269
    forall (check_prem o dest_prem thy params o HOLogic.dest_Trueprop) prems
7a1636c3ffc9 extended core of predicate compiler to expand tuples in introduction rules
bulwahn
parents: 32740
diff changeset
  1270
  end
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1271
*)
33124
5378e61add1a continued cleaning up; moved tuple expanding to core
bulwahn
parents: 33123
diff changeset
  1272
(*
5378e61add1a continued cleaning up; moved tuple expanding to core
bulwahn
parents: 33123
diff changeset
  1273
fun check_intros_elim_match thy prednames =
5378e61add1a continued cleaning up; moved tuple expanding to core
bulwahn
parents: 33123
diff changeset
  1274
  let
5378e61add1a continued cleaning up; moved tuple expanding to core
bulwahn
parents: 33123
diff changeset
  1275
    fun check predname =
5378e61add1a continued cleaning up; moved tuple expanding to core
bulwahn
parents: 33123
diff changeset
  1276
      let
5378e61add1a continued cleaning up; moved tuple expanding to core
bulwahn
parents: 33123
diff changeset
  1277
        val intros = intros_of thy predname
5378e61add1a continued cleaning up; moved tuple expanding to core
bulwahn
parents: 33123
diff changeset
  1278
        val elim = the_elim_of thy predname
5378e61add1a continued cleaning up; moved tuple expanding to core
bulwahn
parents: 33123
diff changeset
  1279
        val nparams = nparams_of thy predname
5378e61add1a continued cleaning up; moved tuple expanding to core
bulwahn
parents: 33123
diff changeset
  1280
        val elim' =
35021
c839a4c670c6 renamed old-style Drule.standard to Drule.export_without_context, to emphasize that this is in no way a standard operation;
wenzelm
parents: 34974
diff changeset
  1281
          (Drule.export_without_context o Skip_Proof.make_thm thy)
42361
23f352990944 modernized structure Proof_Context;
wenzelm
parents: 42141
diff changeset
  1282
          (mk_casesrule (Proof_Context.init_global thy) nparams intros)
33124
5378e61add1a continued cleaning up; moved tuple expanding to core
bulwahn
parents: 33123
diff changeset
  1283
      in
5378e61add1a continued cleaning up; moved tuple expanding to core
bulwahn
parents: 33123
diff changeset
  1284
        if not (Thm.equiv_thm (elim, elim')) then
5378e61add1a continued cleaning up; moved tuple expanding to core
bulwahn
parents: 33123
diff changeset
  1285
          error "Introduction and elimination rules do not match!"
5378e61add1a continued cleaning up; moved tuple expanding to core
bulwahn
parents: 33123
diff changeset
  1286
        else true
5378e61add1a continued cleaning up; moved tuple expanding to core
bulwahn
parents: 33123
diff changeset
  1287
      end
5378e61add1a continued cleaning up; moved tuple expanding to core
bulwahn
parents: 33123
diff changeset
  1288
  in forall check prednames end
5378e61add1a continued cleaning up; moved tuple expanding to core
bulwahn
parents: 33123
diff changeset
  1289
*)
33113
0f6e30b87cf1 processing of tuples in introduction rules
bulwahn
parents: 33112
diff changeset
  1290
33376
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1291
(* create code equation *)
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1292
37007
116670499530 changing operations for accessing data to work with contexts
bulwahn
parents: 37006
diff changeset
  1293
fun add_code_equations ctxt preds result_thmss =
33376
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1294
  let
33629
5f35cf91c6a4 improving code quality thanks to Florian's code review
bulwahn
parents: 33628
diff changeset
  1295
    fun add_code_equation (predname, T) (pred, result_thms) =
33376
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1296
      let
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1297
        val full_mode = fold_rev (curry Fun) (map (K Input) (binder_types T)) Bool
33376
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1298
      in
47329
b9e115d4c5da improved equality check for modes in predicate compiler
bulwahn
parents: 47248
diff changeset
  1299
        if member eq_mode  (modes_of Pred ctxt predname) full_mode then
33376
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1300
          let
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1301
            val Ts = binder_types T
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1302
            val arg_names = Name.variant_list []
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1303
              (map (fn i => "x" ^ string_of_int i) (1 upto length Ts))
33629
5f35cf91c6a4 improving code quality thanks to Florian's code review
bulwahn
parents: 33628
diff changeset
  1304
            val args = map2 (curry Free) arg_names Ts
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
  1305
            val predfun = Const (function_name_of Pred ctxt predname full_mode,
45461
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
  1306
              Ts ---> Predicate_Comp_Funs.mk_monadT @{typ unit})
33754
f2957bd46faf adding derived constant Predicate.holds to Predicate theory; adopting the predicate compiler
bulwahn
parents: 33753
diff changeset
  1307
            val rhs = @{term Predicate.holds} $ (list_comb (predfun, args))
33376
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1308
            val eq_term = HOLogic.mk_Trueprop
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1309
              (HOLogic.mk_eq (list_comb (Const (predname, T), args), rhs))
35888
d902054e7ac6 contextifying the proof procedure in the predicate compiler
bulwahn
parents: 35887
diff changeset
  1310
            val def = predfun_definition_of ctxt predname full_mode
33441
99a5f22a967d eliminated funny record patterns and made SML/NJ happy;
wenzelm
parents: 33377
diff changeset
  1311
            val tac = fn _ => Simplifier.simp_tac
51717
9e7d1c139569 simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents: 51673
diff changeset
  1312
              (put_simpset HOL_basic_ss ctxt addsimps [def, @{thm holds_eq}, @{thm eval_pred}]) 1
35888
d902054e7ac6 contextifying the proof procedure in the predicate compiler
bulwahn
parents: 35887
diff changeset
  1313
            val eq = Goal.prove ctxt arg_names [] eq_term tac
33376
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1314
          in
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1315
            (pred, result_thms @ [eq])
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1316
          end
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1317
        else
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1318
          (pred, result_thms)
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1319
      end
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1320
  in
33629
5f35cf91c6a4 improving code quality thanks to Florian's code review
bulwahn
parents: 33628
diff changeset
  1321
    map2 add_code_equation preds result_thmss
33376
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1322
  end
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1323
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1324
(** main function of predicate compiler **)
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1325
33330
d6eb7f19bfc6 encapsulating records with datatype constructors and adding type annotations to make SML/NJ happy
bulwahn
parents: 33328
diff changeset
  1326
datatype steps = Steps of
d6eb7f19bfc6 encapsulating records with datatype constructors and adding type annotations to make SML/NJ happy
bulwahn
parents: 33328
diff changeset
  1327
  {
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1328
  define_functions : options -> (string * typ) list -> string * (bool * mode) list -> theory -> theory,
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1329
  prove : options -> theory -> (string * (term list * indprem list) list) list -> (string * typ) list
33330
d6eb7f19bfc6 encapsulating records with datatype constructors and adding type annotations to make SML/NJ happy
bulwahn
parents: 33328
diff changeset
  1330
    -> moded_clause list pred_mode_table -> term pred_mode_table -> thm pred_mode_table,
37007
116670499530 changing operations for accessing data to work with contexts
bulwahn
parents: 37006
diff changeset
  1331
  add_code_equations : Proof.context -> (string * typ) list
33376
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1332
    -> (string * thm list) list -> (string * thm list) list,
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1333
  comp_modifiers : Comp_Mod.comp_modifiers,
39761
c2a76ec6e2d9 renaming use_random to use_generators in the predicate compiler
bulwahn
parents: 39760
diff changeset
  1334
  use_generators : bool,
33330
d6eb7f19bfc6 encapsulating records with datatype constructors and adding type annotations to make SML/NJ happy
bulwahn
parents: 33328
diff changeset
  1335
  qname : bstring
d6eb7f19bfc6 encapsulating records with datatype constructors and adding type annotations to make SML/NJ happy
bulwahn
parents: 33328
diff changeset
  1336
  }
d6eb7f19bfc6 encapsulating records with datatype constructors and adding type annotations to make SML/NJ happy
bulwahn
parents: 33328
diff changeset
  1337
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1338
fun add_equations_of steps mode_analysis_options options prednames thy =
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1339
  let
33330
d6eb7f19bfc6 encapsulating records with datatype constructors and adding type annotations to make SML/NJ happy
bulwahn
parents: 33328
diff changeset
  1340
    fun dest_steps (Steps s) = s
35879
99818df5b8f5 reviving the classical depth-limited computation in the predicate compiler
bulwahn
parents: 35845
diff changeset
  1341
    val compilation = Comp_Mod.compilation (#comp_modifiers (dest_steps steps))
42361
23f352990944 modernized structure Proof_Context;
wenzelm
parents: 42141
diff changeset
  1342
    val ctxt = Proof_Context.init_global thy
33482
5029ec373036 strictly respecting the line margin in the predicate compiler core
bulwahn
parents: 33479
diff changeset
  1343
    val _ = print_step options
35879
99818df5b8f5 reviving the classical depth-limited computation in the predicate compiler
bulwahn
parents: 35845
diff changeset
  1344
      ("Starting predicate compiler (compilation: " ^ string_of_compilation compilation
99818df5b8f5 reviving the classical depth-limited computation in the predicate compiler
bulwahn
parents: 35845
diff changeset
  1345
        ^ ") for predicates " ^ commas prednames ^ "...")
33124
5378e61add1a continued cleaning up; moved tuple expanding to core
bulwahn
parents: 33123
diff changeset
  1346
      (*val _ = check_intros_elim_match thy prednames*)
33114
4785ef554dcc added further examples; added mode to code_pred command; tuned; some temporary things in Predicate_Compile_ex
bulwahn
parents: 33113
diff changeset
  1347
      (*val _ = map (check_format_of_intro_rule thy) (maps (intros_of thy) prednames)*)
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1348
    val _ =
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1349
      if show_intermediate_results options then
37007
116670499530 changing operations for accessing data to work with contexts
bulwahn
parents: 37006
diff changeset
  1350
        tracing (commas (map (Display.string_of_thm ctxt) (maps (intros_of ctxt) prednames)))
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1351
      else ()
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1352
    val (preds, all_vs, param_vs, all_modes, clauses) =
39310
17ef4415b17c removing obsolete argument in prepare_intrs; passing context instead of theory in prepare_intrs
bulwahn
parents: 39299
diff changeset
  1353
      prepare_intrs options ctxt prednames (maps (intros_of ctxt) prednames)
33123
3c7c4372f9ad cleaned up debugging messages; added options to code_pred command
bulwahn
parents: 33120
diff changeset
  1354
    val _ = print_step options "Infering modes..."
39273
92aa2a0f7399 refactoring mode inference so that the theory is not changed in the mode inference procedure
bulwahn
parents: 39201
diff changeset
  1355
    val (lookup_mode, lookup_neg_mode, needs_random) = (modes_of compilation ctxt,
92aa2a0f7399 refactoring mode inference so that the theory is not changed in the mode inference procedure
bulwahn
parents: 39201
diff changeset
  1356
      modes_of (negative_compilation_of compilation) ctxt, needs_random ctxt)
92aa2a0f7399 refactoring mode inference so that the theory is not changed in the mode inference procedure
bulwahn
parents: 39201
diff changeset
  1357
    val ((moded_clauses, needs_random), errors) =
42088
8d00484551fe making quickcheck's result value more formal; allowing more result information to be returned after timeout; adding output of timing information in quickcheck
bulwahn
parents: 42011
diff changeset
  1358
      cond_timeit (Config.get ctxt Quickcheck.timing) "Infering modes"
36251
5fd5d732a4ea only add relevant predicates to the list of extra modes
bulwahn
parents: 36247
diff changeset
  1359
      (fn _ => infer_modes mode_analysis_options
39273
92aa2a0f7399 refactoring mode inference so that the theory is not changed in the mode inference procedure
bulwahn
parents: 39201
diff changeset
  1360
        options (lookup_mode, lookup_neg_mode, needs_random) ctxt preds all_modes param_vs clauses)
92aa2a0f7399 refactoring mode inference so that the theory is not changed in the mode inference procedure
bulwahn
parents: 39201
diff changeset
  1361
    val thy' = fold (fn (s, ms) => set_needs_random s ms) needs_random thy
33132
07efd452a698 moved argument expected_modes into options; improved mode check to only check mode of the named predicate
bulwahn
parents: 33131
diff changeset
  1362
    val modes = map (fn (p, mps) => (p, map fst mps)) moded_clauses
40138
432a776c4aee options as first argument to check functions
bulwahn
parents: 40135
diff changeset
  1363
    val _ = check_expected_modes options preds modes
432a776c4aee options as first argument to check functions
bulwahn
parents: 40135
diff changeset
  1364
    val _ = check_proposed_modes options preds modes errors
37004
c62f743e37d4 removing unused argument in print_modes function
bulwahn
parents: 37003
diff changeset
  1365
    val _ = print_modes options modes
33123
3c7c4372f9ad cleaned up debugging messages; added options to code_pred command
bulwahn
parents: 33120
diff changeset
  1366
    val _ = print_step options "Defining executable functions..."
36252
beba03215d8f adding more profiling to the predicate compiler
bulwahn
parents: 36251
diff changeset
  1367
    val thy'' =
42088
8d00484551fe making quickcheck's result value more formal; allowing more result information to be returned after timeout; adding output of timing information in quickcheck
bulwahn
parents: 42011
diff changeset
  1368
      cond_timeit (Config.get ctxt Quickcheck.timing) "Defining executable functions..."
52788
da1fdbfebd39 type theory is purely value-oriented;
wenzelm
parents: 51717
diff changeset
  1369
      (fn _ => fold (#define_functions (dest_steps steps) options preds) modes thy')
42361
23f352990944 modernized structure Proof_Context;
wenzelm
parents: 42141
diff changeset
  1370
    val ctxt'' = Proof_Context.init_global thy''
33123
3c7c4372f9ad cleaned up debugging messages; added options to code_pred command
bulwahn
parents: 33120
diff changeset
  1371
    val _ = print_step options "Compiling equations..."
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1372
    val compiled_terms =
42088
8d00484551fe making quickcheck's result value more formal; allowing more result information to be returned after timeout; adding output of timing information in quickcheck
bulwahn
parents: 42011
diff changeset
  1373
      cond_timeit (Config.get ctxt Quickcheck.timing) "Compiling equations...." (fn _ =>
36254
95ef0a3cf31c added switch detection to the predicate compiler
bulwahn
parents: 36252
diff changeset
  1374
        compile_preds options
37005
842a73dc6d0e changing compilation to work only with contexts; adapting quickcheck
bulwahn
parents: 37004
diff changeset
  1375
          (#comp_modifiers (dest_steps steps)) ctxt'' all_vs param_vs preds moded_clauses)
842a73dc6d0e changing compilation to work only with contexts; adapting quickcheck
bulwahn
parents: 37004
diff changeset
  1376
    val _ = print_compiled_terms options ctxt'' compiled_terms
33123
3c7c4372f9ad cleaned up debugging messages; added options to code_pred command
bulwahn
parents: 33120
diff changeset
  1377
    val _ = print_step options "Proving equations..."
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1378
    val result_thms =
42088
8d00484551fe making quickcheck's result value more formal; allowing more result information to be returned after timeout; adding output of timing information in quickcheck
bulwahn
parents: 42011
diff changeset
  1379
      cond_timeit (Config.get ctxt Quickcheck.timing) "Proving equations...." (fn _ =>
36252
beba03215d8f adding more profiling to the predicate compiler
bulwahn
parents: 36251
diff changeset
  1380
      #prove (dest_steps steps) options thy'' clauses preds moded_clauses compiled_terms)
37007
116670499530 changing operations for accessing data to work with contexts
bulwahn
parents: 37006
diff changeset
  1381
    val result_thms' = #add_code_equations (dest_steps steps) ctxt'' preds
33376
5cb663aa48ee predicate compiler creates code equations for predicates with full mode
bulwahn
parents: 33375
diff changeset
  1382
      (maps_modes result_thms)
33330
d6eb7f19bfc6 encapsulating records with datatype constructors and adding type annotations to make SML/NJ happy
bulwahn
parents: 33328
diff changeset
  1383
    val qname = #qname (dest_steps steps)
47248
afacccb4e2c7 simplified;
wenzelm
parents: 46909
diff changeset
  1384
    val attrib = Thm.declaration_attribute (fn thm => Context.mapping (Code.add_eqn thm) I)
36252
beba03215d8f adding more profiling to the predicate compiler
bulwahn
parents: 36251
diff changeset
  1385
    val thy''' =
42088
8d00484551fe making quickcheck's result value more formal; allowing more result information to be returned after timeout; adding output of timing information in quickcheck
bulwahn
parents: 42011
diff changeset
  1386
      cond_timeit (Config.get ctxt Quickcheck.timing) "Setting code equations...." (fn _ =>
39557
fe5722fce758 renamed structure PureThy to Pure_Thy and moved most content to Global_Theory, to emphasize that this is global-only;
wenzelm
parents: 39545
diff changeset
  1387
      fold (fn (name, result_thms) => fn thy => snd (Global_Theory.add_thmss
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1388
      [((Binding.qualify true (Long_Name.base_name name) (Binding.name qname), result_thms),
47248
afacccb4e2c7 simplified;
wenzelm
parents: 46909
diff changeset
  1389
        [attrib])] thy))
52788
da1fdbfebd39 type theory is purely value-oriented;
wenzelm
parents: 51717
diff changeset
  1390
      result_thms' thy'')
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1391
  in
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1392
    thy'''
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1393
  end
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1394
  
33132
07efd452a698 moved argument expected_modes into options; improved mode check to only check mode of the named predicate
bulwahn
parents: 33131
diff changeset
  1395
fun gen_add_equations steps options names thy =
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1396
  let
33330
d6eb7f19bfc6 encapsulating records with datatype constructors and adding type annotations to make SML/NJ happy
bulwahn
parents: 33328
diff changeset
  1397
    fun dest_steps (Steps s) = s
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1398
    val defined = defined_functions (Comp_Mod.compilation (#comp_modifiers (dest_steps steps)))
52788
da1fdbfebd39 type theory is purely value-oriented;
wenzelm
parents: 51717
diff changeset
  1399
    val thy' = extend_intro_graph names thy;
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1400
    fun strong_conn_of gr keys =
46614
165886a4fe64 clarified Graph.restrict (formerly Graph.subgraph) based on public graph operations;
wenzelm
parents: 46219
diff changeset
  1401
      Graph.strong_conn (Graph.restrict (member (op =) (Graph.all_succs gr keys)) gr)
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1402
    val scc = strong_conn_of (PredData.get thy') names
40053
3fa49ea76cbb using a signature in core_data and moving some more functions to core_data
bulwahn
parents: 40052
diff changeset
  1403
    val thy'' = fold preprocess_intros (flat scc) thy'
39657
5e57675b7e40 moving the preprocessing of introduction rules after the code_pred command; added tuple expansion preprocessing of elimination rule
bulwahn
parents: 39653
diff changeset
  1404
    val thy''' = fold_rev
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1405
      (fn preds => fn thy =>
42361
23f352990944 modernized structure Proof_Context;
wenzelm
parents: 42141
diff changeset
  1406
        if not (forall (defined (Proof_Context.init_global thy)) preds) then
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1407
          let
39761
c2a76ec6e2d9 renaming use_random to use_generators in the predicate compiler
bulwahn
parents: 39760
diff changeset
  1408
            val mode_analysis_options = {use_generators = #use_generators (dest_steps steps),
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1409
              reorder_premises =
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1410
                not (no_topmost_reordering options andalso not (null (inter (op =) preds names))),
39761
c2a76ec6e2d9 renaming use_random to use_generators in the predicate compiler
bulwahn
parents: 39760
diff changeset
  1411
              infer_pos_and_neg_modes = #use_generators (dest_steps steps)}
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1412
          in
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1413
            add_equations_of steps mode_analysis_options options preds thy
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1414
          end
33483
a15a2f7f7560 improved handling of already defined functions in the predicate compiler; could cause trouble before when no modes for a predicate were infered
bulwahn
parents: 33482
diff changeset
  1415
        else thy)
52788
da1fdbfebd39 type theory is purely value-oriented;
wenzelm
parents: 51717
diff changeset
  1416
      scc thy''
39657
5e57675b7e40 moving the preprocessing of introduction rules after the code_pred command; added tuple expansion preprocessing of elimination rule
bulwahn
parents: 39653
diff changeset
  1417
  in thy''' end
35879
99818df5b8f5 reviving the classical depth-limited computation in the predicate compiler
bulwahn
parents: 35845
diff changeset
  1418
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1419
val add_equations = gen_add_equations
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1420
  (Steps {
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1421
  define_functions =
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1422
    fn options => fn preds => fn (s, modes) =>
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1423
      create_definitions
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1424
      options preds (s, map_filter (fn (true, m) => SOME m | _ => NONE) modes),
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1425
  prove = prove,
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1426
  add_code_equations = add_code_equations,
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1427
  comp_modifiers = predicate_comp_modifiers,
39761
c2a76ec6e2d9 renaming use_random to use_generators in the predicate compiler
bulwahn
parents: 39760
diff changeset
  1428
  use_generators = false,
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1429
  qname = "equation"})
33143
730a2e8a6ec6 modularized the compilation in the predicate compiler
bulwahn
parents: 33141
diff changeset
  1430
33134
88c9c3460fe7 renamed functions from sizelim to more natural name depth_limited for compilation of depth-limited search in the predicate compiler
bulwahn
parents: 33133
diff changeset
  1431
val add_depth_limited_equations = gen_add_equations
35879
99818df5b8f5 reviving the classical depth-limited computation in the predicate compiler
bulwahn
parents: 35845
diff changeset
  1432
  (Steps {
99818df5b8f5 reviving the classical depth-limited computation in the predicate compiler
bulwahn
parents: 35845
diff changeset
  1433
  define_functions =
99818df5b8f5 reviving the classical depth-limited computation in the predicate compiler
bulwahn
parents: 35845
diff changeset
  1434
    fn options => fn preds => fn (s, modes) =>
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1435
    define_functions depth_limited_comp_modifiers Predicate_Comp_Funs.compfuns
35879
99818df5b8f5 reviving the classical depth-limited computation in the predicate compiler
bulwahn
parents: 35845
diff changeset
  1436
    options preds (s, map_filter (fn (true, m) => SOME m | _ => NONE) modes),
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1437
  prove = prove_by_skip,
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1438
  add_code_equations = K (K I),
35879
99818df5b8f5 reviving the classical depth-limited computation in the predicate compiler
bulwahn
parents: 35845
diff changeset
  1439
  comp_modifiers = depth_limited_comp_modifiers,
39761
c2a76ec6e2d9 renaming use_random to use_generators in the predicate compiler
bulwahn
parents: 39760
diff changeset
  1440
  use_generators = false,
33330
d6eb7f19bfc6 encapsulating records with datatype constructors and adding type annotations to make SML/NJ happy
bulwahn
parents: 33328
diff changeset
  1441
  qname = "depth_limited_equation"})
35879
99818df5b8f5 reviving the classical depth-limited computation in the predicate compiler
bulwahn
parents: 35845
diff changeset
  1442
35880
2623b23e41fc a new simpler random compilation for the predicate compiler
bulwahn
parents: 35879
diff changeset
  1443
val add_random_equations = gen_add_equations
2623b23e41fc a new simpler random compilation for the predicate compiler
bulwahn
parents: 35879
diff changeset
  1444
  (Steps {
2623b23e41fc a new simpler random compilation for the predicate compiler
bulwahn
parents: 35879
diff changeset
  1445
  define_functions =
2623b23e41fc a new simpler random compilation for the predicate compiler
bulwahn
parents: 35879
diff changeset
  1446
    fn options => fn preds => fn (s, modes) =>
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1447
      define_functions random_comp_modifiers Predicate_Comp_Funs.compfuns options preds
35880
2623b23e41fc a new simpler random compilation for the predicate compiler
bulwahn
parents: 35879
diff changeset
  1448
      (s, map_filter (fn (true, m) => SOME m | _ => NONE) modes),
2623b23e41fc a new simpler random compilation for the predicate compiler
bulwahn
parents: 35879
diff changeset
  1449
  comp_modifiers = random_comp_modifiers,
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1450
  prove = prove_by_skip,
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1451
  add_code_equations = K (K I),
39761
c2a76ec6e2d9 renaming use_random to use_generators in the predicate compiler
bulwahn
parents: 39760
diff changeset
  1452
  use_generators = true,
33375
fd3e861f8d31 renamed rpred to random
bulwahn
parents: 33333
diff changeset
  1453
  qname = "random_equation"})
35880
2623b23e41fc a new simpler random compilation for the predicate compiler
bulwahn
parents: 35879
diff changeset
  1454
35881
aa412e08bfee adding depth_limited_random compilation to predicate compiler
bulwahn
parents: 35880
diff changeset
  1455
val add_depth_limited_random_equations = gen_add_equations
aa412e08bfee adding depth_limited_random compilation to predicate compiler
bulwahn
parents: 35880
diff changeset
  1456
  (Steps {
aa412e08bfee adding depth_limited_random compilation to predicate compiler
bulwahn
parents: 35880
diff changeset
  1457
  define_functions =
aa412e08bfee adding depth_limited_random compilation to predicate compiler
bulwahn
parents: 35880
diff changeset
  1458
    fn options => fn preds => fn (s, modes) =>
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1459
      define_functions depth_limited_random_comp_modifiers Predicate_Comp_Funs.compfuns options preds
35881
aa412e08bfee adding depth_limited_random compilation to predicate compiler
bulwahn
parents: 35880
diff changeset
  1460
      (s, map_filter (fn (true, m) => SOME m | _ => NONE) modes),
aa412e08bfee adding depth_limited_random compilation to predicate compiler
bulwahn
parents: 35880
diff changeset
  1461
  comp_modifiers = depth_limited_random_comp_modifiers,
aa412e08bfee adding depth_limited_random compilation to predicate compiler
bulwahn
parents: 35880
diff changeset
  1462
  prove = prove_by_skip,
aa412e08bfee adding depth_limited_random compilation to predicate compiler
bulwahn
parents: 35880
diff changeset
  1463
  add_code_equations = K (K I),
39761
c2a76ec6e2d9 renaming use_random to use_generators in the predicate compiler
bulwahn
parents: 39760
diff changeset
  1464
  use_generators = true,
35881
aa412e08bfee adding depth_limited_random compilation to predicate compiler
bulwahn
parents: 35880
diff changeset
  1465
  qname = "depth_limited_random_equation"})
aa412e08bfee adding depth_limited_random compilation to predicate compiler
bulwahn
parents: 35880
diff changeset
  1466
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1467
val add_dseq_equations = gen_add_equations
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1468
  (Steps {
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1469
  define_functions =
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1470
  fn options => fn preds => fn (s, modes) =>
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1471
    define_functions dseq_comp_modifiers DSequence_CompFuns.compfuns
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1472
    options preds (s, map_filter (fn (true, m) => SOME m | _ => NONE) modes),
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1473
  prove = prove_by_skip,
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1474
  add_code_equations = K (K I),
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1475
  comp_modifiers = dseq_comp_modifiers,
39761
c2a76ec6e2d9 renaming use_random to use_generators in the predicate compiler
bulwahn
parents: 39760
diff changeset
  1476
  use_generators = false,
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1477
  qname = "dseq_equation"})
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1478
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1479
val add_random_dseq_equations = gen_add_equations
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1480
  (Steps {
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1481
  define_functions =
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1482
    fn options => fn preds => fn (s, modes) =>
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1483
    let
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1484
      val pos_modes = map_filter (fn (true, m) => SOME m | _ => NONE) modes
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1485
      val neg_modes = map_filter (fn (false, m) => SOME m | _ => NONE) modes
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1486
    in define_functions pos_random_dseq_comp_modifiers Random_Sequence_CompFuns.compfuns
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1487
      options preds (s, pos_modes)
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1488
      #> define_functions neg_random_dseq_comp_modifiers Random_Sequence_CompFuns.compfuns
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1489
      options preds (s, neg_modes)
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1490
    end,
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1491
  prove = prove_by_skip,
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1492
  add_code_equations = K (K I),
35324
c9f428269b38 adopting mutabelle and quickcheck to return timing information; exporting make_case_combs in datatype package for predicate compiler; adding Spec_Rules declaration for tail recursive functions; improving the predicate compiler and function flattening
bulwahn
parents: 35267
diff changeset
  1493
  comp_modifiers = pos_random_dseq_comp_modifiers,
39761
c2a76ec6e2d9 renaming use_random to use_generators in the predicate compiler
bulwahn
parents: 39760
diff changeset
  1494
  use_generators = true,
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1495
  qname = "random_dseq_equation"})
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1496
36018
096ec83348f3 added new compilation to predicate_compiler
bulwahn
parents: 36004
diff changeset
  1497
val add_new_random_dseq_equations = gen_add_equations
096ec83348f3 added new compilation to predicate_compiler
bulwahn
parents: 36004
diff changeset
  1498
  (Steps {
096ec83348f3 added new compilation to predicate_compiler
bulwahn
parents: 36004
diff changeset
  1499
  define_functions =
096ec83348f3 added new compilation to predicate_compiler
bulwahn
parents: 36004
diff changeset
  1500
    fn options => fn preds => fn (s, modes) =>
096ec83348f3 added new compilation to predicate_compiler
bulwahn
parents: 36004
diff changeset
  1501
    let
096ec83348f3 added new compilation to predicate_compiler
bulwahn
parents: 36004
diff changeset
  1502
      val pos_modes = map_filter (fn (true, m) => SOME m | _ => NONE) modes
096ec83348f3 added new compilation to predicate_compiler
bulwahn
parents: 36004
diff changeset
  1503
      val neg_modes = map_filter (fn (false, m) => SOME m | _ => NONE) modes
40049
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
  1504
    in define_functions new_pos_random_dseq_comp_modifiers New_Pos_Random_Sequence_CompFuns.depth_limited_compfuns
36018
096ec83348f3 added new compilation to predicate_compiler
bulwahn
parents: 36004
diff changeset
  1505
      options preds (s, pos_modes)
40049
75d9f57123d6 adding decreasing bind and non-decreasing bind; depth-limited and depth-unlimited compilation possible
bulwahn
parents: 39785
diff changeset
  1506
      #> define_functions new_neg_random_dseq_comp_modifiers New_Neg_Random_Sequence_CompFuns.depth_limited_compfuns
36018
096ec83348f3 added new compilation to predicate_compiler
bulwahn
parents: 36004
diff changeset
  1507
      options preds (s, neg_modes)
096ec83348f3 added new compilation to predicate_compiler
bulwahn
parents: 36004
diff changeset
  1508
    end,
096ec83348f3 added new compilation to predicate_compiler
bulwahn
parents: 36004
diff changeset
  1509
  prove = prove_by_skip,
096ec83348f3 added new compilation to predicate_compiler
bulwahn
parents: 36004
diff changeset
  1510
  add_code_equations = K (K I),
096ec83348f3 added new compilation to predicate_compiler
bulwahn
parents: 36004
diff changeset
  1511
  comp_modifiers = new_pos_random_dseq_comp_modifiers,
39761
c2a76ec6e2d9 renaming use_random to use_generators in the predicate compiler
bulwahn
parents: 39760
diff changeset
  1512
  use_generators = true,
36018
096ec83348f3 added new compilation to predicate_compiler
bulwahn
parents: 36004
diff changeset
  1513
  qname = "new_random_dseq_equation"})
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1514
40051
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
  1515
val add_generator_dseq_equations = gen_add_equations
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
  1516
  (Steps {
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
  1517
  define_functions =
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
  1518
  fn options => fn preds => fn (s, modes) =>
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
  1519
    let
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
  1520
      val pos_modes = map_filter (fn (true, m) => SOME m | _ => NONE) modes
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
  1521
      val neg_modes = map_filter (fn (false, m) => SOME m | _ => NONE) modes
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
  1522
    in 
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
  1523
      define_functions pos_generator_dseq_comp_modifiers New_Pos_DSequence_CompFuns.depth_limited_compfuns
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
  1524
        options preds (s, pos_modes)
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
  1525
      #> define_functions neg_generator_dseq_comp_modifiers New_Neg_DSequence_CompFuns.depth_limited_compfuns
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
  1526
        options preds (s, neg_modes)
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
  1527
    end,
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
  1528
  prove = prove_by_skip,
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
  1529
  add_code_equations = K (K I),
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
  1530
  comp_modifiers = pos_generator_dseq_comp_modifiers,
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
  1531
  use_generators = true,
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
  1532
  qname = "generator_dseq_equation"})
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
  1533
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1534
val add_generator_cps_equations = gen_add_equations
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1535
  (Steps {
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1536
  define_functions =
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1537
  fn options => fn preds => fn (s, modes) =>
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1538
    let
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1539
      val pos_modes = map_filter (fn (true, m) => SOME m | _ => NONE) modes
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1540
      val neg_modes = map_filter (fn (false, m) => SOME m | _ => NONE) modes
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1541
    in 
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1542
      define_functions pos_generator_cps_comp_modifiers Pos_Bounded_CPS_Comp_Funs.compfuns
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1543
        options preds (s, pos_modes)
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1544
      #> define_functions neg_generator_cps_comp_modifiers Neg_Bounded_CPS_Comp_Funs.compfuns
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1545
        options preds (s, neg_modes)
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1546
    end,
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1547
  prove = prove_by_skip,
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1548
  add_code_equations = K (K I),
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1549
  comp_modifiers = pos_generator_cps_comp_modifiers,
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1550
  use_generators = true,
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1551
  qname = "generator_cps_equation"})
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1552
  
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1553
  
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1554
(** user interface **)
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1555
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1556
(* code_pred_intro attribute *)
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1557
39545
631cf48c7894 code_pred_intro can be used to name facts for the code_pred command
bulwahn
parents: 39477
diff changeset
  1558
fun attrib' f opt_case_name =
631cf48c7894 code_pred_intro can be used to name facts for the code_pred command
bulwahn
parents: 39477
diff changeset
  1559
  Thm.declaration_attribute (fn thm => Context.mapping (f (opt_case_name, thm)) I);
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1560
39545
631cf48c7894 code_pred_intro can be used to name facts for the code_pred command
bulwahn
parents: 39477
diff changeset
  1561
val code_pred_intro_attrib = attrib' add_intro NONE;
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1562
32668
b2de45007537 added first prototype of the extended predicate compiler
bulwahn
parents: 32667
diff changeset
  1563
(*FIXME
b2de45007537 added first prototype of the extended predicate compiler
bulwahn
parents: 32667
diff changeset
  1564
- Naming of auxiliary rules necessary?
b2de45007537 added first prototype of the extended predicate compiler
bulwahn
parents: 32667
diff changeset
  1565
*)
b2de45007537 added first prototype of the extended predicate compiler
bulwahn
parents: 32667
diff changeset
  1566
42141
2c255ba8f299 changing values_timeout from a static option to a dynamic option as required for testing with SML/NJ
bulwahn
parents: 42094
diff changeset
  1567
(* values_timeout configuration *)
2c255ba8f299 changing values_timeout from a static option to a dynamic option as required for testing with SML/NJ
bulwahn
parents: 42094
diff changeset
  1568
45452
414732ebf891 increasing values_timeout to avoid failures of isatest with HOL-IMP
bulwahn
parents: 45450
diff changeset
  1569
val default_values_timeout = if ML_System.is_smlnj then 1200.0 else 40.0
43896
8955dcac6c71 values_timeout defaults to 600.0 on SML/NJ -- saves us from cluttering all theories equivalent declarations
krauss
parents: 43619
diff changeset
  1570
8955dcac6c71 values_timeout defaults to 600.0 on SML/NJ -- saves us from cluttering all theories equivalent declarations
krauss
parents: 43619
diff changeset
  1571
val values_timeout = Attrib.setup_config_real @{binding values_timeout} (K default_values_timeout)
42141
2c255ba8f299 changing values_timeout from a static option to a dynamic option as required for testing with SML/NJ
bulwahn
parents: 42094
diff changeset
  1572
32668
b2de45007537 added first prototype of the extended predicate compiler
bulwahn
parents: 32667
diff changeset
  1573
val setup = PredData.put (Graph.empty) #>
39545
631cf48c7894 code_pred_intro can be used to name facts for the code_pred command
bulwahn
parents: 39477
diff changeset
  1574
  Attrib.setup @{binding code_pred_intro} (Scan.lift (Scan.option Args.name) >> attrib' add_intro)
32668
b2de45007537 added first prototype of the extended predicate compiler
bulwahn
parents: 32667
diff changeset
  1575
    "adding alternative introduction rules for code generation of inductive predicates"
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1576
53380
08f3491c50bf cases: formal binding of 'assumes', with position provided via invoke_case;
wenzelm
parents: 53378
diff changeset
  1577
fun qualified_binding a =
08f3491c50bf cases: formal binding of 'assumes', with position provided via invoke_case;
wenzelm
parents: 53378
diff changeset
  1578
  Binding.qualify true (Long_Name.qualifier a) (Binding.name (Long_Name.base_name a));
08f3491c50bf cases: formal binding of 'assumes', with position provided via invoke_case;
wenzelm
parents: 53378
diff changeset
  1579
33522
737589bb9bb8 adapted Theory_Data;
wenzelm
parents: 33519
diff changeset
  1580
(* TODO: make Theory_Data to Generic_Data & remove duplication of local theory and theory *)
38757
2b3e054ae6fc renamed Local_Theory.theory(_result) to Local_Theory.background_theory(_result) to emphasize that this belongs to the infrastructure and is rarely appropriate in user-space tools;
wenzelm
parents: 38558
diff changeset
  1581
(* FIXME ... this is important to avoid changing the background theory below *)
33132
07efd452a698 moved argument expected_modes into options; improved mode check to only check mode of the named predicate
bulwahn
parents: 33131
diff changeset
  1582
fun generic_code_pred prep_const options raw_const lthy =
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1583
  let
42361
23f352990944 modernized structure Proof_Context;
wenzelm
parents: 42141
diff changeset
  1584
    val thy = Proof_Context.theory_of lthy
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1585
    val const = prep_const thy raw_const
40053
3fa49ea76cbb using a signature in core_data and moving some more functions to core_data
bulwahn
parents: 40052
diff changeset
  1586
    val lthy' = Local_Theory.background_theory (extend_intro_graph [const]) lthy
42361
23f352990944 modernized structure Proof_Context;
wenzelm
parents: 42141
diff changeset
  1587
    val thy' = Proof_Context.theory_of lthy'
23f352990944 modernized structure Proof_Context;
wenzelm
parents: 42141
diff changeset
  1588
    val ctxt' = Proof_Context.init_global thy'
37007
116670499530 changing operations for accessing data to work with contexts
bulwahn
parents: 37006
diff changeset
  1589
    val preds = Graph.all_succs (PredData.get thy') [const] |> filter_out (has_elim ctxt')
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1590
    fun mk_cases const =
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1591
      let
39299
e98a06145530 directly computing the values of interest instead of composing functions in an unintelligent way that causes exponential much garbage; using the latest theory
bulwahn
parents: 39273
diff changeset
  1592
        val T = Sign.the_const_type thy' const
33146
bf852ef586f2 now the predicate compilere handles the predicate without introduction rules better as before
bulwahn
parents: 33145
diff changeset
  1593
        val pred = Const (const, T)
37007
116670499530 changing operations for accessing data to work with contexts
bulwahn
parents: 37006
diff changeset
  1594
        val intros = intros_of ctxt' const
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1595
      in mk_casesrule lthy' pred intros end  
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1596
    val cases_rules = map mk_cases preds
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1597
    val cases =
39545
631cf48c7894 code_pred_intro can be used to name facts for the code_pred command
bulwahn
parents: 39477
diff changeset
  1598
      map2 (fn pred_name => fn case_rule => Rule_Cases.Case {fixes = [],
53380
08f3491c50bf cases: formal binding of 'assumes', with position provided via invoke_case;
wenzelm
parents: 53378
diff changeset
  1599
        assumes =
08f3491c50bf cases: formal binding of 'assumes', with position provided via invoke_case;
wenzelm
parents: 53378
diff changeset
  1600
          (Binding.name "that", tl (Logic.strip_imp_prems case_rule)) ::
08f3491c50bf cases: formal binding of 'assumes', with position provided via invoke_case;
wenzelm
parents: 53378
diff changeset
  1601
          map_filter (fn (fact_name, fact) =>
08f3491c50bf cases: formal binding of 'assumes', with position provided via invoke_case;
wenzelm
parents: 53378
diff changeset
  1602
              Option.map (fn a => (qualified_binding a, [fact])) fact_name)
08f3491c50bf cases: formal binding of 'assumes', with position provided via invoke_case;
wenzelm
parents: 53378
diff changeset
  1603
            ((SOME (Long_Name.base_name pred_name ^ ".prems") :: names_of ctxt' pred_name) ~~
08f3491c50bf cases: formal binding of 'assumes', with position provided via invoke_case;
wenzelm
parents: 53378
diff changeset
  1604
              Logic.strip_imp_prems case_rule),
39545
631cf48c7894 code_pred_intro can be used to name facts for the code_pred command
bulwahn
parents: 39477
diff changeset
  1605
        binds = [], cases = []}) preds cases_rules
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1606
    val case_env = map2 (fn p => fn c => (Long_Name.base_name p, SOME c)) preds cases
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1607
    val lthy'' = lthy'
39545
631cf48c7894 code_pred_intro can be used to name facts for the code_pred command
bulwahn
parents: 39477
diff changeset
  1608
      |> fold Variable.auto_fixes cases_rules
53378
07990ba8c0ea cases: more position information and PIDE markup;
wenzelm
parents: 52788
diff changeset
  1609
      |> Proof_Context.update_cases true case_env
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1610
    fun after_qed thms goal_ctxt =
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1611
      let
42361
23f352990944 modernized structure Proof_Context;
wenzelm
parents: 42141
diff changeset
  1612
        val global_thms = Proof_Context.export goal_ctxt
23f352990944 modernized structure Proof_Context;
wenzelm
parents: 42141
diff changeset
  1613
          (Proof_Context.init_global (Proof_Context.theory_of goal_ctxt)) (map the_single thms)
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1614
      in
38757
2b3e054ae6fc renamed Local_Theory.theory(_result) to Local_Theory.background_theory(_result) to emphasize that this belongs to the infrastructure and is rarely appropriate in user-space tools;
wenzelm
parents: 38558
diff changeset
  1615
        goal_ctxt |> Local_Theory.background_theory (fold set_elim global_thms #>
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1616
          ((case compilation options of
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1617
             Pred => add_equations
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1618
           | DSeq => add_dseq_equations
35879
99818df5b8f5 reviving the classical depth-limited computation in the predicate compiler
bulwahn
parents: 35845
diff changeset
  1619
           | Pos_Random_DSeq => add_random_dseq_equations
99818df5b8f5 reviving the classical depth-limited computation in the predicate compiler
bulwahn
parents: 35845
diff changeset
  1620
           | Depth_Limited => add_depth_limited_equations
35880
2623b23e41fc a new simpler random compilation for the predicate compiler
bulwahn
parents: 35879
diff changeset
  1621
           | Random => add_random_equations
35881
aa412e08bfee adding depth_limited_random compilation to predicate compiler
bulwahn
parents: 35880
diff changeset
  1622
           | Depth_Limited_Random => add_depth_limited_random_equations
36018
096ec83348f3 added new compilation to predicate_compiler
bulwahn
parents: 36004
diff changeset
  1623
           | New_Pos_Random_DSeq => add_new_random_dseq_equations
40051
b6acda4d1c29 added generator_dseq compilation for a sound depth-limited compilation with small value generators
bulwahn
parents: 40050
diff changeset
  1624
           | Pos_Generator_DSeq => add_generator_dseq_equations
45450
dc2236b19a3d adding CPS compilation to predicate compiler;
bulwahn
parents: 45214
diff changeset
  1625
           | Pos_Generator_CPS => add_generator_cps_equations
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
  1626
           | _ => error ("Compilation not supported")
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1627
           ) options [const]))
33144
1831516747d4 removed obsolete GeneratorPrem; clean-up after modularization; tuned
bulwahn
parents: 33143
diff changeset
  1628
      end
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1629
  in
36323
655e2d74de3a modernized naming conventions of main Isar proof elements;
wenzelm
parents: 36261
diff changeset
  1630
    Proof.theorem NONE after_qed (map (single o (rpair [])) cases_rules) lthy''
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1631
  end;
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1632
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1633
val code_pred = generic_code_pred (K I);
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1634
val code_pred_cmd = generic_code_pred Code.read_const
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1635
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1636
(* transformation for code generation *)
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1637
41472
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1638
(* FIXME just one data slot (record) per program unit *)
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1639
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1640
structure Pred_Result = Proof_Data
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1641
(
39388
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1642
  type T = unit -> term Predicate.pred
41472
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1643
  (* FIXME avoid user error with non-user text *)
39388
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1644
  fun init _ () = error "Pred_Result"
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1645
);
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1646
val put_pred_result = Pred_Result.put;
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1647
41472
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1648
structure Pred_Random_Result = Proof_Data
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1649
(
50057
57209cfbf16b prefer explicit Random.seed
haftmann
parents: 50056
diff changeset
  1650
  type T = unit -> seed -> term Predicate.pred * seed
41472
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1651
  (* FIXME avoid user error with non-user text *)
39388
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1652
  fun init _ () = error "Pred_Random_Result"
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1653
);
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1654
val put_pred_random_result = Pred_Random_Result.put;
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1655
41472
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1656
structure Dseq_Result = Proof_Data
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1657
(
51126
df86080de4cb reform of predicate compiler / quickcheck theories:
haftmann
parents: 50057
diff changeset
  1658
  type T = unit -> term Limited_Sequence.dseq
41472
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1659
  (* FIXME avoid user error with non-user text *)
39388
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1660
  fun init _ () = error "Dseq_Result"
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1661
);
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1662
val put_dseq_result = Dseq_Result.put;
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1663
41472
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1664
structure Dseq_Random_Result = Proof_Data
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1665
(
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
  1666
  type T = unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> term Limited_Sequence.dseq * seed
41472
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1667
  (* FIXME avoid user error with non-user text *)
39388
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1668
  fun init _ () = error "Dseq_Random_Result"
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1669
);
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1670
val put_dseq_random_result = Dseq_Random_Result.put;
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1671
41472
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1672
structure New_Dseq_Result = Proof_Data
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1673
(
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
  1674
  type T = unit -> Code_Numeral.natural -> term Lazy_Sequence.lazy_sequence
41472
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1675
  (* FIXME avoid user error with non-user text *)
40102
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1676
  fun init _ () = error "New_Dseq_Random_Result"
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1677
);
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1678
val put_new_dseq_result = New_Dseq_Result.put;
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1679
41472
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1680
structure Lseq_Random_Result = Proof_Data
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1681
(
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
  1682
  type T = unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> Code_Numeral.natural -> term Lazy_Sequence.lazy_sequence
41472
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1683
  (* FIXME avoid user error with non-user text *)
39388
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1684
  fun init _ () = error "Lseq_Random_Result"
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1685
);
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1686
val put_lseq_random_result = Lseq_Random_Result.put;
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1687
41472
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1688
structure Lseq_Random_Stats_Result = Proof_Data
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1689
(
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
  1690
  type T = unit -> Code_Numeral.natural -> Code_Numeral.natural -> seed -> Code_Numeral.natural -> (term * Code_Numeral.natural) Lazy_Sequence.lazy_sequence
41472
f6ab14e61604 misc tuning and comments based on review of Theory_Data, Proof_Data, Generic_Data usage;
wenzelm
parents: 40845
diff changeset
  1691
  (* FIXME avoid user error with non-user text *)
39388
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1692
  fun init _ () = error "Lseq_Random_Stats_Result"
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1693
);
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1694
val put_lseq_random_stats_result = Lseq_Random_Stats_Result.put;
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1695
42094
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1696
fun dest_special_compr t =
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1697
  let
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
  1698
    val (inner_t, T_compr) = case t of (Const (@{const_name Collect}, _) $ Abs (_, T, t)) => (t, T)
42094
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1699
      | _ => raise TERM ("dest_special_compr", [t])
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1700
    val (Ts, conj) = apfst (map snd) (Predicate_Compile_Aux.strip_ex inner_t)
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1701
    val [eq, body] = HOLogic.dest_conj conj
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1702
    val rhs = case HOLogic.dest_eq eq of
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1703
        (Bound i, rhs) => if i = length Ts then rhs else raise TERM ("dest_special_compr", [t])
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1704
      | _ => raise TERM ("dest_special_compr", [t])
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1705
    val output_names = Name.variant_list (fold Term.add_free_names [rhs, body] [])
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1706
      (map (fn i => "x" ^ string_of_int i) (1 upto length Ts))
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1707
    val output_frees = map2 (curry Free) output_names (rev Ts)
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1708
    val body = subst_bounds (output_frees, body)
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1709
    val output = subst_bounds (output_frees, rhs)
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1710
  in
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1711
    (((body, output), T_compr), output_names)
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1712
  end
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1713
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1714
fun dest_general_compr ctxt t_compr =
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1715
  let      
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1716
    val inner_t = case t_compr of (Const (@{const_name Collect}, _) $ t) => t
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1717
      | _ => error ("Not a set comprehension: " ^ Syntax.string_of_term ctxt t_compr);    
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1718
    val (body, Ts, fp) = HOLogic.strip_psplits inner_t;
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1719
    val output_names = Name.variant_list (Term.add_free_names body [])
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1720
      (map (fn i => "x" ^ string_of_int i) (1 upto length Ts))
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1721
    val output_frees = map2 (curry Free) output_names (rev Ts)
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1722
    val body = subst_bounds (output_frees, body)
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1723
    val T_compr = HOLogic.mk_ptupleT fp Ts
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1724
    val output = HOLogic.mk_ptuple fp T_compr (rev output_frees)
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1725
  in
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1726
    (((body, output), T_compr), output_names)
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1727
  end
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1728
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1729
(*FIXME turn this into an LCF-guarded preprocessor for comprehensions*)
40102
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1730
fun analyze_compr ctxt (comp_modifiers, additional_arguments) param_user_modes
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
  1731
  (compilation, _) t_compr =
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1732
  let
40102
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1733
    val compfuns = Comp_Mod.compfuns comp_modifiers
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1734
    val all_modes_of = all_modes_of compilation
42094
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1735
    val (((body, output), T_compr), output_names) =
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1736
      case try dest_special_compr t_compr of SOME r => r | NONE => dest_general_compr ctxt t_compr
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
  1737
    val (Const (name, _), all_args) =
36031
199fe16cdaab returning an more understandable user error message in the values command
bulwahn
parents: 36030
diff changeset
  1738
      case strip_comb body of
199fe16cdaab returning an more understandable user error message in the values command
bulwahn
parents: 36030
diff changeset
  1739
        (Const (name, T), all_args) => (Const (name, T), all_args)
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
  1740
      | (head, _) => error ("Not a constant: " ^ Syntax.string_of_term ctxt head)
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1741
  in
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
  1742
    if defined_functions compilation ctxt name then
32668
b2de45007537 added first prototype of the extended predicate compiler
bulwahn
parents: 32667
diff changeset
  1743
      let
37391
476270a6c2dc tuned quotes, antiquotations and whitespace
haftmann
parents: 37146
diff changeset
  1744
        fun extract_mode (Const (@{const_name Pair}, _) $ t1 $ t2) = Pair (extract_mode t1, extract_mode t2)
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1745
          | extract_mode (Free (x, _)) = if member (op =) output_names x then Output else Input
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1746
          | extract_mode _ = Input
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1747
        val user_mode = fold_rev (curry Fun) (map extract_mode all_args) Bool
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1748
        fun valid modes1 modes2 =
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1749
          case int_ord (length modes1, length modes2) of
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1750
            GREATER => error "Not enough mode annotations"
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1751
          | LESS => error "Too many mode annotations"
50056
72efd6b4038d dropped dead code
haftmann
parents: 47329
diff changeset
  1752
          | EQUAL => forall (fn (_, NONE) => true | (m, SOME m2) => eq_mode (m, m2))
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1753
            (modes1 ~~ modes2)
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1754
        fun mode_instance_of (m1, m2) =
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1755
          let
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1756
            fun instance_of (Fun _, Input) = true
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1757
              | instance_of (Input, Input) = true
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1758
              | instance_of (Output, Output) = true
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1759
              | instance_of (Pair (m1, m2), Pair (m1', m2')) =
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1760
                  instance_of  (m1, m1') andalso instance_of (m2, m2')
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1761
              | instance_of (Pair (m1, m2), Input) =
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1762
                  instance_of (m1, Input) andalso instance_of (m2, Input)
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1763
              | instance_of (Pair (m1, m2), Output) =
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1764
                  instance_of (m1, Output) andalso instance_of (m2, Output)
37002
34e73e8bab66 improved values command to handle a special case with tuples and polymorphic predicates more correctly
bulwahn
parents: 37001
diff changeset
  1765
              | instance_of (Input, Pair (m1, m2)) =
34e73e8bab66 improved values command to handle a special case with tuples and polymorphic predicates more correctly
bulwahn
parents: 37001
diff changeset
  1766
                  instance_of (Input, m1) andalso instance_of (Input, m2)
34e73e8bab66 improved values command to handle a special case with tuples and polymorphic predicates more correctly
bulwahn
parents: 37001
diff changeset
  1767
              | instance_of (Output, Pair (m1, m2)) =
34e73e8bab66 improved values command to handle a special case with tuples and polymorphic predicates more correctly
bulwahn
parents: 37001
diff changeset
  1768
                  instance_of (Output, m1) andalso instance_of (Output, m2)
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1769
              | instance_of _ = false
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1770
          in forall instance_of (strip_fun_mode m1 ~~ strip_fun_mode m2) end
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
  1771
        val derivs = all_derivations_of ctxt (all_modes_of ctxt) [] body
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1772
          |> filter (fn (d, missing_vars) =>
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1773
            let
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1774
              val (p_mode :: modes) = collect_context_modes d
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1775
            in
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1776
              null missing_vars andalso
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1777
              mode_instance_of (p_mode, user_mode) andalso
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1778
              the_default true (Option.map (valid modes) param_user_modes)
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1779
            end)
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1780
          |> map fst
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1781
        val deriv = case derivs of
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1782
            [] => error ("No mode possible for comprehension "
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
  1783
                    ^ Syntax.string_of_term ctxt t_compr)
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1784
          | [d] => d
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1785
          | d :: _ :: _ => (warning ("Multiple modes possible for comprehension "
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
  1786
                    ^ Syntax.string_of_term ctxt t_compr); d);
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1787
        val (_, outargs) = split_mode (head_mode_of deriv) all_args
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
  1788
        val t_pred = compile_expr comp_modifiers ctxt
39648
655307cb8489 rewriting function mk_Eval_of in predicate compiler
bulwahn
parents: 39557
diff changeset
  1789
          (body, deriv) [] additional_arguments;
45461
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
  1790
        val T_pred = dest_monadT compfuns (fastype_of t_pred)
42094
e6867e9c6d10 allowing special set comprehensions in values command; adding an example for special set comprehension in values
bulwahn
parents: 42088
diff changeset
  1791
        val arrange = HOLogic.tupled_lambda (HOLogic.mk_tuple outargs) output
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1792
      in
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1793
        if null outargs then t_pred else mk_map compfuns T_pred T_compr arrange t_pred
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1794
      end
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1795
    else
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1796
      error "Evaluation with values is not possible because compilation with code_pred was not invoked"
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1797
  end
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1798
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
  1799
fun eval ctxt stats param_user_modes (options as (compilation, arguments)) k t_compr =
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1800
  let
36027
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1801
    fun count xs x =
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1802
      let
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1803
        fun count' i [] = i
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1804
          | count' i (x' :: xs) = if x = x' then count' (i + 1) xs else count' i xs
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1805
      in count' 0 xs end
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
  1806
    fun accumulate xs = (map (fn x => (x, count xs x)) o sort int_ord o distinct (op =)) xs;
40102
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1807
    val comp_modifiers =
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1808
      case compilation of
40102
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1809
          Pred => predicate_comp_modifiers
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1810
        | Random => random_comp_modifiers
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1811
        | Depth_Limited => depth_limited_comp_modifiers
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1812
        | Depth_Limited_Random => depth_limited_random_comp_modifiers
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1813
        (*| Annotated => annotated_comp_modifiers*)
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1814
        | DSeq => dseq_comp_modifiers
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1815
        | Pos_Random_DSeq => pos_random_dseq_comp_modifiers
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1816
        | New_Pos_Random_DSeq => new_pos_random_dseq_comp_modifiers
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1817
        | Pos_Generator_DSeq => pos_generator_dseq_comp_modifiers
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1818
    val compfuns = Comp_Mod.compfuns comp_modifiers
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1819
    val additional_arguments =
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1820
      case compilation of
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1821
        Pred => []
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
  1822
      | Random => map (HOLogic.mk_number @{typ "natural"}) arguments @
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
  1823
        [@{term "(1, 1) :: natural * natural"}]
40102
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1824
      | Annotated => []
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
  1825
      | Depth_Limited => [HOLogic.mk_number @{typ "natural"} (hd arguments)]
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
  1826
      | Depth_Limited_Random => map (HOLogic.mk_number @{typ "natural"}) arguments @
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
  1827
        [@{term "(1, 1) :: natural * natural"}]
40102
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1828
      | DSeq => []
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1829
      | Pos_Random_DSeq => []
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1830
      | New_Pos_Random_DSeq => []
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1831
      | Pos_Generator_DSeq => []
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1832
    val t = analyze_compr ctxt (comp_modifiers, additional_arguments) param_user_modes options t_compr;
45461
130c90bb80b4 using more conventional names for monad plus operations
bulwahn
parents: 45452
diff changeset
  1833
    val T = dest_monadT compfuns (fastype_of t);
36027
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1834
    val t' =
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1835
      if stats andalso compilation = New_Pos_Random_DSeq then
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
  1836
        mk_map compfuns T (HOLogic.mk_prodT (HOLogic.termT, @{typ natural}))
44241
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 43948
diff changeset
  1837
          (absdummy T (HOLogic.mk_prod (HOLogic.term_of_const T $ Bound 0,
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
  1838
            @{term natural_of_nat} $ (HOLogic.size_const T $ Bound 0)))) t
36027
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1839
      else
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1840
        mk_map compfuns T HOLogic.termT (HOLogic.term_of_const T) t
42361
23f352990944 modernized structure Proof_Context;
wenzelm
parents: 42141
diff changeset
  1841
    val thy = Proof_Context.theory_of ctxt
42141
2c255ba8f299 changing values_timeout from a static option to a dynamic option as required for testing with SML/NJ
bulwahn
parents: 42094
diff changeset
  1842
    val time_limit = seconds (Config.get ctxt values_timeout)
36027
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1843
    val (ts, statistics) =
40135
abc45472e48a adding a global time limit to the values command
bulwahn
parents: 40103
diff changeset
  1844
      (case compilation of
35880
2623b23e41fc a new simpler random compilation for the predicate compiler
bulwahn
parents: 35879
diff changeset
  1845
       (* Random =>
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1846
          fst (Predicate.yieldn k
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1847
          (Code_Eval.eval NONE ("Predicate_Compile_Core.random_eval_ref", random_eval_ref)
33137
0d16c07f8d24 added option to generate random values to values command in the predicate compiler
bulwahn
parents: 33135
diff changeset
  1848
            (fn proc => fn g => fn s => g s |>> Predicate.map proc) thy t' []
35880
2623b23e41fc a new simpler random compilation for the predicate compiler
bulwahn
parents: 35879
diff changeset
  1849
            |> Random_Engine.run))*)
2623b23e41fc a new simpler random compilation for the predicate compiler
bulwahn
parents: 35879
diff changeset
  1850
        Pos_Random_DSeq =>
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1851
          let
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
  1852
            val [nrandom, size, depth] = map Code_Numeral.natural_of_integer arguments
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1853
          in
51126
df86080de4cb reform of predicate compiler / quickcheck theories:
haftmann
parents: 50057
diff changeset
  1854
            rpair NONE (TimeLimit.timeLimit time_limit (fn () => fst (Limited_Sequence.yieldn k
39471
55e0ff582fa4 adjusted to changes in Code_Runtime
haftmann
parents: 39403
diff changeset
  1855
              (Code_Runtime.dynamic_value_strict (Dseq_Random_Result.get, put_dseq_random_result, "Predicate_Compile_Core.put_dseq_random_result")
51126
df86080de4cb reform of predicate compiler / quickcheck theories:
haftmann
parents: 50057
diff changeset
  1856
                thy NONE (fn proc => fn g => fn nrandom => fn size => fn s => g nrandom size s |>> Limited_Sequence.map proc)
39471
55e0ff582fa4 adjusted to changes in Code_Runtime
haftmann
parents: 39403
diff changeset
  1857
                  t' [] nrandom size
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1858
                |> Random_Engine.run)
40135
abc45472e48a adding a global time limit to the values command
bulwahn
parents: 40103
diff changeset
  1859
              depth true)) ())
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1860
          end
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1861
      | DSeq =>
51126
df86080de4cb reform of predicate compiler / quickcheck theories:
haftmann
parents: 50057
diff changeset
  1862
          rpair NONE (TimeLimit.timeLimit time_limit (fn () => fst (Limited_Sequence.yieldn k
39471
55e0ff582fa4 adjusted to changes in Code_Runtime
haftmann
parents: 39403
diff changeset
  1863
            (Code_Runtime.dynamic_value_strict (Dseq_Result.get, put_dseq_result, "Predicate_Compile_Core.put_dseq_result")
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
  1864
              thy NONE Limited_Sequence.map t' []) (Code_Numeral.natural_of_integer (the_single arguments)) true)) ())
40102
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1865
      | Pos_Generator_DSeq =>
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1866
          let
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
  1867
            val depth = Code_Numeral.natural_of_integer (the_single arguments)
40102
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1868
          in
42141
2c255ba8f299 changing values_timeout from a static option to a dynamic option as required for testing with SML/NJ
bulwahn
parents: 42094
diff changeset
  1869
            rpair NONE (TimeLimit.timeLimit time_limit (fn () => fst (Lazy_Sequence.yieldn k
40102
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1870
              (Code_Runtime.dynamic_value_strict (New_Dseq_Result.get, put_new_dseq_result, "Predicate_Compile_Core.put_new_dseq_result")
51126
df86080de4cb reform of predicate compiler / quickcheck theories:
haftmann
parents: 50057
diff changeset
  1871
              thy NONE (fn proc => fn g => fn depth => g depth |> Lazy_Sequence.map proc)
40135
abc45472e48a adding a global time limit to the values command
bulwahn
parents: 40103
diff changeset
  1872
              t' [] depth))) ())
40102
a9e4e94b3022 restructuring values command and adding generator compilation
bulwahn
parents: 40053
diff changeset
  1873
          end
36020
3ee4c29ead7f adding values command for new monad; added new random monad compilation to predicate_compile_quickcheck
bulwahn
parents: 36019
diff changeset
  1874
      | New_Pos_Random_DSeq =>
3ee4c29ead7f adding values command for new monad; added new random monad compilation to predicate_compile_quickcheck
bulwahn
parents: 36019
diff changeset
  1875
          let
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
  1876
            val [nrandom, size, depth] = map Code_Numeral.natural_of_integer arguments
36020
3ee4c29ead7f adding values command for new monad; added new random monad compilation to predicate_compile_quickcheck
bulwahn
parents: 36019
diff changeset
  1877
            val seed = Random_Engine.next_seed ()
3ee4c29ead7f adding values command for new monad; added new random monad compilation to predicate_compile_quickcheck
bulwahn
parents: 36019
diff changeset
  1878
          in
36027
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1879
            if stats then
51143
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
  1880
              apsnd (SOME o accumulate o map Code_Numeral.integer_of_natural)
0a2371e7ced3 two target language numeral types: integer and natural, as replacement for code_numeral;
haftmann
parents: 51126
diff changeset
  1881
              (split_list (TimeLimit.timeLimit time_limit
40135
abc45472e48a adding a global time limit to the values command
bulwahn
parents: 40103
diff changeset
  1882
              (fn () => fst (Lazy_Sequence.yieldn k
39471
55e0ff582fa4 adjusted to changes in Code_Runtime
haftmann
parents: 39403
diff changeset
  1883
                (Code_Runtime.dynamic_value_strict
39388
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1884
                  (Lseq_Random_Stats_Result.get, put_lseq_random_stats_result, "Predicate_Compile_Core.put_lseq_random_stats_result")
39471
55e0ff582fa4 adjusted to changes in Code_Runtime
haftmann
parents: 39403
diff changeset
  1885
                  thy NONE
36027
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1886
                  (fn proc => fn g => fn nrandom => fn size => fn s => fn depth => g nrandom size s depth
51126
df86080de4cb reform of predicate compiler / quickcheck theories:
haftmann
parents: 50057
diff changeset
  1887
                    |> Lazy_Sequence.map (apfst proc))
40135
abc45472e48a adding a global time limit to the values command
bulwahn
parents: 40103
diff changeset
  1888
                    t' [] nrandom size seed depth))) ()))
36027
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1889
            else rpair NONE
42141
2c255ba8f299 changing values_timeout from a static option to a dynamic option as required for testing with SML/NJ
bulwahn
parents: 42094
diff changeset
  1890
              (TimeLimit.timeLimit time_limit (fn () => fst (Lazy_Sequence.yieldn k
39471
55e0ff582fa4 adjusted to changes in Code_Runtime
haftmann
parents: 39403
diff changeset
  1891
                (Code_Runtime.dynamic_value_strict
39388
fdbb2c55ffc2 replaced ML_Context.evaluate by ML_Context.value -- using context data instead of bare metal references
haftmann
parents: 39310
diff changeset
  1892
                  (Lseq_Random_Result.get, put_lseq_random_result, "Predicate_Compile_Core.put_lseq_random_result")
39471
55e0ff582fa4 adjusted to changes in Code_Runtime
haftmann
parents: 39403
diff changeset
  1893
                  thy NONE 
36027
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1894
                  (fn proc => fn g => fn nrandom => fn size => fn s => fn depth => g nrandom size s depth
51126
df86080de4cb reform of predicate compiler / quickcheck theories:
haftmann
parents: 50057
diff changeset
  1895
                    |> Lazy_Sequence.map proc)
40135
abc45472e48a adding a global time limit to the values command
bulwahn
parents: 40103
diff changeset
  1896
                    t' [] nrandom size seed depth))) ())
36020
3ee4c29ead7f adding values command for new monad; added new random monad compilation to predicate_compile_quickcheck
bulwahn
parents: 36019
diff changeset
  1897
          end
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1898
      | _ =>
42141
2c255ba8f299 changing values_timeout from a static option to a dynamic option as required for testing with SML/NJ
bulwahn
parents: 42094
diff changeset
  1899
          rpair NONE (TimeLimit.timeLimit time_limit (fn () => fst (Predicate.yieldn k
39471
55e0ff582fa4 adjusted to changes in Code_Runtime
haftmann
parents: 39403
diff changeset
  1900
            (Code_Runtime.dynamic_value_strict (Pred_Result.get, put_pred_result, "Predicate_Compile_Core.put_pred_result")
40135
abc45472e48a adding a global time limit to the values command
bulwahn
parents: 40103
diff changeset
  1901
              thy NONE Predicate.map t' []))) ()))
abc45472e48a adding a global time limit to the values command
bulwahn
parents: 40103
diff changeset
  1902
     handle TimeLimit.TimeOut => error "Reached timeout during execution of values"
36027
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1903
  in ((T, ts), statistics) end;
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1904
43123
28e6351b2f8e creating a free variable with proper name and local mixfix syntax (cf. db9b9e46131c)
bulwahn
parents: 42616
diff changeset
  1905
fun values param_user_modes ((raw_expected, stats), comp_options) k t_compr ctxt =
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1906
  let
37003
a393a588b82e moving towards working with proof contexts in the predicate compiler
bulwahn
parents: 37002
diff changeset
  1907
    val ((T, ts), statistics) = eval ctxt stats param_user_modes comp_options k t_compr
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1908
    val setT = HOLogic.mk_setT T
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1909
    val elems = HOLogic.mk_set T ts
43123
28e6351b2f8e creating a free variable with proper name and local mixfix syntax (cf. db9b9e46131c)
bulwahn
parents: 42616
diff changeset
  1910
    val ([dots], ctxt') =
43619
3803869014aa proper @{binding} antiquotations (relevant for formal references);
wenzelm
parents: 43324
diff changeset
  1911
      Proof_Context.add_fixes [(@{binding dots}, SOME setT, Mixfix ("...", [], 1000))] ctxt 
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1912
    (* check expected values *)
43123
28e6351b2f8e creating a free variable with proper name and local mixfix syntax (cf. db9b9e46131c)
bulwahn
parents: 42616
diff changeset
  1913
    val union = Const (@{const_abbrev Set.union}, setT --> setT --> setT)
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1914
    val () =
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1915
      case raw_expected of
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1916
        NONE => ()
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1917
      | SOME s =>
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1918
        if eq_set (op =) (HOLogic.dest_set (Syntax.read_term ctxt s), ts) then ()
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1919
        else
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1920
          error ("expected and computed values do not match:\n" ^
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1921
            "expected values: " ^ Syntax.string_of_term ctxt (Syntax.read_term ctxt s) ^ "\n" ^
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1922
            "computed values: " ^ Syntax.string_of_term ctxt elems ^ "\n")
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1923
  in
43123
28e6351b2f8e creating a free variable with proper name and local mixfix syntax (cf. db9b9e46131c)
bulwahn
parents: 42616
diff changeset
  1924
    ((if k = ~1 orelse length ts < k then elems else union $ elems $ Free (dots, setT), statistics), ctxt')
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1925
  end;
33623
4ec42d38224f changed modes to expected_modes; added UNION to code_pred_inlining; fixed some examples; tuned
bulwahn
parents: 33620
diff changeset
  1926
33479
428ddcc16e7b added optional mode annotations for parameters in the values command
bulwahn
parents: 33478
diff changeset
  1927
fun values_cmd print_modes param_user_modes options k raw_t state =
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1928
  let
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1929
    val ctxt = Toplevel.context_of state
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1930
    val t = Syntax.read_term ctxt raw_t
43123
28e6351b2f8e creating a free variable with proper name and local mixfix syntax (cf. db9b9e46131c)
bulwahn
parents: 42616
diff changeset
  1931
    val ((t', stats), ctxt') = values param_user_modes options k t ctxt
34948
2d5f2a9f7601 refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
bulwahn
parents: 34028
diff changeset
  1932
    val ty' = Term.type_of t'
43123
28e6351b2f8e creating a free variable with proper name and local mixfix syntax (cf. db9b9e46131c)
bulwahn
parents: 42616
diff changeset
  1933
    val ctxt'' = Variable.auto_fixes t' ctxt'
36027
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1934
    val pretty_stat =
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1935
      case stats of
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1936
          NONE => []
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1937
        | SOME xs =>
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1938
          let
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1939
            val total = fold (curry (op +)) (map snd xs) 0
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1940
            fun pretty_entry (s, n) =
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1941
              [Pretty.str "size", Pretty.brk 1,
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1942
               Pretty.str (string_of_int s), Pretty.str ":", Pretty.brk 1,
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1943
               Pretty.str (string_of_int n), Pretty.fbrk]
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1944
          in
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1945
            [Pretty.fbrk, Pretty.str "Statistics:", Pretty.fbrk,
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1946
             Pretty.str "total:", Pretty.brk 1, Pretty.str (string_of_int total), Pretty.fbrk]
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1947
             @ maps pretty_entry xs
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1948
          end
37146
f652333bbf8e renamed structure PrintMode to Print_Mode, keeping the old name as legacy alias for some time;
wenzelm
parents: 37135
diff changeset
  1949
    val p = Print_Mode.with_modes print_modes (fn () =>
43123
28e6351b2f8e creating a free variable with proper name and local mixfix syntax (cf. db9b9e46131c)
bulwahn
parents: 42616
diff changeset
  1950
      Pretty.block ([Pretty.quote (Syntax.pretty_term ctxt'' t'), Pretty.fbrk,
28e6351b2f8e creating a free variable with proper name and local mixfix syntax (cf. db9b9e46131c)
bulwahn
parents: 42616
diff changeset
  1951
        Pretty.str "::", Pretty.brk 1, Pretty.quote (Syntax.pretty_typ ctxt'' ty')]
36027
29a15da9c63d added statistics to values command for random generation
bulwahn
parents: 36025
diff changeset
  1952
        @ pretty_stat)) ();
32667
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1953
  in Pretty.writeln p end;
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1954
09546e654222 moved predicate compiler to Tools
bulwahn
parents:
diff changeset
  1955
end;