refactoring the predicate compiler; adding theories for Sequences; adding retrieval to Spec_Rules; adding timing to Quickcheck
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/src/HOL/DSequence.thy Wed Jan 20 11:56:45 2010 +0100
1.3 @@ -0,0 +1,112 @@
1.4 +
1.5 +(* Author: Lukas Bulwahn, TU Muenchen *)
1.6 +
1.7 +header {* Depth-Limited Sequences with failure element *}
1.8 +
1.9 +theory DSequence
1.10 +imports Lazy_Sequence Code_Numeral
1.11 +begin
1.12 +
1.13 +types 'a dseq = "code_numeral => bool => 'a Lazy_Sequence.lazy_sequence option"
1.14 +
1.15 +definition empty :: "'a dseq"
1.16 +where
1.17 + "empty = (%i pol. Some Lazy_Sequence.empty)"
1.18 +
1.19 +definition single :: "'a => 'a dseq"
1.20 +where
1.21 + "single x = (%i pol. Some (Lazy_Sequence.single x))"
1.22 +
1.23 +fun eval :: "'a dseq => code_numeral => bool => 'a Lazy_Sequence.lazy_sequence option"
1.24 +where
1.25 + "eval f i pol = f i pol"
1.26 +
1.27 +definition yield :: "'a dseq => code_numeral => bool => ('a * 'a dseq) option"
1.28 +where
1.29 + "yield dseq i pol = (case eval dseq i pol of
1.30 + None => None
1.31 + | Some s => Option.map (apsnd (%r i pol. Some r)) (Lazy_Sequence.yield s))"
1.32 +
1.33 +definition yieldn :: "code_numeral => 'a dseq => code_numeral => bool => 'a list * 'a dseq"
1.34 +where
1.35 + "yieldn n dseq i pol = (case eval dseq i pol of
1.36 + None => ([], %i pol. None)
1.37 + | Some s => let (xs, s') = Lazy_Sequence.yieldn n s in (xs, %i pol. Some s))"
1.38 +
1.39 +fun map_seq :: "('a => 'b dseq) => 'a Lazy_Sequence.lazy_sequence => 'b dseq"
1.40 +where
1.41 + "map_seq f xq i pol = (case Lazy_Sequence.yield xq of
1.42 + None => Some Lazy_Sequence.empty
1.43 + | Some (x, xq') => (case eval (f x) i pol of
1.44 + None => None
1.45 + | Some yq => (case map_seq f xq' i pol of
1.46 + None => None
1.47 + | Some zq => Some (Lazy_Sequence.append yq zq))))"
1.48 +
1.49 +fun bind :: "'a dseq => ('a => 'b dseq) => 'b dseq"
1.50 +where
1.51 + "bind x f = (%i pol.
1.52 + if i = 0 then
1.53 + (if pol then Some Lazy_Sequence.empty else None)
1.54 + else
1.55 + (case x (i - 1) pol of
1.56 + None => None
1.57 + | Some xq => map_seq f xq i pol))"
1.58 +
1.59 +fun union :: "'a dseq => 'a dseq => 'a dseq"
1.60 +where
1.61 + "union x y = (%i pol. case (x i pol, y i pol) of
1.62 + (Some xq, Some yq) => Some (Lazy_Sequence.append xq yq)
1.63 + | _ => None)"
1.64 +
1.65 +definition if_seq :: "bool => unit dseq"
1.66 +where
1.67 + "if_seq b = (if b then single () else empty)"
1.68 +
1.69 +fun not_seq :: "unit dseq => unit dseq"
1.70 +where
1.71 + "not_seq x = (%i pol. case x i (\<not>pol) of
1.72 + None => Some Lazy_Sequence.empty
1.73 + | Some xq => (case Lazy_Sequence.yield xq of
1.74 + None => Some (Lazy_Sequence.single ())
1.75 + | Some _ => Some (Lazy_Sequence.empty)))"
1.76 +
1.77 +fun map :: "('a => 'b) => 'a dseq => 'b dseq"
1.78 +where
1.79 + "map f g = (%i pol. case g i pol of
1.80 + None => None
1.81 + | Some xq => Some (Lazy_Sequence.map f xq))"
1.82 +
1.83 +ML {*
1.84 +signature DSEQUENCE =
1.85 +sig
1.86 + type 'a dseq = int -> bool -> 'a Lazy_Sequence.lazy_sequence option
1.87 + val yield : 'a dseq -> int -> bool -> ('a * 'a dseq) option
1.88 + val yieldn : int -> 'a dseq -> int -> bool -> 'a list * 'a dseq
1.89 + val map : ('a -> 'b) -> 'a dseq -> 'b dseq
1.90 +end;
1.91 +
1.92 +structure DSequence : DSEQUENCE =
1.93 +struct
1.94 +
1.95 +type 'a dseq = int -> bool -> 'a Lazy_Sequence.lazy_sequence option
1.96 +
1.97 +val yieldn = @{code yieldn}
1.98 +val yield = @{code yield}
1.99 +val map = @{code map}
1.100 +
1.101 +end;
1.102 +*}
1.103 +
1.104 +code_reserved Eval DSequence
1.105 +(*
1.106 +hide type Sequence.seq
1.107 +
1.108 +hide const Sequence.Seq Sequence.yield Sequence.yieldn Sequence.empty Sequence.single
1.109 + Sequence.append Sequence.flat Sequence.map Sequence.bind Sequence.ifpred Sequence.not_seq
1.110 +*)
1.111 +hide (open) const empty single eval map_seq bind union if_seq not_seq map
1.112 +hide (open) fact empty_def single_def eval.simps map_seq.simps bind.simps union.simps
1.113 + if_seq_def not_seq.simps map.simps
1.114 +
1.115 +end
2.1 --- a/src/HOL/IsaMakefile Sat Jan 16 21:14:15 2010 +0100
2.2 +++ b/src/HOL/IsaMakefile Wed Jan 20 11:56:45 2010 +0100
2.3 @@ -246,10 +246,12 @@
2.4 Code_Evaluation.thy \
2.5 Code_Numeral.thy \
2.6 Divides.thy \
2.7 + DSequence.thy \
2.8 Equiv_Relations.thy \
2.9 Groebner_Basis.thy \
2.10 Hilbert_Choice.thy \
2.11 Int.thy \
2.12 + Lazy_Sequence.thy \
2.13 List.thy \
2.14 Main.thy \
2.15 Map.thy \
2.16 @@ -260,6 +262,7 @@
2.17 Predicate_Compile.thy \
2.18 Quickcheck.thy \
2.19 Random.thy \
2.20 + Random_Sequence.thy \
2.21 Recdef.thy \
2.22 SetInterval.thy \
2.23 String.thy \
3.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
3.2 +++ b/src/HOL/Lazy_Sequence.thy Wed Jan 20 11:56:45 2010 +0100
3.3 @@ -0,0 +1,158 @@
3.4 +
3.5 +(* Author: Lukas Bulwahn, TU Muenchen *)
3.6 +
3.7 +header {* Lazy sequences *}
3.8 +
3.9 +theory Lazy_Sequence
3.10 +imports List Code_Numeral
3.11 +begin
3.12 +
3.13 +datatype 'a lazy_sequence = Empty | Insert 'a "'a lazy_sequence"
3.14 +
3.15 +definition Lazy_Sequence :: "(unit => ('a * 'a lazy_sequence) option) => 'a lazy_sequence"
3.16 +where
3.17 + "Lazy_Sequence f = (case f () of None => Empty | Some (x, xq) => Insert x xq)"
3.18 +
3.19 +code_datatype Lazy_Sequence
3.20 +
3.21 +primrec yield :: "'a lazy_sequence => ('a * 'a lazy_sequence) option"
3.22 +where
3.23 + "yield Empty = None"
3.24 +| "yield (Insert x xq) = Some (x, xq)"
3.25 +
3.26 +fun yieldn :: "code_numeral => 'a lazy_sequence => 'a list * 'a lazy_sequence"
3.27 +where
3.28 + "yieldn i S = (if i = 0 then ([], S) else
3.29 + case yield S of
3.30 + None => ([], S)
3.31 + | Some (x, S') => let
3.32 + (xs, S'') = yieldn (i - 1) S'
3.33 + in (x # xs, S''))"
3.34 +
3.35 +lemma [simp]: "yield xq = Some (x, xq') ==> size xq' < size xq"
3.36 +by (cases xq) auto
3.37 +
3.38 +lemma yield_Seq [code]:
3.39 + "yield (Lazy_Sequence f) = f ()"
3.40 +unfolding Lazy_Sequence_def by (cases "f ()") auto
3.41 +
3.42 +lemma Seq_yield:
3.43 + "Lazy_Sequence (%u. yield f) = f"
3.44 +unfolding Lazy_Sequence_def by (cases f) auto
3.45 +
3.46 +lemma lazy_sequence_size_code [code]:
3.47 + "lazy_sequence_size s xq = (case yield xq of None => 0 | Some (x, xq') => s x + lazy_sequence_size s xq' + 1)"
3.48 +by (cases xq) auto
3.49 +
3.50 +lemma size_code [code]:
3.51 + "size xq = (case yield xq of None => 0 | Some (x, xq') => size xq' + 1)"
3.52 +by (cases xq) auto
3.53 +
3.54 +lemma [code]: "eq_class.eq xq yq = (case (yield xq, yield yq) of
3.55 + (None, None) => True | (Some (x, xq'), Some (y, yq')) => (HOL.eq x y) \<and> (eq_class.eq xq yq) | _ => False)"
3.56 +apply (cases xq) apply (cases yq) apply (auto simp add: eq_class.eq_equals)
3.57 +apply (cases yq) apply (auto simp add: eq_class.eq_equals) done
3.58 +
3.59 +lemma seq_case [code]:
3.60 + "lazy_sequence_case f g xq = (case (yield xq) of None => f | Some (x, xq') => g x xq')"
3.61 +by (cases xq) auto
3.62 +
3.63 +lemma [code]: "lazy_sequence_rec f g xq = (case (yield xq) of None => f | Some (x, xq') => g x xq' (lazy_sequence_rec f g xq'))"
3.64 +by (cases xq) auto
3.65 +
3.66 +definition empty :: "'a lazy_sequence"
3.67 +where
3.68 + [code]: "empty = Lazy_Sequence (%u. None)"
3.69 +
3.70 +definition single :: "'a => 'a lazy_sequence"
3.71 +where
3.72 + [code]: "single x = Lazy_Sequence (%u. Some (x, empty))"
3.73 +
3.74 +primrec append :: "'a lazy_sequence => 'a lazy_sequence => 'a lazy_sequence"
3.75 +where
3.76 + "append Empty yq = yq"
3.77 +| "append (Insert x xq) yq = Insert x (append xq yq)"
3.78 +
3.79 +lemma [code]:
3.80 + "append xq yq = Lazy_Sequence (%u. case yield xq of
3.81 + None => yield yq
3.82 + | Some (x, xq') => Some (x, append xq' yq))"
3.83 +unfolding Lazy_Sequence_def
3.84 +apply (cases "xq")
3.85 +apply auto
3.86 +apply (cases "yq")
3.87 +apply auto
3.88 +done
3.89 +
3.90 +primrec flat :: "'a lazy_sequence lazy_sequence => 'a lazy_sequence"
3.91 +where
3.92 + "flat Empty = Empty"
3.93 +| "flat (Insert xq xqq) = append xq (flat xqq)"
3.94 +
3.95 +lemma [code]:
3.96 + "flat xqq = Lazy_Sequence (%u. case yield xqq of
3.97 + None => None
3.98 + | Some (xq, xqq') => yield (append xq (flat xqq')))"
3.99 +apply (cases "xqq")
3.100 +apply (auto simp add: Seq_yield)
3.101 +unfolding Lazy_Sequence_def
3.102 +by auto
3.103 +
3.104 +primrec map :: "('a => 'b) => 'a lazy_sequence => 'b lazy_sequence"
3.105 +where
3.106 + "map f Empty = Empty"
3.107 +| "map f (Insert x xq) = Insert (f x) (map f xq)"
3.108 +
3.109 +lemma [code]:
3.110 + "map f xq = Lazy_Sequence (%u. Option.map (%(x, xq'). (f x, map f xq')) (yield xq))"
3.111 +apply (cases xq)
3.112 +apply (auto simp add: Seq_yield)
3.113 +unfolding Lazy_Sequence_def
3.114 +apply auto
3.115 +done
3.116 +
3.117 +definition bind :: "'a lazy_sequence => ('a => 'b lazy_sequence) => 'b lazy_sequence"
3.118 +where
3.119 + [code]: "bind xq f = flat (map f xq)"
3.120 +
3.121 +definition if_seq :: "bool => unit lazy_sequence"
3.122 +where
3.123 + "if_seq b = (if b then single () else empty)"
3.124 +
3.125 +definition not_seq :: "unit lazy_sequence => unit lazy_sequence"
3.126 +where
3.127 + "not_seq xq = (case yield xq of None => single () | Some ((), xq) => empty)"
3.128 +
3.129 +subsection {* Code setup *}
3.130 +
3.131 +ML {*
3.132 +signature LAZY_SEQUENCE =
3.133 +sig
3.134 + datatype 'a lazy_sequence = Lazy_Sequence of unit -> ('a * 'a lazy_sequence) option
3.135 + val yield : 'a lazy_sequence -> ('a * 'a lazy_sequence) option
3.136 + val yieldn : int -> 'a lazy_sequence -> ('a list * 'a lazy_sequence)
3.137 +end;
3.138 +
3.139 +structure Lazy_Sequence : LAZY_SEQUENCE =
3.140 +struct
3.141 +
3.142 +@{code_datatype lazy_sequence = Lazy_Sequence}
3.143 +
3.144 +val yield = @{code yield}
3.145 +
3.146 +val yieldn = @{code yieldn}
3.147 +
3.148 +end;
3.149 +*}
3.150 +
3.151 +code_reserved Eval Lazy_Sequence
3.152 +
3.153 +code_type lazy_sequence (Eval "_/ Lazy'_Sequence.lazy'_sequence")
3.154 +
3.155 +code_const Lazy_Sequence (Eval "Lazy'_Sequence.Lazy'_Sequence")
3.156 +
3.157 +hide (open) type lazy_sequence
3.158 +hide (open) const Empty Insert Lazy_Sequence yield yieldn empty single append flat map bind if_seq not_seq
3.159 +hide (open) fact yield.simps yieldn.simps empty_def single_def append.simps flat.simps map.simps bind_def if_seq_def not_seq_def
3.160 +
3.161 +end
4.1 --- a/src/HOL/Predicate_Compile.thy Sat Jan 16 21:14:15 2010 +0100
4.2 +++ b/src/HOL/Predicate_Compile.thy Wed Jan 20 11:56:45 2010 +0100
4.3 @@ -5,7 +5,7 @@
4.4 header {* A compiler for predicates defined by introduction rules *}
4.5
4.6 theory Predicate_Compile
4.7 -imports Quickcheck
4.8 +imports Random_Sequence Quickcheck
4.9 uses
4.10 "Tools/Predicate_Compile/predicate_compile_aux.ML"
4.11 "Tools/Predicate_Compile/predicate_compile_core.ML"
4.12 @@ -18,4 +18,4 @@
4.13
4.14 setup Predicate_Compile.setup
4.15
4.16 -end
4.17 \ No newline at end of file
4.18 +end
5.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
5.2 +++ b/src/HOL/Random_Sequence.thy Wed Jan 20 11:56:45 2010 +0100
5.3 @@ -0,0 +1,61 @@
5.4 +
5.5 +(* Author: Lukas Bulwahn, TU Muenchen *)
5.6 +
5.7 +theory Random_Sequence
5.8 +imports Quickcheck DSequence
5.9 +begin
5.10 +
5.11 +types 'a random_dseq = "code_numeral \<Rightarrow> code_numeral \<Rightarrow> Random.seed \<Rightarrow> ('a DSequence.dseq \<times> Random.seed)"
5.12 +
5.13 +definition empty :: "'a random_dseq"
5.14 +where
5.15 + "empty = (%nrandom size. Pair (DSequence.empty))"
5.16 +
5.17 +definition single :: "'a => 'a random_dseq"
5.18 +where
5.19 + "single x = (%nrandom size. Pair (DSequence.single x))"
5.20 +
5.21 +definition bind :: "'a random_dseq => ('a \<Rightarrow> 'b random_dseq) \<Rightarrow> 'b random_dseq"
5.22 +where
5.23 + "bind R f = (\<lambda>nrandom size s. let
5.24 + (P, s') = R nrandom size s;
5.25 + (s1, s2) = Random.split_seed s'
5.26 + in (DSequence.bind P (%a. fst (f a nrandom size s1)), s2))"
5.27 +
5.28 +definition union :: "'a random_dseq => 'a random_dseq => 'a random_dseq"
5.29 +where
5.30 + "union R1 R2 = (\<lambda>nrandom size s. let
5.31 + (S1, s') = R1 nrandom size s; (S2, s'') = R2 nrandom size s'
5.32 + in (DSequence.union S1 S2, s''))"
5.33 +
5.34 +definition if_random_dseq :: "bool => unit random_dseq"
5.35 +where
5.36 + "if_random_dseq b = (if b then single () else empty)"
5.37 +
5.38 +definition not_random_dseq :: "unit random_dseq => unit random_dseq"
5.39 +where
5.40 + "not_random_dseq R = (\<lambda>nrandom size s. let
5.41 + (S, s') = R nrandom size s
5.42 + in (DSequence.not_seq S, s'))"
5.43 +
5.44 +fun Random :: "(code_numeral \<Rightarrow> Random.seed \<Rightarrow> (('a \<times> (unit \<Rightarrow> term)) \<times> Random.seed)) \<Rightarrow> 'a random_dseq"
5.45 +where
5.46 + "Random g nrandom = (%size. if nrandom <= 0 then (Pair DSequence.empty) else
5.47 + (scomp (g size) (%r. scomp (Random g (nrandom - 1) size) (%rs. Pair (DSequence.union (DSequence.single (fst r)) rs)))))"
5.48 +
5.49 +definition map :: "('a => 'b) => 'a random_dseq => 'b random_dseq"
5.50 +where
5.51 + "map f P = bind P (single o f)"
5.52 +
5.53 +(*
5.54 +hide const DSequence.empty DSequence.single DSequence.eval
5.55 + DSequence.map_seq DSequence.bind DSequence.union DSequence.if_seq DSequence.not_seq
5.56 + DSequence.map
5.57 +*)
5.58 +
5.59 +hide (open) const empty single bind union if_random_dseq not_random_dseq Random map
5.60 +
5.61 +hide type DSequence.dseq random_dseq
5.62 +hide (open) fact empty_def single_def bind_def union_def if_random_dseq_def not_random_dseq_def Random_def map_def
5.63 +
5.64 +end
5.65 \ No newline at end of file
6.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile.ML Sat Jan 16 21:14:15 2010 +0100
6.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile.ML Wed Jan 20 11:56:45 2010 +0100
6.3 @@ -69,14 +69,19 @@
6.4 (intross3 @ new_intross, thy'''')
6.5 end
6.6
6.7 -fun preprocess_strong_conn_constnames options gr constnames thy =
6.8 +fun preprocess_strong_conn_constnames options gr ts thy =
6.9 let
6.10 - val get_specs = map (fn k => (k, Graph.get_node gr k))
6.11 - val _ = print_step options ("Preprocessing scc of " ^ commas constnames)
6.12 - val (prednames, funnames) = List.partition (is_pred thy) constnames
6.13 + fun get_specs ts = map_filter (fn t =>
6.14 + TermGraph.get_node gr t |>
6.15 + (fn ths => if null ths then NONE else SOME (fst (dest_Const t), ths)))
6.16 + ts
6.17 + val _ = print_step options ("Preprocessing scc of " ^
6.18 + commas (map (Syntax.string_of_term_global thy) ts))
6.19 + val (prednames, funnames) = List.partition (fn t => body_type (fastype_of t) = @{typ bool}) ts
6.20 (* untangle recursion by defining predicates for all functions *)
6.21 val _ = print_step options
6.22 - ("Compiling functions (" ^ commas funnames ^ ") to predicates...")
6.23 + ("Compiling functions (" ^ commas (map (Syntax.string_of_term_global thy) funnames) ^
6.24 + ") to predicates...")
6.25 val (fun_pred_specs, thy') =
6.26 if not (null funnames) then Predicate_Compile_Fun.define_predicates
6.27 (get_specs funnames) thy else ([], thy)
6.28 @@ -95,17 +100,19 @@
6.29 thy''''
6.30 end;
6.31
6.32 -fun preprocess options const thy =
6.33 +fun preprocess options t thy =
6.34 let
6.35 val _ = print_step options "Fetching definitions from theory..."
6.36 - val table = Predicate_Compile_Data.make_const_spec_table options thy
6.37 - val gr = Predicate_Compile_Data.obtain_specification_graph options thy table const
6.38 - val gr = Graph.subgraph (member (op =) (Graph.all_succs gr [const])) gr
6.39 - in fold_rev (preprocess_strong_conn_constnames options gr)
6.40 - (Graph.strong_conn gr) thy
6.41 + val gr = Output.cond_timeit (!Quickcheck.timing) "preprocess-obtain graph"
6.42 + (fn () => Predicate_Compile_Data.obtain_specification_graph options thy t
6.43 + |> (fn gr => TermGraph.subgraph (member (op =) (TermGraph.all_succs gr [t])) gr))
6.44 + in
6.45 + Output.cond_timeit (!Quickcheck.timing) "preprocess-process"
6.46 + (fn () => (fold_rev (preprocess_strong_conn_constnames options gr)
6.47 + (TermGraph.strong_conn gr) thy))
6.48 end
6.49
6.50 -fun extract_options (((expected_modes, proposed_modes), raw_options), const) =
6.51 +fun extract_options (((expected_modes, proposed_modes), (compilation, raw_options)), const) =
6.52 let
6.53 fun chk s = member (op =) raw_options s
6.54 in
6.55 @@ -123,9 +130,7 @@
6.56 show_compilation = chk "show_compilation",
6.57 skip_proof = chk "skip_proof",
6.58 inductify = chk "inductify",
6.59 - random = chk "random",
6.60 - depth_limited = chk "depth_limited",
6.61 - annotated = chk "annotated"
6.62 + compilation = compilation
6.63 }
6.64 end
6.65
6.66 @@ -133,11 +138,13 @@
6.67 let
6.68 val thy = ProofContext.theory_of lthy
6.69 val const = Code.read_const thy raw_const
6.70 + val T = Sign.the_const_type thy const
6.71 + val t = Const (const, T)
6.72 val options = extract_options (((expected_modes, proposed_modes), raw_options), const)
6.73 in
6.74 if (is_inductify options) then
6.75 let
6.76 - val lthy' = Local_Theory.theory (preprocess options const) lthy
6.77 + val lthy' = Local_Theory.theory (preprocess options t) lthy
6.78 |> Local_Theory.checkpoint
6.79 val const =
6.80 case Predicate_Compile_Fun.pred_of_function (ProofContext.theory_of lthy') const of
6.81 @@ -153,10 +160,6 @@
6.82
6.83 val setup = Predicate_Compile_Core.setup
6.84
6.85 -val bool_options = ["show_steps", "show_intermediate_results", "show_proof_trace", "show_modes",
6.86 - "show_mode_inference", "show_compilation", "skip_proof", "inductify", "random", "depth_limited",
6.87 - "annotated"]
6.88 -
6.89 local structure P = OuterParse
6.90 in
6.91
6.92 @@ -187,8 +190,11 @@
6.93 val scan_options =
6.94 let
6.95 val scan_bool_option = foldl1 (op ||) (map Args.$$$ bool_options)
6.96 + val scan_compilation = foldl1 (op ||) (map (fn (s, c) => Args.$$$ s >> K c) compilation_names)
6.97 in
6.98 - Scan.optional (P.$$$ "[" |-- P.enum1 "," scan_bool_option --| P.$$$ "]") []
6.99 + Scan.optional (P.$$$ "[" |-- Scan.optional scan_compilation Pred
6.100 + -- P.enum "," scan_bool_option --| P.$$$ "]")
6.101 + (Pred, [])
6.102 end
6.103
6.104 val opt_print_modes = Scan.optional (P.$$$ "(" |-- P.!!! (Scan.repeat1 P.xname --| P.$$$ ")")) [];
6.105 @@ -200,12 +206,15 @@
6.106
6.107 val value_options =
6.108 let
6.109 - val depth_limit = Scan.optional (Args.$$$ "depth_limit" |-- P.$$$ "=" |-- P.nat >> SOME) NONE
6.110 - val random = Scan.optional (Args.$$$ "random" >> K true) false
6.111 - val annotated = Scan.optional (Args.$$$ "annotated" >> K true) false
6.112 + val expected_values = Scan.optional (Args.$$$ "expected" |-- P.term >> SOME) NONE
6.113 + val scan_compilation =
6.114 + Scan.optional
6.115 + (foldl1 (op ||)
6.116 + (map (fn (s, c) => Args.$$$ s -- P.enum "," P.int >> (fn (_, ps) => (c, ps)))
6.117 + compilation_names))
6.118 + (Pred, [])
6.119 in
6.120 - Scan.optional (P.$$$ "[" |-- depth_limit -- (random -- annotated) --| P.$$$ "]")
6.121 - (NONE, (false, false))
6.122 + Scan.optional (P.$$$ "[" |-- expected_values -- scan_compilation --| P.$$$ "]") (NONE, (Pred, []))
6.123 end
6.124
6.125 (* code_pred command and values command *)
6.126 @@ -217,7 +226,7 @@
6.127
6.128 val _ = OuterSyntax.improper_command "values" "enumerate and print comprehensions" OuterKeyword.diag
6.129 (opt_print_modes -- opt_param_modes -- value_options -- Scan.optional P.nat ~1 -- P.term
6.130 - >> (fn ((((print_modes, param_modes), options), k), t) => Toplevel.no_timing o Toplevel.keep
6.131 + >> (fn ((((print_modes, param_modes), options), k), t) => Toplevel.keep
6.132 (Predicate_Compile_Core.values_cmd print_modes param_modes options k t)));
6.133
6.134 end
7.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_aux.ML Sat Jan 16 21:14:15 2010 +0100
7.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_aux.ML Wed Jan 20 11:56:45 2010 +0100
7.3 @@ -6,49 +6,45 @@
7.4
7.5 (* FIXME proper signature *)
7.6
7.7 +structure TermGraph = Graph(type key = term val ord = TermOrd.fast_term_ord);
7.8 +
7.9 structure Predicate_Compile_Aux =
7.10 struct
7.11
7.12 +(* general functions *)
7.13 +
7.14 +fun apfst3 f (x, y, z) = (f x, y, z)
7.15 +fun apsnd3 f (x, y, z) = (x, f y, z)
7.16 +fun aptrd3 f (x, y, z) = (x, y, f z)
7.17 +
7.18 +fun comb_option f (SOME x1, SOME x2) = SOME (f (x1, x2))
7.19 + | comb_option f (NONE, SOME x2) = SOME x2
7.20 + | comb_option f (SOME x1, NONE) = SOME x1
7.21 + | comb_option f (NONE, NONE) = NONE
7.22 +
7.23 +fun map2_optional f (x :: xs) (y :: ys) = (f x (SOME y)) :: (map2_optional f xs ys)
7.24 + | map2_optional f (x :: xs) [] = (f x NONE) :: (map2_optional f xs [])
7.25 + | map2_optional f [] [] = []
7.26 +
7.27 +fun find_indices f xs =
7.28 + map_filter (fn (i, true) => SOME i | (i, false) => NONE) (map_index (apsnd f) xs)
7.29
7.30 (* mode *)
7.31
7.32 -type smode = (int * int list option) list
7.33 -type mode = smode option list * smode
7.34 -datatype tmode = Mode of mode * smode * tmode option list;
7.35 -
7.36 -fun string_of_smode js =
7.37 - commas (map
7.38 - (fn (i, is) =>
7.39 - string_of_int i ^ (case is of NONE => ""
7.40 - | SOME is => "p" ^ enclose "[" "]" (commas (map string_of_int is)))) js)
7.41 -(* FIXME: remove! *)
7.42 -
7.43 -fun string_of_mode (iss, is) = space_implode " -> " (map
7.44 - (fn NONE => "X"
7.45 - | SOME js => enclose "[" "]" (string_of_smode js))
7.46 - (iss @ [SOME is]));
7.47 -
7.48 -fun string_of_tmode (Mode (predmode, termmode, param_modes)) =
7.49 - "predmode: " ^ (string_of_mode predmode) ^
7.50 - (if null param_modes then "" else
7.51 - "; " ^ "params: " ^ commas (map (the_default "NONE" o Option.map string_of_tmode) param_modes))
7.52 -
7.53 -(* new datatype for mode *)
7.54 -
7.55 -datatype mode' = Bool | Input | Output | Pair of mode' * mode' | Fun of mode' * mode'
7.56 +datatype mode = Bool | Input | Output | Pair of mode * mode | Fun of mode * mode
7.57
7.58 (* equality of instantiatedness with respect to equivalences:
7.59 Pair Input Input == Input and Pair Output Output == Output *)
7.60 -fun eq_mode' (Fun (m1, m2), Fun (m3, m4)) = eq_mode' (m1, m3) andalso eq_mode' (m2, m4)
7.61 - | eq_mode' (Pair (m1, m2), Pair (m3, m4)) = eq_mode' (m1, m3) andalso eq_mode' (m2, m4)
7.62 - | eq_mode' (Pair (m1, m2), Input) = eq_mode' (m1, Input) andalso eq_mode' (m2, Input)
7.63 - | eq_mode' (Pair (m1, m2), Output) = eq_mode' (m1, Output) andalso eq_mode' (m2, Output)
7.64 - | eq_mode' (Input, Pair (m1, m2)) = eq_mode' (Input, m1) andalso eq_mode' (Input, m2)
7.65 - | eq_mode' (Output, Pair (m1, m2)) = eq_mode' (Output, m1) andalso eq_mode' (Output, m2)
7.66 - | eq_mode' (Input, Input) = true
7.67 - | eq_mode' (Output, Output) = true
7.68 - | eq_mode' (Bool, Bool) = true
7.69 - | eq_mode' _ = false
7.70 +fun eq_mode (Fun (m1, m2), Fun (m3, m4)) = eq_mode (m1, m3) andalso eq_mode (m2, m4)
7.71 + | eq_mode (Pair (m1, m2), Pair (m3, m4)) = eq_mode (m1, m3) andalso eq_mode (m2, m4)
7.72 + | eq_mode (Pair (m1, m2), Input) = eq_mode (m1, Input) andalso eq_mode (m2, Input)
7.73 + | eq_mode (Pair (m1, m2), Output) = eq_mode (m1, Output) andalso eq_mode (m2, Output)
7.74 + | eq_mode (Input, Pair (m1, m2)) = eq_mode (Input, m1) andalso eq_mode (Input, m2)
7.75 + | eq_mode (Output, Pair (m1, m2)) = eq_mode (Output, m1) andalso eq_mode (Output, m2)
7.76 + | eq_mode (Input, Input) = true
7.77 + | eq_mode (Output, Output) = true
7.78 + | eq_mode (Bool, Bool) = true
7.79 + | eq_mode _ = false
7.80
7.81 (* name: binder_modes? *)
7.82 fun strip_fun_mode (Fun (mode, mode')) = mode :: strip_fun_mode mode'
7.83 @@ -61,7 +57,153 @@
7.84 fun dest_tuple_mode (Pair (mode, mode')) = mode :: dest_tuple_mode mode'
7.85 | dest_tuple_mode _ = []
7.86
7.87 -fun string_of_mode' mode' =
7.88 +fun all_modes_of_typ (T as Type ("fun", _)) =
7.89 + let
7.90 + val (S, U) = strip_type T
7.91 + in
7.92 + if U = HOLogic.boolT then
7.93 + fold_rev (fn m1 => fn m2 => map_product (curry Fun) m1 m2)
7.94 + (map all_modes_of_typ S) [Bool]
7.95 + else
7.96 + [Input, Output]
7.97 + end
7.98 + | all_modes_of_typ (Type ("*", [T1, T2])) =
7.99 + map_product (curry Pair) (all_modes_of_typ T1) (all_modes_of_typ T2)
7.100 + | all_modes_of_typ (Type ("bool", [])) = [Bool]
7.101 + | all_modes_of_typ _ = [Input, Output]
7.102 +
7.103 +fun extract_params arg =
7.104 + case fastype_of arg of
7.105 + (T as Type ("fun", _)) =>
7.106 + (if (body_type T = HOLogic.boolT) then
7.107 + (case arg of
7.108 + Free _ => [arg] | _ => error "extract_params: Unexpected term")
7.109 + else [])
7.110 + | (Type ("*", [T1, T2])) =>
7.111 + let
7.112 + val (t1, t2) = HOLogic.dest_prod arg
7.113 + in
7.114 + extract_params t1 @ extract_params t2
7.115 + end
7.116 + | _ => []
7.117 +
7.118 +fun ho_arg_modes_of mode =
7.119 + let
7.120 + fun ho_arg_mode (m as Fun _) = [m]
7.121 + | ho_arg_mode (Pair (m1, m2)) = ho_arg_mode m1 @ ho_arg_mode m2
7.122 + | ho_arg_mode _ = []
7.123 + in
7.124 + maps ho_arg_mode (strip_fun_mode mode)
7.125 + end
7.126 +
7.127 +fun ho_args_of mode ts =
7.128 + let
7.129 + fun ho_arg (Fun _) (SOME t) = [t]
7.130 + | ho_arg (Fun _) NONE = error "ho_arg_of"
7.131 + | ho_arg (Pair (m1, m2)) (SOME (Const ("Pair", _) $ t1 $ t2)) =
7.132 + ho_arg m1 (SOME t1) @ ho_arg m2 (SOME t2)
7.133 + | ho_arg (Pair (m1, m2)) NONE = ho_arg m1 NONE @ ho_arg m2 NONE
7.134 + | ho_arg _ _ = []
7.135 + in
7.136 + flat (map2_optional ho_arg (strip_fun_mode mode) ts)
7.137 + end
7.138 +
7.139 +(* temporary function should be replaced by unsplit_input or so? *)
7.140 +fun replace_ho_args mode hoargs ts =
7.141 + let
7.142 + fun replace (Fun _, _) (arg' :: hoargs') = (arg', hoargs')
7.143 + | replace (Pair (m1, m2), Const ("Pair", T) $ t1 $ t2) hoargs =
7.144 + let
7.145 + val (t1', hoargs') = replace (m1, t1) hoargs
7.146 + val (t2', hoargs'') = replace (m2, t2) hoargs'
7.147 + in
7.148 + (Const ("Pair", T) $ t1' $ t2', hoargs'')
7.149 + end
7.150 + | replace (_, t) hoargs = (t, hoargs)
7.151 + in
7.152 + fst (fold_map replace ((strip_fun_mode mode) ~~ ts) hoargs)
7.153 + end
7.154 +
7.155 +fun ho_argsT_of mode Ts =
7.156 + let
7.157 + fun ho_arg (Fun _) T = [T]
7.158 + | ho_arg (Pair (m1, m2)) (Type ("*", [T1, T2])) = ho_arg m1 T1 @ ho_arg m2 T2
7.159 + | ho_arg _ _ = []
7.160 + in
7.161 + flat (map2 ho_arg (strip_fun_mode mode) Ts)
7.162 + end
7.163 +
7.164 +(* splits mode and maps function to higher-order argument types *)
7.165 +fun split_map_mode f mode ts =
7.166 + let
7.167 + fun split_arg_mode' (m as Fun _) t = f m t
7.168 + | split_arg_mode' (Pair (m1, m2)) (Const ("Pair", _) $ t1 $ t2) =
7.169 + let
7.170 + val (i1, o1) = split_arg_mode' m1 t1
7.171 + val (i2, o2) = split_arg_mode' m2 t2
7.172 + in
7.173 + (comb_option HOLogic.mk_prod (i1, i2), comb_option HOLogic.mk_prod (o1, o2))
7.174 + end
7.175 + | split_arg_mode' Input t = (SOME t, NONE)
7.176 + | split_arg_mode' Output t = (NONE, SOME t)
7.177 + | split_arg_mode' _ _ = error "split_map_mode: mode and term do not match"
7.178 + in
7.179 + (pairself (map_filter I) o split_list) (map2 split_arg_mode' (strip_fun_mode mode) ts)
7.180 + end
7.181 +
7.182 +(* splits mode and maps function to higher-order argument types *)
7.183 +fun split_map_modeT f mode Ts =
7.184 + let
7.185 + fun split_arg_mode' (m as Fun _) T = f m T
7.186 + | split_arg_mode' (Pair (m1, m2)) (Type ("*", [T1, T2])) =
7.187 + let
7.188 + val (i1, o1) = split_arg_mode' m1 T1
7.189 + val (i2, o2) = split_arg_mode' m2 T2
7.190 + in
7.191 + (comb_option HOLogic.mk_prodT (i1, i2), comb_option HOLogic.mk_prodT (o1, o2))
7.192 + end
7.193 + | split_arg_mode' Input T = (SOME T, NONE)
7.194 + | split_arg_mode' Output T = (NONE, SOME T)
7.195 + | split_arg_mode' _ _ = error "split_modeT': mode and type do not match"
7.196 + in
7.197 + (pairself (map_filter I) o split_list) (map2 split_arg_mode' (strip_fun_mode mode) Ts)
7.198 + end
7.199 +
7.200 +fun split_mode mode ts = split_map_mode (fn _ => fn _ => (NONE, NONE)) mode ts
7.201 +
7.202 +fun fold_map_aterms_prodT comb f (Type ("*", [T1, T2])) s =
7.203 + let
7.204 + val (x1, s') = fold_map_aterms_prodT comb f T1 s
7.205 + val (x2, s'') = fold_map_aterms_prodT comb f T2 s'
7.206 + in
7.207 + (comb x1 x2, s'')
7.208 + end
7.209 + | fold_map_aterms_prodT comb f T s = f T s
7.210 +
7.211 +fun map_filter_prod f (Const ("Pair", _) $ t1 $ t2) =
7.212 + comb_option HOLogic.mk_prod (map_filter_prod f t1, map_filter_prod f t2)
7.213 + | map_filter_prod f t = f t
7.214 +
7.215 +(* obviously, split_mode' and split_modeT' do not match? where does that cause problems? *)
7.216 +
7.217 +fun split_modeT' mode Ts =
7.218 + let
7.219 + fun split_arg_mode' (Fun _) T = ([], [])
7.220 + | split_arg_mode' (Pair (m1, m2)) (Type ("*", [T1, T2])) =
7.221 + let
7.222 + val (i1, o1) = split_arg_mode' m1 T1
7.223 + val (i2, o2) = split_arg_mode' m2 T2
7.224 + in
7.225 + (i1 @ i2, o1 @ o2)
7.226 + end
7.227 + | split_arg_mode' Input T = ([T], [])
7.228 + | split_arg_mode' Output T = ([], [T])
7.229 + | split_arg_mode' _ _ = error "split_modeT': mode and type do not match"
7.230 + in
7.231 + (pairself flat o split_list) (map2 split_arg_mode' (strip_fun_mode mode) Ts)
7.232 + end
7.233 +
7.234 +fun string_of_mode mode =
7.235 let
7.236 fun string_of_mode1 Input = "i"
7.237 | string_of_mode1 Output = "o"
7.238 @@ -71,9 +213,9 @@
7.239 | string_of_mode2 mode = string_of_mode1 mode
7.240 and string_of_mode3 (Fun (m1, m2)) = string_of_mode2 m1 ^ " => " ^ string_of_mode3 m2
7.241 | string_of_mode3 mode = string_of_mode2 mode
7.242 - in string_of_mode3 mode' end
7.243 + in string_of_mode3 mode end
7.244
7.245 -fun ascii_string_of_mode' mode' =
7.246 +fun ascii_string_of_mode mode' =
7.247 let
7.248 fun ascii_string_of_mode' Input = "i"
7.249 | ascii_string_of_mode' Output = "o"
7.250 @@ -91,55 +233,10 @@
7.251 | ascii_string_of_mode'_Pair m = ascii_string_of_mode' m
7.252 in ascii_string_of_mode'_Fun mode' end
7.253
7.254 -fun translate_mode T (iss, is) =
7.255 - let
7.256 - val Ts = binder_types T
7.257 - val (Ts1, Ts2) = chop (length iss) Ts
7.258 - fun translate_smode Ts is =
7.259 - let
7.260 - fun translate_arg (i, T) =
7.261 - case AList.lookup (op =) is (i + 1) of
7.262 - SOME NONE => Input
7.263 - | SOME (SOME its) =>
7.264 - let
7.265 - fun translate_tuple (i, T) = if member (op =) its (i + 1) then Input else Output
7.266 - in
7.267 - foldr1 Pair (map_index translate_tuple (HOLogic.strip_tupleT T))
7.268 - end
7.269 - | NONE => Output
7.270 - in map_index translate_arg Ts end
7.271 - fun mk_mode arg_modes = foldr1 Fun (arg_modes @ [Bool])
7.272 - val param_modes =
7.273 - map (fn (T, NONE) => Input | (T, SOME is) => mk_mode (translate_smode (binder_types T) is))
7.274 - (Ts1 ~~ iss)
7.275 - in
7.276 - mk_mode (param_modes @ translate_smode Ts2 is)
7.277 - end;
7.278 +(* premises *)
7.279
7.280 -fun translate_mode' nparams mode' =
7.281 - let
7.282 - fun err () = error "translate_mode': given mode cannot be translated"
7.283 - val (m1, m2) = chop nparams (strip_fun_mode mode')
7.284 - val translate_to_tupled_mode =
7.285 - (map_filter I) o (map_index (fn (i, m) =>
7.286 - if eq_mode' (m, Input) then SOME (i + 1)
7.287 - else if eq_mode' (m, Output) then NONE
7.288 - else err ()))
7.289 - val translate_to_smode =
7.290 - (map_filter I) o (map_index (fn (i, m) =>
7.291 - if eq_mode' (m, Input) then SOME (i + 1, NONE)
7.292 - else if eq_mode' (m, Output) then NONE
7.293 - else SOME (i + 1, SOME (translate_to_tupled_mode (dest_tuple_mode m)))))
7.294 - fun translate_to_param_mode m =
7.295 - case rev (dest_fun_mode m) of
7.296 - Bool :: _ :: _ => SOME (translate_to_smode (strip_fun_mode m))
7.297 - | _ => if eq_mode' (m, Input) then NONE else err ()
7.298 - in
7.299 - (map translate_to_param_mode m1, translate_to_smode m2)
7.300 - end
7.301 -
7.302 -fun string_of_mode thy constname mode =
7.303 - string_of_mode' (translate_mode (Sign.the_const_type thy constname) mode)
7.304 +datatype indprem = Prem of term | Negprem of term | Sidecond of term
7.305 + | Generator of (string * typ);
7.306
7.307 (* general syntactic functions *)
7.308
7.309 @@ -162,9 +259,9 @@
7.310 val is_pred_equation = is_pred_equation_term o prop_of
7.311
7.312 fun is_intro_term constname t =
7.313 - case fst (strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl t))) of
7.314 + the_default false (try (fn t => case fst (strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl t))) of
7.315 Const (c, _) => c = constname
7.316 - | _ => false
7.317 + | _ => false) t)
7.318
7.319 fun is_intro constname t = is_intro_term constname (prop_of t)
7.320
7.321 @@ -177,21 +274,8 @@
7.322 fun is_predT (T as Type("fun", [_, _])) = (snd (strip_type T) = HOLogic.boolT)
7.323 | is_predT _ = false
7.324
7.325 -(* guessing number of parameters *)
7.326 -fun find_indexes pred xs =
7.327 - let
7.328 - fun find is n [] = is
7.329 - | find is n (x :: xs) = find (if pred x then (n :: is) else is) (n + 1) xs;
7.330 - in rev (find [] 0 xs) end;
7.331 -
7.332 -fun guess_nparams T =
7.333 - let
7.334 - val argTs = binder_types T
7.335 - val nparams = fold Integer.max
7.336 - (map (fn x => x + 1) (find_indexes is_predT argTs)) 0
7.337 - in nparams end;
7.338 -
7.339 (*** check if a term contains only constructor functions ***)
7.340 +(* TODO: another copy in the core! *)
7.341 (* FIXME: constructor terms are supposed to be seen in the way the code generator
7.342 sees constructors.*)
7.343 fun is_constrt thy =
7.344 @@ -206,7 +290,34 @@
7.345 | _ => false)
7.346 | _ => false)
7.347 in check end;
7.348 -
7.349 +
7.350 +fun is_funtype (Type ("fun", [_, _])) = true
7.351 + | is_funtype _ = false;
7.352 +
7.353 +fun is_Type (Type _) = true
7.354 + | is_Type _ = false
7.355 +
7.356 +(* returns true if t is an application of an datatype constructor *)
7.357 +(* which then consequently would be splitted *)
7.358 +(* else false *)
7.359 +(*
7.360 +fun is_constructor thy t =
7.361 + if (is_Type (fastype_of t)) then
7.362 + (case DatatypePackage.get_datatype thy ((fst o dest_Type o fastype_of) t) of
7.363 + NONE => false
7.364 + | SOME info => (let
7.365 + val constr_consts = maps (fn (_, (_, _, constrs)) => map fst constrs) (#descr info)
7.366 + val (c, _) = strip_comb t
7.367 + in (case c of
7.368 + Const (name, _) => name mem_string constr_consts
7.369 + | _ => false) end))
7.370 + else false
7.371 +*)
7.372 +
7.373 +(* must be exported in code.ML *)
7.374 +(* TODO: is there copy in the core? *)
7.375 +fun is_constr thy = is_some o Code.get_datatype_of_constr thy;
7.376 +
7.377 fun strip_ex (Const ("Ex", _) $ Abs (x, T, t)) =
7.378 let
7.379 val (xTs, t') = strip_ex t
7.380 @@ -224,7 +335,6 @@
7.381 val t'' = Term.subst_bounds (rev vs, t');
7.382 in ((ps', t''), nctxt') end;
7.383
7.384 -
7.385 (* introduction rule combinators *)
7.386
7.387 (* combinators to apply a function to all literals of an introduction rules *)
7.388 @@ -280,10 +390,23 @@
7.389
7.390 (* Different options for compiler *)
7.391
7.392 +datatype compilation = Pred | Random | Depth_Limited | DSeq | Annotated | Random_DSeq
7.393 +
7.394 +fun string_of_compilation c = case c of
7.395 + Pred => ""
7.396 + | Random => "random"
7.397 + | Depth_Limited => "depth limited"
7.398 + | DSeq => "dseq"
7.399 + | Annotated => "annotated"
7.400 + | Random_DSeq => "random dseq"
7.401 +
7.402 +(*datatype compilation_options =
7.403 + Pred | Random of int | Depth_Limited of int | DSeq of int | Annotated*)
7.404 +
7.405 datatype options = Options of {
7.406 - expected_modes : (string * mode' list) option,
7.407 - proposed_modes : (string * mode' list) option,
7.408 - proposed_names : ((string * mode') * string) list,
7.409 + expected_modes : (string * mode list) option,
7.410 + proposed_modes : (string * mode list) option,
7.411 + proposed_names : ((string * mode) * string) list,
7.412 show_steps : bool,
7.413 show_proof_trace : bool,
7.414 show_intermediate_results : bool,
7.415 @@ -293,14 +416,12 @@
7.416 skip_proof : bool,
7.417
7.418 inductify : bool,
7.419 - random : bool,
7.420 - depth_limited : bool,
7.421 - annotated : bool
7.422 + compilation : compilation
7.423 };
7.424
7.425 fun expected_modes (Options opt) = #expected_modes opt
7.426 fun proposed_modes (Options opt) = #proposed_modes opt
7.427 -fun proposed_names (Options opt) name mode = AList.lookup (eq_pair (op =) eq_mode')
7.428 +fun proposed_names (Options opt) name mode = AList.lookup (eq_pair (op =) eq_mode)
7.429 (#proposed_names opt) (name, mode)
7.430
7.431 fun show_steps (Options opt) = #show_steps opt
7.432 @@ -312,9 +433,8 @@
7.433 fun skip_proof (Options opt) = #skip_proof opt
7.434
7.435 fun is_inductify (Options opt) = #inductify opt
7.436 -fun is_random (Options opt) = #random opt
7.437 -fun is_depth_limited (Options opt) = #depth_limited opt
7.438 -fun is_annotated (Options opt) = #annotated opt
7.439 +
7.440 +fun compilation (Options opt) = #compilation opt
7.441
7.442 val default_options = Options {
7.443 expected_modes = NONE,
7.444 @@ -326,14 +446,18 @@
7.445 show_modes = false,
7.446 show_mode_inference = false,
7.447 show_compilation = false,
7.448 - skip_proof = false,
7.449 + skip_proof = true,
7.450
7.451 inductify = false,
7.452 - random = false,
7.453 - depth_limited = false,
7.454 - annotated = false
7.455 + compilation = Pred
7.456 }
7.457
7.458 +val bool_options = ["show_steps", "show_intermediate_results", "show_proof_trace", "show_modes",
7.459 + "show_mode_inference", "show_compilation", "skip_proof", "inductify"]
7.460 +
7.461 +val compilation_names = [("pred", Pred),
7.462 + (*("random", Random), ("depth_limited", Depth_Limited), ("annotated", Annotated),*)
7.463 + ("dseq", DSeq), ("random_dseq", Random_DSeq)]
7.464
7.465 fun print_step options s =
7.466 if show_steps options then tracing s else ()
8.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_core.ML Sat Jan 16 21:14:15 2010 +0100
8.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_core.ML Wed Jan 20 11:56:45 2010 +0100
8.3 @@ -9,36 +9,41 @@
8.4 val setup : theory -> theory
8.5 val code_pred : Predicate_Compile_Aux.options -> string -> Proof.context -> Proof.state
8.6 val code_pred_cmd : Predicate_Compile_Aux.options -> string -> Proof.context -> Proof.state
8.7 - val values_cmd : string list -> Predicate_Compile_Aux.mode' option list option
8.8 - -> int option * (bool * bool) -> int -> string -> Toplevel.state -> unit
8.9 - val register_predicate : (string * thm list * thm * int) -> theory -> theory
8.10 + val values_cmd : string list -> Predicate_Compile_Aux.mode option list option
8.11 + -> (string option * (Predicate_Compile_Aux.compilation * int list))
8.12 + -> int -> string -> Toplevel.state -> unit
8.13 + val register_predicate : (string * thm list * thm) -> theory -> theory
8.14 val register_intros : string * thm list -> theory -> theory
8.15 val is_registered : theory -> string -> bool
8.16 + val function_name_of : Predicate_Compile_Aux.compilation -> theory
8.17 + -> string -> Predicate_Compile_Aux.mode -> string
8.18 val predfun_intro_of: theory -> string -> Predicate_Compile_Aux.mode -> thm
8.19 val predfun_elim_of: theory -> string -> Predicate_Compile_Aux.mode -> thm
8.20 - val predfun_name_of: theory -> string -> Predicate_Compile_Aux.mode -> string
8.21 val all_preds_of : theory -> string list
8.22 - val modes_of: theory -> string -> Predicate_Compile_Aux.mode list
8.23 - val depth_limited_modes_of: theory -> string -> Predicate_Compile_Aux.mode list
8.24 - val depth_limited_function_name_of : theory -> string -> Predicate_Compile_Aux.mode -> string
8.25 - val random_modes_of: theory -> string -> Predicate_Compile_Aux.mode list
8.26 - val random_function_name_of : theory -> string -> Predicate_Compile_Aux.mode -> string
8.27 - val all_modes_of : theory -> (string * Predicate_Compile_Aux.mode list) list
8.28 + val modes_of: Predicate_Compile_Aux.compilation
8.29 + -> theory -> string -> Predicate_Compile_Aux.mode list
8.30 + val all_modes_of : Predicate_Compile_Aux.compilation
8.31 + -> theory -> (string * Predicate_Compile_Aux.mode list) list
8.32 val all_random_modes_of : theory -> (string * Predicate_Compile_Aux.mode list) list
8.33 val intros_of : theory -> string -> thm list
8.34 - val nparams_of : theory -> string -> int
8.35 val add_intro : thm -> theory -> theory
8.36 val set_elim : thm -> theory -> theory
8.37 - val set_nparams : string -> int -> theory -> theory
8.38 + val preprocess_intro : theory -> thm -> thm
8.39 val print_stored_rules : theory -> unit
8.40 - val print_all_modes : theory -> unit
8.41 - val mk_casesrule : Proof.context -> term -> int -> thm list -> term
8.42 + val print_all_modes : Predicate_Compile_Aux.compilation -> theory -> unit
8.43 + val mk_casesrule : Proof.context -> term -> thm list -> term
8.44 +
8.45 val eval_ref : (unit -> term Predicate.pred) option Unsynchronized.ref
8.46 val random_eval_ref : (unit -> int * int -> term Predicate.pred * (int * int))
8.47 option Unsynchronized.ref
8.48 + val dseq_eval_ref : (unit -> term DSequence.dseq) option Unsynchronized.ref
8.49 + val random_dseq_eval_ref : (unit -> int -> int -> int * int -> term DSequence.dseq * (int * int))
8.50 + option Unsynchronized.ref
8.51 val code_pred_intro_attrib : attribute
8.52 +
8.53 (* used by Quickcheck_Generator *)
8.54 (* temporary for testing of the compilation *)
8.55 +
8.56 datatype compilation_funs = CompilationFuns of {
8.57 mk_predT : typ -> typ,
8.58 dest_predT : typ -> typ,
8.59 @@ -50,12 +55,11 @@
8.60 mk_not : term -> term,
8.61 mk_map : typ -> typ -> term -> term -> term
8.62 };
8.63 +
8.64 val pred_compfuns : compilation_funs
8.65 val randompred_compfuns : compilation_funs
8.66 val add_equations : Predicate_Compile_Aux.options -> string list -> theory -> theory
8.67 - val add_quickcheck_equations : Predicate_Compile_Aux.options -> string list -> theory -> theory
8.68 - val add_depth_limited_equations : Predicate_Compile_Aux.options
8.69 - -> string list -> theory -> theory
8.70 + val add_random_dseq_equations : Predicate_Compile_Aux.options -> string list -> theory -> theory
8.71 val mk_tracing : string -> term -> term
8.72 end;
8.73
8.74 @@ -75,6 +79,8 @@
8.75
8.76 fun debug_tac msg = Seq.single; (* (fn st => (Output.tracing msg; Seq.single st)); *)
8.77
8.78 +fun assert b = if not b then error "Assertion failed" else warning "Assertion holds"
8.79 +
8.80 datatype assertion = Max_number_of_subgoals of int
8.81 fun assert_tac (Max_number_of_subgoals i) st =
8.82 if (nprems_of st <= i) then Seq.single st
8.83 @@ -97,7 +103,7 @@
8.84 val T = fastype_of t
8.85 val U = fastype_of u
8.86 val [A] = binder_types T
8.87 - val D = body_type U
8.88 + val D = body_type U
8.89 in
8.90 Const (@{const_name "scomp"}, T --> U --> A --> D) $ t $ u
8.91 end;
8.92 @@ -121,96 +127,92 @@
8.93 Const(@{const_name Code_Evaluation.tracing},
8.94 @{typ String.literal} --> (fastype_of t) --> (fastype_of t)) $ (HOLogic.mk_literal s) $ t
8.95
8.96 -(* destruction of intro rules *)
8.97 +val strip_intro_concl = (strip_comb o HOLogic.dest_Trueprop o Logic.strip_imp_concl o prop_of)
8.98
8.99 -(* FIXME: look for other place where this functionality was used before *)
8.100 -fun strip_intro_concl nparams intro =
8.101 +(* derivation trees for modes of premises *)
8.102 +
8.103 +datatype mode_derivation = Mode_App of mode_derivation * mode_derivation | Context of mode
8.104 + | Mode_Pair of mode_derivation * mode_derivation | Term of mode
8.105 +
8.106 +fun string_of_derivation (Mode_App (m1, m2)) =
8.107 + "App (" ^ string_of_derivation m1 ^ ", " ^ string_of_derivation m2 ^ ")"
8.108 + | string_of_derivation (Mode_Pair (m1, m2)) =
8.109 + "Pair (" ^ string_of_derivation m1 ^ ", " ^ string_of_derivation m2 ^ ")"
8.110 + | string_of_derivation (Term m) = "Term (" ^ string_of_mode m ^ ")"
8.111 + | string_of_derivation (Context m) = "Context (" ^ string_of_mode m ^ ")"
8.112 +
8.113 +fun strip_mode_derivation deriv =
8.114 let
8.115 - val _ $ u = Logic.strip_imp_concl intro
8.116 - val (pred, all_args) = strip_comb u
8.117 - val (params, args) = chop nparams all_args
8.118 - in (pred, (params, args)) end
8.119 + fun strip (Mode_App (deriv1, deriv2)) ds = strip deriv1 (deriv2 :: ds)
8.120 + | strip deriv ds = (deriv, ds)
8.121 + in
8.122 + strip deriv []
8.123 + end
8.124
8.125 -(** data structures **)
8.126 +fun mode_of (Context m) = m
8.127 + | mode_of (Term m) = m
8.128 + | mode_of (Mode_App (d1, d2)) =
8.129 + (case mode_of d1 of Fun (m, m') =>
8.130 + (if m = mode_of d2 then m' else error "mode_of")
8.131 + | _ => error "mode_of2")
8.132 + | mode_of (Mode_Pair (d1, d2)) =
8.133 + Pair (mode_of d1, mode_of d2)
8.134
8.135 -fun gen_split_smode (mk_tuple, strip_tuple) smode ts =
8.136 +fun head_mode_of deriv = mode_of (fst (strip_mode_derivation deriv))
8.137 +
8.138 +fun param_derivations_of deriv =
8.139 let
8.140 - fun split_tuple' _ _ [] = ([], [])
8.141 - | split_tuple' is i (t::ts) =
8.142 - (if member (op =) is i then apfst else apsnd) (cons t)
8.143 - (split_tuple' is (i+1) ts)
8.144 - fun split_tuple is t = split_tuple' is 1 (strip_tuple t)
8.145 - fun split_smode' _ _ [] = ([], [])
8.146 - | split_smode' smode i (t::ts) =
8.147 - (if member (op =) (map fst smode) i then
8.148 - case (the (AList.lookup (op =) smode i)) of
8.149 - NONE => apfst (cons t)
8.150 - | SOME is =>
8.151 - let
8.152 - val (ts1, ts2) = split_tuple is t
8.153 - fun cons_tuple ts = if null ts then I else cons (mk_tuple ts)
8.154 - in (apfst (cons_tuple ts1)) o (apsnd (cons_tuple ts2)) end
8.155 - else apsnd (cons t))
8.156 - (split_smode' smode (i+1) ts)
8.157 - in split_smode' smode 1 ts end
8.158 + val (_, argument_derivs) = strip_mode_derivation deriv
8.159 + fun param_derivation (Mode_Pair (m1, m2)) =
8.160 + param_derivation m1 @ param_derivation m2
8.161 + | param_derivation (Term _) = []
8.162 + | param_derivation m = [m]
8.163 + in
8.164 + maps param_derivation argument_derivs
8.165 + end
8.166
8.167 -fun split_smode smode ts = gen_split_smode (HOLogic.mk_tuple, HOLogic.strip_tuple) smode ts
8.168 -fun split_smodeT smode ts = gen_split_smode (HOLogic.mk_tupleT, HOLogic.strip_tupleT) smode ts
8.169 +fun collect_context_modes (Mode_App (m1, m2)) =
8.170 + collect_context_modes m1 @ collect_context_modes m2
8.171 + | collect_context_modes (Mode_Pair (m1, m2)) =
8.172 + collect_context_modes m1 @ collect_context_modes m2
8.173 + | collect_context_modes (Context m) = [m]
8.174 + | collect_context_modes (Term _) = []
8.175
8.176 -fun gen_split_mode split_smode (iss, is) ts =
8.177 - let
8.178 - val (t1, t2) = chop (length iss) ts
8.179 - in (t1, split_smode is t2) end
8.180 +(* representation of inferred clauses with modes *)
8.181
8.182 -fun split_mode (iss, is) ts = gen_split_mode split_smode (iss, is) ts
8.183 -fun split_modeT (iss, is) ts = gen_split_mode split_smodeT (iss, is) ts
8.184 +type moded_clause = term list * (indprem * mode_derivation) list
8.185
8.186 -datatype indprem = Prem of term list * term | Negprem of term list * term | Sidecond of term
8.187 - | Generator of (string * typ);
8.188 -
8.189 -type moded_clause = term list * (indprem * tmode) list
8.190 type 'a pred_mode_table = (string * (mode * 'a) list) list
8.191
8.192 +(* book-keeping *)
8.193 +
8.194 datatype predfun_data = PredfunData of {
8.195 - name : string,
8.196 definition : thm,
8.197 intro : thm,
8.198 elim : thm
8.199 };
8.200
8.201 fun rep_predfun_data (PredfunData data) = data;
8.202 -fun mk_predfun_data (name, definition, intro, elim) =
8.203 - PredfunData {name = name, definition = definition, intro = intro, elim = elim}
8.204
8.205 -datatype function_data = FunctionData of {
8.206 - name : string,
8.207 - equation : thm option (* is not used at all? *)
8.208 -};
8.209 -
8.210 -fun rep_function_data (FunctionData data) = data;
8.211 -fun mk_function_data (name, equation) =
8.212 - FunctionData {name = name, equation = equation}
8.213 +fun mk_predfun_data (definition, intro, elim) =
8.214 + PredfunData {definition = definition, intro = intro, elim = elim}
8.215
8.216 datatype pred_data = PredData of {
8.217 intros : thm list,
8.218 elim : thm option,
8.219 - nparams : int,
8.220 - functions : bool * (mode * predfun_data) list,
8.221 - random_functions : bool * (mode * function_data) list,
8.222 - depth_limited_functions : bool * (mode * function_data) list,
8.223 - annotated_functions : bool * (mode * function_data) list
8.224 + function_names : (compilation * (mode * string) list) list,
8.225 + predfun_data : (mode * predfun_data) list,
8.226 + needs_random : mode list
8.227 };
8.228
8.229 fun rep_pred_data (PredData data) = data;
8.230 -fun mk_pred_data ((intros, elim, nparams),
8.231 - (functions, random_functions, depth_limited_functions, annotated_functions)) =
8.232 - PredData {intros = intros, elim = elim, nparams = nparams,
8.233 - functions = functions, random_functions = random_functions,
8.234 - depth_limited_functions = depth_limited_functions, annotated_functions = annotated_functions}
8.235 -fun map_pred_data f (PredData {intros, elim, nparams,
8.236 - functions, random_functions, depth_limited_functions, annotated_functions}) =
8.237 - mk_pred_data (f ((intros, elim, nparams), (functions, random_functions,
8.238 - depth_limited_functions, annotated_functions)))
8.239 +
8.240 +fun mk_pred_data ((intros, elim), (function_names, predfun_data, needs_random)) =
8.241 + PredData {intros = intros, elim = elim,
8.242 + function_names = function_names, predfun_data = predfun_data, needs_random = needs_random}
8.243 +
8.244 +fun map_pred_data f (PredData {intros, elim, function_names, predfun_data, needs_random}) =
8.245 + mk_pred_data (f ((intros, elim), (function_names, predfun_data, needs_random)))
8.246
8.247 fun eq_option eq (NONE, NONE) = true
8.248 | eq_option eq (SOME x, SOME y) = eq (x, y)
8.249 @@ -218,8 +220,7 @@
8.250
8.251 fun eq_pred_data (PredData d1, PredData d2) =
8.252 eq_list (Thm.eq_thm) (#intros d1, #intros d2) andalso
8.253 - eq_option (Thm.eq_thm) (#elim d1, #elim d2) andalso
8.254 - #nparams d1 = #nparams d2
8.255 + eq_option (Thm.eq_thm) (#elim d1, #elim d2)
8.256
8.257 structure PredData = Theory_Data
8.258 (
8.259 @@ -238,7 +239,7 @@
8.260 of NONE => error ("No such predicate " ^ quote name)
8.261 | SOME data => data;
8.262
8.263 -val is_registered = is_some oo lookup_pred_data
8.264 +val is_registered = is_some oo lookup_pred_data
8.265
8.266 val all_preds_of = Graph.keys o PredData.get
8.267
8.268 @@ -250,24 +251,38 @@
8.269
8.270 val has_elim = is_some o #elim oo the_pred_data;
8.271
8.272 -val nparams_of = #nparams oo the_pred_data
8.273 +fun function_names_of compilation thy name =
8.274 + case AList.lookup (op =) (#function_names (the_pred_data thy name)) compilation of
8.275 + NONE => error ("No " ^ string_of_compilation compilation
8.276 + ^ "functions defined for predicate " ^ quote name)
8.277 + | SOME fun_names => fun_names
8.278
8.279 -val modes_of = (map fst) o snd o #functions oo the_pred_data
8.280 +fun function_name_of compilation thy name mode =
8.281 + case AList.lookup (op =) (function_names_of compilation thy name) mode of
8.282 + NONE => error ("No " ^ string_of_compilation compilation
8.283 + ^ "function defined for mode " ^ string_of_mode mode ^ " of predicate " ^ quote name)
8.284 + | SOME function_name => function_name
8.285
8.286 -fun all_modes_of thy = map (fn name => (name, modes_of thy name)) (all_preds_of thy)
8.287 +fun modes_of compilation thy name = map fst (function_names_of compilation thy name)
8.288
8.289 -val defined_functions = fst o #functions oo the_pred_data
8.290 +fun all_modes_of compilation thy =
8.291 + map_filter (fn name => Option.map (pair name) (try (modes_of compilation thy) name))
8.292 + (all_preds_of thy)
8.293 +
8.294 +val all_random_modes_of = all_modes_of Random
8.295 +
8.296 +fun defined_functions compilation thy name =
8.297 + AList.defined (op =) (#function_names (the_pred_data thy name)) compilation
8.298
8.299 fun lookup_predfun_data thy name mode =
8.300 Option.map rep_predfun_data
8.301 - (AList.lookup (op =) (snd (#functions (the_pred_data thy name))) mode)
8.302 + (AList.lookup (op =) (#predfun_data (the_pred_data thy name)) mode)
8.303
8.304 -fun the_predfun_data thy name mode = case lookup_predfun_data thy name mode
8.305 - of NONE => error ("No function defined for mode " ^ string_of_mode thy name mode ^
8.306 - " of predicate " ^ name)
8.307 - | SOME data => data;
8.308 -
8.309 -val predfun_name_of = #name ooo the_predfun_data
8.310 +fun the_predfun_data thy name mode =
8.311 + case lookup_predfun_data thy name mode of
8.312 + NONE => error ("No function defined for mode " ^ string_of_mode mode ^
8.313 + " of predicate " ^ name)
8.314 + | SOME data => data;
8.315
8.316 val predfun_definition_of = #definition ooo the_predfun_data
8.317
8.318 @@ -275,102 +290,32 @@
8.319
8.320 val predfun_elim_of = #elim ooo the_predfun_data
8.321
8.322 -fun lookup_random_function_data thy name mode =
8.323 - Option.map rep_function_data
8.324 - (AList.lookup (op =) (snd (#random_functions (the_pred_data thy name))) mode)
8.325 -
8.326 -fun the_random_function_data thy name mode = case lookup_random_function_data thy name mode of
8.327 - NONE => error ("No random function defined for mode " ^ string_of_mode thy name mode ^
8.328 - " of predicate " ^ name)
8.329 - | SOME data => data
8.330 -
8.331 -val random_function_name_of = #name ooo the_random_function_data
8.332 -
8.333 -val random_modes_of = (map fst) o snd o #random_functions oo the_pred_data
8.334 -
8.335 -val defined_random_functions = fst o #random_functions oo the_pred_data
8.336 -
8.337 -fun all_random_modes_of thy =
8.338 - map (fn name => (name, random_modes_of thy name)) (all_preds_of thy)
8.339 -
8.340 -fun lookup_depth_limited_function_data thy name mode =
8.341 - Option.map rep_function_data
8.342 - (AList.lookup (op =) (snd (#depth_limited_functions (the_pred_data thy name))) mode)
8.343 -
8.344 -fun the_depth_limited_function_data thy name mode =
8.345 - case lookup_depth_limited_function_data thy name mode of
8.346 - NONE => error ("No depth-limited function defined for mode " ^ string_of_mode thy name mode
8.347 - ^ " of predicate " ^ name)
8.348 - | SOME data => data
8.349 -
8.350 -val depth_limited_function_name_of = #name ooo the_depth_limited_function_data
8.351 -
8.352 -val depth_limited_modes_of = (map fst) o snd o #depth_limited_functions oo the_pred_data
8.353 -
8.354 -val defined_depth_limited_functions = fst o #depth_limited_functions oo the_pred_data
8.355 -
8.356 -fun lookup_annotated_function_data thy name mode =
8.357 - Option.map rep_function_data
8.358 - (AList.lookup (op =) (snd (#annotated_functions (the_pred_data thy name))) mode)
8.359 -
8.360 -fun the_annotated_function_data thy name mode = case lookup_annotated_function_data thy name mode
8.361 - of NONE => error ("No annotated function defined for mode " ^ string_of_mode thy name mode
8.362 - ^ " of predicate " ^ name)
8.363 - | SOME data => data
8.364 -
8.365 -val annotated_function_name_of = #name ooo the_annotated_function_data
8.366 -
8.367 -val annotated_modes_of = (map fst) o snd o #annotated_functions oo the_pred_data
8.368 -
8.369 -val defined_annotated_functions = fst o #annotated_functions oo the_pred_data
8.370 -
8.371 (* diagnostic display functions *)
8.372
8.373 fun print_modes options thy modes =
8.374 if show_modes options then
8.375 tracing ("Inferred modes:\n" ^
8.376 cat_lines (map (fn (s, ms) => s ^ ": " ^ commas (map
8.377 - (string_of_mode thy s) ms)) modes))
8.378 + string_of_mode ms)) modes))
8.379 else ()
8.380
8.381 fun print_pred_mode_table string_of_entry thy pred_mode_table =
8.382 let
8.383 - fun print_mode pred (mode, entry) = "mode : " ^ string_of_mode thy pred mode
8.384 + fun print_mode pred (mode, entry) = "mode : " ^ string_of_mode mode
8.385 ^ string_of_entry pred mode entry
8.386 fun print_pred (pred, modes) =
8.387 "predicate " ^ pred ^ ": " ^ cat_lines (map (print_mode pred) modes)
8.388 val _ = tracing (cat_lines (map print_pred pred_mode_table))
8.389 in () end;
8.390
8.391 -fun string_of_prem thy (Prem (ts, p)) =
8.392 - (Syntax.string_of_term_global thy (list_comb (p, ts))) ^ "(premise)"
8.393 - | string_of_prem thy (Negprem (ts, p)) =
8.394 - (Syntax.string_of_term_global thy (HOLogic.mk_not (list_comb (p, ts)))) ^ "(negative premise)"
8.395 +fun string_of_prem thy (Prem t) =
8.396 + (Syntax.string_of_term_global thy t) ^ "(premise)"
8.397 + | string_of_prem thy (Negprem t) =
8.398 + (Syntax.string_of_term_global thy (HOLogic.mk_not t)) ^ "(negative premise)"
8.399 | string_of_prem thy (Sidecond t) =
8.400 (Syntax.string_of_term_global thy t) ^ "(sidecondition)"
8.401 | string_of_prem thy _ = error "string_of_prem: unexpected input"
8.402
8.403 -fun string_of_moded_prem thy (Prem (ts, p), tmode) =
8.404 - (Syntax.string_of_term_global thy (list_comb (p, ts))) ^
8.405 - "(" ^ (string_of_tmode tmode) ^ ")"
8.406 - | string_of_moded_prem thy (Generator (v, T), _) =
8.407 - "Generator for " ^ v ^ " of Type " ^ (Syntax.string_of_typ_global thy T)
8.408 - | string_of_moded_prem thy (Negprem (ts, p), Mode (_, is, _)) =
8.409 - (Syntax.string_of_term_global thy (list_comb (p, ts))) ^
8.410 - "(negative mode: " ^ string_of_smode is ^ ")"
8.411 - | string_of_moded_prem thy (Sidecond t, Mode (_, is, _)) =
8.412 - (Syntax.string_of_term_global thy t) ^
8.413 - "(sidecond mode: " ^ string_of_smode is ^ ")"
8.414 - | string_of_moded_prem _ _ = error "string_of_moded_prem: unimplemented"
8.415 -
8.416 -fun print_moded_clauses thy =
8.417 - let
8.418 - fun string_of_clause pred mode clauses =
8.419 - cat_lines (map (fn (ts, prems) => (space_implode " --> "
8.420 - (map (string_of_moded_prem thy) prems)) ^ " --> " ^ pred ^ " "
8.421 - ^ (space_implode " " (map (Syntax.string_of_term_global thy) ts))) clauses)
8.422 - in print_pred_mode_table string_of_clause thy end;
8.423 -
8.424 fun string_of_clause thy pred (ts, prems) =
8.425 (space_implode " --> "
8.426 (map (string_of_prem thy) prems)) ^ " --> " ^ pred ^ " "
8.427 @@ -386,7 +331,6 @@
8.428 val preds = (Graph.keys o PredData.get) thy
8.429 fun print pred () = let
8.430 val _ = writeln ("predicate: " ^ pred)
8.431 - val _ = writeln ("number of parameters: " ^ string_of_int (nparams_of thy pred))
8.432 val _ = writeln ("introrules: ")
8.433 val _ = fold (fn thm => fn u => writeln (Display.string_of_thm_global thy thm))
8.434 (rev (intros_of thy pred)) ()
8.435 @@ -400,16 +344,16 @@
8.436 fold print preds ()
8.437 end;
8.438
8.439 -fun print_all_modes thy =
8.440 +fun print_all_modes compilation thy =
8.441 let
8.442 val _ = writeln ("Inferred modes:")
8.443 fun print (pred, modes) u =
8.444 let
8.445 val _ = writeln ("predicate: " ^ pred)
8.446 - val _ = writeln ("modes: " ^ (commas (map (string_of_mode thy pred) modes)))
8.447 + val _ = writeln ("modes: " ^ (commas (map string_of_mode modes)))
8.448 in u end
8.449 in
8.450 - fold print (all_modes_of thy) ()
8.451 + fold print (all_modes_of compilation thy) ()
8.452 end
8.453
8.454 (* validity checks *)
8.455 @@ -420,12 +364,12 @@
8.456 SOME (s, ms) => (case AList.lookup (op =) modes s of
8.457 SOME modes =>
8.458 let
8.459 - val modes' = map (translate_mode (the (AList.lookup (op =) preds s))) modes
8.460 + val modes' = modes
8.461 in
8.462 - if not (eq_set eq_mode' (ms, modes')) then
8.463 + if not (eq_set eq_mode (ms, modes')) then
8.464 error ("expected modes were not inferred:\n"
8.465 - ^ " inferred modes for " ^ s ^ ": " ^ commas (map string_of_mode' modes') ^ "\n"
8.466 - ^ " expected modes for " ^ s ^ ": " ^ commas (map string_of_mode' ms))
8.467 + ^ " inferred modes for " ^ s ^ ": " ^ commas (map string_of_mode modes') ^ "\n"
8.468 + ^ " expected modes for " ^ s ^ ": " ^ commas (map string_of_mode ms))
8.469 else ()
8.470 end
8.471 | NONE => ())
8.472 @@ -437,12 +381,12 @@
8.473 SOME inferred_ms =>
8.474 let
8.475 val preds_without_modes = map fst (filter (null o snd) (modes @ extra_modes))
8.476 - val modes' = map (translate_mode (the (AList.lookup (op =) preds s))) inferred_ms
8.477 + val modes' = inferred_ms
8.478 in
8.479 - if not (eq_set eq_mode' (ms, modes')) then
8.480 + if not (eq_set eq_mode (ms, modes')) then
8.481 error ("expected modes were not inferred:\n"
8.482 - ^ " inferred modes for " ^ s ^ ": " ^ commas (map string_of_mode' modes') ^ "\n"
8.483 - ^ " expected modes for " ^ s ^ ": " ^ commas (map string_of_mode' ms) ^ "\n"
8.484 + ^ " inferred modes for " ^ s ^ ": " ^ commas (map string_of_mode modes') ^ "\n"
8.485 + ^ " expected modes for " ^ s ^ ": " ^ commas (map string_of_mode ms) ^ "\n"
8.486 ^ "For the following clauses, the following modes could not be inferred: " ^ "\n"
8.487 ^ cat_lines errors ^
8.488 (if not (null preds_without_modes) then
8.489 @@ -474,58 +418,88 @@
8.490 end) handle Type.TUNIFY =>
8.491 (warning "Occurrences of recursive constant have non-unifiable types"; (cs, intr_ts));
8.492
8.493 -fun import_intros inp_pred nparams [] ctxt =
8.494 +fun import_intros inp_pred [] ctxt =
8.495 let
8.496 - val ([outp_pred], ctxt') = Variable.import_terms false [inp_pred] ctxt
8.497 - val (paramTs, _) = chop nparams (binder_types (fastype_of outp_pred))
8.498 - val (param_names, ctxt'') = Variable.variant_fixes (map (fn i => "p" ^ (string_of_int i))
8.499 - (1 upto nparams)) ctxt'
8.500 + val ([outp_pred], ctxt') = Variable.import_terms true [inp_pred] ctxt
8.501 + val T = fastype_of outp_pred
8.502 + (* TODO: put in a function for this next line! *)
8.503 + val paramTs = ho_argsT_of (hd (all_modes_of_typ T)) (binder_types T)
8.504 + val (param_names, ctxt'') = Variable.variant_fixes
8.505 + (map (fn i => "p" ^ (string_of_int i)) (1 upto (length paramTs))) ctxt'
8.506 val params = map2 (curry Free) param_names paramTs
8.507 - in (((outp_pred, params), []), ctxt') end
8.508 - | import_intros inp_pred nparams (th :: ths) ctxt =
8.509 + in
8.510 + (((outp_pred, params), []), ctxt')
8.511 + end
8.512 + | import_intros inp_pred (th :: ths) ctxt =
8.513 let
8.514 - val ((_, [th']), ctxt') = Variable.import false [th] ctxt
8.515 + val ((_, [th']), ctxt') = Variable.import true [th] ctxt
8.516 val thy = ProofContext.theory_of ctxt'
8.517 - val (pred, (params, args)) = strip_intro_concl nparams (prop_of th')
8.518 - val ho_args = filter (is_predT o fastype_of) args
8.519 + val (pred, args) = strip_intro_concl th'
8.520 + val T = fastype_of pred
8.521 + val ho_args = ho_args_of (hd (all_modes_of_typ T)) args
8.522 fun subst_of (pred', pred) =
8.523 let
8.524 val subst = Sign.typ_match thy (fastype_of pred', fastype_of pred) Vartab.empty
8.525 in map (fn (indexname, (s, T)) => ((indexname, s), T)) (Vartab.dest subst) end
8.526 fun instantiate_typ th =
8.527 let
8.528 - val (pred', _) = strip_intro_concl 0 (prop_of th)
8.529 + val (pred', _) = strip_intro_concl th
8.530 val _ = if not (fst (dest_Const pred) = fst (dest_Const pred')) then
8.531 error "Trying to instantiate another predicate" else ()
8.532 in Thm.certify_instantiate (subst_of (pred', pred), []) th end;
8.533 fun instantiate_ho_args th =
8.534 let
8.535 - val (_, (params', args')) = strip_intro_concl nparams (prop_of th)
8.536 - val ho_args' = map dest_Var (filter (is_predT o fastype_of) args')
8.537 - in Thm.certify_instantiate ([], map dest_Var params' ~~ params) th end
8.538 + val (_, args') = (strip_comb o HOLogic.dest_Trueprop o Logic.strip_imp_concl o prop_of) th
8.539 + val ho_args' = map dest_Var (ho_args_of (hd (all_modes_of_typ T)) args')
8.540 + in Thm.certify_instantiate ([], ho_args' ~~ ho_args) th end
8.541 val outp_pred =
8.542 Term_Subst.instantiate (subst_of (inp_pred, pred), []) inp_pred
8.543 val ((_, ths'), ctxt1) =
8.544 Variable.import false (map (instantiate_typ #> instantiate_ho_args) ths) ctxt'
8.545 in
8.546 - (((outp_pred, params), th' :: ths'), ctxt1)
8.547 + (((outp_pred, ho_args), th' :: ths'), ctxt1)
8.548 end
8.549
8.550 (* generation of case rules from user-given introduction rules *)
8.551
8.552 -fun mk_casesrule ctxt pred nparams introrules =
8.553 +fun mk_args2 (Type ("*", [T1, T2])) st =
8.554 + let
8.555 + val (t1, st') = mk_args2 T1 st
8.556 + val (t2, st'') = mk_args2 T2 st'
8.557 + in
8.558 + (HOLogic.mk_prod (t1, t2), st'')
8.559 + end
8.560 + | mk_args2 (T as Type ("fun", _)) (params, ctxt) =
8.561 + let
8.562 + val (S, U) = strip_type T
8.563 + in
8.564 + if U = HOLogic.boolT then
8.565 + (hd params, (tl params, ctxt))
8.566 + else
8.567 + let
8.568 + val ([x], ctxt') = Variable.variant_fixes ["x"] ctxt
8.569 + in
8.570 + (Free (x, T), (params, ctxt'))
8.571 + end
8.572 + end
8.573 + | mk_args2 T (params, ctxt) =
8.574 + let
8.575 + val ([x], ctxt') = Variable.variant_fixes ["x"] ctxt
8.576 + in
8.577 + (Free (x, T), (params, ctxt'))
8.578 + end
8.579 +
8.580 +fun mk_casesrule ctxt pred introrules =
8.581 let
8.582 - val (((pred, params), intros_th), ctxt1) = import_intros pred nparams introrules ctxt
8.583 + val (((pred, params), intros_th), ctxt1) = import_intros pred introrules ctxt
8.584 val intros = map prop_of intros_th
8.585 val ([propname], ctxt2) = Variable.variant_fixes ["thesis"] ctxt1
8.586 val prop = HOLogic.mk_Trueprop (Free (propname, HOLogic.boolT))
8.587 - val (_, argsT) = chop nparams (binder_types (fastype_of pred))
8.588 - val (argnames, ctxt3) = Variable.variant_fixes
8.589 - (map (fn i => "a" ^ string_of_int i) (1 upto length argsT)) ctxt2
8.590 - val argvs = map2 (curry Free) argnames argsT
8.591 + val argsT = binder_types (fastype_of pred)
8.592 + val (argvs, _) = fold_map mk_args2 argsT (params, ctxt2)
8.593 fun mk_case intro =
8.594 let
8.595 - val (_, (_, args)) = strip_intro_concl nparams intro
8.596 + val (_, args) = (strip_comb o HOLogic.dest_Trueprop o Logic.strip_imp_concl) intro
8.597 val prems = Logic.strip_imp_prems intro
8.598 val eqprems = map2 (HOLogic.mk_Trueprop oo (curry HOLogic.mk_eq)) argvs args
8.599 val frees = (fold o fold_aterms)
8.600 @@ -533,11 +507,11 @@
8.601 if member (op aconv) params t then I else insert (op aconv) t
8.602 | _ => I) (args @ prems) []
8.603 in fold Logic.all frees (Logic.list_implies (eqprems @ prems, prop)) end
8.604 - val assm = HOLogic.mk_Trueprop (list_comb (pred, params @ argvs))
8.605 + val assm = HOLogic.mk_Trueprop (list_comb (pred, argvs))
8.606 val cases = map mk_case intros
8.607 in Logic.list_implies (assm :: cases, prop) end;
8.608
8.609 -(** preprocessing rules **)
8.610 +(** preprocessing rules **)
8.611
8.612 fun imp_prems_conv cv ct =
8.613 case Thm.term_of ct of
8.614 @@ -555,7 +529,7 @@
8.615 (Trueprop_conv (Conv.try_conv (Conv.rewr_conv (Thm.symmetric @{thm Predicate.eq_is_eq})))))
8.616 (Thm.transfer thy rule)
8.617
8.618 -fun preprocess_elim thy nparams elimrule =
8.619 +fun preprocess_elim thy elimrule =
8.620 let
8.621 fun replace_eqs (Const ("Trueprop", _) $ (Const ("op =", T) $ lhs $ rhs)) =
8.622 HOLogic.mk_Trueprop (Const (@{const_name Predicate.eq}, T) $ lhs $ rhs)
8.623 @@ -563,7 +537,7 @@
8.624 val ctxt = ProofContext.init thy
8.625 val ((_, [elimrule]), ctxt') = Variable.import false [elimrule] ctxt
8.626 val prems = Thm.prems_of elimrule
8.627 - val nargs = length (snd (strip_comb (HOLogic.dest_Trueprop (hd prems)))) - nparams
8.628 + val nargs = length (snd (strip_comb (HOLogic.dest_Trueprop (hd prems))))
8.629 fun preprocess_case t =
8.630 let
8.631 val params = Logic.strip_params t
8.632 @@ -585,15 +559,7 @@
8.633
8.634 fun expand_tuples_elim th = th
8.635
8.636 -(* updaters *)
8.637 -
8.638 -fun apfst4 f (x1, x2, x3, x4) = (f x1, x2, x3, x4)
8.639 -fun apsnd4 f (x1, x2, x3, x4) = (x1, f x2, x3, x4)
8.640 -fun aptrd4 f (x1, x2, x3, x4) = (x1, x2, f x3, x4)
8.641 -fun apfourth4 f (x1, x2, x3, x4) = (x1, x2, x3, f x4)
8.642 -fun appair f g (x, y) = (f x, g x)
8.643 -
8.644 -val no_compilation = ((false, []), (false, []), (false, []), (false, []))
8.645 +val no_compilation = ([], [], [])
8.646
8.647 fun fetch_pred_data thy name =
8.648 case try (Inductive.the_inductive (ProofContext.init thy)) name of
8.649 @@ -608,20 +574,19 @@
8.650 val index = find_index (fn s => s = name) (#names (fst info))
8.651 val pre_elim = nth (#elims result) index
8.652 val pred = nth (#preds result) index
8.653 - val nparams = length (Inductive.params_of (#raw_induct result))
8.654 (*val elim = singleton (Inductive_Set.codegen_preproc thy) (preprocess_elim thy nparams
8.655 (expand_tuples_elim pre_elim))*)
8.656 val elim =
8.657 (Drule.standard o Skip_Proof.make_thm thy)
8.658 - (mk_casesrule (ProofContext.init thy) pred nparams intros)
8.659 + (mk_casesrule (ProofContext.init thy) pred intros)
8.660 in
8.661 - mk_pred_data ((intros, SOME elim, nparams), no_compilation)
8.662 + mk_pred_data ((intros, SOME elim), no_compilation)
8.663 end
8.664 | NONE => error ("No such predicate: " ^ quote name)
8.665
8.666 -fun add_predfun name mode data =
8.667 +fun add_predfun_data name mode data =
8.668 let
8.669 - val add = (apsnd o apfst4) (fn (x, y) => (true, cons (mode, mk_predfun_data data) y))
8.670 + val add = (apsnd o apsnd3) (cons (mode, mk_predfun_data data))
8.671 in PredData.map (Graph.map_node name (map_pred_data add)) end
8.672
8.673 fun is_inductive_predicate thy name =
8.674 @@ -636,96 +601,74 @@
8.675 (is_inductive_predicate thy c orelse is_registered thy c))
8.676 end;
8.677
8.678 -
8.679 -(* code dependency graph *)
8.680 -(*
8.681 -fun dependencies_of thy name =
8.682 - let
8.683 - val (intros, elim, nparams) = fetch_pred_data thy name
8.684 - val data = mk_pred_data ((intros, SOME elim, nparams), ([], [], []))
8.685 - val keys = depending_preds_of thy intros
8.686 - in
8.687 - (data, keys)
8.688 - end;
8.689 -*)
8.690 -
8.691 fun add_intro thm thy =
8.692 let
8.693 - val (name, T) = dest_Const (fst (strip_intro_concl 0 (prop_of thm)))
8.694 + val (name, T) = dest_Const (fst (strip_intro_concl thm))
8.695 fun cons_intro gr =
8.696 case try (Graph.get_node gr) name of
8.697 SOME pred_data => Graph.map_node name (map_pred_data
8.698 - (apfst (fn (intros, elim, nparams) => (intros @ [thm], elim, nparams)))) gr
8.699 - | NONE =>
8.700 - let
8.701 - val nparams = the_default (guess_nparams T)
8.702 - (try (#nparams o rep_pred_data o (fetch_pred_data thy)) name)
8.703 - in Graph.new_node (name, mk_pred_data (([thm], NONE, nparams), no_compilation)) gr end;
8.704 + (apfst (fn (intros, elim) => (intros @ [thm], elim)))) gr
8.705 + | NONE => Graph.new_node (name, mk_pred_data (([thm], NONE), no_compilation)) gr
8.706 in PredData.map cons_intro thy end
8.707
8.708 fun set_elim thm =
8.709 let
8.710 val (name, _) = dest_Const (fst
8.711 (strip_comb (HOLogic.dest_Trueprop (hd (prems_of thm)))))
8.712 - fun set (intros, _, nparams) = (intros, SOME thm, nparams)
8.713 + fun set (intros, _) = (intros, SOME thm)
8.714 in PredData.map (Graph.map_node name (map_pred_data (apfst set))) end
8.715
8.716 -fun set_nparams name nparams =
8.717 +fun register_predicate (constname, pre_intros, pre_elim) thy =
8.718 let
8.719 - fun set (intros, elim, _ ) = (intros, elim, nparams)
8.720 - in PredData.map (Graph.map_node name (map_pred_data (apfst set))) end
8.721 -
8.722 -fun register_predicate (constname, pre_intros, pre_elim, nparams) thy =
8.723 - let
8.724 - (* preprocessing *)
8.725 val intros = map (preprocess_intro thy) pre_intros
8.726 - val elim = preprocess_elim thy nparams pre_elim
8.727 + val elim = preprocess_elim thy pre_elim
8.728 in
8.729 if not (member (op =) (Graph.keys (PredData.get thy)) constname) then
8.730 PredData.map
8.731 (Graph.new_node (constname,
8.732 - mk_pred_data ((intros, SOME elim, nparams), no_compilation))) thy
8.733 + mk_pred_data ((intros, SOME elim), no_compilation))) thy
8.734 else thy
8.735 end
8.736
8.737 fun register_intros (constname, pre_intros) thy =
8.738 let
8.739 val T = Sign.the_const_type thy constname
8.740 - fun constname_of_intro intr = fst (dest_Const (fst (strip_intro_concl 0 (prop_of intr))))
8.741 + fun constname_of_intro intr = fst (dest_Const (fst (strip_intro_concl intr)))
8.742 val _ = if not (forall (fn intr => constname_of_intro intr = constname) pre_intros) then
8.743 error ("register_intros: Introduction rules of different constants are used\n" ^
8.744 "expected rules for " ^ constname ^ ", but received rules for " ^
8.745 commas (map constname_of_intro pre_intros))
8.746 else ()
8.747 val pred = Const (constname, T)
8.748 - val nparams = guess_nparams T
8.749 val pre_elim =
8.750 (Drule.standard o Skip_Proof.make_thm thy)
8.751 - (mk_casesrule (ProofContext.init thy) pred nparams pre_intros)
8.752 - in register_predicate (constname, pre_intros, pre_elim, nparams) thy end
8.753 + (mk_casesrule (ProofContext.init thy) pred pre_intros)
8.754 + in register_predicate (constname, pre_intros, pre_elim) thy end
8.755
8.756 -fun set_random_function_name pred mode name =
8.757 +fun defined_function_of compilation pred =
8.758 let
8.759 - val set = (apsnd o apsnd4) (fn (x, y) => (true, cons (mode, mk_function_data (name, NONE)) y))
8.760 + val set = (apsnd o apfst3) (cons (compilation, []))
8.761 in
8.762 PredData.map (Graph.map_node pred (map_pred_data set))
8.763 end
8.764
8.765 -fun set_depth_limited_function_name pred mode name =
8.766 +fun set_function_name compilation pred mode name =
8.767 let
8.768 - val set = (apsnd o aptrd4) (fn (x, y) => (true, cons (mode, mk_function_data (name, NONE)) y))
8.769 + val set = (apsnd o apfst3)
8.770 + (AList.map_default (op =) (compilation, [(mode, name)]) (cons (mode, name)))
8.771 in
8.772 PredData.map (Graph.map_node pred (map_pred_data set))
8.773 end
8.774
8.775 -fun set_annotated_function_name pred mode name =
8.776 +fun set_needs_random name modes =
8.777 let
8.778 - val set = (apsnd o apfourth4)
8.779 - (fn (x, y) => (true, cons (mode, mk_function_data (name, NONE)) y))
8.780 + val set = (apsnd o aptrd3) (K modes)
8.781 in
8.782 - PredData.map (Graph.map_node pred (map_pred_data set))
8.783 + PredData.map (Graph.map_node name (map_pred_data set))
8.784 end
8.785
8.786 +(* datastructures and setup for generic compilation *)
8.787 +
8.788 datatype compilation_funs = CompilationFuns of {
8.789 mk_predT : typ -> typ,
8.790 dest_predT : typ -> typ,
8.791 @@ -789,6 +732,8 @@
8.792 Const (@{const_name Predicate.eval}, mk_predT T --> T --> HOLogic.boolT) $ f $ x
8.793 end;
8.794
8.795 +fun dest_Eval (Const (@{const_name Predicate.eval}, _) $ f $ x) = (f, x)
8.796 +
8.797 fun mk_map T1 T2 tf tp = Const (@{const_name Predicate.map},
8.798 (T1 --> T2) --> mk_predT T1 --> mk_predT T2) $ tf $ tp;
8.799
8.800 @@ -811,7 +756,7 @@
8.801 fun mk_bot T = Const(@{const_name Quickcheck.empty}, mk_randompredT T)
8.802
8.803 fun mk_single t =
8.804 - let
8.805 + let
8.806 val T = fastype_of t
8.807 in
8.808 Const (@{const_name Quickcheck.single}, T --> mk_randompredT T) $ t
8.809 @@ -840,54 +785,119 @@
8.810 mk_not = mk_not, mk_map = mk_map};
8.811
8.812 end;
8.813 +
8.814 +structure DSequence_CompFuns =
8.815 +struct
8.816 +
8.817 +fun mk_dseqT T = Type ("fun", [@{typ code_numeral}, Type ("fun", [@{typ bool},
8.818 + Type (@{type_name Option.option}, [Type ("Lazy_Sequence.lazy_sequence", [T])])])])
8.819 +
8.820 +fun dest_dseqT (Type ("fun", [@{typ code_numeral}, Type ("fun", [@{typ bool},
8.821 + Type (@{type_name Option.option}, [Type ("Lazy_Sequence.lazy_sequence", [T])])])])) = T
8.822 + | dest_dseqT T = raise TYPE ("dest_dseqT", [T], []);
8.823 +
8.824 +fun mk_bot T = Const ("DSequence.empty", mk_dseqT T);
8.825 +
8.826 +fun mk_single t =
8.827 + let val T = fastype_of t
8.828 + in Const("DSequence.single", T --> mk_dseqT T) $ t end;
8.829 +
8.830 +fun mk_bind (x, f) =
8.831 + let val T as Type ("fun", [_, U]) = fastype_of f
8.832 + in
8.833 + Const ("DSequence.bind", fastype_of x --> T --> U) $ x $ f
8.834 + end;
8.835 +
8.836 +val mk_sup = HOLogic.mk_binop "DSequence.union";
8.837 +
8.838 +fun mk_if cond = Const ("DSequence.if_seq",
8.839 + HOLogic.boolT --> mk_dseqT HOLogic.unitT) $ cond;
8.840 +
8.841 +fun mk_not t = let val T = mk_dseqT HOLogic.unitT
8.842 + in Const ("DSequence.not_seq", T --> T) $ t end
8.843 +
8.844 +fun mk_map T1 T2 tf tp = Const ("DSequence.map",
8.845 + (T1 --> T2) --> mk_dseqT T1 --> mk_dseqT T2) $ tf $ tp
8.846 +
8.847 +val compfuns = CompilationFuns {mk_predT = mk_dseqT, dest_predT = dest_dseqT,
8.848 + mk_bot = mk_bot, mk_single = mk_single, mk_bind = mk_bind, mk_sup = mk_sup, mk_if = mk_if,
8.849 + mk_not = mk_not, mk_map = mk_map}
8.850 +
8.851 +end;
8.852 +
8.853 +structure Random_Sequence_CompFuns =
8.854 +struct
8.855 +
8.856 +fun mk_random_dseqT T =
8.857 + @{typ code_numeral} --> @{typ code_numeral} --> @{typ Random.seed} -->
8.858 + HOLogic.mk_prodT (DSequence_CompFuns.mk_dseqT T, @{typ Random.seed})
8.859 +
8.860 +fun dest_random_dseqT (Type ("fun", [@{typ code_numeral}, Type ("fun", [@{typ code_numeral},
8.861 + Type ("fun", [@{typ Random.seed},
8.862 + Type (@{type_name "*"}, [T, @{typ Random.seed}])])])])) = DSequence_CompFuns.dest_dseqT T
8.863 + | dest_random_dseqT T = raise TYPE ("dest_random_dseqT", [T], []);
8.864 +
8.865 +fun mk_bot T = Const ("Random_Sequence.empty", mk_random_dseqT T);
8.866 +
8.867 +fun mk_single t =
8.868 + let val T = fastype_of t
8.869 + in Const("Random_Sequence.single", T --> mk_random_dseqT T) $ t end;
8.870 +
8.871 +fun mk_bind (x, f) =
8.872 + let
8.873 + val T as Type ("fun", [_, U]) = fastype_of f
8.874 + in
8.875 + Const ("Random_Sequence.bind", fastype_of x --> T --> U) $ x $ f
8.876 + end;
8.877 +
8.878 +val mk_sup = HOLogic.mk_binop "Random_Sequence.union";
8.879 +
8.880 +fun mk_if cond = Const ("Random_Sequence.if_random_dseq",
8.881 + HOLogic.boolT --> mk_random_dseqT HOLogic.unitT) $ cond;
8.882 +
8.883 +fun mk_not t = let val T = mk_random_dseqT HOLogic.unitT
8.884 + in Const ("Random_Sequence.not_random_dseq", T --> T) $ t end
8.885 +
8.886 +fun mk_map T1 T2 tf tp = Const ("Random_Sequence.map",
8.887 + (T1 --> T2) --> mk_random_dseqT T1 --> mk_random_dseqT T2) $ tf $ tp
8.888 +
8.889 +val compfuns = CompilationFuns {mk_predT = mk_random_dseqT, dest_predT = dest_random_dseqT,
8.890 + mk_bot = mk_bot, mk_single = mk_single, mk_bind = mk_bind, mk_sup = mk_sup, mk_if = mk_if,
8.891 + mk_not = mk_not, mk_map = mk_map}
8.892 +
8.893 +end;
8.894 +
8.895 +
8.896 +
8.897 +fun mk_random T =
8.898 + let
8.899 + val random = Const ("Quickcheck.random_class.random",
8.900 + @{typ code_numeral} --> @{typ Random.seed} -->
8.901 + HOLogic.mk_prodT (HOLogic.mk_prodT (T, @{typ "unit => term"}), @{typ Random.seed}))
8.902 + in
8.903 + Const ("Random_Sequence.Random", (@{typ code_numeral} --> @{typ Random.seed} -->
8.904 + HOLogic.mk_prodT (HOLogic.mk_prodT (T, @{typ "unit => term"}), @{typ Random.seed})) -->
8.905 + Random_Sequence_CompFuns.mk_random_dseqT T) $ random
8.906 + end;
8.907 +
8.908 +
8.909 +
8.910 (* for external use with interactive mode *)
8.911 val pred_compfuns = PredicateCompFuns.compfuns
8.912 -val randompred_compfuns = RandomPredCompFuns.compfuns;
8.913 -
8.914 -fun lift_random random =
8.915 - let
8.916 - val T = dest_randomT (fastype_of random)
8.917 - in
8.918 - Const (@{const_name Quickcheck.Random}, (@{typ Random.seed} -->
8.919 - HOLogic.mk_prodT (HOLogic.mk_prodT (T, @{typ "unit => term"}), @{typ Random.seed})) -->
8.920 - RandomPredCompFuns.mk_randompredT T) $ random
8.921 - end;
8.922 +val randompred_compfuns = Random_Sequence_CompFuns.compfuns;
8.923
8.924 (* function types and names of different compilations *)
8.925
8.926 -fun funT_of compfuns (iss, is) T =
8.927 +fun funT_of compfuns mode T =
8.928 let
8.929 val Ts = binder_types T
8.930 - val (paramTs, (inargTs, outargTs)) = split_modeT (iss, is) Ts
8.931 - val paramTs' = map2 (fn NONE => I | SOME is => funT_of compfuns ([], is)) iss paramTs
8.932 + val (inTs, outTs) = split_map_modeT (fn m => fn T => (SOME (funT_of compfuns m T), NONE)) mode Ts
8.933 in
8.934 - (paramTs' @ inargTs) ---> (mk_predT compfuns (HOLogic.mk_tupleT outargTs))
8.935 + inTs ---> (mk_predT compfuns (HOLogic.mk_tupleT outTs))
8.936 end;
8.937
8.938 -fun depth_limited_funT_of compfuns (iss, is) T =
8.939 - let
8.940 - val Ts = binder_types T
8.941 - val (paramTs, (inargTs, outargTs)) = split_modeT (iss, is) Ts
8.942 - val paramTs' =
8.943 - map2 (fn SOME is => depth_limited_funT_of compfuns ([], is) | NONE => I) iss paramTs
8.944 - in
8.945 - (paramTs' @ inargTs @ [@{typ bool}, @{typ "code_numeral"}])
8.946 - ---> (mk_predT compfuns (HOLogic.mk_tupleT outargTs))
8.947 - end;
8.948 +(** mode analysis **)
8.949
8.950 -fun random_function_funT_of (iss, is) T =
8.951 - let
8.952 - val Ts = binder_types T
8.953 - val (paramTs, (inargTs, outargTs)) = split_modeT (iss, is) Ts
8.954 - val paramTs' = map2 (fn SOME is => random_function_funT_of ([], is) | NONE => I) iss paramTs
8.955 - in
8.956 - (paramTs' @ inargTs @ [@{typ code_numeral}]) --->
8.957 - (mk_predT RandomPredCompFuns.compfuns (HOLogic.mk_tupleT outargTs))
8.958 - end
8.959 -
8.960 -(* Mode analysis *)
8.961 -
8.962 -(*** check if a term contains only constructor functions ***)
8.963 fun is_constrt thy =
8.964 let
8.965 val cnstrs = flat (maps
8.966 @@ -924,235 +934,347 @@
8.967 val is = subsets (i+1) j
8.968 in merge (map (fn ks => i::ks) is) is end
8.969 else [[]];
8.970 -
8.971 -(* FIXME: should be in library - cprod = map_prod I *)
8.972 -fun cprod ([], ys) = []
8.973 - | cprod (x :: xs, ys) = map (pair x) ys @ cprod (xs, ys);
8.974 -
8.975 -fun cprods xss = List.foldr (map op :: o cprod) [[]] xss;
8.976 -
8.977 -fun cprods_subset [] = [[]]
8.978 - | cprods_subset (xs :: xss) =
8.979 - let
8.980 - val yss = (cprods_subset xss)
8.981 - in maps (fn ys => map (fn x => cons x ys) xs) yss @ yss end
8.982 -
8.983 -fun modes_of_term modes t =
8.984 - let
8.985 - val ks = map_index (fn (i, T) => (i + 1, NONE)) (binder_types (fastype_of t));
8.986 - val default = [Mode (([], ks), ks, [])];
8.987 - fun mk_modes name args = Option.map (maps (fn (m as (iss, is)) =>
8.988 - let
8.989 - val (args1, args2) =
8.990 - if length args < length iss then
8.991 - error ("Too few arguments for inductive predicate " ^ name)
8.992 - else chop (length iss) args;
8.993 - val k = length args2;
8.994 - val prfx = map (rpair NONE) (1 upto k)
8.995 - in
8.996 - if not (is_prefix op = prfx is) then [] else
8.997 - let val is' = map (fn (i, t) => (i - k, t)) (List.drop (is, k))
8.998 - in map (fn x => Mode (m, is', x)) (cprods (map
8.999 - (fn (NONE, _) => [NONE]
8.1000 - | (SOME js, arg) => map SOME (filter
8.1001 - (fn Mode (_, js', _) => js=js') (modes_of_term modes arg)))
8.1002 - (iss ~~ args1)))
8.1003 - end
8.1004 - end)) (AList.lookup op = modes name)
8.1005 - in
8.1006 - case strip_comb (Envir.eta_contract t) of
8.1007 - (Const (name, _), args) => the_default default (mk_modes name args)
8.1008 - | (Var ((name, _), _), args) => the (mk_modes name args)
8.1009 - | (Free (name, _), args) => the (mk_modes name args)
8.1010 - | (Abs _, []) => error "Abs at param position" (* modes_of_param default modes t *)
8.1011 - | _ => default
8.1012 - end
8.1013 -
8.1014 -fun select_mode_prem thy modes vs ps =
8.1015 - find_first (is_some o snd) (ps ~~ map
8.1016 - (fn Prem (us, t) => find_first (fn Mode (_, is, _) =>
8.1017 - let
8.1018 - val (in_ts, out_ts) = split_smode is us;
8.1019 - val (out_ts', in_ts') = List.partition (is_constrt thy) out_ts;
8.1020 - val vTs = maps term_vTs out_ts';
8.1021 - val dupTs = map snd (duplicates (op =) vTs) @
8.1022 - map_filter (AList.lookup (op =) vTs) vs;
8.1023 - in
8.1024 - subset (op =) (terms_vs (in_ts @ in_ts'), vs) andalso
8.1025 - forall (is_eqT o fastype_of) in_ts' andalso
8.1026 - subset (op =) (term_vs t, vs) andalso
8.1027 - forall is_eqT dupTs
8.1028 - end)
8.1029 - (modes_of_term modes t handle Option =>
8.1030 - error ("Bad predicate: " ^ Syntax.string_of_term_global thy t))
8.1031 - | Negprem (us, t) => find_first (fn Mode (_, is, _) =>
8.1032 - is = map (rpair NONE) (1 upto length us) andalso
8.1033 - subset (op =) (terms_vs us, vs) andalso
8.1034 - subset (op =) (term_vs t, vs))
8.1035 - (modes_of_term modes t handle Option =>
8.1036 - error ("Bad predicate: " ^ Syntax.string_of_term_global thy t))
8.1037 - | Sidecond t => if subset (op =) (term_vs t, vs) then SOME (Mode (([], []), [], []))
8.1038 - else NONE
8.1039 - ) ps);
8.1040 -
8.1041 -fun fold_prem f (Prem (args, _)) = fold f args
8.1042 - | fold_prem f (Negprem (args, _)) = fold f args
8.1043 - | fold_prem f (Sidecond t) = f t
8.1044 -
8.1045 -fun all_subsets [] = [[]]
8.1046 - | all_subsets (x::xs) = let val xss' = all_subsets xs in xss' @ (map (cons x) xss') end
8.1047 -
8.1048 -fun generator vTs v =
8.1049 - let
8.1050 - val T = the (AList.lookup (op =) vTs v)
8.1051 - in
8.1052 - (Generator (v, T), Mode (([], []), [], []))
8.1053 - end;
8.1054 -
8.1055 -fun check_mode_clause with_generator thy param_vs modes gen_modes (iss, is) (ts, ps) =
8.1056 - let
8.1057 - val modes' = modes @ map_filter
8.1058 - (fn (_, NONE) => NONE | (v, SOME js) => SOME (v, [([], js)]))
8.1059 - (param_vs ~~ iss);
8.1060 - val gen_modes' = gen_modes @ map_filter
8.1061 - (fn (_, NONE) => NONE | (v, SOME js) => SOME (v, [([], js)]))
8.1062 - (param_vs ~~ iss);
8.1063 - val vTs = distinct (op =) ((fold o fold_prem) Term.add_frees ps (fold Term.add_frees ts []))
8.1064 - val prem_vs = distinct (op =) ((fold o fold_prem) Term.add_free_names ps [])
8.1065 - fun check_mode_prems acc_ps vs [] = SOME (acc_ps, vs)
8.1066 - | check_mode_prems acc_ps vs ps = (case select_mode_prem thy modes' vs ps of
8.1067 - NONE =>
8.1068 - (if with_generator then
8.1069 - (case select_mode_prem thy gen_modes' vs ps of
8.1070 - SOME (p as Prem _, SOME mode) => check_mode_prems ((p, mode) :: acc_ps)
8.1071 - (case p of Prem (us, _) => union (op =) vs (terms_vs us) | _ => vs)
8.1072 - (filter_out (equal p) ps)
8.1073 - | _ =>
8.1074 - let
8.1075 - val all_generator_vs = all_subsets (subtract (op =) vs prem_vs)
8.1076 - |> sort (int_ord o (pairself length))
8.1077 - in
8.1078 - case (find_first (fn generator_vs => is_some
8.1079 - (select_mode_prem thy modes' (union (op =) vs generator_vs) ps))
8.1080 - all_generator_vs) of
8.1081 - SOME generator_vs => check_mode_prems
8.1082 - ((map (generator vTs) generator_vs) @ acc_ps)
8.1083 - (union (op =) vs generator_vs) ps
8.1084 - | NONE => NONE
8.1085 - end)
8.1086 - else
8.1087 - NONE)
8.1088 - | SOME (p, SOME mode) => check_mode_prems ((p, mode) :: acc_ps)
8.1089 - (case p of Prem (us, _) => union (op =) vs (terms_vs us) | _ => vs)
8.1090 - (filter_out (equal p) ps))
8.1091 - val (in_ts, in_ts') = List.partition (is_constrt thy) (fst (split_smode is ts));
8.1092 - val in_vs = terms_vs in_ts;
8.1093 - val concl_vs = terms_vs ts
8.1094 - in
8.1095 - if forall is_eqT (map snd (duplicates (op =) (maps term_vTs in_ts))) andalso
8.1096 - forall (is_eqT o fastype_of) in_ts' then
8.1097 - case check_mode_prems [] (union (op =) param_vs in_vs) ps of
8.1098 - NONE => NONE
8.1099 - | SOME (acc_ps, vs) =>
8.1100 - if with_generator then
8.1101 - SOME (ts, (rev acc_ps) @ (map (generator vTs) (subtract (op =) vs concl_vs)))
8.1102 - else
8.1103 - if subset (op =) (concl_vs, vs) then SOME (ts, rev acc_ps) else NONE
8.1104 - else NONE
8.1105 - end;
8.1106
8.1107 fun print_failed_mode options thy modes p m rs is =
8.1108 if show_mode_inference options then
8.1109 let
8.1110 val _ = tracing ("Clauses " ^ commas (map (fn i => string_of_int (i + 1)) is) ^ " of " ^
8.1111 - p ^ " violates mode " ^ string_of_mode thy p m)
8.1112 + p ^ " violates mode " ^ string_of_mode m)
8.1113 in () end
8.1114 else ()
8.1115
8.1116 -fun error_of thy p m is =
8.1117 +fun error_of p m is =
8.1118 (" Clauses " ^ commas (map (fn i => string_of_int (i + 1)) is) ^ " of " ^
8.1119 - p ^ " violates mode " ^ string_of_mode thy p m)
8.1120 + p ^ " violates mode " ^ string_of_mode m)
8.1121
8.1122 -fun find_indices f xs =
8.1123 - map_filter (fn (i, true) => SOME i | (i, false) => NONE) (map_index (apsnd f) xs)
8.1124 +fun is_all_input mode =
8.1125 + let
8.1126 + fun is_all_input' (Fun _) = true
8.1127 + | is_all_input' (Pair (m1, m2)) = is_all_input' m1 andalso is_all_input' m2
8.1128 + | is_all_input' Input = true
8.1129 + | is_all_input' Output = false
8.1130 + in
8.1131 + forall is_all_input' (strip_fun_mode mode)
8.1132 + end
8.1133
8.1134 -fun check_modes_pred options with_generator thy param_vs clauses modes gen_modes (p, ms) =
8.1135 +fun all_input_of T =
8.1136 let
8.1137 - val rs = case AList.lookup (op =) clauses p of SOME rs => rs | NONE => []
8.1138 - fun invalid_mode m =
8.1139 - case find_indices
8.1140 - (is_none o check_mode_clause with_generator thy param_vs modes gen_modes m) rs of
8.1141 - [] => NONE
8.1142 - | is => SOME (error_of thy p m is)
8.1143 - val res = map (fn m => (m, invalid_mode m)) ms
8.1144 - val ms' = map_filter (fn (m, NONE) => SOME m | _ => NONE) res
8.1145 - val errors = map_filter snd res
8.1146 + val (Ts, U) = strip_type T
8.1147 + fun input_of (Type ("*", [T1, T2])) = Pair (input_of T1, input_of T2)
8.1148 + | input_of _ = Input
8.1149 + in
8.1150 + if U = HOLogic.boolT then
8.1151 + fold_rev (curry Fun) (map input_of Ts) Bool
8.1152 + else
8.1153 + error "all_input_of: not a predicate"
8.1154 + end
8.1155 +
8.1156 +fun partial_hd [] = NONE
8.1157 + | partial_hd (x :: xs) = SOME x
8.1158 +
8.1159 +fun term_vs tm = fold_aterms (fn Free (x, T) => cons x | _ => I) tm [];
8.1160 +val terms_vs = distinct (op =) o maps term_vs;
8.1161 +
8.1162 +fun input_mode T =
8.1163 + let
8.1164 + val (Ts, U) = strip_type T
8.1165 + in
8.1166 + fold_rev (curry Fun) (map (K Input) Ts) Input
8.1167 + end
8.1168 +
8.1169 +fun output_mode T =
8.1170 + let
8.1171 + val (Ts, U) = strip_type T
8.1172 + in
8.1173 + fold_rev (curry Fun) (map (K Output) Ts) Output
8.1174 + end
8.1175 +
8.1176 +fun is_invertible_function thy (Const (f, _)) = is_constr thy f
8.1177 + | is_invertible_function thy _ = false
8.1178 +
8.1179 +fun non_invertible_subterms thy (Free _) = []
8.1180 + | non_invertible_subterms thy t =
8.1181 + case (strip_comb t) of (f, args) =>
8.1182 + if is_invertible_function thy f then
8.1183 + maps (non_invertible_subterms thy) args
8.1184 + else
8.1185 + [t]
8.1186 +
8.1187 +fun collect_non_invertible_subterms thy (f as Free _) (names, eqs) = (f, (names, eqs))
8.1188 + | collect_non_invertible_subterms thy t (names, eqs) =
8.1189 + case (strip_comb t) of (f, args) =>
8.1190 + if is_invertible_function thy f then
8.1191 + let
8.1192 + val (args', (names', eqs')) =
8.1193 + fold_map (collect_non_invertible_subterms thy) args (names, eqs)
8.1194 + in
8.1195 + (list_comb (f, args'), (names', eqs'))
8.1196 + end
8.1197 + else
8.1198 + let
8.1199 + val s = Name.variant names "x"
8.1200 + val v = Free (s, fastype_of t)
8.1201 + in
8.1202 + (v, (s :: names, HOLogic.mk_eq (v, t) :: eqs))
8.1203 + end
8.1204 +(*
8.1205 + if is_constrt thy t then (t, (names, eqs)) else
8.1206 + let
8.1207 + val s = Name.variant names "x"
8.1208 + val v = Free (s, fastype_of t)
8.1209 + in (v, (s::names, HOLogic.mk_eq (v, t)::eqs)) end;
8.1210 +*)
8.1211 +
8.1212 +fun is_possible_output thy vs t =
8.1213 + forall
8.1214 + (fn t => is_eqT (fastype_of t) andalso forall (member (op =) vs) (term_vs t))
8.1215 + (non_invertible_subterms thy t)
8.1216 +
8.1217 +fun vars_of_destructable_term thy (Free (x, _)) = [x]
8.1218 + | vars_of_destructable_term thy t =
8.1219 + case (strip_comb t) of (f, args) =>
8.1220 + if is_invertible_function thy f then
8.1221 + maps (vars_of_destructable_term thy) args
8.1222 + else
8.1223 + []
8.1224 +
8.1225 +fun is_constructable thy vs t = forall (member (op =) vs) (term_vs t)
8.1226 +
8.1227 +fun missing_vars vs t = subtract (op =) vs (term_vs t)
8.1228 +
8.1229 +fun derivations_of thy modes vs t Input =
8.1230 + [(Term Input, missing_vars vs t)]
8.1231 + | derivations_of thy modes vs t Output =
8.1232 + if is_possible_output thy vs t then [(Term Output, [])] else []
8.1233 + | derivations_of thy modes vs (Const ("Pair", _) $ t1 $ t2) (Pair (m1, m2)) =
8.1234 + map_product
8.1235 + (fn (m1, mvars1) => fn (m2, mvars2) => (Mode_Pair (m1, m2), union (op =) mvars1 mvars2))
8.1236 + (derivations_of thy modes vs t1 m1) (derivations_of thy modes vs t2 m2)
8.1237 + | derivations_of thy modes vs t m =
8.1238 + (case try (all_derivations_of thy modes vs) t of
8.1239 + SOME derivs => filter (fn (d, mvars) => mode_of d = m) derivs
8.1240 + | NONE => (if is_all_input m then [(Context m, [])] else []))
8.1241 +and all_derivations_of thy modes vs (Const ("Pair", _) $ t1 $ t2) =
8.1242 + let
8.1243 + val derivs1 = all_derivations_of thy modes vs t1
8.1244 + val derivs2 = all_derivations_of thy modes vs t2
8.1245 + in
8.1246 + map_product
8.1247 + (fn (m1, mvars1) => fn (m2, mvars2) => (Mode_Pair (m1, m2), union (op =) mvars1 mvars2))
8.1248 + derivs1 derivs2
8.1249 + end
8.1250 + | all_derivations_of thy modes vs (t1 $ t2) =
8.1251 + let
8.1252 + val derivs1 = all_derivations_of thy modes vs t1
8.1253 + in
8.1254 + maps (fn (d1, mvars1) =>
8.1255 + case mode_of d1 of
8.1256 + Fun (m', _) => map (fn (d2, mvars2) =>
8.1257 + (Mode_App (d1, d2), union (op =) mvars1 mvars2)) (derivations_of thy modes vs t2 m')
8.1258 + | _ => error "Something went wrong") derivs1
8.1259 + end
8.1260 + | all_derivations_of thy modes vs (Const (s, T)) =
8.1261 + (case (AList.lookup (op =) modes s) of
8.1262 + SOME ms => map (fn m => (Context m, [])) ms
8.1263 + | NONE => error ("No mode for constant " ^ s))
8.1264 + | all_derivations_of _ modes vs (Free (x, _)) =
8.1265 + (case (AList.lookup (op =) modes x) of
8.1266 + SOME ms => map (fn m => (Context m , [])) ms
8.1267 + | NONE => error ("No mode for parameter variable " ^ x))
8.1268 + | all_derivations_of _ modes vs _ = error "all_derivations_of"
8.1269 +
8.1270 +fun rev_option_ord ord (NONE, NONE) = EQUAL
8.1271 + | rev_option_ord ord (NONE, SOME _) = GREATER
8.1272 + | rev_option_ord ord (SOME _, NONE) = LESS
8.1273 + | rev_option_ord ord (SOME x, SOME y) = ord (x, y)
8.1274 +
8.1275 +fun term_of_prem (Prem t) = t
8.1276 + | term_of_prem (Negprem t) = t
8.1277 + | term_of_prem (Sidecond t) = t
8.1278 +
8.1279 +fun random_mode_in_deriv modes t deriv =
8.1280 + case try dest_Const (fst (strip_comb t)) of
8.1281 + SOME (s, _) =>
8.1282 + (case AList.lookup (op =) modes s of
8.1283 + SOME ms =>
8.1284 + (case AList.lookup (op =) ms (head_mode_of deriv) of
8.1285 + SOME r => r
8.1286 + | NONE => false)
8.1287 + | NONE => false)
8.1288 + | NONE => false
8.1289 +
8.1290 +fun number_of_output_positions mode =
8.1291 + let
8.1292 + val args = strip_fun_mode mode
8.1293 + fun contains_output (Fun _) = false
8.1294 + | contains_output Input = false
8.1295 + | contains_output Output = true
8.1296 + | contains_output (Pair (m1, m2)) = contains_output m1 orelse contains_output m2
8.1297 + in
8.1298 + length (filter contains_output args)
8.1299 + end
8.1300 +
8.1301 +fun lex_ord ord1 ord2 (x, x') =
8.1302 + case ord1 (x, x') of
8.1303 + EQUAL => ord2 (x, x')
8.1304 + | ord => ord
8.1305 +
8.1306 +fun deriv_ord2' thy modes t1 t2 ((deriv1, mvars1), (deriv2, mvars2)) =
8.1307 + let
8.1308 + fun mvars_ord ((t1, deriv1, mvars1), (t2, deriv2, mvars2)) =
8.1309 + int_ord (length mvars1, length mvars2)
8.1310 + fun random_mode_ord ((t1, deriv1, mvars1), (t2, deriv2, mvars2)) =
8.1311 + int_ord (if random_mode_in_deriv modes t1 deriv1 then 1 else 0,
8.1312 + if random_mode_in_deriv modes t1 deriv1 then 1 else 0)
8.1313 + fun output_mode_ord ((t1, deriv1, mvars1), (t2, deriv2, mvars2)) =
8.1314 + int_ord (number_of_output_positions (head_mode_of deriv1),
8.1315 + number_of_output_positions (head_mode_of deriv2))
8.1316 + in
8.1317 + lex_ord mvars_ord (lex_ord random_mode_ord output_mode_ord)
8.1318 + ((t1, deriv1, mvars1), (t2, deriv2, mvars2))
8.1319 + end
8.1320 +
8.1321 +fun deriv_ord2 thy modes t = deriv_ord2' thy modes t t
8.1322 +
8.1323 +fun deriv_ord ((deriv1, mvars1), (deriv2, mvars2)) =
8.1324 + int_ord (length mvars1, length mvars2)
8.1325 +
8.1326 +fun premise_ord thy modes ((prem1, a1), (prem2, a2)) =
8.1327 + rev_option_ord (deriv_ord2' thy modes (term_of_prem prem1) (term_of_prem prem2)) (a1, a2)
8.1328 +
8.1329 +fun print_mode_list modes =
8.1330 + tracing ("modes: " ^ (commas (map (fn (s, ms) => s ^ ": " ^
8.1331 + commas (map (fn (m, r) => string_of_mode m ^ (if r then " random " else " not ")) ms)) modes)))
8.1332 +
8.1333 +fun select_mode_prem' thy modes vs ps =
8.1334 + let
8.1335 + val modes' = map (fn (s, ms) => (s, map fst ms)) modes
8.1336 + in
8.1337 + partial_hd (sort (premise_ord thy modes) (ps ~~ map
8.1338 + (fn Prem t =>
8.1339 + partial_hd
8.1340 + (sort (deriv_ord2 thy modes t) (all_derivations_of thy modes' vs t))
8.1341 + | Sidecond t => SOME (Context Bool, missing_vars vs t)
8.1342 + | Negprem t =>
8.1343 + partial_hd
8.1344 + (sort (deriv_ord2 thy modes t) (filter (fn (d, missing_vars) => is_all_input (head_mode_of d))
8.1345 + (all_derivations_of thy modes' vs t)))
8.1346 + | p => error (string_of_prem thy p))
8.1347 + ps))
8.1348 + end
8.1349 +
8.1350 +fun check_mode_clause' use_random thy param_vs modes mode (ts, ps) =
8.1351 + let
8.1352 + val vTs = distinct (op =) (fold Term.add_frees (map term_of_prem ps) (fold Term.add_frees ts []))
8.1353 + val modes' = modes @ (param_vs ~~ map (fn x => [(x, false)]) (ho_arg_modes_of mode))
8.1354 + val (in_ts, out_ts) = split_mode mode ts
8.1355 + val in_vs = maps (vars_of_destructable_term thy) in_ts
8.1356 + val out_vs = terms_vs out_ts
8.1357 + fun check_mode_prems acc_ps rnd vs [] = SOME (acc_ps, vs, rnd)
8.1358 + | check_mode_prems acc_ps rnd vs ps =
8.1359 + (case select_mode_prem' thy modes' vs ps of
8.1360 + SOME (p, SOME (deriv, [])) => check_mode_prems ((p, deriv) :: acc_ps) rnd (*TODO: uses random? *)
8.1361 + (case p of
8.1362 + Prem t => union (op =) vs (term_vs t)
8.1363 + | Sidecond t => vs
8.1364 + | Negprem t => union (op =) vs (term_vs t)
8.1365 + | _ => error "I do not know")
8.1366 + (filter_out (equal p) ps)
8.1367 + | SOME (p, SOME (deriv, missing_vars)) =>
8.1368 + if use_random then
8.1369 + check_mode_prems ((p, deriv) :: (map
8.1370 + (fn v => (Generator (v, the (AList.lookup (op =) vTs v)), Term Output)) missing_vars)
8.1371 + @ acc_ps) true
8.1372 + (case p of
8.1373 + Prem t => union (op =) vs (term_vs t)
8.1374 + | Sidecond t => union (op =) vs (term_vs t)
8.1375 + | Negprem t => union (op =) vs (term_vs t)
8.1376 + | _ => error "I do not know")
8.1377 + (filter_out (equal p) ps)
8.1378 + else NONE
8.1379 + | SOME (p, NONE) => NONE
8.1380 + | NONE => NONE)
8.1381 + in
8.1382 + case check_mode_prems [] false in_vs ps of
8.1383 + NONE => NONE
8.1384 + | SOME (acc_ps, vs, rnd) =>
8.1385 + if forall (is_constructable thy vs) (in_ts @ out_ts) then
8.1386 + SOME (ts, rev acc_ps, rnd)
8.1387 + else
8.1388 + if use_random then
8.1389 + let
8.1390 + val generators = map
8.1391 + (fn v => (Generator (v, the (AList.lookup (op =) vTs v)), Term Output))
8.1392 + (subtract (op =) vs (terms_vs out_ts))
8.1393 + in
8.1394 + SOME (ts, rev (generators @ acc_ps), true)
8.1395 + end
8.1396 + else
8.1397 + NONE
8.1398 + end
8.1399 +
8.1400 +datatype result = Success of bool | Error of string
8.1401 +
8.1402 +fun check_modes_pred' use_random options thy param_vs clauses modes (p, ms) =
8.1403 + let
8.1404 + fun split xs =
8.1405 + let
8.1406 + fun split' [] (ys, zs) = (rev ys, rev zs)
8.1407 + | split' ((m, Error z) :: xs) (ys, zs) = split' xs (ys, z :: zs)
8.1408 + | split' ((m, Success rnd) :: xs) (ys, zs) = split' xs ((m, rnd) :: ys, zs)
8.1409 + in
8.1410 + split' xs ([], [])
8.1411 + end
8.1412 + val rs = these (AList.lookup (op =) clauses p)
8.1413 + fun check_mode m =
8.1414 + let
8.1415 + val res = map (check_mode_clause' use_random thy param_vs modes m) rs
8.1416 + in
8.1417 + case find_indices is_none res of
8.1418 + [] => Success (exists (fn SOME (_, _, true) => true | _ => false) res)
8.1419 + | is => (print_failed_mode options thy modes p m rs is; Error (error_of p m is))
8.1420 + end
8.1421 + val res = map (fn (m, _) => (m, check_mode m)) ms
8.1422 + val (ms', errors) = split res
8.1423 in
8.1424 ((p, ms'), errors)
8.1425 end;
8.1426
8.1427 -fun get_modes_pred with_generator thy param_vs clauses modes gen_modes (p, ms) =
8.1428 +fun get_modes_pred' use_random thy param_vs clauses modes (p, ms) =
8.1429 let
8.1430 - val rs = case AList.lookup (op =) clauses p of SOME rs => rs | NONE => []
8.1431 + val rs = these (AList.lookup (op =) clauses p)
8.1432 in
8.1433 - (p, map (fn m =>
8.1434 - (m, map (the o check_mode_clause with_generator thy param_vs modes gen_modes m) rs)) ms)
8.1435 + (p, map (fn (m, rnd) =>
8.1436 + (m, map ((fn (ts, ps, rnd) => (ts, ps)) o the o check_mode_clause' use_random thy param_vs modes m) rs)) ms)
8.1437 end;
8.1438
8.1439 -fun fixp f (x : (string * mode list) list) =
8.1440 +fun fixp f x =
8.1441 let val y = f x
8.1442 in if x = y then x else fixp f y end;
8.1443
8.1444 -fun fixp_with_state f ((x : (string * mode list) list), state) =
8.1445 +fun fixp_with_state f (x, state) =
8.1446 let
8.1447 val (y, state') = f (x, state)
8.1448 in
8.1449 if x = y then (y, state') else fixp_with_state f (y, state')
8.1450 end
8.1451
8.1452 -fun infer_modes options thy extra_modes all_modes param_vs clauses =
8.1453 +fun infer_modes use_random options preds extra_modes param_vs clauses thy =
8.1454 let
8.1455 + val all_modes = map (fn (s, T) => (s, map (rpair false) (all_modes_of_typ T))) preds
8.1456 + fun needs_random s m = (m, member (op =) (#needs_random (the_pred_data thy s)) m)
8.1457 + val extra_modes = map (fn (s, ms) => (s, map (needs_random s) ms)) extra_modes
8.1458 val (modes, errors) =
8.1459 fixp_with_state (fn (modes, errors) =>
8.1460 let
8.1461 val res = map
8.1462 - (check_modes_pred options false thy param_vs clauses (modes @ extra_modes) []) modes
8.1463 + (check_modes_pred' use_random options thy param_vs clauses (modes @ extra_modes)) modes
8.1464 in (map fst res, errors @ maps snd res) end)
8.1465 (all_modes, [])
8.1466 + val thy' = fold (fn (s, ms) => if member (op =) (map fst preds) s then
8.1467 + set_needs_random s (map fst (filter (fn (_, rnd) => rnd = true) ms)) else I) modes thy
8.1468 in
8.1469 - (map (get_modes_pred false thy param_vs clauses (modes @ extra_modes) []) modes, errors)
8.1470 - end;
8.1471 -
8.1472 -fun remove_from rem [] = []
8.1473 - | remove_from rem ((k, vs) :: xs) =
8.1474 - (case AList.lookup (op =) rem k of
8.1475 - NONE => (k, vs)
8.1476 - | SOME vs' => (k, subtract (op =) vs' vs))
8.1477 - :: remove_from rem xs
8.1478 -
8.1479 -fun infer_modes_with_generator options thy extra_modes all_modes param_vs clauses =
8.1480 - let
8.1481 - val prednames = map fst clauses
8.1482 - val extra_modes' = all_modes_of thy
8.1483 - val gen_modes = all_random_modes_of thy
8.1484 - |> filter_out (fn (name, _) => member (op =) prednames name)
8.1485 - val starting_modes = remove_from extra_modes' all_modes
8.1486 - fun eq_mode (m1, m2) = (m1 = m2)
8.1487 - val (modes, errors) =
8.1488 - fixp_with_state (fn (modes, errors) =>
8.1489 - let
8.1490 - val res = map
8.1491 - (check_modes_pred options true thy param_vs clauses extra_modes'
8.1492 - (gen_modes @ modes)) modes
8.1493 - in (map fst res, errors @ maps snd res) end) (starting_modes, [])
8.1494 - val moded_clauses =
8.1495 - map (get_modes_pred true thy param_vs clauses extra_modes (gen_modes @ modes)) modes
8.1496 - val (moded_clauses', _) = infer_modes options thy extra_modes all_modes param_vs clauses
8.1497 - val join_moded_clauses_table = AList.join (op =)
8.1498 - (fn _ => fn ((mps1, mps2)) =>
8.1499 - merge (fn ((m1, _), (m2, _)) => eq_mode (m1, m2)) (mps1, mps2))
8.1500 - in
8.1501 - (join_moded_clauses_table (moded_clauses', moded_clauses), errors)
8.1502 + ((map (get_modes_pred' use_random thy param_vs clauses (modes @ extra_modes)) modes, errors), thy')
8.1503 end;
8.1504
8.1505 (* term construction *)
8.1506 @@ -1231,10 +1353,9 @@
8.1507
8.1508 datatype comp_modifiers = Comp_Modifiers of
8.1509 {
8.1510 - function_name_of : theory -> string -> Predicate_Compile_Aux.mode -> string,
8.1511 - set_function_name : string -> Predicate_Compile_Aux.mode -> string -> theory -> theory,
8.1512 + compilation : compilation,
8.1513 function_name_prefix : string,
8.1514 - funT_of : compilation_funs -> mode -> typ -> typ,
8.1515 + compfuns : compilation_funs,
8.1516 additional_arguments : string list -> term list,
8.1517 wrap_compilation : compilation_funs -> string -> typ -> mode -> term list -> term -> term,
8.1518 transform_additional_arguments : indprem -> term list -> term list
8.1519 @@ -1242,25 +1363,27 @@
8.1520
8.1521 fun dest_comp_modifiers (Comp_Modifiers c) = c
8.1522
8.1523 -val function_name_of = #function_name_of o dest_comp_modifiers
8.1524 -val set_function_name = #set_function_name o dest_comp_modifiers
8.1525 +val compilation = #compilation o dest_comp_modifiers
8.1526 val function_name_prefix = #function_name_prefix o dest_comp_modifiers
8.1527 -val funT_of = #funT_of o dest_comp_modifiers
8.1528 +val compfuns = #compfuns o dest_comp_modifiers
8.1529 +val funT_of = funT_of o compfuns
8.1530 val additional_arguments = #additional_arguments o dest_comp_modifiers
8.1531 val wrap_compilation = #wrap_compilation o dest_comp_modifiers
8.1532 val transform_additional_arguments = #transform_additional_arguments o dest_comp_modifiers
8.1533
8.1534 end;
8.1535
8.1536 +(* TODO: uses param_vs -- change necessary for compilation with new modes *)
8.1537 fun compile_arg compilation_modifiers compfuns additional_arguments thy param_vs iss arg =
8.1538 let
8.1539 fun map_params (t as Free (f, T)) =
8.1540 if member (op =) param_vs f then
8.1541 - case (the (AList.lookup (op =) (param_vs ~~ iss) f)) of
8.1542 + case (AList.lookup (op =) (param_vs ~~ iss) f) of
8.1543 SOME is =>
8.1544 let
8.1545 - val T' = Comp_Mod.funT_of compilation_modifiers compfuns ([], is) T
8.1546 - in fst (mk_Eval_of additional_arguments ((Free (f, T'), T), SOME is) []) end
8.1547 + val _ = error "compile_arg: A parameter in a input position -- do we have a test case?"
8.1548 + val T' = Comp_Mod.funT_of compilation_modifiers is T
8.1549 + in t(*fst (mk_Eval_of additional_arguments ((Free (f, T'), T), is) [])*) end
8.1550 | NONE => t
8.1551 else t
8.1552 | map_params t = t
8.1553 @@ -1291,104 +1414,83 @@
8.1554 (v', mk_bot compfuns U')]))
8.1555 end;
8.1556
8.1557 -(*FIXME function can be removed*)
8.1558 -fun mk_funcomp f t =
8.1559 +fun compile_expr compilation_modifiers compfuns thy (t, deriv) additional_arguments =
8.1560 let
8.1561 - val names = Term.add_free_names t [];
8.1562 - val Ts = binder_types (fastype_of t);
8.1563 - val vs = map2 (curry Free)
8.1564 - (Name.variant_list names (replicate (length Ts) "x")) Ts
8.1565 + fun expr_of (t, deriv) =
8.1566 + (case (t, deriv) of
8.1567 + (t, Term Input) => SOME t
8.1568 + | (t, Term Output) => NONE
8.1569 + | (Const (name, T), Context mode) =>
8.1570 + SOME (Const (function_name_of (Comp_Mod.compilation compilation_modifiers) thy name mode,
8.1571 + Comp_Mod.funT_of compilation_modifiers mode T))
8.1572 + | (Free (s, T), Context m) =>
8.1573 + SOME (Free (s, Comp_Mod.funT_of compilation_modifiers m T))
8.1574 + | (t, Context m) =>
8.1575 + let
8.1576 + val bs = map (pair "x") (binder_types (fastype_of t))
8.1577 + val bounds = map Bound (rev (0 upto (length bs) - 1))
8.1578 + in SOME (list_abs (bs, mk_if compfuns (list_comb (t, bounds)))) end
8.1579 + | (Const ("Pair", _) $ t1 $ t2, Mode_Pair (d1, d2)) =>
8.1580 + (case (expr_of (t1, d1), expr_of (t2, d2)) of
8.1581 + (NONE, NONE) => NONE
8.1582 + | (NONE, SOME t) => SOME t
8.1583 + | (SOME t, NONE) => SOME t
8.1584 + | (SOME t1, SOME t2) => SOME (HOLogic.mk_prod (t1, t2)))
8.1585 + | (t1 $ t2, Mode_App (deriv1, deriv2)) =>
8.1586 + (case (expr_of (t1, deriv1), expr_of (t2, deriv2)) of
8.1587 + (SOME t, NONE) => SOME t
8.1588 + | (SOME t, SOME u) => SOME (t $ u)
8.1589 + | _ => error "something went wrong here!"))
8.1590 in
8.1591 - fold_rev lambda vs (f (list_comb (t, vs)))
8.1592 - end;
8.1593 -
8.1594 -fun compile_param compilation_modifiers compfuns thy NONE t = t
8.1595 - | compile_param compilation_modifiers compfuns thy (m as SOME (Mode (mode, _, ms))) t =
8.1596 - let
8.1597 - val (f, args) = strip_comb (Envir.eta_contract t)
8.1598 - val (params, args') = chop (length ms) args
8.1599 - val params' = map2 (compile_param compilation_modifiers compfuns thy) ms params
8.1600 - val f' =
8.1601 - case f of
8.1602 - Const (name, T) => Const (Comp_Mod.function_name_of compilation_modifiers thy name mode,
8.1603 - Comp_Mod.funT_of compilation_modifiers compfuns mode T)
8.1604 - | Free (name, T) => Free (name, Comp_Mod.funT_of compilation_modifiers compfuns mode T)
8.1605 - | _ => error ("PredicateCompiler: illegal parameter term")
8.1606 - in
8.1607 - list_comb (f', params' @ args')
8.1608 - end
8.1609 -
8.1610 -fun compile_expr compilation_modifiers compfuns thy ((Mode (mode, _, ms)), t)
8.1611 - inargs additional_arguments =
8.1612 - case strip_comb t of
8.1613 - (Const (name, T), params) =>
8.1614 - let
8.1615 - val params' = map2 (compile_param compilation_modifiers compfuns thy) ms params
8.1616 - val name' = Comp_Mod.function_name_of compilation_modifiers thy name mode
8.1617 - val T' = Comp_Mod.funT_of compilation_modifiers compfuns mode T
8.1618 - in
8.1619 - (list_comb (Const (name', T'), params' @ inargs @ additional_arguments))
8.1620 - end
8.1621 - | (Free (name, T), params) =>
8.1622 - list_comb (Free (name, Comp_Mod.funT_of compilation_modifiers compfuns mode T),
8.1623 - params @ inargs @ additional_arguments)
8.1624 + the (expr_of (t, deriv))
8.1625 + end
8.1626
8.1627 fun compile_clause compilation_modifiers compfuns thy all_vs param_vs additional_arguments
8.1628 - (iss, is) inp (ts, moded_ps) =
8.1629 + mode inp (ts, moded_ps) =
8.1630 let
8.1631 + val iss = ho_arg_modes_of mode
8.1632 val compile_match = compile_match compilation_modifiers compfuns
8.1633 additional_arguments param_vs iss thy
8.1634 - fun check_constrt t (names, eqs) =
8.1635 - if is_constrt thy t then (t, (names, eqs)) else
8.1636 - let
8.1637 - val s = Name.variant names "x"
8.1638 - val v = Free (s, fastype_of t)
8.1639 - in (v, (s::names, HOLogic.mk_eq (v, t)::eqs)) end;
8.1640 -
8.1641 - val (in_ts, out_ts) = split_smode is ts;
8.1642 + val (in_ts, out_ts) = split_mode mode ts;
8.1643 val (in_ts', (all_vs', eqs)) =
8.1644 - fold_map check_constrt in_ts (all_vs, []);
8.1645 -
8.1646 + fold_map (collect_non_invertible_subterms thy) in_ts (all_vs, []);
8.1647 fun compile_prems out_ts' vs names [] =
8.1648 let
8.1649 val (out_ts'', (names', eqs')) =
8.1650 - fold_map check_constrt out_ts' (names, []);
8.1651 + fold_map (collect_non_invertible_subterms thy) out_ts' (names, []);
8.1652 val (out_ts''', (names'', constr_vs)) = fold_map distinct_v
8.1653 out_ts'' (names', map (rpair []) vs);
8.1654 in
8.1655 compile_match constr_vs (eqs @ eqs') out_ts'''
8.1656 (mk_single compfuns (HOLogic.mk_tuple out_ts))
8.1657 end
8.1658 - | compile_prems out_ts vs names ((p, mode as Mode ((_, is), _, _)) :: ps) =
8.1659 + | compile_prems out_ts vs names ((p, deriv) :: ps) =
8.1660 let
8.1661 val vs' = distinct (op =) (flat (vs :: map term_vs out_ts));
8.1662 val (out_ts', (names', eqs)) =
8.1663 - fold_map check_constrt out_ts (names, [])
8.1664 + fold_map (collect_non_invertible_subterms thy) out_ts (names, [])
8.1665 val (out_ts'', (names'', constr_vs')) = fold_map distinct_v
8.1666 out_ts' ((names', map (rpair []) vs))
8.1667 + val mode = head_mode_of deriv
8.1668 val additional_arguments' =
8.1669 Comp_Mod.transform_additional_arguments compilation_modifiers p additional_arguments
8.1670 val (compiled_clause, rest) = case p of
8.1671 - Prem (us, t) =>
8.1672 + Prem t =>
8.1673 let
8.1674 - val (in_ts, out_ts''') = split_smode is us;
8.1675 - val in_ts = map (compile_arg compilation_modifiers compfuns
8.1676 - additional_arguments thy param_vs iss) in_ts
8.1677 val u =
8.1678 compile_expr compilation_modifiers compfuns thy
8.1679 - (mode, t) in_ts additional_arguments'
8.1680 + (t, deriv) additional_arguments'
8.1681 + val (_, out_ts''') = split_mode mode (snd (strip_comb t))
8.1682 val rest = compile_prems out_ts''' vs' names'' ps
8.1683 in
8.1684 (u, rest)
8.1685 end
8.1686 - | Negprem (us, t) =>
8.1687 + | Negprem t =>
8.1688 let
8.1689 - val (in_ts, out_ts''') = split_smode is us
8.1690 - val in_ts = map (compile_arg compilation_modifiers compfuns
8.1691 - additional_arguments thy param_vs iss) in_ts
8.1692 val u = mk_not compfuns
8.1693 (compile_expr compilation_modifiers compfuns thy
8.1694 - (mode, t) in_ts additional_arguments')
8.1695 + (t, deriv) additional_arguments')
8.1696 + val (_, out_ts''') = split_mode mode (snd (strip_comb t))
8.1697 val rest = compile_prems out_ts''' vs' names'' ps
8.1698 in
8.1699 (u, rest)
8.1700 @@ -1403,8 +1505,7 @@
8.1701 end
8.1702 | Generator (v, T) =>
8.1703 let
8.1704 - val [size] = additional_arguments
8.1705 - val u = lift_random (HOLogic.mk_random T size)
8.1706 + val u = mk_random T
8.1707 val rest = compile_prems [Free (v, T)] vs' names'' ps;
8.1708 in
8.1709 (u, rest)
8.1710 @@ -1418,47 +1519,45 @@
8.1711 mk_bind compfuns (mk_single compfuns inp, prem_t)
8.1712 end
8.1713
8.1714 -fun compile_pred compilation_modifiers compfuns thy all_vs param_vs s T mode moded_cls =
8.1715 +fun compile_pred compilation_modifiers thy all_vs param_vs s T mode moded_cls =
8.1716 let
8.1717 - val (Ts1, Ts2) = chop (length (fst mode)) (binder_types T)
8.1718 - val (Us1, Us2) = split_smodeT (snd mode) Ts2
8.1719 - val Ts1' =
8.1720 - map2 (fn NONE => I | SOME is => Comp_Mod.funT_of compilation_modifiers compfuns ([], is))
8.1721 - (fst mode) Ts1
8.1722 - fun mk_input_term (i, NONE) =
8.1723 - [Free (Name.variant (all_vs @ param_vs) ("x" ^ string_of_int i), nth Ts2 (i - 1))]
8.1724 - | mk_input_term (i, SOME pis) = case HOLogic.strip_tupleT (nth Ts2 (i - 1)) of
8.1725 - [] => error "strange unit input"
8.1726 - | [T] => [Free (Name.variant (all_vs @ param_vs)
8.1727 - ("x" ^ string_of_int i), nth Ts2 (i - 1))]
8.1728 - | Ts => let
8.1729 - val vnames = Name.variant_list (all_vs @ param_vs)
8.1730 - (map (fn j => "x" ^ string_of_int i ^ "p" ^ string_of_int j)
8.1731 - pis)
8.1732 - in
8.1733 - if null pis then
8.1734 - []
8.1735 - else
8.1736 - [HOLogic.mk_tuple (map2 (curry Free) vnames (map (fn j => nth Ts (j - 1)) pis))]
8.1737 - end
8.1738 - val in_ts = maps mk_input_term (snd mode)
8.1739 - val params = map2 (fn s => fn T => Free (s, T)) param_vs Ts1'
8.1740 - val additional_arguments = Comp_Mod.additional_arguments compilation_modifiers
8.1741 + (* TODO: val additional_arguments = Comp_Mod.additional_arguments compilation_modifiers
8.1742 (all_vs @ param_vs)
8.1743 + *)
8.1744 + val compfuns = Comp_Mod.compfuns compilation_modifiers
8.1745 + fun is_param_type (T as Type ("fun",[_ , T'])) =
8.1746 + is_some (try (dest_predT compfuns) T) orelse is_param_type T'
8.1747 + | is_param_type T = is_some (try (dest_predT compfuns) T)
8.1748 + val additional_arguments = []
8.1749 + val (inpTs, outTs) = split_map_modeT (fn m => fn T => (SOME (funT_of compfuns m T), NONE)) mode
8.1750 + (binder_types T)
8.1751 + val predT = mk_predT compfuns (HOLogic.mk_tupleT outTs)
8.1752 + val funT = Comp_Mod.funT_of compilation_modifiers mode T
8.1753 +
8.1754 + val (in_ts, _) = fold_map (fold_map_aterms_prodT (curry HOLogic.mk_prod)
8.1755 + (fn T => fn (param_vs, names) =>
8.1756 + if is_param_type T then
8.1757 + (Free (hd param_vs, T), (tl param_vs, names))
8.1758 + else
8.1759 + let
8.1760 + val new = Name.variant names "x"
8.1761 + in (Free (new, T), (param_vs, new :: names)) end)) inpTs
8.1762 + (param_vs, (all_vs @ param_vs))
8.1763 + val in_ts' = map_filter (map_filter_prod
8.1764 + (fn t as Free (x, _) => if member (op =) param_vs x then NONE else SOME t | t => SOME t)) in_ts
8.1765 val cl_ts =
8.1766 map (compile_clause compilation_modifiers compfuns
8.1767 - thy all_vs param_vs additional_arguments mode (HOLogic.mk_tuple in_ts)) moded_cls;
8.1768 + thy all_vs param_vs additional_arguments mode (HOLogic.mk_tuple in_ts')) moded_cls;
8.1769 val compilation = Comp_Mod.wrap_compilation compilation_modifiers compfuns
8.1770 s T mode additional_arguments
8.1771 (if null cl_ts then
8.1772 - mk_bot compfuns (HOLogic.mk_tupleT Us2)
8.1773 + mk_bot compfuns (HOLogic.mk_tupleT outTs)
8.1774 else foldr1 (mk_sup compfuns) cl_ts)
8.1775 val fun_const =
8.1776 - Const (Comp_Mod.function_name_of compilation_modifiers thy s mode,
8.1777 - Comp_Mod.funT_of compilation_modifiers compfuns mode T)
8.1778 + Const (function_name_of (Comp_Mod.compilation compilation_modifiers) thy s mode, funT)
8.1779 in
8.1780 HOLogic.mk_Trueprop
8.1781 - (HOLogic.mk_eq (list_comb (fun_const, params @ in_ts @ additional_arguments), compilation))
8.1782 + (HOLogic.mk_eq (list_comb (fun_const, in_ts @ additional_arguments), compilation))
8.1783 end;
8.1784
8.1785 (* special setup for simpset *)
8.1786 @@ -1474,152 +1573,108 @@
8.1787 (fn NONE => "X" | SOME k' => string_of_int k')
8.1788 (ks @ [SOME k]))) arities));
8.1789
8.1790 -fun create_intro_elim_rule (mode as (iss, is)) defthm mode_id funT pred thy =
8.1791 -let
8.1792 - val Ts = binder_types (fastype_of pred)
8.1793 - val funtrm = Const (mode_id, funT)
8.1794 - val (Ts1, Ts2) = chop (length iss) Ts;
8.1795 - val Ts1' =
8.1796 - map2 (fn NONE => I | SOME is => funT_of (PredicateCompFuns.compfuns) ([], is)) iss Ts1
8.1797 - val param_names = Name.variant_list []
8.1798 - (map (fn i => "x" ^ string_of_int i) (1 upto (length Ts1)));
8.1799 - val params = map2 (curry Free) param_names Ts1'
8.1800 - fun mk_args (i, T) argnames =
8.1801 +fun split_lambda (x as Free _) t = lambda x t
8.1802 + | split_lambda (Const ("Pair", _) $ t1 $ t2) t =
8.1803 + HOLogic.mk_split (split_lambda t1 (split_lambda t2 t))
8.1804 + | split_lambda (Const ("Product_Type.Unity", _)) t = Abs ("x", HOLogic.unitT, t)
8.1805 + | split_lambda t _ = raise (TERM ("split_lambda", [t]))
8.1806 +
8.1807 +fun strip_split_abs (Const ("split", _) $ t) = strip_split_abs t
8.1808 + | strip_split_abs (Abs (_, _, t)) = strip_split_abs t
8.1809 + | strip_split_abs t = t
8.1810 +
8.1811 +fun mk_args is_eval (Pair (m1, m2), Type ("*", [T1, T2])) names =
8.1812 let
8.1813 - val vname = Name.variant (param_names @ argnames) ("x" ^ string_of_int (length Ts1' + i))
8.1814 - val default = (Free (vname, T), vname :: argnames)
8.1815 + val (t1, names') = mk_args is_eval (m1, T1) names
8.1816 + val (t2, names'') = mk_args is_eval (m2, T2) names'
8.1817 in
8.1818 - case AList.lookup (op =) is i of
8.1819 - NONE => default
8.1820 - | SOME NONE => default
8.1821 - | SOME (SOME pis) =>
8.1822 - case HOLogic.strip_tupleT T of
8.1823 - [] => default
8.1824 - | [_] => default
8.1825 - | Ts =>
8.1826 - let
8.1827 - val vnames = Name.variant_list (param_names @ argnames)
8.1828 - (map (fn j => "x" ^ string_of_int (length Ts1' + i) ^ "p" ^ string_of_int j)
8.1829 - (1 upto (length Ts)))
8.1830 - in (HOLogic.mk_tuple (map2 (curry Free) vnames Ts), vnames @ argnames) end
8.1831 + (HOLogic.mk_prod (t1, t2), names'')
8.1832 end
8.1833 - val (args, argnames) = fold_map mk_args (1 upto (length Ts2) ~~ Ts2) []
8.1834 - val (inargs, outargs) = split_smode is args
8.1835 - val param_names' = Name.variant_list (param_names @ argnames)
8.1836 - (map (fn i => "p" ^ string_of_int i) (1 upto (length iss)))
8.1837 - val param_vs = map2 (curry Free) param_names' Ts1
8.1838 - val (params', names) = fold_map (mk_Eval_of []) ((params ~~ Ts1) ~~ iss) []
8.1839 - val predpropI = HOLogic.mk_Trueprop (list_comb (pred, param_vs @ args))
8.1840 - val predpropE = HOLogic.mk_Trueprop (list_comb (pred, params' @ args))
8.1841 - val param_eqs = map2 (HOLogic.mk_Trueprop oo (curry HOLogic.mk_eq)) param_vs params'
8.1842 - val funargs = params @ inargs
8.1843 - val funpropE = HOLogic.mk_Trueprop (PredicateCompFuns.mk_Eval (list_comb (funtrm, funargs),
8.1844 - if null outargs then Free("y", HOLogic.unitT) else HOLogic.mk_tuple outargs))
8.1845 - val funpropI = HOLogic.mk_Trueprop (PredicateCompFuns.mk_Eval (list_comb (funtrm, funargs),
8.1846 - HOLogic.mk_tuple outargs))
8.1847 - val introtrm = Logic.list_implies (predpropI :: param_eqs, funpropI)
8.1848 - val simprules = [defthm, @{thm eval_pred},
8.1849 - @{thm "split_beta"}, @{thm "fst_conv"}, @{thm "snd_conv"}, @{thm pair_collapse}]
8.1850 - val unfolddef_tac = Simplifier.asm_full_simp_tac (HOL_basic_ss addsimps simprules) 1
8.1851 - val introthm = Goal.prove (ProofContext.init thy)
8.1852 - (argnames @ param_names @ param_names' @ ["y"]) [] introtrm (fn _ => unfolddef_tac)
8.1853 - val P = HOLogic.mk_Trueprop (Free ("P", HOLogic.boolT));
8.1854 - val elimtrm = Logic.list_implies ([funpropE, Logic.mk_implies (predpropE, P)], P)
8.1855 - val elimthm = Goal.prove (ProofContext.init thy)
8.1856 - (argnames @ param_names @ param_names' @ ["y", "P"]) [] elimtrm (fn _ => unfolddef_tac)
8.1857 -in
8.1858 - (introthm, elimthm)
8.1859 -end;
8.1860 + | mk_args is_eval ((m as Fun _), T) names =
8.1861 + let
8.1862 + val funT = funT_of PredicateCompFuns.compfuns m T
8.1863 + val x = Name.variant names "x"
8.1864 + val (args, _) = fold_map (mk_args is_eval) (strip_fun_mode m ~~ binder_types T) (x :: names)
8.1865 + val (inargs, outargs) = split_map_mode (fn _ => fn t => (SOME t, NONE)) m args
8.1866 + val t = fold_rev split_lambda args (PredicateCompFuns.mk_Eval
8.1867 + (list_comb (Free (x, funT), inargs), HOLogic.mk_tuple outargs))
8.1868 + in
8.1869 + (if is_eval then t else Free (x, funT), x :: names)
8.1870 + end
8.1871 + | mk_args is_eval (_, T) names =
8.1872 + let
8.1873 + val x = Name.variant names "x"
8.1874 + in
8.1875 + (Free (x, T), x :: names)
8.1876 + end
8.1877 +
8.1878 +fun create_intro_elim_rule mode defthm mode_id funT pred thy =
8.1879 + let
8.1880 + val funtrm = Const (mode_id, funT)
8.1881 + val Ts = binder_types (fastype_of pred)
8.1882 + val (args, argnames) = fold_map (mk_args true) (strip_fun_mode mode ~~ Ts) []
8.1883 + fun strip_eval _ t =
8.1884 + let
8.1885 + val t' = strip_split_abs t
8.1886 + val (r, _) = PredicateCompFuns.dest_Eval t'
8.1887 + in (SOME (fst (strip_comb r)), NONE) end
8.1888 + val (inargs, outargs) = split_map_mode strip_eval mode args
8.1889 + val eval_hoargs = ho_args_of mode args
8.1890 + val hoargTs = ho_argsT_of mode Ts
8.1891 + val hoarg_names' =
8.1892 + Name.variant_list argnames ((map (fn i => "x" ^ string_of_int i)) (1 upto (length hoargTs)))
8.1893 + val hoargs' = map2 (curry Free) hoarg_names' hoargTs
8.1894 + val args' = replace_ho_args mode hoargs' args
8.1895 + val predpropI = HOLogic.mk_Trueprop (list_comb (pred, args'))
8.1896 + val predpropE = HOLogic.mk_Trueprop (list_comb (pred, args))
8.1897 + val param_eqs = map2 (HOLogic.mk_Trueprop oo (curry HOLogic.mk_eq)) eval_hoargs hoargs'
8.1898 + val funpropE = HOLogic.mk_Trueprop (PredicateCompFuns.mk_Eval (list_comb (funtrm, inargs),
8.1899 + if null outargs then Free("y", HOLogic.unitT) else HOLogic.mk_tuple outargs))
8.1900 + val funpropI = HOLogic.mk_Trueprop (PredicateCompFuns.mk_Eval (list_comb (funtrm, inargs),
8.1901 + HOLogic.mk_tuple outargs))
8.1902 + val introtrm = Logic.list_implies (predpropI :: param_eqs, funpropI)
8.1903 + val simprules = [defthm, @{thm eval_pred},
8.1904 + @{thm "split_beta"}, @{thm "fst_conv"}, @{thm "snd_conv"}, @{thm pair_collapse}]
8.1905 + val unfolddef_tac = Simplifier.asm_full_simp_tac (HOL_basic_ss addsimps simprules) 1
8.1906 + val introthm = Goal.prove (ProofContext.init thy)
8.1907 + (argnames @ hoarg_names' @ ["y"]) [] introtrm (fn _ => unfolddef_tac)
8.1908 + val P = HOLogic.mk_Trueprop (Free ("P", HOLogic.boolT));
8.1909 + val elimtrm = Logic.list_implies ([funpropE, Logic.mk_implies (predpropE, P)], P)
8.1910 + val elimthm = Goal.prove (ProofContext.init thy)
8.1911 + (argnames @ ["y", "P"]) [] elimtrm (fn _ => unfolddef_tac)
8.1912 + in
8.1913 + (introthm, elimthm)
8.1914 + end
8.1915
8.1916 fun create_constname_of_mode options thy prefix name T mode =
8.1917 let
8.1918 val system_proposal = prefix ^ (Long_Name.base_name name)
8.1919 - ^ "_" ^ ascii_string_of_mode' (translate_mode T mode)
8.1920 - val name = the_default system_proposal (proposed_names options name (translate_mode T mode))
8.1921 + ^ "_" ^ ascii_string_of_mode mode
8.1922 + val name = the_default system_proposal (proposed_names options name mode)
8.1923 in
8.1924 Sign.full_bname thy name
8.1925 end;
8.1926
8.1927 -fun split_tupleT is T =
8.1928 - let
8.1929 - fun split_tuple' _ _ [] = ([], [])
8.1930 - | split_tuple' is i (T::Ts) =
8.1931 - (if member (op =) is i then apfst else apsnd) (cons T)
8.1932 - (split_tuple' is (i+1) Ts)
8.1933 - in
8.1934 - split_tuple' is 1 (HOLogic.strip_tupleT T)
8.1935 - end
8.1936 -
8.1937 -fun mk_arg xin xout pis T =
8.1938 - let
8.1939 - val n = length (HOLogic.strip_tupleT T)
8.1940 - val ni = length pis
8.1941 - fun mk_proj i j t =
8.1942 - (if i = j then I else HOLogic.mk_fst)
8.1943 - (funpow (i - 1) HOLogic.mk_snd t)
8.1944 - fun mk_arg' i (si, so) =
8.1945 - if member (op =) pis i then
8.1946 - (mk_proj si ni xin, (si+1, so))
8.1947 - else
8.1948 - (mk_proj so (n - ni) xout, (si, so+1))
8.1949 - val (args, _) = fold_map mk_arg' (1 upto n) (1, 1)
8.1950 - in
8.1951 - HOLogic.mk_tuple args
8.1952 - end
8.1953 -
8.1954 fun create_definitions options preds (name, modes) thy =
8.1955 let
8.1956 val compfuns = PredicateCompFuns.compfuns
8.1957 val T = AList.lookup (op =) preds name |> the
8.1958 - fun create_definition (mode as (iss, is)) thy =
8.1959 + fun create_definition mode thy =
8.1960 let
8.1961 val mode_cname = create_constname_of_mode options thy "" name T mode
8.1962 val mode_cbasename = Long_Name.base_name mode_cname
8.1963 - val Ts = binder_types T
8.1964 - val (Ts1, Ts2) = chop (length iss) Ts
8.1965 - val (Us1, Us2) = split_smodeT is Ts2
8.1966 - val Ts1' = map2 (fn NONE => I | SOME is => funT_of compfuns ([], is)) iss Ts1
8.1967 - val funT = (Ts1' @ Us1) ---> (mk_predT compfuns (HOLogic.mk_tupleT Us2))
8.1968 - val names = Name.variant_list []
8.1969 - (map (fn i => "x" ^ string_of_int i) (1 upto (length Ts)));
8.1970 - val param_names = Name.variant_list []
8.1971 - (map (fn i => "x" ^ string_of_int i) (1 upto (length Ts1')))
8.1972 - val xparams = map2 (curry Free) param_names Ts1'
8.1973 - fun mk_vars (i, T) names =
8.1974 + val funT = funT_of compfuns mode T
8.1975 + val (args, _) = fold_map (mk_args true) ((strip_fun_mode mode) ~~ (binder_types T)) []
8.1976 + fun strip_eval m t =
8.1977 let
8.1978 - val vname = Name.variant names ("x" ^ string_of_int (length Ts1' + i))
8.1979 - in
8.1980 - case AList.lookup (op =) is i of
8.1981 - NONE => ((([], [Free (vname, T)]), Free (vname, T)), vname :: names)
8.1982 - | SOME NONE => ((([Free (vname, T)], []), Free (vname, T)), vname :: names)
8.1983 - | SOME (SOME pis) =>
8.1984 - let
8.1985 - val (Tins, Touts) = split_tupleT pis T
8.1986 - val name_in = Name.variant names ("x" ^ string_of_int (length Ts1' + i) ^ "in")
8.1987 - val name_out = Name.variant names ("x" ^ string_of_int (length Ts1' + i) ^ "out")
8.1988 - val xin = Free (name_in, HOLogic.mk_tupleT Tins)
8.1989 - val xout = Free (name_out, HOLogic.mk_tupleT Touts)
8.1990 - val xarg = mk_arg xin xout pis T
8.1991 - in
8.1992 - (((if null Tins then [] else [xin],
8.1993 - if null Touts then [] else [xout]), xarg), name_in :: name_out :: names) end
8.1994 - end
8.1995 - val (xinoutargs, names) = fold_map mk_vars ((1 upto (length Ts2)) ~~ Ts2) param_names
8.1996 - val (xinout, xargs) = split_list xinoutargs
8.1997 - val (xins, xouts) = pairself flat (split_list xinout)
8.1998 - val (xparams', names') = fold_map (mk_Eval_of []) ((xparams ~~ Ts1) ~~ iss) names
8.1999 - fun mk_split_lambda [] t = lambda (Free (Name.variant names' "x", HOLogic.unitT)) t
8.2000 - | mk_split_lambda [x] t = lambda x t
8.2001 - | mk_split_lambda xs t =
8.2002 - let
8.2003 - fun mk_split_lambda' (x::y::[]) t = HOLogic.mk_split (lambda x (lambda y t))
8.2004 - | mk_split_lambda' (x::xs) t = HOLogic.mk_split (lambda x (mk_split_lambda' xs t))
8.2005 - in
8.2006 - mk_split_lambda' xs t
8.2007 - end;
8.2008 - val predterm = PredicateCompFuns.mk_Enum (mk_split_lambda xouts
8.2009 - (list_comb (Const (name, T), xparams' @ xargs)))
8.2010 - val lhs = list_comb (Const (mode_cname, funT), xparams @ xins)
8.2011 + val t' = strip_split_abs t
8.2012 + val (r, _) = PredicateCompFuns.dest_Eval t'
8.2013 + in (SOME (fst (strip_comb r)), NONE) end
8.2014 + val (inargs, outargs) = split_map_mode strip_eval mode args
8.2015 + val predterm = fold_rev split_lambda inargs
8.2016 + (PredicateCompFuns.mk_Enum (split_lambda (HOLogic.mk_tuple outargs)
8.2017 + (list_comb (Const (name, T), args))))
8.2018 + val lhs = Const (mode_cname, funT)
8.2019 val def = Logic.mk_equals (lhs, predterm)
8.2020 val ([definition], thy') = thy |>
8.2021 Sign.add_consts_i [(Binding.name mode_cbasename, funT, NoSyn)] |>
8.2022 @@ -1627,13 +1682,14 @@
8.2023 val (intro, elim) =
8.2024 create_intro_elim_rule mode definition mode_cname funT (Const (name, T)) thy'
8.2025 in thy'
8.2026 - |> add_predfun name mode (mode_cname, definition, intro, elim)
8.2027 + |> set_function_name Pred name mode mode_cname
8.2028 + |> add_predfun_data name mode (definition, intro, elim)
8.2029 |> PureThy.store_thm (Binding.name (mode_cbasename ^ "I"), intro) |> snd
8.2030 |> PureThy.store_thm (Binding.name (mode_cbasename ^ "E"), elim) |> snd
8.2031 |> Theory.checkpoint
8.2032 end;
8.2033 in
8.2034 - fold create_definition modes thy
8.2035 + thy |> defined_function_of Pred name |> fold create_definition modes
8.2036 end;
8.2037
8.2038 fun define_functions comp_modifiers compfuns options preds (name, modes) thy =
8.2039 @@ -1643,13 +1699,15 @@
8.2040 let
8.2041 val function_name_prefix = Comp_Mod.function_name_prefix comp_modifiers
8.2042 val mode_cname = create_constname_of_mode options thy function_name_prefix name T mode
8.2043 - val funT = Comp_Mod.funT_of comp_modifiers compfuns mode T
8.2044 + val funT = Comp_Mod.funT_of comp_modifiers mode T
8.2045 in
8.2046 thy |> Sign.add_consts_i [(Binding.name (Long_Name.base_name mode_cname), funT, NoSyn)]
8.2047 - |> Comp_Mod.set_function_name comp_modifiers name mode mode_cname
8.2048 + |> set_function_name (Comp_Mod.compilation comp_modifiers) name mode mode_cname
8.2049 end;
8.2050 in
8.2051 - fold create_definition modes thy
8.2052 + thy
8.2053 + |> defined_function_of (Comp_Mod.compilation comp_modifiers) name
8.2054 + |> fold create_definition modes
8.2055 end;
8.2056
8.2057 (* Proving equivalence of term *)
8.2058 @@ -1674,11 +1732,13 @@
8.2059
8.2060 (* MAJOR FIXME: prove_params should be simple
8.2061 - different form of introrule for parameters ? *)
8.2062 -fun prove_param options thy NONE t = TRY (rtac @{thm refl} 1)
8.2063 - | prove_param options thy (m as SOME (Mode (mode, is, ms))) t =
8.2064 +
8.2065 +fun prove_param options thy t deriv =
8.2066 let
8.2067 val (f, args) = strip_comb (Envir.eta_contract t)
8.2068 - val (params, _) = chop (length ms) args
8.2069 + val mode = head_mode_of deriv
8.2070 + val param_derivations = param_derivations_of deriv
8.2071 + val ho_args = ho_args_of mode args
8.2072 val f_tac = case f of
8.2073 Const (name, T) => simp_tac (HOL_basic_ss addsimps
8.2074 ([@{thm eval_pred}, (predfun_definition_of thy name mode),
8.2075 @@ -1691,19 +1751,20 @@
8.2076 THEN print_tac' options "prove_param"
8.2077 THEN f_tac
8.2078 THEN print_tac' options "after simplification in prove_args"
8.2079 - THEN (EVERY (map2 (prove_param options thy) ms params))
8.2080 THEN (REPEAT_DETERM (atac 1))
8.2081 + THEN (EVERY (map2 (prove_param options thy) ho_args param_derivations))
8.2082 end
8.2083
8.2084 -fun prove_expr options thy (Mode (mode, is, ms), t, us) (premposition : int) =
8.2085 +fun prove_expr options thy (premposition : int) (t, deriv) =
8.2086 case strip_comb t of
8.2087 - (Const (name, T), args) =>
8.2088 + (Const (name, T), args) =>
8.2089 let
8.2090 + val mode = head_mode_of deriv
8.2091 val introrule = predfun_intro_of thy name mode
8.2092 - val (args1, args2) = chop (length ms) args
8.2093 + val param_derivations = param_derivations_of deriv
8.2094 + val ho_args = ho_args_of mode args
8.2095 in
8.2096 - rtac @{thm bindI} 1
8.2097 - THEN print_tac' options "before intro rule:"
8.2098 + print_tac' options "before intro rule:"
8.2099 (* for the right assumption in first position *)
8.2100 THEN rotate_tac premposition 1
8.2101 THEN debug_tac (Display.string_of_thm (ProofContext.init thy) introrule)
8.2102 @@ -1712,39 +1773,58 @@
8.2103 (* work with parameter arguments *)
8.2104 THEN atac 1
8.2105 THEN print_tac' options "parameter goal"
8.2106 - THEN (EVERY (map2 (prove_param options thy) ms args1))
8.2107 + THEN (EVERY (map2 (prove_param options thy) ho_args param_derivations))
8.2108 THEN (REPEAT_DETERM (atac 1))
8.2109 end
8.2110 - | _ => rtac @{thm bindI} 1
8.2111 - THEN asm_full_simp_tac
8.2112 + | _ =>
8.2113 + asm_full_simp_tac
8.2114 (HOL_basic_ss' addsimps [@{thm "split_eta"}, @{thm "split_beta"}, @{thm "fst_conv"},
8.2115 @{thm "snd_conv"}, @{thm pair_collapse}]) 1
8.2116 THEN (atac 1)
8.2117 THEN print_tac' options "after prove parameter call"
8.2118 -
8.2119
8.2120 -fun SOLVED tac st = FILTER (fn st' => nprems_of st' = nprems_of st - 1) tac st;
8.2121 +
8.2122 +fun SOLVED tac st = FILTER (fn st' => nprems_of st' = nprems_of st - 1) tac st;
8.2123
8.2124 fun SOLVEDALL tac st = FILTER (fn st' => nprems_of st' = 0) tac st
8.2125
8.2126 -fun prove_match thy (out_ts : term list) = let
8.2127 - fun get_case_rewrite t =
8.2128 - if (is_constructor thy t) then let
8.2129 - val case_rewrites = (#case_rewrites (Datatype.the_info thy
8.2130 - ((fst o dest_Type o fastype_of) t)))
8.2131 - in case_rewrites @ maps get_case_rewrite (snd (strip_comb t)) end
8.2132 - else []
8.2133 - val simprules = @{thm "unit.cases"} :: @{thm "prod.cases"} :: maps get_case_rewrite out_ts
8.2134 -(* replace TRY by determining if it necessary - are there equations when calling compile match? *)
8.2135 -in
8.2136 - (* make this simpset better! *)
8.2137 - asm_full_simp_tac (HOL_basic_ss' addsimps simprules) 1
8.2138 - THEN print_tac "after prove_match:"
8.2139 - THEN (DETERM (TRY (EqSubst.eqsubst_tac (ProofContext.init thy) [0] [@{thm "HOL.if_P"}] 1
8.2140 - THEN (REPEAT_DETERM (rtac @{thm conjI} 1 THEN (SOLVED (asm_simp_tac HOL_basic_ss 1))))
8.2141 - THEN (SOLVED (asm_simp_tac HOL_basic_ss 1)))))
8.2142 - THEN print_tac "after if simplification"
8.2143 -end;
8.2144 +fun check_format thy st =
8.2145 + let
8.2146 + val concl' = Logic.strip_assums_concl (hd (prems_of st))
8.2147 + val concl = HOLogic.dest_Trueprop concl'
8.2148 + val expr = fst (strip_comb (fst (PredicateCompFuns.dest_Eval concl)))
8.2149 + fun valid_expr (Const (@{const_name Predicate.bind}, _)) = true
8.2150 + | valid_expr (Const (@{const_name Predicate.single}, _)) = true
8.2151 + | valid_expr _ = false
8.2152 + in
8.2153 + if valid_expr expr then
8.2154 + ((*tracing "expression is valid";*) Seq.single st)
8.2155 + else
8.2156 + ((*tracing "expression is not valid";*) Seq.empty) (*error "check_format: wrong format"*)
8.2157 + end
8.2158 +
8.2159 +fun prove_match options thy (out_ts : term list) =
8.2160 + let
8.2161 + fun get_case_rewrite t =
8.2162 + if (is_constructor thy t) then let
8.2163 + val case_rewrites = (#case_rewrites (Datatype.the_info thy
8.2164 + ((fst o dest_Type o fastype_of) t)))
8.2165 + in case_rewrites @ maps get_case_rewrite (snd (strip_comb t)) end
8.2166 + else []
8.2167 + val simprules = @{thm "unit.cases"} :: @{thm "prod.cases"} :: maps get_case_rewrite out_ts
8.2168 + (* replace TRY by determining if it necessary - are there equations when calling compile match? *)
8.2169 + in
8.2170 + (* make this simpset better! *)
8.2171 + asm_full_simp_tac (HOL_basic_ss' addsimps simprules) 1
8.2172 + THEN print_tac' options "after prove_match:"
8.2173 + THEN (DETERM (TRY (EqSubst.eqsubst_tac (ProofContext.init thy) [0] [@{thm "HOL.if_P"}] 1
8.2174 + THEN (REPEAT_DETERM (rtac @{thm conjI} 1 THEN (SOLVED (asm_simp_tac HOL_basic_ss' 1))))
8.2175 + THEN print_tac' options "if condition to be solved:"
8.2176 + THEN (SOLVED (asm_simp_tac HOL_basic_ss' 1 THEN print_tac' options "after if simp; in SOLVED:"))
8.2177 + THEN check_format thy
8.2178 + THEN print_tac' options "after if simplification - a TRY block")))
8.2179 + THEN print_tac' options "after if simplification"
8.2180 + end;
8.2181
8.2182 (* corresponds to compile_fun -- maybe call that also compile_sidecond? *)
8.2183
8.2184 @@ -1758,7 +1838,7 @@
8.2185 val preds = preds_of t []
8.2186 val defs = map
8.2187 (fn (pred, T) => predfun_definition_of thy pred
8.2188 - ([], map (rpair NONE) (1 upto (length (binder_types T)))))
8.2189 + (all_input_of T))
8.2190 preds
8.2191 in
8.2192 (* remove not_False_eq_True when simpset in prove_match is better *)
8.2193 @@ -1767,63 +1847,74 @@
8.2194 (* need better control here! *)
8.2195 end
8.2196
8.2197 -fun prove_clause options thy nargs modes (iss, is) (_, clauses) (ts, moded_ps) =
8.2198 +fun prove_clause options thy nargs modes mode (_, clauses) (ts, moded_ps) =
8.2199 let
8.2200 - val (in_ts, clause_out_ts) = split_smode is ts;
8.2201 + val (in_ts, clause_out_ts) = split_mode mode ts;
8.2202 fun prove_prems out_ts [] =
8.2203 - (prove_match thy out_ts)
8.2204 + (prove_match options thy out_ts)
8.2205 THEN print_tac' options "before simplifying assumptions"
8.2206 THEN asm_full_simp_tac HOL_basic_ss' 1
8.2207 THEN print_tac' options "before single intro rule"
8.2208 THEN (rtac (if null clause_out_ts then @{thm singleI_unit} else @{thm singleI}) 1)
8.2209 - | prove_prems out_ts ((p, mode as Mode ((iss, is), _, param_modes)) :: ps) =
8.2210 + | prove_prems out_ts ((p, deriv) :: ps) =
8.2211 let
8.2212 val premposition = (find_index (equal p) clauses) + nargs
8.2213 - val rest_tac = (case p of Prem (us, t) =>
8.2214 + val mode = head_mode_of deriv
8.2215 + val rest_tac =
8.2216 + rtac @{thm bindI} 1
8.2217 + THEN (case p of Prem t =>
8.2218 let
8.2219 - val (_, out_ts''') = split_smode is us
8.2220 + val (_, us) = strip_comb t
8.2221 + val (_, out_ts''') = split_mode mode us
8.2222 val rec_tac = prove_prems out_ts''' ps
8.2223 in
8.2224 print_tac' options "before clause:"
8.2225 - THEN asm_simp_tac HOL_basic_ss 1
8.2226 + (*THEN asm_simp_tac HOL_basic_ss 1*)
8.2227 THEN print_tac' options "before prove_expr:"
8.2228 - THEN prove_expr options thy (mode, t, us) premposition
8.2229 + THEN prove_expr options thy premposition (t, deriv)
8.2230 THEN print_tac' options "after prove_expr:"
8.2231 THEN rec_tac
8.2232 end
8.2233 - | Negprem (us, t) =>
8.2234 + | Negprem t =>
8.2235 let
8.2236 - val (_, out_ts''') = split_smode is us
8.2237 + val (t, args) = strip_comb t
8.2238 + val (_, out_ts''') = split_mode mode args
8.2239 val rec_tac = prove_prems out_ts''' ps
8.2240 val name = (case strip_comb t of (Const (c, _), _) => SOME c | _ => NONE)
8.2241 - val (_, params) = strip_comb t
8.2242 + val param_derivations = param_derivations_of deriv
8.2243 + val params = ho_args_of mode args
8.2244 in
8.2245 - rtac @{thm bindI} 1
8.2246 - THEN print_tac' options "before prove_neg_expr:"
8.2247 + print_tac' options "before prove_neg_expr:"
8.2248 + THEN full_simp_tac (HOL_basic_ss addsimps
8.2249 + [@{thm split_eta}, @{thm split_beta}, @{thm fst_conv},
8.2250 + @{thm snd_conv}, @{thm pair_collapse}, @{thm Product_Type.split_conv}]) 1
8.2251 THEN (if (is_some name) then
8.2252 print_tac' options ("before unfolding definition " ^
8.2253 (Display.string_of_thm_global thy
8.2254 - (predfun_definition_of thy (the name) (iss, is))))
8.2255 + (predfun_definition_of thy (the name) mode)))
8.2256 +
8.2257 THEN simp_tac (HOL_basic_ss addsimps
8.2258 - [predfun_definition_of thy (the name) (iss, is)]) 1
8.2259 + [predfun_definition_of thy (the name) mode]) 1
8.2260 THEN rtac @{thm not_predI} 1
8.2261 THEN print_tac' options "after applying rule not_predI"
8.2262 - THEN simp_tac (HOL_basic_ss addsimps [@{thm not_False_eq_True}]) 1
8.2263 + THEN full_simp_tac (HOL_basic_ss addsimps [@{thm not_False_eq_True},
8.2264 + @{thm split_eta}, @{thm split_beta}, @{thm fst_conv},
8.2265 + @{thm snd_conv}, @{thm pair_collapse}, @{thm Product_Type.split_conv}]) 1
8.2266 THEN (REPEAT_DETERM (atac 1))
8.2267 - THEN (EVERY (map2 (prove_param options thy) param_modes params))
8.2268 + THEN (EVERY (map2 (prove_param options thy) params param_derivations))
8.2269 + THEN (REPEAT_DETERM (atac 1))
8.2270 else
8.2271 rtac @{thm not_predI'} 1)
8.2272 THEN simp_tac (HOL_basic_ss addsimps [@{thm not_False_eq_True}]) 1
8.2273 THEN rec_tac
8.2274 end
8.2275 | Sidecond t =>
8.2276 - rtac @{thm bindI} 1
8.2277 - THEN rtac @{thm if_predI} 1
8.2278 + rtac @{thm if_predI} 1
8.2279 THEN print_tac' options "before sidecond:"
8.2280 THEN prove_sidecond thy modes t
8.2281 THEN print_tac' options "after sidecond:"
8.2282 THEN prove_prems [] ps)
8.2283 - in (prove_match thy out_ts)
8.2284 + in (prove_match options thy out_ts)
8.2285 THEN rest_tac
8.2286 end;
8.2287 val prems_tac = prove_prems in_ts moded_ps
8.2288 @@ -1841,7 +1932,7 @@
8.2289 fun prove_one_direction options thy clauses preds modes pred mode moded_clauses =
8.2290 let
8.2291 val T = the (AList.lookup (op =) preds pred)
8.2292 - val nargs = length (binder_types T) - nparams_of thy pred
8.2293 + val nargs = length (binder_types T)
8.2294 val pred_case_rule = the_elim_of thy pred
8.2295 in
8.2296 REPEAT_DETERM (CHANGED (rewtac @{thm "split_paired_all"}))
8.2297 @@ -1893,11 +1984,12 @@
8.2298 *)
8.2299 (* TODO: remove function *)
8.2300
8.2301 -fun prove_param2 thy NONE t = all_tac
8.2302 - | prove_param2 thy (m as SOME (Mode (mode, is, ms))) t =
8.2303 +fun prove_param2 thy t deriv =
8.2304 let
8.2305 - val (f, args) = strip_comb (Envir.eta_contract t)
8.2306 - val (params, _) = chop (length ms) args
8.2307 + val (f, args) = strip_comb (Envir.eta_contract t)
8.2308 + val mode = head_mode_of deriv
8.2309 + val param_derivations = param_derivations_of deriv
8.2310 + val ho_args = ho_args_of mode args
8.2311 val f_tac = case f of
8.2312 Const (name, T) => full_simp_tac (HOL_basic_ss addsimps
8.2313 (@{thm eval_pred}::(predfun_definition_of thy name mode)
8.2314 @@ -1908,24 +2000,29 @@
8.2315 print_tac "before simplification in prove_args:"
8.2316 THEN f_tac
8.2317 THEN print_tac "after simplification in prove_args"
8.2318 - THEN (EVERY (map2 (prove_param2 thy) ms params))
8.2319 + THEN EVERY (map2 (prove_param2 thy) ho_args param_derivations)
8.2320 end
8.2321
8.2322 +fun prove_expr2 thy (t, deriv) =
8.2323 + (case strip_comb t of
8.2324 + (Const (name, T), args) =>
8.2325 + let
8.2326 + val mode = head_mode_of deriv
8.2327 + val param_derivations = param_derivations_of deriv
8.2328 + val ho_args = ho_args_of mode args
8.2329 + in
8.2330 + etac @{thm bindE} 1
8.2331 + THEN (REPEAT_DETERM (CHANGED (rewtac @{thm "split_paired_all"})))
8.2332 + THEN print_tac "prove_expr2-before"
8.2333 + THEN (debug_tac (Syntax.string_of_term_global thy
8.2334 + (prop_of (predfun_elim_of thy name mode))))
8.2335 + THEN (etac (predfun_elim_of thy name mode) 1)
8.2336 + THEN print_tac "prove_expr2"
8.2337 + THEN (EVERY (map2 (prove_param2 thy) ho_args param_derivations))
8.2338 + THEN print_tac "finished prove_expr2"
8.2339 + end
8.2340 + | _ => etac @{thm bindE} 1)
8.2341
8.2342 -fun prove_expr2 thy (Mode (mode, is, ms), t) =
8.2343 - (case strip_comb t of
8.2344 - (Const (name, T), args) =>
8.2345 - etac @{thm bindE} 1
8.2346 - THEN (REPEAT_DETERM (CHANGED (rewtac @{thm "split_paired_all"})))
8.2347 - THEN print_tac "prove_expr2-before"
8.2348 - THEN (debug_tac (Syntax.string_of_term_global thy
8.2349 - (prop_of (predfun_elim_of thy name mode))))
8.2350 - THEN (etac (predfun_elim_of thy name mode) 1)
8.2351 - THEN print_tac "prove_expr2"
8.2352 - THEN (EVERY (map2 (prove_param2 thy) ms args))
8.2353 - THEN print_tac "finished prove_expr2"
8.2354 - | _ => etac @{thm bindE} 1)
8.2355 -
8.2356 (* FIXME: what is this for? *)
8.2357 (* replace defined by has_mode thy pred *)
8.2358 (* TODO: rewrite function *)
8.2359 @@ -1938,7 +2035,7 @@
8.2360 val preds = preds_of t []
8.2361 val defs = map
8.2362 (fn (pred, T) => predfun_definition_of thy pred
8.2363 - ([], map (rpair NONE) (1 upto (length (binder_types T)))))
8.2364 + (all_input_of T))
8.2365 preds
8.2366 in
8.2367 (* only simplify the one assumption *)
8.2368 @@ -1947,10 +2044,10 @@
8.2369 THEN print_tac "after sidecond2 simplification"
8.2370 end
8.2371
8.2372 -fun prove_clause2 thy modes pred (iss, is) (ts, ps) i =
8.2373 +fun prove_clause2 thy modes pred mode (ts, ps) i =
8.2374 let
8.2375 val pred_intro_rule = nth (intros_of thy pred) (i - 1)
8.2376 - val (in_ts, clause_out_ts) = split_smode is ts;
8.2377 + val (in_ts, clause_out_ts) = split_mode mode ts;
8.2378 fun prove_prems2 out_ts [] =
8.2379 print_tac "before prove_match2 - last call:"
8.2380 THEN prove_match2 thy out_ts
8.2381 @@ -1969,31 +2066,35 @@
8.2382 [@{thm split_eta}, @{thm "split_beta"}, @{thm "fst_conv"},
8.2383 @{thm "snd_conv"}, @{thm pair_collapse}]) 1)
8.2384 THEN print_tac "state after simp_tac:"))))
8.2385 - | prove_prems2 out_ts ((p, mode as Mode ((iss, is), _, param_modes)) :: ps) =
8.2386 + | prove_prems2 out_ts ((p, deriv) :: ps) =
8.2387 let
8.2388 + val mode = head_mode_of deriv
8.2389 val rest_tac = (case p of
8.2390 - Prem (us, t) =>
8.2391 + Prem t =>
8.2392 let
8.2393 - val (_, out_ts''') = split_smode is us
8.2394 + val (_, us) = strip_comb t
8.2395 + val (_, out_ts''') = split_mode mode us
8.2396 val rec_tac = prove_prems2 out_ts''' ps
8.2397 in
8.2398 - (prove_expr2 thy (mode, t)) THEN rec_tac
8.2399 + (prove_expr2 thy (t, deriv)) THEN rec_tac
8.2400 end
8.2401 - | Negprem (us, t) =>
8.2402 + | Negprem t =>
8.2403 let
8.2404 - val (_, out_ts''') = split_smode is us
8.2405 + val (_, args) = strip_comb t
8.2406 + val (_, out_ts''') = split_mode mode args
8.2407 val rec_tac = prove_prems2 out_ts''' ps
8.2408 val name = (case strip_comb t of (Const (c, _), _) => SOME c | _ => NONE)
8.2409 - val (_, params) = strip_comb t
8.2410 + val param_derivations = param_derivations_of deriv
8.2411 + val ho_args = ho_args_of mode args
8.2412 in
8.2413 print_tac "before neg prem 2"
8.2414 THEN etac @{thm bindE} 1
8.2415 THEN (if is_some name then
8.2416 full_simp_tac (HOL_basic_ss addsimps
8.2417 - [predfun_definition_of thy (the name) (iss, is)]) 1
8.2418 + [predfun_definition_of thy (the name) mode]) 1
8.2419 THEN etac @{thm not_predE} 1
8.2420 THEN simp_tac (HOL_basic_ss addsimps [@{thm not_False_eq_True}]) 1
8.2421 - THEN (EVERY (map2 (prove_param2 thy) param_modes params))
8.2422 + THEN (EVERY (map2 (prove_param2 thy) ho_args param_derivations))
8.2423 else
8.2424 etac @{thm not_predE'} 1)
8.2425 THEN rec_tac
8.2426 @@ -2066,10 +2167,10 @@
8.2427
8.2428 fun maps_modes preds_modes_table =
8.2429 map (fn (pred, modes) =>
8.2430 - (pred, map (fn (mode, value) => value) modes)) preds_modes_table
8.2431 + (pred, map (fn (mode, value) => value) modes)) preds_modes_table
8.2432
8.2433 -fun compile_preds comp_modifiers compfuns thy all_vs param_vs preds moded_clauses =
8.2434 - map_preds_modes (fn pred => compile_pred comp_modifiers compfuns thy all_vs param_vs pred
8.2435 +fun compile_preds comp_modifiers thy all_vs param_vs preds moded_clauses =
8.2436 + map_preds_modes (fn pred => compile_pred comp_modifiers thy all_vs param_vs pred
8.2437 (the (AList.lookup (op =) preds pred))) moded_clauses
8.2438
8.2439 fun prove options thy clauses preds modes moded_clauses compiled_terms =
8.2440 @@ -2084,89 +2185,58 @@
8.2441
8.2442 fun dest_prem thy params t =
8.2443 (case strip_comb t of
8.2444 - (v as Free _, ts) => if member (op =) params v then Prem (ts, v) else Sidecond t
8.2445 + (v as Free _, ts) => if member (op =) params v then Prem t else Sidecond t
8.2446 | (c as Const (@{const_name Not}, _), [t]) => (case dest_prem thy params t of
8.2447 - Prem (ts, t) => Negprem (ts, t)
8.2448 + Prem t => Negprem t
8.2449 | Negprem _ => error ("Double negation not allowed in premise: " ^
8.2450 Syntax.string_of_term_global thy (c $ t))
8.2451 | Sidecond t => Sidecond (c $ t))
8.2452 | (c as Const (s, _), ts) =>
8.2453 - if is_registered thy s then
8.2454 - let val (ts1, ts2) = chop (nparams_of thy s) ts
8.2455 - in Prem (ts2, list_comb (c, ts1)) end
8.2456 - else Sidecond t
8.2457 + if is_registered thy s then Prem t else Sidecond t
8.2458 | _ => Sidecond t)
8.2459 -
8.2460 -fun prepare_intrs options thy prednames intros =
8.2461 +
8.2462 +fun prepare_intrs options compilation thy prednames intros =
8.2463 let
8.2464 val intrs = map prop_of intros
8.2465 - val nparams = nparams_of thy (hd prednames)
8.2466 val preds = map (fn c => Const (c, Sign.the_const_type thy c)) prednames
8.2467 val (preds, intrs) = unify_consts thy preds intrs
8.2468 val ([preds, intrs], _) = fold_burrow (Variable.import_terms false) [preds, intrs]
8.2469 (ProofContext.init thy)
8.2470 val preds = map dest_Const preds
8.2471 - val extra_modes = all_modes_of thy
8.2472 - |> filter_out (fn (name, _) => member (op =) prednames name)
8.2473 - val params = case intrs of
8.2474 + val extra_modes =
8.2475 + all_modes_of compilation thy |> filter_out (fn (name, _) => member (op =) prednames name)
8.2476 + val all_vs = terms_vs intrs
8.2477 + val params =
8.2478 + case intrs of
8.2479 [] =>
8.2480 let
8.2481 - val (paramTs, _) = chop nparams (binder_types (snd (hd preds)))
8.2482 + val T = snd (hd preds)
8.2483 + val paramTs =
8.2484 + ho_argsT_of (hd (all_modes_of_typ T)) (binder_types T)
8.2485 val param_names = Name.variant_list [] (map (fn i => "p" ^ string_of_int i)
8.2486 (1 upto length paramTs))
8.2487 - in map2 (curry Free) param_names paramTs end
8.2488 - | intr :: _ => fst (chop nparams
8.2489 - (snd (strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl intr)))))
8.2490 - val param_vs = maps term_vs params
8.2491 - val all_vs = terms_vs intrs
8.2492 - fun add_clause intr (clauses, arities) =
8.2493 - let
8.2494 - val _ $ t = Logic.strip_imp_concl intr;
8.2495 - val (Const (name, T), ts) = strip_comb t;
8.2496 - val (ts1, ts2) = chop nparams ts;
8.2497 - val prems = map (dest_prem thy params o HOLogic.dest_Trueprop) (Logic.strip_imp_prems intr);
8.2498 - val (Ts, Us) = chop nparams (binder_types T)
8.2499 - in
8.2500 - (AList.update op = (name, these (AList.lookup op = clauses name) @
8.2501 - [(ts2, prems)]) clauses,
8.2502 - AList.update op = (name, (map (fn U => (case strip_type U of
8.2503 - (Rs as _ :: _, Type ("bool", [])) => SOME (length Rs)
8.2504 - | _ => NONE)) Ts,
8.2505 - length Us)) arities)
8.2506 - end;
8.2507 - val (clauses, arities) = fold add_clause intrs ([], []);
8.2508 - fun modes_of_arities arities =
8.2509 - (map (fn (s, (ks, k)) => (s, cprod (cprods (map
8.2510 - (fn NONE => [NONE]
8.2511 - | SOME k' => map SOME (map (map (rpair NONE)) (subsets 1 k'))) ks),
8.2512 - map (map (rpair NONE)) (subsets 1 k)))) arities)
8.2513 - fun modes_of_typ T =
8.2514 + in
8.2515 + map2 (curry Free) param_names paramTs
8.2516 + end
8.2517 + | (intr :: _) => maps extract_params
8.2518 + (snd (strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl intr))))
8.2519 + val param_vs = map (fst o dest_Free) params
8.2520 + fun add_clause intr clauses =
8.2521 let
8.2522 - val (Ts, Us) = chop nparams (binder_types T)
8.2523 - fun all_smodes_of_typs Ts = cprods_subset (
8.2524 - map_index (fn (i, U) =>
8.2525 - case HOLogic.strip_tupleT U of
8.2526 - [] => [(i + 1, NONE)]
8.2527 - | [U] => [(i + 1, NONE)]
8.2528 - | Us => (i + 1, NONE) ::
8.2529 - (map (pair (i + 1) o SOME)
8.2530 - (subtract (op =) [[], 1 upto (length Us)] (subsets 1 (length Us)))))
8.2531 - Ts)
8.2532 + val (Const (name, T), ts) = strip_comb (HOLogic.dest_Trueprop (Logic.strip_imp_concl intr))
8.2533 + val prems = map (dest_prem thy params o HOLogic.dest_Trueprop) (Logic.strip_imp_prems intr)
8.2534 in
8.2535 - cprod (cprods (map (fn T => case strip_type T of
8.2536 - (Rs as _ :: _, Type ("bool", [])) =>
8.2537 - map SOME (all_smodes_of_typs Rs) | _ => [NONE]) Ts), all_smodes_of_typs Us)
8.2538 - end
8.2539 - val all_modes = map (fn (s, T) =>
8.2540 - case proposed_modes options of
8.2541 - NONE => (s, modes_of_typ T)
8.2542 - | SOME (s', modes') =>
8.2543 - if s = s' then (s, map (translate_mode' nparams) modes') else (s, modes_of_typ T))
8.2544 - preds
8.2545 - in (preds, nparams, all_vs, param_vs, extra_modes, clauses, all_modes) end;
8.2546 + AList.update op = (name, these (AList.lookup op = clauses name) @
8.2547 + [(ts, prems)]) clauses
8.2548 + end;
8.2549 + val clauses = fold add_clause intrs []
8.2550 + in
8.2551 + (preds, all_vs, param_vs, extra_modes, clauses)
8.2552 + end;
8.2553
8.2554 (* sanity check of introduction rules *)
8.2555 -
8.2556 +(* TODO: rethink check with new modes *)
8.2557 +(*
8.2558 fun check_format_of_intro_rule thy intro =
8.2559 let
8.2560 val concl = Logic.strip_imp_concl (prop_of intro)
8.2561 @@ -2182,14 +2252,14 @@
8.2562 (Display.string_of_thm_global thy intro))
8.2563 | _ => true
8.2564 val prems = Logic.strip_imp_prems (prop_of intro)
8.2565 - fun check_prem (Prem (args, _)) = forall check_arg args
8.2566 - | check_prem (Negprem (args, _)) = forall check_arg args
8.2567 + fun check_prem (Prem t) = forall check_arg args
8.2568 + | check_prem (Negprem t) = forall check_arg args
8.2569 | check_prem _ = true
8.2570 in
8.2571 forall check_arg args andalso
8.2572 forall (check_prem o dest_prem thy params o HOLogic.dest_Trueprop) prems
8.2573 end
8.2574 -
8.2575 +*)
8.2576 (*
8.2577 fun check_intros_elim_match thy prednames =
8.2578 let
8.2579 @@ -2211,20 +2281,19 @@
8.2580
8.2581 (* create code equation *)
8.2582
8.2583 -fun add_code_equations thy nparams preds result_thmss =
8.2584 +fun add_code_equations thy preds result_thmss =
8.2585 let
8.2586 fun add_code_equation (predname, T) (pred, result_thms) =
8.2587 let
8.2588 - val full_mode = (replicate nparams NONE,
8.2589 - map (rpair NONE) (1 upto (length (binder_types T) - nparams)))
8.2590 + val full_mode = fold_rev (curry Fun) (map (K Input) (binder_types T)) Bool
8.2591 in
8.2592 - if member (op =) (modes_of thy predname) full_mode then
8.2593 + if member (op =) (modes_of Pred thy predname) full_mode then
8.2594 let
8.2595 val Ts = binder_types T
8.2596 val arg_names = Name.variant_list []
8.2597 (map (fn i => "x" ^ string_of_int i) (1 upto length Ts))
8.2598 val args = map2 (curry Free) arg_names Ts
8.2599 - val predfun = Const (predfun_name_of thy predname full_mode,
8.2600 + val predfun = Const (function_name_of Pred thy predname full_mode,
8.2601 Ts ---> PredicateCompFuns.mk_predT @{typ unit})
8.2602 val rhs = @{term Predicate.holds} $ (list_comb (predfun, args))
8.2603 val eq_term = HOLogic.mk_Trueprop
8.2604 @@ -2247,22 +2316,19 @@
8.2605
8.2606 datatype steps = Steps of
8.2607 {
8.2608 - compile_preds : theory -> string list -> string list -> (string * typ) list
8.2609 - -> (moded_clause list) pred_mode_table -> term pred_mode_table,
8.2610 define_functions : options -> (string * typ) list -> string * mode list -> theory -> theory,
8.2611 - infer_modes : options -> theory -> (string * mode list) list -> (string * mode list) list
8.2612 + infer_modes : options -> (string * typ) list -> (string * mode list) list
8.2613 -> string list -> (string * (term list * indprem list) list) list
8.2614 - -> moded_clause list pred_mode_table * string list,
8.2615 + -> theory -> ((moded_clause list pred_mode_table * string list) * theory),
8.2616 prove : options -> theory -> (string * (term list * indprem list) list) list
8.2617 -> (string * typ) list -> (string * mode list) list
8.2618 -> moded_clause list pred_mode_table -> term pred_mode_table -> thm pred_mode_table,
8.2619 - add_code_equations : theory -> int -> (string * typ) list
8.2620 + add_code_equations : theory -> (string * typ) list
8.2621 -> (string * thm list) list -> (string * thm list) list,
8.2622 - defined : theory -> string -> bool,
8.2623 + comp_modifiers : Comp_Mod.comp_modifiers,
8.2624 qname : bstring
8.2625 }
8.2626
8.2627 -
8.2628 fun add_equations_of steps options prednames thy =
8.2629 let
8.2630 fun dest_steps (Steps s) = s
8.2631 @@ -2270,37 +2336,37 @@
8.2632 ("Starting predicate compiler for predicates " ^ commas prednames ^ "...")
8.2633 (*val _ = check_intros_elim_match thy prednames*)
8.2634 (*val _ = map (check_format_of_intro_rule thy) (maps (intros_of thy) prednames)*)
8.2635 - val (preds, nparams, all_vs, param_vs, extra_modes, clauses, all_modes) =
8.2636 - prepare_intrs options thy prednames (maps (intros_of thy) prednames)
8.2637 + val compilation = Comp_Mod.compilation (#comp_modifiers (dest_steps steps))
8.2638 + val (preds, all_vs, param_vs, extra_modes, clauses) =
8.2639 + prepare_intrs options compilation thy prednames (maps (intros_of thy) prednames)
8.2640 val _ = print_step options "Infering modes..."
8.2641 - val (moded_clauses, errors) =
8.2642 - #infer_modes (dest_steps steps) options thy extra_modes all_modes param_vs clauses
8.2643 + val ((moded_clauses, errors), thy') =
8.2644 + #infer_modes (dest_steps steps) options preds extra_modes param_vs clauses thy
8.2645 val modes = map (fn (p, mps) => (p, map fst mps)) moded_clauses
8.2646 val _ = check_expected_modes preds options modes
8.2647 val _ = check_proposed_modes preds options modes extra_modes errors
8.2648 - val _ = print_modes options thy modes
8.2649 - (*val _ = print_moded_clauses thy moded_clauses*)
8.2650 + val _ = print_modes options thy' modes
8.2651 val _ = print_step options "Defining executable functions..."
8.2652 - val thy' = fold (#define_functions (dest_steps steps) options preds) modes thy
8.2653 + val thy'' = fold (#define_functions (dest_steps steps) options preds) modes thy'
8.2654 |> Theory.checkpoint
8.2655 val _ = print_step options "Compiling equations..."
8.2656 val compiled_terms =
8.2657 - #compile_preds (dest_steps steps) thy' all_vs param_vs preds moded_clauses
8.2658 - val _ = print_compiled_terms options thy' compiled_terms
8.2659 + compile_preds (#comp_modifiers (dest_steps steps)) thy'' all_vs param_vs preds moded_clauses
8.2660 + val _ = print_compiled_terms options thy'' compiled_terms
8.2661 val _ = print_step options "Proving equations..."
8.2662 - val result_thms = #prove (dest_steps steps) options thy' clauses preds (extra_modes @ modes)
8.2663 + val result_thms = #prove (dest_steps steps) options thy'' clauses preds (extra_modes @ modes)
8.2664 moded_clauses compiled_terms
8.2665 - val result_thms' = #add_code_equations (dest_steps steps) thy' nparams preds
8.2666 + val result_thms' = #add_code_equations (dest_steps steps) thy'' preds
8.2667 (maps_modes result_thms)
8.2668 val qname = #qname (dest_steps steps)
8.2669 val attrib = fn thy => Attrib.attribute_i thy (Attrib.internal (K (Thm.declaration_attribute
8.2670 (fn thm => Context.mapping (Code.add_eqn thm) I))))
8.2671 - val thy'' = fold (fn (name, result_thms) => fn thy => snd (PureThy.add_thmss
8.2672 + val thy''' = fold (fn (name, result_thms) => fn thy => snd (PureThy.add_thmss
8.2673 [((Binding.qualify true (Long_Name.base_name name) (Binding.name qname), result_thms),
8.2674 [attrib thy ])] thy))
8.2675 - result_thms' thy' |> Theory.checkpoint
8.2676 + result_thms' thy'' |> Theory.checkpoint
8.2677 in
8.2678 - thy''
8.2679 + thy'''
8.2680 end
8.2681
8.2682 fun extend' value_of edges_of key (G, visited) =
8.2683 @@ -2320,36 +2386,27 @@
8.2684 fun gen_add_equations steps options names thy =
8.2685 let
8.2686 fun dest_steps (Steps s) = s
8.2687 + val defined = defined_functions (Comp_Mod.compilation (#comp_modifiers (dest_steps steps)))
8.2688 val thy' = thy
8.2689 |> PredData.map (fold (extend (fetch_pred_data thy) (depending_preds_of thy)) names)
8.2690 |> Theory.checkpoint;
8.2691 fun strong_conn_of gr keys =
8.2692 Graph.strong_conn (Graph.subgraph (member (op =) (Graph.all_succs gr keys)) gr)
8.2693 val scc = strong_conn_of (PredData.get thy') names
8.2694 +
8.2695 val thy'' = fold_rev
8.2696 (fn preds => fn thy =>
8.2697 - if not (forall (#defined (dest_steps steps) thy) preds) then
8.2698 + if not (forall (defined thy) preds) then
8.2699 add_equations_of steps options preds thy
8.2700 else thy)
8.2701 scc thy' |> Theory.checkpoint
8.2702 in thy'' end
8.2703 -
8.2704 -(* different instantiantions of the predicate compiler *)
8.2705 -
8.2706 -val predicate_comp_modifiers = Comp_Mod.Comp_Modifiers
8.2707 - {function_name_of = predfun_name_of : (theory -> string -> mode -> string),
8.2708 - set_function_name = (fn _ => fn _ => fn _ => I),
8.2709 - function_name_prefix = "",
8.2710 - funT_of = funT_of : (compilation_funs -> mode -> typ -> typ),
8.2711 - additional_arguments = K [],
8.2712 - wrap_compilation = K (K (K (K (K I))))
8.2713 - : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
8.2714 - transform_additional_arguments = K I : (indprem -> term list -> term list)
8.2715 - }
8.2716 -
8.2717 +(*
8.2718 val depth_limited_comp_modifiers = Comp_Mod.Comp_Modifiers
8.2719 - {function_name_of = depth_limited_function_name_of,
8.2720 - set_function_name = set_depth_limited_function_name,
8.2721 + {
8.2722 + compilation = Depth_Limited,
8.2723 + function_name_of = function_name_of Depth_Limited,
8.2724 + set_function_name = set_function_name Depth_Limited,
8.2725 funT_of = depth_limited_funT_of : (compilation_funs -> mode -> typ -> typ),
8.2726 function_name_prefix = "depth_limited_",
8.2727 additional_arguments = fn names =>
8.2728 @@ -2384,8 +2441,10 @@
8.2729 }
8.2730
8.2731 val random_comp_modifiers = Comp_Mod.Comp_Modifiers
8.2732 - {function_name_of = random_function_name_of,
8.2733 - set_function_name = set_random_function_name,
8.2734 + {
8.2735 + compilation = Random,
8.2736 + function_name_of = function_name_of Random,
8.2737 + set_function_name = set_function_name Random,
8.2738 function_name_prefix = "random_",
8.2739 funT_of = K random_function_funT_of : (compilation_funs -> mode -> typ -> typ),
8.2740 additional_arguments = fn names => [Free (Name.variant names "size", @{typ code_numeral})],
8.2741 @@ -2393,55 +2452,106 @@
8.2742 : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
8.2743 transform_additional_arguments = K I : (indprem -> term list -> term list)
8.2744 }
8.2745 +*)
8.2746 +(* different instantiantions of the predicate compiler *)
8.2747 +
8.2748 +val predicate_comp_modifiers = Comp_Mod.Comp_Modifiers
8.2749 + {
8.2750 + compilation = Pred,
8.2751 + function_name_prefix = "",
8.2752 + compfuns = PredicateCompFuns.compfuns,
8.2753 + additional_arguments = K [],
8.2754 + wrap_compilation = K (K (K (K (K I))))
8.2755 + : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
8.2756 + transform_additional_arguments = K I : (indprem -> term list -> term list)
8.2757 + }
8.2758 +
8.2759 +val add_equations = gen_add_equations
8.2760 + (Steps {infer_modes = infer_modes false,
8.2761 + define_functions = create_definitions,
8.2762 + prove = prove,
8.2763 + add_code_equations = add_code_equations,
8.2764 + comp_modifiers = predicate_comp_modifiers,
8.2765 + qname = "equation"})
8.2766
8.2767 val annotated_comp_modifiers = Comp_Mod.Comp_Modifiers
8.2768 - {function_name_of = annotated_function_name_of,
8.2769 - set_function_name = set_annotated_function_name,
8.2770 + {
8.2771 + compilation = Annotated,
8.2772 function_name_prefix = "annotated_",
8.2773 - funT_of = funT_of : (compilation_funs -> mode -> typ -> typ),
8.2774 + compfuns = PredicateCompFuns.compfuns,
8.2775 additional_arguments = K [],
8.2776 wrap_compilation =
8.2777 fn compfuns => fn s => fn T => fn mode => fn additional_arguments => fn compilation =>
8.2778 mk_tracing ("calling predicate " ^ s ^
8.2779 - " with mode " ^ string_of_mode' (translate_mode T mode)) compilation,
8.2780 + " with mode " ^ string_of_mode mode) compilation,
8.2781 transform_additional_arguments = K I : (indprem -> term list -> term list)
8.2782 }
8.2783
8.2784 -val add_equations = gen_add_equations
8.2785 - (Steps {infer_modes = infer_modes,
8.2786 - define_functions = create_definitions,
8.2787 - compile_preds = compile_preds predicate_comp_modifiers PredicateCompFuns.compfuns,
8.2788 - prove = prove,
8.2789 - add_code_equations = add_code_equations,
8.2790 - defined = defined_functions,
8.2791 - qname = "equation"})
8.2792 +val dseq_comp_modifiers = Comp_Mod.Comp_Modifiers
8.2793 + {
8.2794 + compilation = DSeq,
8.2795 + function_name_prefix = "dseq_",
8.2796 + compfuns = DSequence_CompFuns.compfuns,
8.2797 + additional_arguments = K [],
8.2798 + wrap_compilation = K (K (K (K (K I))))
8.2799 + : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
8.2800 + transform_additional_arguments = K I : (indprem -> term list -> term list)
8.2801 + }
8.2802
8.2803 +val random_dseq_comp_modifiers = Comp_Mod.Comp_Modifiers
8.2804 + {
8.2805 + compilation = Random_DSeq,
8.2806 + function_name_prefix = "random_dseq_",
8.2807 + compfuns = Random_Sequence_CompFuns.compfuns,
8.2808 + additional_arguments = K [],
8.2809 + wrap_compilation = K (K (K (K (K I))))
8.2810 + : (compilation_funs -> string -> typ -> mode -> term list -> term -> term),
8.2811 + transform_additional_arguments = K I : (indprem -> term list -> term list)
8.2812 + }
8.2813 +
8.2814 +(*
8.2815 val add_depth_limited_equations = gen_add_equations
8.2816 (Steps {infer_modes = infer_modes,
8.2817 define_functions = define_functions depth_limited_comp_modifiers PredicateCompFuns.compfuns,
8.2818 compile_preds = compile_preds depth_limited_comp_modifiers PredicateCompFuns.compfuns,
8.2819 prove = prove_by_skip,
8.2820 - add_code_equations = K (K (K I)),
8.2821 - defined = defined_depth_limited_functions,
8.2822 + add_code_equations = K (K I),
8.2823 + defined = defined_functions Depth_Limited,
8.2824 qname = "depth_limited_equation"})
8.2825 -
8.2826 +*)
8.2827 val add_annotated_equations = gen_add_equations
8.2828 - (Steps {infer_modes = infer_modes,
8.2829 + (Steps {infer_modes = infer_modes false,
8.2830 define_functions = define_functions annotated_comp_modifiers PredicateCompFuns.compfuns,
8.2831 - compile_preds = compile_preds annotated_comp_modifiers PredicateCompFuns.compfuns,
8.2832 prove = prove_by_skip,
8.2833 - add_code_equations = K (K (K I)),
8.2834 - defined = defined_annotated_functions,
8.2835 + add_code_equations = K (K I),
8.2836 + comp_modifiers = annotated_comp_modifiers,
8.2837 qname = "annotated_equation"})
8.2838 -
8.2839 +(*
8.2840 val add_quickcheck_equations = gen_add_equations
8.2841 (Steps {infer_modes = infer_modes_with_generator,
8.2842 define_functions = define_functions random_comp_modifiers RandomPredCompFuns.compfuns,
8.2843 compile_preds = compile_preds random_comp_modifiers RandomPredCompFuns.compfuns,
8.2844 prove = prove_by_skip,
8.2845 - add_code_equations = K (K (K I)),
8.2846 - defined = defined_random_functions,
8.2847 + add_code_equations = K (K I),
8.2848 + defined = defined_functions Random,
8.2849 qname = "random_equation"})
8.2850 +*)
8.2851 +val add_dseq_equations = gen_add_equations
8.2852 + (Steps {infer_modes = infer_modes false,
8.2853 + define_functions = define_functions dseq_comp_modifiers DSequence_CompFuns.compfuns,
8.2854 + prove = prove_by_skip,
8.2855 + add_code_equations = K (K I),
8.2856 + comp_modifiers = dseq_comp_modifiers,
8.2857 + qname = "dseq_equation"})
8.2858 +
8.2859 +val add_random_dseq_equations = gen_add_equations
8.2860 + (Steps {infer_modes = infer_modes true,
8.2861 + define_functions = define_functions random_dseq_comp_modifiers Random_Sequence_CompFuns.compfuns,
8.2862 + prove = prove_by_skip,
8.2863 + add_code_equations = K (K I),
8.2864 + comp_modifiers = random_dseq_comp_modifiers,
8.2865 + qname = "random_dseq_equation"})
8.2866 +
8.2867
8.2868 (** user interface **)
8.2869
8.2870 @@ -2474,9 +2584,8 @@
8.2871 let
8.2872 val T = Sign.the_const_type thy const
8.2873 val pred = Const (const, T)
8.2874 - val nparams = nparams_of thy' const
8.2875 val intros = intros_of thy' const
8.2876 - in mk_casesrule lthy' pred nparams intros end
8.2877 + in mk_casesrule lthy' pred intros end
8.2878 val cases_rules = map mk_cases preds
8.2879 val cases =
8.2880 map (fn case_rule => Rule_Cases.Case {fixes = [],
8.2881 @@ -2492,15 +2601,15 @@
8.2882 (ProofContext.init (ProofContext.theory_of goal_ctxt)) (map the_single thms)
8.2883 in
8.2884 goal_ctxt |> Local_Theory.theory (fold set_elim global_thms #>
8.2885 - (if is_random options then
8.2886 - (add_equations options [const] #>
8.2887 - add_quickcheck_equations options [const])
8.2888 - else if is_depth_limited options then
8.2889 - add_depth_limited_equations options [const]
8.2890 - else if is_annotated options then
8.2891 - add_annotated_equations options [const]
8.2892 - else
8.2893 - add_equations options [const]))
8.2894 + ((case compilation options of
8.2895 + Pred => add_equations
8.2896 + | DSeq => add_dseq_equations
8.2897 + | Random_DSeq => add_random_dseq_equations
8.2898 + | compilation => error ("Compilation not supported")
8.2899 + (*| Random => (fn opt => fn cs => add_equations opt cs #> add_quickcheck_equations opt cs)
8.2900 + | Depth_Limited => add_depth_limited_equations
8.2901 + | Annotated => add_annotated_equations*)
8.2902 + ) options [const]))
8.2903 end
8.2904 in
8.2905 Proof.theorem_i NONE after_qed (map (single o (rpair [])) cases_rules) lthy''
8.2906 @@ -2514,104 +2623,161 @@
8.2907 val eval_ref = Unsynchronized.ref (NONE : (unit -> term Predicate.pred) option);
8.2908 val random_eval_ref =
8.2909 Unsynchronized.ref (NONE : (unit -> int * int -> term Predicate.pred * (int * int)) option);
8.2910 +val dseq_eval_ref = Unsynchronized.ref (NONE : (unit -> term DSequence.dseq) option);
8.2911 +val random_dseq_eval_ref =
8.2912 + Unsynchronized.ref (NONE : (unit -> int -> int -> int * int -> term DSequence.dseq * (int * int)) option);
8.2913
8.2914 (*FIXME turn this into an LCF-guarded preprocessor for comprehensions*)
8.2915 -(* TODO: make analyze_compr generic with respect to the compilation modifiers*)
8.2916 -fun analyze_compr thy compfuns param_user_modes (depth_limit, (random, annotated)) t_compr =
8.2917 +fun analyze_compr thy compfuns param_user_modes (compilation, arguments) t_compr =
8.2918 let
8.2919 + val all_modes_of = all_modes_of compilation
8.2920 val split = case t_compr of (Const (@{const_name Collect}, _) $ t) => t
8.2921 | _ => error ("Not a set comprehension: " ^ Syntax.string_of_term_global thy t_compr);
8.2922 val (body, Ts, fp) = HOLogic.strip_psplits split;
8.2923 - val (pred as Const (name, T), all_args) = strip_comb body;
8.2924 - val (params, args) = chop (nparams_of thy name) all_args;
8.2925 - val user_mode = map_filter I (map_index
8.2926 - (fn (i, t) => case t of Bound j => if j < length Ts then NONE
8.2927 - else SOME (i+1) | _ => SOME (i+1)) args); (*FIXME dangling bounds should not occur*)
8.2928 - val user_mode' = map (rpair NONE) user_mode
8.2929 - val all_modes_of = if random then all_random_modes_of else all_modes_of
8.2930 - fun fits_to is NONE = true
8.2931 - | fits_to is (SOME pm) = (is = (snd (translate_mode' 0 pm)))
8.2932 - fun valid ((SOME (Mode (_, is, ms))) :: ms') (pm :: pms) =
8.2933 - fits_to is pm andalso valid (ms @ ms') pms
8.2934 - | valid (NONE :: ms') pms = valid ms' pms
8.2935 - | valid [] [] = true
8.2936 - | valid [] _ = error "Too many mode annotations"
8.2937 - | valid (SOME _ :: _) [] = error "Not enough mode annotations"
8.2938 - val modes = filter (fn Mode (_, is, ms) => is = user_mode'
8.2939 - andalso (the_default true (Option.map (valid ms) param_user_modes)))
8.2940 - (modes_of_term (all_modes_of thy) (list_comb (pred, params)));
8.2941 - val m = case modes
8.2942 - of [] => error ("No mode possible for comprehension "
8.2943 - ^ Syntax.string_of_term_global thy t_compr)
8.2944 - | [m] => m
8.2945 - | m :: _ :: _ => (warning ("Multiple modes possible for comprehension "
8.2946 - ^ Syntax.string_of_term_global thy t_compr); m);
8.2947 - val (inargs, outargs) = split_smode user_mode' args;
8.2948 - val additional_arguments =
8.2949 - case depth_limit of
8.2950 - NONE => (if random then [@{term "5 :: code_numeral"}] else [])
8.2951 - | SOME d => [@{term "True"}, HOLogic.mk_number @{typ "code_numeral"} d]
8.2952 - val comp_modifiers =
8.2953 - case depth_limit of
8.2954 - NONE =>
8.2955 - (if random then random_comp_modifiers else
8.2956 - if annotated then annotated_comp_modifiers else predicate_comp_modifiers)
8.2957 - | SOME _ => depth_limited_comp_modifiers
8.2958 - val t_pred = compile_expr comp_modifiers compfuns thy
8.2959 - (m, list_comb (pred, params)) inargs additional_arguments;
8.2960 - val t_eval = if null outargs then t_pred else
8.2961 + val output_names = Name.variant_list (Term.add_free_names body [])
8.2962 + (map (fn i => "x" ^ string_of_int i) (1 upto length Ts))
8.2963 + val output_frees = map2 (curry Free) output_names Ts
8.2964 + val body = subst_bounds (output_frees, body)
8.2965 + val T_compr = HOLogic.mk_ptupleT fp (rev Ts)
8.2966 + val output_tuple = HOLogic.mk_ptuple fp T_compr (rev output_frees)
8.2967 + val (pred as Const (name, T), all_args) = strip_comb body
8.2968 + in
8.2969 + if defined_functions compilation thy name then
8.2970 let
8.2971 - val outargs_bounds = map (fn Bound i => i) outargs;
8.2972 - val outargsTs = map (nth Ts) outargs_bounds;
8.2973 - val T_pred = HOLogic.mk_tupleT outargsTs;
8.2974 - val T_compr = HOLogic.mk_ptupleT fp (rev Ts);
8.2975 - val k = length outargs - 1;
8.2976 - val arrange_bounds = map_index (fn (i, j) => (k-i, k-j)) outargs_bounds
8.2977 - |> sort (prod_ord (K EQUAL) int_ord)
8.2978 - |> map fst;
8.2979 - val (outargsTs', outargsT) = split_last outargsTs;
8.2980 - val (arrange, _) = fold_rev (fn U => fn (t, T) =>
8.2981 - (HOLogic.split_const (U, T, T_compr) $ Abs ("", U, t),
8.2982 - HOLogic.mk_prodT (U, T)))
8.2983 - outargsTs' (Abs ("", outargsT,
8.2984 - HOLogic.mk_ptuple fp T_compr (map Bound arrange_bounds)), outargsT)
8.2985 - in mk_map compfuns T_pred T_compr arrange t_pred end
8.2986 - in t_eval end;
8.2987 + fun extract_mode (Const ("Pair", _) $ t1 $ t2) = Pair (extract_mode t1, extract_mode t2)
8.2988 + | extract_mode (Free (x, _)) = if member (op =) output_names x then Output else Input
8.2989 + | extract_mode _ = Input
8.2990 + val user_mode = fold_rev (curry Fun) (map extract_mode all_args) Bool
8.2991 + fun valid modes1 modes2 =
8.2992 + case int_ord (length modes1, length modes2) of
8.2993 + GREATER => error "Not enough mode annotations"
8.2994 + | LESS => error "Too many mode annotations"
8.2995 + | EQUAL => forall (fn (m, NONE) => true | (m, SOME m2) => eq_mode (m, m2))
8.2996 + (modes1 ~~ modes2)
8.2997 + fun mode_instance_of (m1, m2) =
8.2998 + let
8.2999 + fun instance_of (Fun _, Input) = true
8.3000 + | instance_of (Input, Input) = true
8.3001 + | instance_of (Output, Output) = true
8.3002 + | instance_of (Pair (m1, m2), Pair (m1', m2')) =
8.3003 + instance_of (m1, m1') andalso instance_of (m2, m2')
8.3004 + | instance_of (Pair (m1, m2), Input) =
8.3005 + instance_of (m1, Input) andalso instance_of (m2, Input)
8.3006 + | instance_of (Pair (m1, m2), Output) =
8.3007 + instance_of (m1, Output) andalso instance_of (m2, Output)
8.3008 + | instance_of _ = false
8.3009 + in forall instance_of (strip_fun_mode m1 ~~ strip_fun_mode m2) end
8.3010 + val derivs = all_derivations_of thy (all_modes_of thy) [] body
8.3011 + |> filter (fn (d, missing_vars) =>
8.3012 + let
8.3013 + val (p_mode :: modes) = collect_context_modes d
8.3014 + in
8.3015 + null missing_vars andalso
8.3016 + mode_instance_of (p_mode, user_mode) andalso
8.3017 + the_default true (Option.map (valid modes) param_user_modes)
8.3018 + end)
8.3019 + |> map fst
8.3020 + val deriv = case derivs of
8.3021 + [] => error ("No mode possible for comprehension "
8.3022 + ^ Syntax.string_of_term_global thy t_compr)
8.3023 + | [d] => d
8.3024 + | d :: _ :: _ => (warning ("Multiple modes possible for comprehension "
8.3025 + ^ Syntax.string_of_term_global thy t_compr); d);
8.3026 + val (_, outargs) = split_mode (head_mode_of deriv) all_args
8.3027 + val additional_arguments =
8.3028 + case compilation of
8.3029 + Pred => []
8.3030 + | Random => [@{term "5 :: code_numeral"}]
8.3031 + | Annotated => []
8.3032 + | Depth_Limited => [@{term "True"}, HOLogic.mk_number @{typ "code_numeral"} (hd arguments)]
8.3033 + | DSeq => []
8.3034 + | Random_DSeq => []
8.3035 + val comp_modifiers =
8.3036 + case compilation of
8.3037 + Pred => predicate_comp_modifiers
8.3038 + (*| Random => random_comp_modifiers
8.3039 + | Depth_Limited => depth_limited_comp_modifiers
8.3040 + | Annotated => annotated_comp_modifiers*)
8.3041 + | DSeq => dseq_comp_modifiers
8.3042 + | Random_DSeq => random_dseq_comp_modifiers
8.3043 + val t_pred = compile_expr comp_modifiers compfuns thy (body, deriv) additional_arguments;
8.3044 + val T_pred = dest_predT compfuns (fastype_of t_pred)
8.3045 + val arrange = split_lambda (HOLogic.mk_tuple outargs) output_tuple
8.3046 + in
8.3047 + if null outargs then t_pred else mk_map compfuns T_pred T_compr arrange t_pred
8.3048 + end
8.3049 + else
8.3050 + error "Evaluation with values is not possible because compilation with code_pred was not invoked"
8.3051 + end
8.3052
8.3053 -fun eval thy param_user_modes (options as (depth_limit, (random, annotated))) t_compr =
8.3054 +fun eval thy param_user_modes (options as (compilation, arguments)) k t_compr =
8.3055 let
8.3056 - val compfuns = if random then RandomPredCompFuns.compfuns else PredicateCompFuns.compfuns
8.3057 + val compfuns =
8.3058 + case compilation of
8.3059 + Random => RandomPredCompFuns.compfuns
8.3060 + | DSeq => DSequence_CompFuns.compfuns
8.3061 + | Random_DSeq => Random_Sequence_CompFuns.compfuns
8.3062 + | _ => PredicateCompFuns.compfuns
8.3063 val t = analyze_compr thy compfuns param_user_modes options t_compr;
8.3064 val T = dest_predT compfuns (fastype_of t);
8.3065 val t' = mk_map compfuns T HOLogic.termT (HOLogic.term_of_const T) t;
8.3066 - val eval =
8.3067 - if random then
8.3068 - Code_Eval.eval NONE ("Predicate_Compile_Core.random_eval_ref", random_eval_ref)
8.3069 + val ts =
8.3070 + case compilation of
8.3071 + Random =>
8.3072 + fst (Predicate.yieldn k
8.3073 + (Code_Eval.eval NONE ("Predicate_Compile_Core.random_eval_ref", random_eval_ref)
8.3074 (fn proc => fn g => fn s => g s |>> Predicate.map proc) thy t' []
8.3075 - |> Random_Engine.run
8.3076 - else
8.3077 - Code_Eval.eval NONE ("Predicate_Compile_Core.eval_ref", eval_ref) Predicate.map thy t' []
8.3078 - in (T, eval) end;
8.3079 + |> Random_Engine.run))
8.3080 + | Random_DSeq =>
8.3081 + let
8.3082 + val [nrandom, size, depth] = arguments
8.3083 + in
8.3084 + fst (DSequence.yieldn k
8.3085 + (Code_Eval.eval NONE ("Predicate_Compile_Core.random_dseq_eval_ref", random_dseq_eval_ref)
8.3086 + (fn proc => fn g => fn nrandom => fn size => fn s => g nrandom size s |>> DSequence.map proc)
8.3087 + thy t' [] nrandom size
8.3088 + |> Random_Engine.run)
8.3089 + depth true)
8.3090 + end
8.3091 + | DSeq =>
8.3092 + fst (DSequence.yieldn k
8.3093 + (Code_Eval.eval NONE ("Predicate_Compile_Core.dseq_eval_ref", dseq_eval_ref)
8.3094 + DSequence.map thy t' []) (the_single arguments) true)
8.3095 + | _ =>
8.3096 + fst (Predicate.yieldn k
8.3097 + (Code_Eval.eval NONE ("Predicate_Compile_Core.eval_ref", eval_ref)
8.3098 + Predicate.map thy t' []))
8.3099 + in (T, ts) end;
8.3100
8.3101 -fun values ctxt param_user_modes options k t_compr =
8.3102 +fun values ctxt param_user_modes (raw_expected, comp_options) k t_compr =
8.3103 let
8.3104 - val thy = ProofContext.theory_of ctxt;
8.3105 - val (T, ts) = eval thy param_user_modes options t_compr;
8.3106 - val (ts, _) = Predicate.yieldn k ts;
8.3107 - val setT = HOLogic.mk_setT T;
8.3108 - val elemsT = HOLogic.mk_set T ts;
8.3109 + val thy = ProofContext.theory_of ctxt
8.3110 + val (T, ts) = eval thy param_user_modes comp_options k t_compr
8.3111 + val setT = HOLogic.mk_setT T
8.3112 + val elems = HOLogic.mk_set T ts
8.3113 val cont = Free ("...", setT)
8.3114 - in if k = ~1 orelse length ts < k then elemsT
8.3115 - else Const (@{const_name Set.union}, setT --> setT --> setT) $ elemsT $ cont
8.3116 + (* check expected values *)
8.3117 + val () =
8.3118 + case raw_expected of
8.3119 + NONE => ()
8.3120 + | SOME s =>
8.3121 + if eq_set (op =) (HOLogic.dest_set (Syntax.read_term ctxt s), ts) then ()
8.3122 + else
8.3123 + error ("expected and computed values do not match:\n" ^
8.3124 + "expected values: " ^ Syntax.string_of_term ctxt (Syntax.read_term ctxt s) ^ "\n" ^
8.3125 + "computed values: " ^ Syntax.string_of_term ctxt elems ^ "\n")
8.3126 + in
8.3127 + if k = ~1 orelse length ts < k then elems
8.3128 + else Const (@{const_name Set.union}, setT --> setT --> setT) $ elems $ cont
8.3129 end;
8.3130
8.3131 fun values_cmd print_modes param_user_modes options k raw_t state =
8.3132 let
8.3133 - val ctxt = Toplevel.context_of state;
8.3134 - val t = Syntax.read_term ctxt raw_t;
8.3135 - val t' = values ctxt param_user_modes options k t;
8.3136 - val ty' = Term.type_of t';
8.3137 - val ctxt' = Variable.auto_fixes t' ctxt;
8.3138 + val ctxt = Toplevel.context_of state
8.3139 + val t = Syntax.read_term ctxt raw_t
8.3140 + val t' = values ctxt param_user_modes options k t
8.3141 + val ty' = Term.type_of t'
8.3142 + val ctxt' = Variable.auto_fixes t' ctxt
8.3143 val p = PrintMode.with_modes print_modes (fn () =>
8.3144 Pretty.block [Pretty.quote (Syntax.pretty_term ctxt' t'), Pretty.fbrk,
8.3145 Pretty.str "::", Pretty.brk 1, Pretty.quote (Syntax.pretty_typ ctxt' ty')]) ();
9.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_data.ML Sat Jan 16 21:14:15 2010 +0100
9.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_data.ML Wed Jan 20 11:56:45 2010 +0100
9.3 @@ -7,10 +7,10 @@
9.4 signature PREDICATE_COMPILE_DATA =
9.5 sig
9.6 type specification_table;
9.7 - val make_const_spec_table : Predicate_Compile_Aux.options -> theory -> specification_table
9.8 - val get_specification : specification_table -> string -> thm list
9.9 - val obtain_specification_graph : Predicate_Compile_Aux.options -> theory ->
9.10 - specification_table -> string -> thm list Graph.T
9.11 + (*val make_const_spec_table : Predicate_Compile_Aux.options -> theory -> specification_table*)
9.12 + val get_specification : theory -> term -> thm list
9.13 + val obtain_specification_graph :
9.14 + Predicate_Compile_Aux.options -> theory -> term -> thm list TermGraph.T
9.15 val normalize_equation : theory -> thm -> thm
9.16 end;
9.17
9.18 @@ -37,16 +37,17 @@
9.19
9.20 type specification_table = thm list Symtab.table
9.21
9.22 -fun defining_const_of_introrule_term t =
9.23 +fun defining_term_of_introrule_term t =
9.24 let
9.25 val _ $ u = Logic.strip_imp_concl t
9.26 - val (pred, all_args) = strip_comb u
9.27 + in fst (strip_comb u) end
9.28 +(*
9.29 in case pred of
9.30 Const (c, T) => c
9.31 | _ => raise TERM ("defining_const_of_introrule_term failed: Not a constant", [t])
9.32 end
9.33 -
9.34 -val defining_const_of_introrule = defining_const_of_introrule_term o prop_of
9.35 +*)
9.36 +val defining_term_of_introrule = defining_term_of_introrule_term o prop_of
9.37
9.38 (*TODO*)
9.39 fun is_introlike_term t = true
9.40 @@ -66,14 +67,20 @@
9.41
9.42 val check_equation_format = check_equation_format_term o prop_of
9.43
9.44 -fun defining_const_of_equation_term (t as (Const ("==", _) $ u $ v)) =
9.45 - (case fst (strip_comb u) of
9.46 - Const (c, _) => c
9.47 - | _ => raise TERM ("defining_const_of_equation_term failed: Not a constant", [t]))
9.48 - | defining_const_of_equation_term t =
9.49 +
9.50 +fun defining_term_of_equation_term (t as (Const ("==", _) $ u $ v)) = fst (strip_comb u)
9.51 + | defining_term_of_equation_term t =
9.52 raise TERM ("defining_const_of_equation_term failed: Not an equation", [t])
9.53
9.54 -val defining_const_of_equation = defining_const_of_equation_term o prop_of
9.55 +val defining_term_of_equation = defining_term_of_equation_term o prop_of
9.56 +
9.57 +fun defining_const_of_equation th =
9.58 + case defining_term_of_equation th
9.59 + of Const (c, _) => c
9.60 + | _ => raise TERM ("defining_const_of_equation failed: Not a constant", [prop_of th])
9.61 +
9.62 +
9.63 +
9.64
9.65 (* Normalizing equations *)
9.66
9.67 @@ -125,7 +132,7 @@
9.68 |> split_all_pairs thy
9.69 |> tap check_equation_format
9.70
9.71 -fun inline_equations options thy th =
9.72 +fun inline_equations thy th =
9.73 let
9.74 val inline_defs = Predicate_Compile_Inline_Defs.get (ProofContext.init thy)
9.75 val th' = (Simplifier.full_simplify (HOL_basic_ss addsimps inline_defs)) th
9.76 @@ -136,7 +143,7 @@
9.77 in
9.78 th'
9.79 end
9.80 -
9.81 +(*
9.82 fun store_thm_in_table options ignore thy th=
9.83 let
9.84 val th = th
9.85 @@ -150,7 +157,7 @@
9.86 in
9.87 (defining_const_of_equation eq, eq)
9.88 end
9.89 - else if (is_introlike th) then (defining_const_of_introrule th, th)
9.90 + else if is_introlike th then (defining_const_of_introrule th, th)
9.91 else error "store_thm: unexpected definition format"
9.92 in
9.93 if ignore const then I else Symtab.cons_list (const, th)
9.94 @@ -160,15 +167,15 @@
9.95 let
9.96 fun store ignore f =
9.97 fold (store_thm_in_table options ignore thy)
9.98 - (map (Thm.transfer thy) (f (ProofContext.init thy)))
9.99 + (map (Thm.transfer thy) (f ))
9.100 val table = Symtab.empty
9.101 |> store (K false) Predicate_Compile_Alternative_Defs.get
9.102 val ignore = Symtab.defined table
9.103 in
9.104 table
9.105 |> store ignore (fn ctxt => maps
9.106 - (fn (roughly, (ts, ths)) => if roughly = Spec_Rules.Equational then ths else [])
9.107 - (Spec_Rules.get ctxt))
9.108 + else [])
9.109 +
9.110 |> store ignore Nitpick_Simps.get
9.111 |> store ignore Nitpick_Intros.get
9.112 end
9.113 @@ -177,28 +184,62 @@
9.114 case Symtab.lookup table constname of
9.115 SOME thms => thms
9.116 | NONE => error ("get_specification: lookup of constant " ^ quote constname ^ " failed")
9.117 +*)
9.118 +
9.119 +fun get_specification thy t =
9.120 + Output.cond_timeit true "get_specification" (fn () =>
9.121 + let
9.122 + val ctxt = ProofContext.init thy
9.123 + fun filtering th =
9.124 + if is_equationlike th andalso
9.125 + defining_const_of_equation (normalize_equation thy th) = (fst (dest_Const t)) then
9.126 + SOME (normalize_equation thy th)
9.127 + else
9.128 + if is_introlike th andalso defining_term_of_introrule th = t then
9.129 + SOME th
9.130 + else
9.131 + NONE
9.132 + in
9.133 + case map_filter filtering (map (Thm.transfer thy) (Predicate_Compile_Alternative_Defs.get ctxt))
9.134 + of [] => (case map_filter
9.135 + (fn (roughly, (ts, ths)) =>
9.136 + if roughly = Spec_Rules.Equational andalso member (op =) ts t then SOME ths else NONE)
9.137 + (map ((apsnd o apsnd) (map (Thm.transfer thy))) (Spec_Rules.retrieve ctxt t))
9.138 + of [] => Output.cond_timeit true "Nitpick get_spec"
9.139 + (fn () => (case map_filter filtering (map (Thm.transfer thy) (Nitpick_Simps.get ctxt))
9.140 + of [] => map_filter filtering (map (Thm.transfer thy) (Nitpick_Intros.get ctxt))
9.141 + | ths => ths))
9.142 + | thss => flat thss)
9.143 + | ths => ths
9.144 + end)
9.145
9.146 val logic_operator_names =
9.147 - [@{const_name "=="}, @{const_name "op ="}, @{const_name "op -->"}, @{const_name "All"}, @{const_name "Ex"},
9.148 + [@{const_name "=="},
9.149 + @{const_name "==>"},
9.150 + @{const_name "Trueprop"},
9.151 + @{const_name "Not"},
9.152 + @{const_name "op ="},
9.153 + @{const_name "op -->"},
9.154 + @{const_name "All"},
9.155 + @{const_name "Ex"},
9.156 @{const_name "op &"}]
9.157
9.158 -val special_cases = member (op =) [
9.159 - @{const_name "False"},
9.160 - @{const_name "Suc"}, @{const_name Nat.zero_nat_inst.zero_nat},
9.161 - @{const_name Nat.one_nat_inst.one_nat},
9.162 -@{const_name "HOL.ord_class.less"}, @{const_name "HOL.ord_class.less_eq"},
9.163 -@{const_name "HOL.zero_class.zero"},
9.164 -@{const_name "HOL.one_class.one"}, @{const_name HOL.plus_class.plus},
9.165 -@{const_name Nat.ord_nat_inst.less_eq_nat},
9.166 -@{const_name Nat.ord_nat_inst.less_nat},
9.167 -@{const_name number_nat_inst.number_of_nat},
9.168 +fun special_cases (c, T) = member (op =) [
9.169 + @{const_name "Product_Type.Unity"},
9.170 + @{const_name "False"},
9.171 + @{const_name "Suc"}, @{const_name Nat.zero_nat_inst.zero_nat},
9.172 + @{const_name Nat.one_nat_inst.one_nat},
9.173 + @{const_name "HOL.ord_class.less"}, @{const_name "HOL.ord_class.less_eq"},
9.174 + @{const_name "HOL.zero_class.zero"},
9.175 + @{const_name "HOL.one_class.one"}, @{const_name HOL.plus_class.plus},
9.176 + @{const_name Nat.ord_nat_inst.less_eq_nat},
9.177 + @{const_name Nat.ord_nat_inst.less_nat},
9.178 + @{const_name number_nat_inst.number_of_nat},
9.179 @{const_name Int.Bit0},
9.180 @{const_name Int.Bit1},
9.181 @{const_name Int.Pls},
9.182 -@{const_name "Int.zero_int_inst.zero_int"},
9.183 -@{const_name "List.filter"}]
9.184 -
9.185 -fun case_consts thy s = is_some (Datatype.info_of_case thy s)
9.186 + @{const_name "Int.zero_int_inst.zero_int"},
9.187 + @{const_name "List.filter"}] c
9.188
9.189 fun print_specification options thy constname specs =
9.190 if show_intermediate_results options then
9.191 @@ -206,26 +247,32 @@
9.192 cat_lines (map (Display.string_of_thm_global thy) specs))
9.193 else ()
9.194
9.195 -fun obtain_specification_graph options thy table constname =
9.196 +fun obtain_specification_graph options thy t =
9.197 let
9.198 - fun is_nondefining_constname c = member (op =) logic_operator_names c
9.199 - val is_defining_constname = member (op =) (Symtab.keys table)
9.200 - fun has_code_pred_intros c = is_some (try (Predicate_Compile_Core.intros_of thy) c)
9.201 + fun is_nondefining_const (c, T) = member (op =) logic_operator_names c
9.202 + fun has_code_pred_intros (c, T) = is_some (try (Predicate_Compile_Core.intros_of thy) c)
9.203 + fun case_consts (c, T) = is_some (Datatype.info_of_case thy c)
9.204 + fun is_datatype_constructor (c, T) = is_some (Datatype.info_of_constr thy (c, T))
9.205 fun defiants_of specs =
9.206 - fold (Term.add_const_names o prop_of) specs []
9.207 - |> filter is_defining_constname
9.208 - |> filter_out is_nondefining_constname
9.209 + fold (Term.add_consts o prop_of) specs []
9.210 + |> filter_out is_datatype_constructor
9.211 + |> filter_out is_nondefining_const
9.212 |> filter_out has_code_pred_intros
9.213 - |> filter_out (case_consts thy)
9.214 + |> filter_out case_consts
9.215 |> filter_out special_cases
9.216 - fun extend constname =
9.217 + |> map Const
9.218 + (*
9.219 + |> filter is_defining_constname*)
9.220 + fun extend t =
9.221 let
9.222 - val specs = get_specification table constname
9.223 - val _ = print_specification options thy constname specs
9.224 + val specs = rev (get_specification thy t)
9.225 + |> map (inline_equations thy)
9.226 + (*|> Predicate_Compile_Set.unfold_set_notation*)
9.227 + (*val _ = print_specification options thy constname specs*)
9.228 in (specs, defiants_of specs) end;
9.229 in
9.230 - Graph.extend extend constname Graph.empty
9.231 + TermGraph.extend extend t TermGraph.empty
9.232 end;
9.233
9.234 -
9.235 +
9.236 end;
10.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_fun.ML Sat Jan 16 21:14:15 2010 +0100
10.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_fun.ML Wed Jan 20 11:56:45 2010 +0100
10.3 @@ -14,31 +14,7 @@
10.4 structure Predicate_Compile_Fun : PREDICATE_COMPILE_FUN =
10.5 struct
10.6
10.7 -fun is_funtype (Type ("fun", [_, _])) = true
10.8 - | is_funtype _ = false;
10.9 -
10.10 -fun is_Type (Type _) = true
10.11 - | is_Type _ = false
10.12 -
10.13 -(* returns true if t is an application of an datatype constructor *)
10.14 -(* which then consequently would be splitted *)
10.15 -(* else false *)
10.16 -(*
10.17 -fun is_constructor thy t =
10.18 - if (is_Type (fastype_of t)) then
10.19 - (case DatatypePackage.get_datatype thy ((fst o dest_Type o fastype_of) t) of
10.20 - NONE => false
10.21 - | SOME info => (let
10.22 - val constr_consts = maps (fn (_, (_, _, constrs)) => map fst constrs) (#descr info)
10.23 - val (c, _) = strip_comb t
10.24 - in (case c of
10.25 - Const (name, _) => name mem_string constr_consts
10.26 - | _ => false) end))
10.27 - else false
10.28 -*)
10.29 -
10.30 -(* must be exported in code.ML *)
10.31 -fun is_constr thy = is_some o Code.get_datatype_of_constr thy;
10.32 +open Predicate_Compile_Aux;
10.33
10.34 (* Table from constant name (string) to term of inductive predicate *)
10.35 structure Pred_Compile_Preproc = Theory_Data
11.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_pred.ML Sat Jan 16 21:14:15 2010 +0100
11.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_pred.ML Wed Jan 20 11:56:45 2010 +0100
11.3 @@ -112,8 +112,9 @@
11.4 #> Simplifier.simplify (HOL_basic_ss addsimps [@{thm ex_disj_distrib}])
11.5
11.6 val rewrite_intros =
11.7 - Simplifier.simplify (HOL_basic_ss addsimps @{thms HOL.simp_thms(9)})
11.8 -
11.9 +(* Simplifier.simplify (HOL_basic_ss addsimps @{thms HOL.simp_thms(9)}) *)
11.10 + Simplifier.full_simplify (HOL_basic_ss addsimps [@{thm not_not}])
11.11 +
11.12 fun preprocess (constname, specs) thy =
11.13 let
11.14 val ctxt = ProofContext.init thy
12.1 --- a/src/HOL/Tools/Predicate_Compile/predicate_compile_quickcheck.ML Sat Jan 16 21:14:15 2010 +0100
12.2 +++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_quickcheck.ML Wed Jan 20 11:56:45 2010 +0100
12.3 @@ -8,7 +8,8 @@
12.4 sig
12.5 val quickcheck : Proof.context -> term -> int -> term list option
12.6 val test_ref :
12.7 - ((unit -> int -> int * int -> term list Predicate.pred * (int * int)) option) Unsynchronized.ref
12.8 + ((unit -> int -> int -> int * int -> term list DSequence.dseq * (int * int)) option) Unsynchronized.ref
12.9 + val tracing : bool Unsynchronized.ref;
12.10 end;
12.11
12.12 structure Predicate_Compile_Quickcheck : PREDICATE_COMPILE_QUICKCHECK =
12.13 @@ -17,7 +18,9 @@
12.14 open Predicate_Compile_Aux;
12.15
12.16 val test_ref =
12.17 - Unsynchronized.ref (NONE : (unit -> int -> int * int -> term list Predicate.pred * (int * int)) option)
12.18 + Unsynchronized.ref (NONE : (unit -> int -> int -> int * int -> term list DSequence.dseq * (int * int)) option);
12.19 +
12.20 +val tracing = Unsynchronized.ref false;
12.21
12.22 val target = "Quickcheck"
12.23
12.24 @@ -28,15 +31,12 @@
12.25 show_steps = true,
12.26 show_intermediate_results = true,
12.27 show_proof_trace = false,
12.28 - show_modes = true,
12.29 + show_modes = false,
12.30 show_mode_inference = false,
12.31 - show_compilation = true,
12.32 + show_compilation = false,
12.33 skip_proof = false,
12.34 -
12.35 - inductify = false,
12.36 - random = false,
12.37 - depth_limited = false,
12.38 - annotated = false
12.39 + compilation = Random,
12.40 + inductify = false
12.41 }
12.42
12.43 fun dest_compfuns (Predicate_Compile_Core.CompilationFuns funs) = funs
12.44 @@ -65,7 +65,11 @@
12.45
12.46 fun quickcheck ctxt t =
12.47 let
12.48 - val _ = tracing ("Starting quickcheck with " ^ (Syntax.string_of_term ctxt t))
12.49 + (*val () =
12.50 + if !tracing then
12.51 + tracing ("Starting quickcheck with " ^ (Syntax.string_of_term ctxt t))
12.52 + else
12.53 + ()*)
12.54 val ctxt' = ProofContext.theory (Context.copy_thy) ctxt
12.55 val thy = (ProofContext.theory_of ctxt')
12.56 val (vs, t') = strip_abs t
12.57 @@ -75,42 +79,47 @@
12.58 val constname = "pred_compile_quickcheck"
12.59 val full_constname = Sign.full_bname thy constname
12.60 val constT = map snd vs' ---> @{typ bool}
12.61 - val thy' = Sign.add_consts_i [(Binding.name constname, constT, NoSyn)] thy
12.62 + val thy1 = Sign.add_consts_i [(Binding.name constname, constT, NoSyn)] thy
12.63 + val const = Const (full_constname, constT)
12.64 val t = Logic.list_implies
12.65 - (map HOLogic.mk_Trueprop (prems @ [HOLogic.mk_not concl]),
12.66 + (map HOLogic.mk_Trueprop (prems @ [HOLogic.mk_not concl]),
12.67 HOLogic.mk_Trueprop (list_comb (Const (full_constname, constT), map Free vs')))
12.68 - val tac = fn _ => Skip_Proof.cheat_tac thy'
12.69 - val intro = Goal.prove (ProofContext.init thy') (map fst vs') [] t tac
12.70 - val _ = tracing (Display.string_of_thm ctxt' intro)
12.71 - val thy'' = thy'
12.72 - |> Context.theory_map (Predicate_Compile_Alternative_Defs.add_thm intro)
12.73 - |> Predicate_Compile.preprocess options full_constname
12.74 - |> Predicate_Compile_Core.add_equations options [full_constname]
12.75 - (* |> Predicate_Compile_Core.add_depth_limited_equations Predicate_Compile_Aux.default_options [full_constname]*)
12.76 - |> Predicate_Compile_Core.add_quickcheck_equations options [full_constname]
12.77 - val depth_limited_modes = Predicate_Compile_Core.depth_limited_modes_of thy'' full_constname
12.78 - val modes = Predicate_Compile_Core.random_modes_of thy'' full_constname
12.79 + val tac = fn _ => Skip_Proof.cheat_tac thy1
12.80 + val intro = Goal.prove (ProofContext.init thy1) (map fst vs') [] t tac
12.81 + (*val _ = tracing (Display.string_of_thm ctxt' intro)*)
12.82 + val thy2 = (*Output.cond_timeit (!Quickcheck.timing) "predicate intros"
12.83 + (fn () => *)(Context.theory_map (Predicate_Compile_Alternative_Defs.add_thm intro) thy1)
12.84 + val thy3 = (*Output.cond_timeit (!Quickcheck.timing) "predicate preprocessing"
12.85 + (fn () =>*) (Predicate_Compile.preprocess options const thy2)
12.86 + val thy4 = Output.cond_timeit (!Quickcheck.timing) "random_dseq compilation"
12.87 + (fn () => Predicate_Compile_Core.add_random_dseq_equations options [full_constname] thy3)
12.88 + (*val depth_limited_modes = Predicate_Compile_Core.modes_of Depth_Limited thy'' full_constname*)
12.89 + val modes = Predicate_Compile_Core.modes_of Random_DSeq thy4 full_constname
12.90 + val output_mode = fold_rev (curry Fun) (map (K Output) (binder_types constT)) Bool
12.91 val prog =
12.92 - if member (op =) modes ([], []) then
12.93 + if member eq_mode modes output_mode then
12.94 let
12.95 - val name = Predicate_Compile_Core.random_function_name_of thy'' full_constname ([], [])
12.96 - val T = [@{typ code_numeral}] ---> (mk_randompredT (HOLogic.mk_tupleT (map snd vs')))
12.97 - in Const (name, T) $ Bound 0 end
12.98 + val name = Predicate_Compile_Core.function_name_of Random_DSeq thy4 full_constname output_mode
12.99 + val T = (mk_randompredT (HOLogic.mk_tupleT (map snd vs')))
12.100 + in
12.101 + Const (name, T)
12.102 + end
12.103 (*else if member (op =) depth_limited_modes ([], []) then
12.104 let
12.105 val name = Predicate_Compile_Core.depth_limited_function_name_of thy'' full_constname ([], [])
12.106 val T = @{typ code_numeral} --> (mk_predT (HOLogic.mk_tupleT (map snd vs')))
12.107 in lift_pred (Const (name, T) $ Bound 0) end*)
12.108 else error "Predicate Compile Quickcheck failed"
12.109 - val qc_term = Abs ("size", @{typ code_numeral}, mk_bind (prog,
12.110 + val qc_term = mk_bind (prog,
12.111 mk_split_lambda (map Free vs') (mk_return (HOLogic.mk_list @{typ term}
12.112 - (map2 HOLogic.mk_term_of (map snd vs') (map Free vs'))))))
12.113 - val _ = tracing (Syntax.string_of_term ctxt' qc_term)
12.114 - val compile = Code_Eval.eval (SOME target) ("Predicate_Compile_Quickcheck.test_ref", test_ref)
12.115 - (fn proc => fn g => fn s => g s #>> (Predicate.map o map) proc)
12.116 - thy'' qc_term []
12.117 + (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))
12.118 + val compilation =
12.119 + Code_Eval.eval NONE ("Predicate_Compile_Quickcheck.test_ref", test_ref)
12.120 + (fn proc => fn g => fn n => fn size => fn s => g n size s |>> (DSequence.map o map) proc)
12.121 + thy4 qc_term []
12.122 in
12.123 - ((compile #> Random_Engine.run) #> (Option.map fst o Predicate.yield))
12.124 + (fn size =>
12.125 + Option.map fst (DSequence.yield (compilation size size |> Random_Engine.run) size true))
12.126 end
12.127
12.128 end;
13.1 --- a/src/HOL/Word/WordBitwise.thy Sat Jan 16 21:14:15 2010 +0100
13.2 +++ b/src/HOL/Word/WordBitwise.thy Wed Jan 20 11:56:45 2010 +0100
13.3 @@ -204,7 +204,7 @@
13.4
13.5 lemma bl_word_not: "to_bl (NOT w) = map Not (to_bl w)"
13.6 unfolding to_bl_def word_log_defs
13.7 - by (simp add: bl_not_bin number_of_is_id word_no_wi [symmetric])
13.8 + by (simp add: bl_not_bin number_of_is_id word_no_wi [symmetric] bin_to_bl_def[symmetric])
13.9
13.10 lemma bl_word_xor: "to_bl (v XOR w) = map2 op ~= (to_bl v) (to_bl w)"
13.11 unfolding to_bl_def word_log_defs bl_xor_bin
14.1 --- a/src/HOL/ex/Predicate_Compile_Alternative_Defs.thy Sat Jan 16 21:14:15 2010 +0100
14.2 +++ b/src/HOL/ex/Predicate_Compile_Alternative_Defs.thy Wed Jan 20 11:56:45 2010 +0100
14.3 @@ -1,13 +1,19 @@
14.4 theory Predicate_Compile_Alternative_Defs
14.5 -imports Main
14.6 +imports "../Predicate_Compile"
14.7 begin
14.8
14.9 section {* Set operations *}
14.10
14.11 -declare eq_reflection[OF empty_def, code_pred_inline]
14.12 +declare Collect_def[code_pred_inline]
14.13 +declare mem_def[code_pred_inline]
14.14 +
14.15 +declare eq_reflection[OF empty_def, code_pred_inline]
14.16 +declare insert_code[code_pred_def]
14.17 declare eq_reflection[OF Un_def, code_pred_inline]
14.18 declare eq_reflection[OF UNION_def, code_pred_inline]
14.19
14.20 +
14.21 +
14.22 section {* Alternative list definitions *}
14.23
14.24 subsection {* Alternative rules for set *}
14.25 @@ -22,13 +28,13 @@
14.26 unfolding mem_def[symmetric, of _ x]
14.27 by auto
14.28
14.29 -code_pred set
14.30 +code_pred [skip_proof] set
14.31 proof -
14.32 case set
14.33 from this show thesis
14.34 - apply (case_tac a1)
14.35 + apply (case_tac xb)
14.36 apply auto
14.37 - unfolding mem_def[symmetric, of _ a2]
14.38 + unfolding mem_def[symmetric, of _ xc]
14.39 apply auto
14.40 unfolding mem_def
14.41 apply fastsimp
14.42 @@ -43,15 +49,15 @@
14.43 lemma list_all2_ConsI [code_pred_intro]: "list_all2 P xs ys ==> P x y ==> list_all2 P (x#xs) (y#ys)"
14.44 by auto
14.45
14.46 -code_pred list_all2
14.47 +code_pred [skip_proof] list_all2
14.48 proof -
14.49 case list_all2
14.50 from this show thesis
14.51 apply -
14.52 - apply (case_tac a1)
14.53 - apply (case_tac a2)
14.54 + apply (case_tac xa)
14.55 + apply (case_tac xb)
14.56 apply auto
14.57 - apply (case_tac a2)
14.58 + apply (case_tac xb)
14.59 apply auto
14.60 done
14.61 qed
15.1 --- a/src/HOL/ex/Predicate_Compile_Quickcheck.thy Sat Jan 16 21:14:15 2010 +0100
15.2 +++ b/src/HOL/ex/Predicate_Compile_Quickcheck.thy Wed Jan 20 11:56:45 2010 +0100
15.3 @@ -3,10 +3,34 @@
15.4 header {* A Prototype of Quickcheck based on the Predicate Compiler *}
15.5
15.6 theory Predicate_Compile_Quickcheck
15.7 -imports Main
15.8 +imports "../Predicate_Compile"
15.9 uses "../Tools/Predicate_Compile/predicate_compile_quickcheck.ML"
15.10 begin
15.11
15.12 setup {* Quickcheck.add_generator ("predicate_compile", Predicate_Compile_Quickcheck.quickcheck) *}
15.13 +(*
15.14 +datatype alphabet = a | b
15.15
15.16 +inductive_set S\<^isub>1 and A\<^isub>1 and B\<^isub>1 where
15.17 + "[] \<in> S\<^isub>1"
15.18 +| "w \<in> A\<^isub>1 \<Longrightarrow> b # w \<in> S\<^isub>1"
15.19 +| "w \<in> B\<^isub>1 \<Longrightarrow> a # w \<in> S\<^isub>1"
15.20 +| "w \<in> S\<^isub>1 \<Longrightarrow> a # w \<in> A\<^isub>1"
15.21 +| "w \<in> S\<^isub>1 \<Longrightarrow> b # w \<in> S\<^isub>1"
15.22 +| "\<lbrakk>v \<in> B\<^isub>1; v \<in> B\<^isub>1\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^isub>1"
15.23 +
15.24 +ML {* set Toplevel.debug *}
15.25 +
15.26 +declare mem_def[code_pred_inline] Collect_def[code_pred_inline]
15.27 +
15.28 +lemma
15.29 + "w \<in> S\<^isub>1p \<Longrightarrow> w = []"
15.30 +quickcheck[generator = predicate_compile, iterations=1]
15.31 +oops
15.32 +
15.33 +theorem S\<^isub>1_sound:
15.34 +"w \<in> S\<^isub>1p \<Longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
15.35 +quickcheck[generator=predicate_compile, size=15]
15.36 +oops
15.37 +*)
15.38 end
15.39 \ No newline at end of file
16.1 --- a/src/HOL/ex/Predicate_Compile_Quickcheck_ex.thy Sat Jan 16 21:14:15 2010 +0100
16.2 +++ b/src/HOL/ex/Predicate_Compile_Quickcheck_ex.thy Wed Jan 20 11:56:45 2010 +0100
16.3 @@ -3,39 +3,43 @@
16.4 Predicate_Compile_Alternative_Defs
16.5 begin
16.6
16.7 +ML {* Predicate_Compile_Alternative_Defs.get *}
16.8 +
16.9 section {* Sets *}
16.10 -
16.11 +(*
16.12 lemma "x \<in> {(1::nat)} ==> False"
16.13 +quickcheck[generator=predicate_compile, iterations=10]
16.14 +oops
16.15 +*)
16.16 +(* TODO: some error with doubled negation *)
16.17 +(*
16.18 +lemma "x \<in> {Suc 0, Suc (Suc 0)} ==> x \<noteq> Suc 0"
16.19 quickcheck[generator=predicate_compile]
16.20 oops
16.21 -
16.22 -(* TODO: some error with doubled negation *)
16.23 -lemma "x \<in> {Suc 0, Suc (Suc 0)} ==> x \<noteq> Suc 0"
16.24 +*)
16.25 +(*
16.26 +lemma "x \<in> {Suc 0, Suc (Suc 0)} ==> x = Suc 0"
16.27 +quickcheck[generator=predicate_compile]
16.28 +oops
16.29 +*)
16.30 +lemma "x \<in> {Suc 0, Suc (Suc 0)} ==> x <= Suc 0"
16.31 (*quickcheck[generator=predicate_compile]*)
16.32 oops
16.33
16.34 -lemma "x \<in> {Suc 0, Suc (Suc 0)} ==> x = Suc 0"
16.35 -quickcheck[generator=predicate_compile]
16.36 -oops
16.37 -
16.38 -lemma "x \<in> {Suc 0, Suc (Suc 0)} ==> x <= Suc 0"
16.39 -quickcheck[generator=predicate_compile]
16.40 -oops
16.41 -
16.42 section {* Numerals *}
16.43 -
16.44 +(*
16.45 lemma
16.46 "x \<in> {1, 2, (3::nat)} ==> x = 1 \<or> x = 2"
16.47 quickcheck[generator=predicate_compile]
16.48 oops
16.49 -
16.50 +*)
16.51 lemma "x \<in> {1, 2, (3::nat)} ==> x < 3"
16.52 (*quickcheck[generator=predicate_compile]*)
16.53 oops
16.54
16.55 lemma
16.56 "x \<in> {1, 2} \<union> {3, 4} ==> x = (1::nat) \<or> x = (2::nat)"
16.57 -quickcheck[generator=predicate_compile]
16.58 +(*quickcheck[generator=predicate_compile]*)
16.59 oops
16.60
16.61 section {* Context Free Grammar *}
16.62 @@ -49,10 +53,33 @@
16.63 | "w \<in> S\<^isub>1 \<Longrightarrow> a # w \<in> A\<^isub>1"
16.64 | "w \<in> S\<^isub>1 \<Longrightarrow> b # w \<in> S\<^isub>1"
16.65 | "\<lbrakk>v \<in> B\<^isub>1; v \<in> B\<^isub>1\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^isub>1"
16.66 +(*
16.67 +code_pred [random_dseq inductify] "S\<^isub>1p" .
16.68 +*)
16.69 +(*thm B\<^isub>1p.random_dseq_equation*)
16.70 +(*
16.71 +values [random_dseq 2, 2, 4] 10 "{x. S\<^isub>1p x}"
16.72 +values [random_dseq 1, 1, 5] 20 "{x. S\<^isub>1p x}"
16.73 +
16.74 +ML {* set ML_Context.trace *}
16.75 +*)
16.76 +ML {* set Toplevel.debug *}
16.77 +(*
16.78 +quickcheck[generator = predicate_compile, size = 10, iterations = 1]
16.79 +oops
16.80 +*)
16.81 +ML {* Spec_Rules.get *}
16.82 +ML {* Item_Net.retrieve *}
16.83 +local_setup {* Local_Theory.checkpoint *}
16.84 +ML {* Predicate_Compile_Data.get_specification @{theory} @{term "append"} *}
16.85 +lemma
16.86 + "w \<in> S\<^isub>1p \<Longrightarrow> w = []"
16.87 +quickcheck[generator = predicate_compile, iterations=1]
16.88 +oops
16.89
16.90 theorem S\<^isub>1_sound:
16.91 "w \<in> S\<^isub>1p \<Longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
16.92 -(*quickcheck[generator=predicate_compile, size=15]*)
16.93 +quickcheck[generator=predicate_compile, size=15]
16.94 oops
16.95
16.96
16.97 @@ -64,37 +91,37 @@
16.98 | "w \<in> S\<^isub>2 \<Longrightarrow> b # w \<in> B\<^isub>2"
16.99 | "\<lbrakk>v \<in> B\<^isub>2; v \<in> B\<^isub>2\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^isub>2"
16.100
16.101 -code_pred [inductify, random] S\<^isub>2 .
16.102 -thm S\<^isub>2.random_equation
16.103 -thm A\<^isub>2.random_equation
16.104 -thm B\<^isub>2.random_equation
16.105 +code_pred [random_dseq inductify] S\<^isub>2 .
16.106 +thm S\<^isub>2.random_dseq_equation
16.107 +thm A\<^isub>2.random_dseq_equation
16.108 +thm B\<^isub>2.random_dseq_equation
16.109
16.110 -values [random] 10 "{x. S\<^isub>2 x}"
16.111 +values [random_dseq 1, 2, 8] 10 "{x. S\<^isub>2 x}"
16.112
16.113 lemma "w \<in> S\<^isub>2 ==> w \<noteq> [] ==> w \<noteq> [b, a] ==> w \<in> {}"
16.114 -quickcheck[generator=predicate_compile]
16.115 +quickcheck[generator=predicate_compile, size=8]
16.116 oops
16.117
16.118 lemma "[x <- w. x = a] = []"
16.119 quickcheck[generator=predicate_compile]
16.120 oops
16.121
16.122 +declare list.size(3,4)[code_pred_def]
16.123
16.124 +(*
16.125 lemma "length ([x \<leftarrow> w. x = a]) = (0::nat)"
16.126 -(*quickcheck[generator=predicate_compile]*)
16.127 +quickcheck[generator=predicate_compile]
16.128 oops
16.129 -
16.130 -
16.131 +*)
16.132
16.133 lemma
16.134 -"w \<in> S\<^isub>2 ==> length [x \<leftarrow> w. x = a] < Suc (Suc 0)"
16.135 -(*quickcheck[generator=predicate_compile]*)
16.136 +"w \<in> S\<^isub>2 ==> length [x \<leftarrow> w. x = a] <= Suc (Suc 0)"
16.137 +quickcheck[generator=predicate_compile, size = 10, iterations = 1]
16.138 oops
16.139
16.140 -
16.141 theorem S\<^isub>2_sound:
16.142 "w \<in> S\<^isub>2 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
16.143 -(*quickcheck[generator=predicate_compile, size=15, iterations=100]*)
16.144 +quickcheck[generator=predicate_compile, size=15, iterations=1]
16.145 oops
16.146
16.147 inductive_set S\<^isub>3 and A\<^isub>3 and B\<^isub>3 where
16.148 @@ -107,23 +134,24 @@
16.149
16.150 code_pred [inductify] S\<^isub>3 .
16.151 thm S\<^isub>3.equation
16.152 +(*
16.153 +values 10 "{x. S\<^isub>3 x}"
16.154 +*)
16.155
16.156 -values 10 "{x. S\<^isub>3 x}"
16.157
16.158 lemma S\<^isub>3_sound:
16.159 "w \<in> S\<^isub>3 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
16.160 -(*quickcheck[generator=predicate_compile, size=10, iterations=1]*)
16.161 +quickcheck[generator=predicate_compile, size=10, iterations=10]
16.162 oops
16.163
16.164 -
16.165 lemma "\<not> (length w > 2) \<or> \<not> (length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b])"
16.166 -(*quickcheck[size=10, generator = pred_compile]*)
16.167 +quickcheck[size=10, generator = predicate_compile]
16.168 oops
16.169
16.170 theorem S\<^isub>3_complete:
16.171 "length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. b = x] \<longrightarrow> w \<in> S\<^isub>3"
16.172 (*quickcheck[generator=SML]*)
16.173 -(*quickcheck[generator=predicate_compile, size=10, iterations=100]*)
16.174 +quickcheck[generator=predicate_compile, size=10, iterations=100]
16.175 oops
16.176
16.177
16.178 @@ -138,13 +166,205 @@
16.179
16.180 theorem S\<^isub>4_sound:
16.181 "w \<in> S\<^isub>4 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
16.182 -(*quickcheck[generator = predicate_compile, size=2, iterations=1]*)
16.183 +quickcheck[generator = predicate_compile, size=5, iterations=1]
16.184 oops
16.185
16.186 theorem S\<^isub>4_complete:
16.187 "length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] \<longrightarrow> w \<in> S\<^isub>4"
16.188 -(*quickcheck[generator = pred_compile, size=5, iterations=1]*)
16.189 +quickcheck[generator = predicate_compile, size=5, iterations=1]
16.190 oops
16.191
16.192 +hide const b
16.193 +
16.194 +subsection {* Lexicographic order *}
16.195 +lemma
16.196 + "(u, v) : lexord r ==> (x @ u, y @ v) : lexord r"
16.197 +
16.198 +subsection {* IMP *}
16.199 +
16.200 +types
16.201 + var = nat
16.202 + state = "int list"
16.203 +
16.204 +datatype com =
16.205 + Skip |
16.206 + Ass var "int" |
16.207 + Seq com com |
16.208 + IF "state list" com com |
16.209 + While "state list" com
16.210 +
16.211 +inductive exec :: "com => state => state => bool" where
16.212 + "exec Skip s s" |
16.213 + "exec (Ass x e) s (s[x := e])" |
16.214 + "exec c1 s1 s2 ==> exec c2 s2 s3 ==> exec (Seq c1 c2) s1 s3" |
16.215 + "s \<in> set b ==> exec c1 s t ==> exec (IF b c1 c2) s t" |
16.216 + "s \<notin> set b ==> exec c2 s t ==> exec (IF b c1 c2) s t" |
16.217 + "s \<notin> set b ==> exec (While b c) s s" |
16.218 + "s1 \<in> set b ==> exec c s1 s2 ==> exec (While b c) s2 s3 ==> exec (While b c) s1 s3"
16.219 +
16.220 +code_pred [random_dseq] exec .
16.221 +
16.222 +values [random_dseq 1, 2, 3] 10 "{(c, s, s'). exec c s s'}"
16.223 +
16.224 +lemma
16.225 + "exec c s s' ==> exec (Seq c c) s s'"
16.226 +quickcheck[generator = predicate_compile, size=3, iterations=1]
16.227 +oops
16.228 +
16.229 +subsection {* Lambda *}
16.230 +
16.231 +datatype type =
16.232 + Atom nat
16.233 + | Fun type type (infixr "\<Rightarrow>" 200)
16.234 +
16.235 +datatype dB =
16.236 + Var nat
16.237 + | App dB dB (infixl "\<degree>" 200)
16.238 + | Abs type dB
16.239 +
16.240 +primrec
16.241 + nth_el :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option" ("_\<langle>_\<rangle>" [90, 0] 91)
16.242 +where
16.243 + "[]\<langle>i\<rangle> = None"
16.244 +| "(x # xs)\<langle>i\<rangle> = (case i of 0 \<Rightarrow> Some x | Suc j \<Rightarrow> xs \<langle>j\<rangle>)"
16.245 +
16.246 +inductive nth_el' :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> bool"
16.247 +where
16.248 + "nth_el' (x # xs) 0 x"
16.249 +| "nth_el' xs i y \<Longrightarrow> nth_el' (x # xs) (Suc i) y"
16.250 +
16.251 +inductive typing :: "type list \<Rightarrow> dB \<Rightarrow> type \<Rightarrow> bool" ("_ \<turnstile> _ : _" [50, 50, 50] 50)
16.252 + where
16.253 + Var [intro!]: "nth_el' env x T \<Longrightarrow> env \<turnstile> Var x : T"
16.254 + | Abs [intro!]: "T # env \<turnstile> t : U \<Longrightarrow> env \<turnstile> Abs T t : (T \<Rightarrow> U)"
16.255 + | App [intro!]: "env \<turnstile> s : U \<Rightarrow> T \<Longrightarrow> env \<turnstile> t : T \<Longrightarrow> env \<turnstile> (s \<degree> t) : U"
16.256 +
16.257 +primrec
16.258 + lift :: "[dB, nat] => dB"
16.259 +where
16.260 + "lift (Var i) k = (if i < k then Var i else Var (i + 1))"
16.261 + | "lift (s \<degree> t) k = lift s k \<degree> lift t k"
16.262 + | "lift (Abs T s) k = Abs T (lift s (k + 1))"
16.263 +
16.264 +primrec
16.265 + subst :: "[dB, dB, nat] => dB" ("_[_'/_]" [300, 0, 0] 300)
16.266 +where
16.267 + subst_Var: "(Var i)[s/k] =
16.268 + (if k < i then Var (i - 1) else if i = k then s else Var i)"
16.269 + | subst_App: "(t \<degree> u)[s/k] = t[s/k] \<degree> u[s/k]"
16.270 + | subst_Abs: "(Abs T t)[s/k] = Abs T (t[lift s 0 / k+1])"
16.271 +
16.272 +inductive beta :: "[dB, dB] => bool" (infixl "\<rightarrow>\<^sub>\<beta>" 50)
16.273 + where
16.274 + beta [simp, intro!]: "Abs T s \<degree> t \<rightarrow>\<^sub>\<beta> s[t/0]"
16.275 + | appL [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> s \<degree> u \<rightarrow>\<^sub>\<beta> t \<degree> u"
16.276 + | appR [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> u \<degree> s \<rightarrow>\<^sub>\<beta> u \<degree> t"
16.277 + | abs [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> Abs T s \<rightarrow>\<^sub>\<beta> Abs T t"
16.278 +
16.279 +lemma
16.280 + "\<Gamma> \<turnstile> t : U \<Longrightarrow> t \<rightarrow>\<^sub>\<beta> t' \<Longrightarrow> \<Gamma> \<turnstile> t' : U"
16.281 +quickcheck[generator = predicate_compile, size = 7, iterations = 10]
16.282 +oops
16.283 +
16.284 +(*
16.285 +code_pred (expected_modes: i => i => o => bool, i => i => i => bool) typing .
16.286 +thm typing.equation
16.287 +
16.288 +code_pred (modes: i => i => bool, i => o => bool as reduce') beta .
16.289 +thm beta.equation
16.290 +
16.291 +values "{x. App (Abs (Atom 0) (Var 0)) (Var 1) \<rightarrow>\<^sub>\<beta> x}"
16.292 +
16.293 +definition "reduce t = Predicate.the (reduce' t)"
16.294 +
16.295 +value "reduce (App (Abs (Atom 0) (Var 0)) (Var 1))"
16.296 +
16.297 +code_pred [random] typing .
16.298 +code_pred [random_dseq] typing .
16.299 +
16.300 +(*values [random] 1 "{(\<Gamma>, t, T). \<Gamma> \<turnstile> t : T}"
16.301 +*)*)
16.302 +
16.303 +subsection {* JAD *}
16.304 +
16.305 +definition matrix :: "('a :: semiring_0) list list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
16.306 + "matrix M rs cs \<longleftrightarrow> (\<forall> row \<in> set M. length row = cs) \<and> length M = rs"
16.307 +(*
16.308 +code_pred [random_dseq inductify] matrix .
16.309 +thm matrix.random_dseq_equation
16.310 +
16.311 +thm matrix_aux.random_dseq_equation
16.312 +
16.313 +values [random_dseq 3, 2] 10 "{(M, rs, cs). matrix (M:: int list list) rs cs}"
16.314 +*)
16.315 +lemma [code_pred_intro]:
16.316 + "matrix [] 0 m"
16.317 + "matrix xss n m ==> length xs = m ==> matrix (xs # xss) (Suc n) m"
16.318 +sorry
16.319 +
16.320 +code_pred [random_dseq inductify] matrix sorry
16.321 +
16.322 +
16.323 +values [random_dseq 2, 2, 15] 6 "{(M::int list list, n, m). matrix M n m}"
16.324 +
16.325 +definition "scalar_product v w = (\<Sum> (x, y)\<leftarrow>zip v w. x * y)"
16.326 +
16.327 +definition mv :: "('a \<Colon> semiring_0) list list \<Rightarrow> 'a list \<Rightarrow> 'a list"
16.328 + where [simp]: "mv M v = map (scalar_product v) M"
16.329 +text {*
16.330 + This defines the matrix vector multiplication. To work properly @{term
16.331 +"matrix M m n \<and> length v = n"} must hold.
16.332 +*}
16.333 +
16.334 +subsection "Compressed matrix"
16.335 +
16.336 +definition "sparsify xs = [i \<leftarrow> zip [0..<length xs] xs. snd i \<noteq> 0]"
16.337 +(*
16.338 +lemma sparsify_length: "(i, x) \<in> set (sparsify xs) \<Longrightarrow> i < length xs"
16.339 + by (auto simp: sparsify_def set_zip)
16.340 +
16.341 +lemma listsum_sparsify[simp]:
16.342 + fixes v :: "('a \<Colon> semiring_0) list"
16.343 + assumes "length w = length v"
16.344 + shows "(\<Sum>x\<leftarrow>sparsify w. (\<lambda>(i, x). v ! i) x * snd x) = scalar_product v w"
16.345 + (is "(\<Sum>x\<leftarrow>_. ?f x) = _")
16.346 + unfolding sparsify_def scalar_product_def
16.347 + using assms listsum_map_filter[where f="?f" and P="\<lambda> i. snd i \<noteq> (0::'a)"]
16.348 + by (simp add: listsum_setsum)
16.349 +*)
16.350 +definition [simp]: "unzip w = (map fst w, map snd w)"
16.351 +
16.352 +primrec insert :: "('a \<Rightarrow> 'b \<Colon> linorder) => 'a \<Rightarrow> 'a list => 'a list" where
16.353 + "insert f x [] = [x]" |
16.354 + "insert f x (y # ys) = (if f y < f x then y # insert f x ys else x # y # ys)"
16.355 +
16.356 +primrec sort :: "('a \<Rightarrow> 'b \<Colon> linorder) \<Rightarrow> 'a list => 'a list" where
16.357 + "sort f [] = []" |
16.358 + "sort f (x # xs) = insert f x (sort f xs)"
16.359 +
16.360 +definition
16.361 + "length_permutate M = (unzip o sort (length o snd)) (zip [0 ..< length M] M)"
16.362 +
16.363 +definition
16.364 + "transpose M = [map (\<lambda> xs. xs ! i) (takeWhile (\<lambda> xs. i < length xs) M). i \<leftarrow> [0 ..< length (M ! 0)]]"
16.365 +
16.366 +definition
16.367 + "inflate upds = foldr (\<lambda> (i, x) upds. upds[i := x]) upds (replicate (length upds) 0)"
16.368 +
16.369 +definition
16.370 + "jad = apsnd transpose o length_permutate o map sparsify"
16.371 +
16.372 +definition
16.373 + "jad_mv v = inflate o split zip o apsnd (map listsum o transpose o map (map (\<lambda> (i, x). v ! i * x)))"
16.374 +ML {* ML_Context.trace := false *}
16.375 +
16.376 +lemma "matrix (M::int list list) rs cs \<Longrightarrow> False"
16.377 +quickcheck[generator = predicate_compile, size = 6]
16.378 +oops
16.379 +
16.380 +lemma
16.381 + "\<lbrakk> matrix M rs cs ; length v = cs \<rbrakk> \<Longrightarrow> jad_mv v (jad M) = mv M v"
16.382 +(*quickcheck[generator = predicate_compile]*)
16.383 +oops
16.384
16.385 end
16.386 \ No newline at end of file
17.1 --- a/src/HOL/ex/Predicate_Compile_ex.thy Sat Jan 16 21:14:15 2010 +0100
17.2 +++ b/src/HOL/ex/Predicate_Compile_ex.thy Wed Jan 20 11:56:45 2010 +0100
17.3 @@ -1,5 +1,5 @@
17.4 theory Predicate_Compile_ex
17.5 -imports Main Predicate_Compile_Alternative_Defs
17.6 +imports Predicate_Compile_Alternative_Defs
17.7 begin
17.8
17.9 subsection {* Basic predicates *}
17.10 @@ -7,8 +7,35 @@
17.11 inductive False' :: "bool"
17.12
17.13 code_pred (expected_modes: bool) False' .
17.14 -code_pred [depth_limited] False' .
17.15 -code_pred [random] False' .
17.16 +code_pred [dseq] False' .
17.17 +code_pred [random_dseq] False' .
17.18 +
17.19 +values [expected "{}" pred] "{x. False'}"
17.20 +values [expected "{}" dseq 1] "{x. False'}"
17.21 +values [expected "{}" random_dseq 1, 1, 1] "{x. False'}"
17.22 +
17.23 +value "False'"
17.24 +
17.25 +
17.26 +inductive True' :: "bool"
17.27 +where
17.28 + "True ==> True'"
17.29 +
17.30 +code_pred True' .
17.31 +code_pred [dseq] True' .
17.32 +code_pred [random_dseq] True' .
17.33 +
17.34 +thm True'.equation
17.35 +thm True'.dseq_equation
17.36 +thm True'.random_dseq_equation
17.37 +values [expected "{()}" ]"{x. True'}"
17.38 +values [expected "{}" dseq 0] "{x. True'}"
17.39 +values [expected "{()}" dseq 1] "{x. True'}"
17.40 +values [expected "{()}" dseq 2] "{x. True'}"
17.41 +values [expected "{}" random_dseq 1, 1, 0] "{x. True'}"
17.42 +values [expected "{}" random_dseq 1, 1, 1] "{x. True'}"
17.43 +values [expected "{()}" random_dseq 1, 1, 2] "{x. True'}"
17.44 +values [expected "{()}" random_dseq 1, 1, 3] "{x. True'}"
17.45
17.46 inductive EmptySet :: "'a \<Rightarrow> bool"
17.47
17.48 @@ -38,6 +65,7 @@
17.49 EmptyClosure .
17.50
17.51 thm EmptyClosure.equation
17.52 +
17.53 (* TODO: inductive package is broken!
17.54 inductive False'' :: "bool"
17.55 where
17.56 @@ -53,12 +81,6 @@
17.57 code_pred (expected_modes: [], [1]) [inductify] EmptySet'' .
17.58 *)
17.59
17.60 -inductive True' :: "bool"
17.61 -where
17.62 - "True \<Longrightarrow> True'"
17.63 -
17.64 -code_pred (expected_modes: bool) True' .
17.65 -
17.66 consts a' :: 'a
17.67
17.68 inductive Fact :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
17.69 @@ -72,7 +94,30 @@
17.70 "zerozero (0, 0)"
17.71
17.72 code_pred (expected_modes: i => bool, i * o => bool, o * i => bool, o => bool) zerozero .
17.73 -code_pred [random] zerozero .
17.74 +code_pred [dseq] zerozero .
17.75 +code_pred [random_dseq] zerozero .
17.76 +
17.77 +thm zerozero.equation
17.78 +thm zerozero.dseq_equation
17.79 +thm zerozero.random_dseq_equation
17.80 +
17.81 +text {* We expect the user to expand the tuples in the values command.
17.82 +The following values command is not supported. *}
17.83 +(*values "{x. zerozero x}" *)
17.84 +text {* Instead, the user must type *}
17.85 +values "{(x, y). zerozero (x, y)}"
17.86 +
17.87 +values [expected "{}" dseq 0] "{(x, y). zerozero (x, y)}"
17.88 +values [expected "{(0::nat, 0::nat)}" dseq 1] "{(x, y). zerozero (x, y)}"
17.89 +values [expected "{(0::nat, 0::nat)}" dseq 2] "{(x, y). zerozero (x, y)}"
17.90 +values [expected "{}" random_dseq 1, 1, 2] "{(x, y). zerozero (x, y)}"
17.91 +values [expected "{(0::nat, 0:: nat)}" random_dseq 1, 1, 3] "{(x, y). zerozero (x, y)}"
17.92 +
17.93 +inductive nested_tuples :: "((int * int) * int * int) => bool"
17.94 +where
17.95 + "nested_tuples ((0, 1), 2, 3)"
17.96 +
17.97 +code_pred nested_tuples .
17.98
17.99 inductive JamesBond :: "nat => int => code_numeral => bool"
17.100 where
17.101 @@ -80,16 +125,17 @@
17.102
17.103 code_pred JamesBond .
17.104
17.105 -values "{(a, b, c). JamesBond a b c}"
17.106 -values "{(a, c, b). JamesBond a b c}"
17.107 -values "{(b, a, c). JamesBond a b c}"
17.108 -values "{(b, c, a). JamesBond a b c}"
17.109 -values "{(c, a, b). JamesBond a b c}"
17.110 -values "{(c, b, a). JamesBond a b c}"
17.111 +values [expected "{(0::nat, 0::int , 7::code_numeral)}"] "{(a, b, c). JamesBond a b c}"
17.112 +values [expected "{(0::nat, 7::code_numeral, 0:: int)}"] "{(a, c, b). JamesBond a b c}"
17.113 +values [expected "{(0::int, 0::nat, 7::code_numeral)}"] "{(b, a, c). JamesBond a b c}"
17.114 +values [expected "{(0::int, 7::code_numeral, 0::nat)}"] "{(b, c, a). JamesBond a b c}"
17.115 +values [expected "{(7::code_numeral, 0::nat, 0::int)}"] "{(c, a, b). JamesBond a b c}"
17.116 +values [expected "{(7::code_numeral, 0::int, 0::nat)}"] "{(c, b, a). JamesBond a b c}"
17.117
17.118 -values "{(a, b). JamesBond 0 b a}"
17.119 -values "{(c, a). JamesBond a 0 c}"
17.120 -values "{(a, c). JamesBond a 0 c}"
17.121 +values [expected "{(7::code_numeral, 0::int)}"] "{(a, b). JamesBond 0 b a}"
17.122 +values [expected "{(7::code_numeral, 0::nat)}"] "{(c, a). JamesBond a 0 c}"
17.123 +values [expected "{(0::nat, 7::code_numeral)}"] "{(a, c). JamesBond a 0 c}"
17.124 +
17.125
17.126 subsection {* Alternative Rules *}
17.127
17.128 @@ -119,14 +165,14 @@
17.129 case is_D_or_E
17.130 from this(1) show thesis
17.131 proof
17.132 - fix x
17.133 - assume x: "a1 = x"
17.134 - assume "x = D \<or> x = E"
17.135 + fix xa
17.136 + assume x: "x = xa"
17.137 + assume "xa = D \<or> xa = E"
17.138 from this show thesis
17.139 proof
17.140 - assume "x = D" from this x is_D_or_E(2) show thesis by simp
17.141 + assume "xa = D" from this x is_D_or_E(2) show thesis by simp
17.142 next
17.143 - assume "x = E" from this x is_D_or_E(3) show thesis by simp
17.144 + assume "xa = E" from this x is_D_or_E(3) show thesis by simp
17.145 qed
17.146 qed
17.147 qed
17.148 @@ -157,15 +203,15 @@
17.149 case is_F_or_G
17.150 from this(1) show thesis
17.151 proof
17.152 - fix x
17.153 - assume x: "a1 = x"
17.154 - assume "x = F \<or> x = G"
17.155 + fix xa
17.156 + assume x: "x = xa"
17.157 + assume "xa = F \<or> xa = G"
17.158 from this show thesis
17.159 proof
17.160 - assume "x = F"
17.161 + assume "xa = F"
17.162 from this x is_F_or_G(2) show thesis by simp
17.163 next
17.164 - assume "x = G"
17.165 + assume "xa = G"
17.166 from this x is_F_or_G(3) show thesis by simp
17.167 qed
17.168 qed
17.169 @@ -200,15 +246,16 @@
17.170
17.171 code_pred (expected_modes: i * i => bool, i * o => bool, o * i => bool, o => bool) [inductify] zerozero'' .
17.172
17.173 -subsection {* Numerals *}
17.174 +subsection {* Sets and Numerals *}
17.175
17.176 definition
17.177 - "one_or_two == {Suc 0, (Suc (Suc 0))}"
17.178 + "one_or_two = {Suc 0, (Suc (Suc 0))}"
17.179
17.180 -(*code_pred [inductify] one_or_two .*)
17.181 -code_pred [inductify, random] one_or_two .
17.182 -(*values "{x. one_or_two x}"*)
17.183 -values [random] "{x. one_or_two x}"
17.184 +code_pred [inductify] one_or_two .
17.185 +code_pred [dseq] one_or_two .
17.186 +(*code_pred [random_dseq] one_or_two .*)
17.187 +values [expected "{Suc 0::nat, 2::nat}"] "{x. one_or_two x}"
17.188 +(*values [random_dseq 1,1,2] "{x. one_or_two x}"*)
17.189
17.190 inductive one_or_two' :: "nat => bool"
17.191 where
17.192 @@ -222,13 +269,12 @@
17.193
17.194 definition one_or_two'':
17.195 "one_or_two'' == {1, (2::nat)}"
17.196 -
17.197 -code_pred [inductify] one_or_two'' .
17.198 +ML {* prop_of @{thm one_or_two''} *}
17.199 +(*code_pred [inductify] one_or_two'' .
17.200 thm one_or_two''.equation
17.201
17.202 values "{x. one_or_two'' x}"
17.203 -
17.204 -
17.205 +*)
17.206 subsection {* even predicate *}
17.207
17.208 inductive even :: "nat \<Rightarrow> bool" and odd :: "nat \<Rightarrow> bool" where
17.209 @@ -237,35 +283,55 @@
17.210 | "odd n \<Longrightarrow> even (Suc n)"
17.211
17.212 code_pred (expected_modes: i => bool, o => bool) even .
17.213 -code_pred [depth_limited] even .
17.214 -code_pred [random] even .
17.215 +code_pred [dseq] even .
17.216 +code_pred [random_dseq] even .
17.217
17.218 thm odd.equation
17.219 thm even.equation
17.220 -thm odd.depth_limited_equation
17.221 -thm even.depth_limited_equation
17.222 -thm even.random_equation
17.223 -thm odd.random_equation
17.224 +thm odd.dseq_equation
17.225 +thm even.dseq_equation
17.226 +thm odd.random_dseq_equation
17.227 +thm even.random_dseq_equation
17.228
17.229 values "{x. even 2}"
17.230 values "{x. odd 2}"
17.231 values 10 "{n. even n}"
17.232 values 10 "{n. odd n}"
17.233 -values [depth_limit = 2] "{x. even 6}"
17.234 -values [depth_limit = 7] "{x. even 6}"
17.235 -values [depth_limit = 2] "{x. odd 7}"
17.236 -values [depth_limit = 8] "{x. odd 7}"
17.237 -values [depth_limit = 7] 10 "{n. even n}"
17.238 +values [expected "{}" dseq 2] "{x. even 6}"
17.239 +values [expected "{}" dseq 6] "{x. even 6}"
17.240 +values [expected "{()}" dseq 7] "{x. even 6}"
17.241 +values [dseq 2] "{x. odd 7}"
17.242 +values [dseq 6] "{x. odd 7}"
17.243 +values [dseq 7] "{x. odd 7}"
17.244 +values [expected "{()}" dseq 8] "{x. odd 7}"
17.245 +
17.246 +values [expected "{}" dseq 0] 8 "{x. even x}"
17.247 +values [expected "{0::nat}" dseq 1] 8 "{x. even x}"
17.248 +values [expected "{0::nat, 2}" dseq 3] 8 "{x. even x}"
17.249 +values [expected "{0::nat, 2}" dseq 4] 8 "{x. even x}"
17.250 +values [expected "{0::nat, 2, 4}" dseq 6] 8 "{x. even x}"
17.251 +
17.252 +values [random_dseq 1, 1, 0] 8 "{x. even x}"
17.253 +values [random_dseq 1, 1, 1] 8 "{x. even x}"
17.254 +values [random_dseq 1, 1, 2] 8 "{x. even x}"
17.255 +values [random_dseq 1, 1, 3] 8 "{x. even x}"
17.256 +values [random_dseq 1, 1, 6] 8 "{x. even x}"
17.257 +
17.258 +values [expected "{}" random_dseq 1, 1, 7] "{x. odd 7}"
17.259 +values [random_dseq 1, 1, 8] "{x. odd 7}"
17.260 +values [random_dseq 1, 1, 9] "{x. odd 7}"
17.261
17.262 definition odd' where "odd' x == \<not> even x"
17.263
17.264 code_pred (expected_modes: i => bool) [inductify] odd' .
17.265 -code_pred [inductify, depth_limited] odd' .
17.266 -code_pred [inductify, random] odd' .
17.267 +code_pred [dseq inductify] odd' .
17.268 +code_pred [random_dseq inductify] odd' .
17.269
17.270 -thm odd'.depth_limited_equation
17.271 -values [depth_limit = 2] "{x. odd' 7}"
17.272 -values [depth_limit = 9] "{x. odd' 7}"
17.273 +values [expected "{}" dseq 2] "{x. odd' 7}"
17.274 +values [expected "{()}" dseq 9] "{x. odd' 7}"
17.275 +values [expected "{}" dseq 2] "{x. odd' 8}"
17.276 +values [expected "{}" dseq 10] "{x. odd' 8}"
17.277 +
17.278
17.279 inductive is_even :: "nat \<Rightarrow> bool"
17.280 where
17.281 @@ -280,22 +346,28 @@
17.282 | "append xs ys zs \<Longrightarrow> append (x # xs) ys (x # zs)"
17.283
17.284 code_pred (modes: i => i => o => bool as "concat", o => o => i => bool as "slice", o => i => i => bool as prefix,
17.285 - i => o => i => bool as suffix) append .
17.286 -code_pred [depth_limited] append .
17.287 -code_pred [random] append .
17.288 -code_pred [annotated] append .
17.289 + i => o => i => bool as suffix, i => i => i => bool) append .
17.290 +code_pred [dseq] append .
17.291 +code_pred [random_dseq] append .
17.292
17.293 thm append.equation
17.294 -thm append.depth_limited_equation
17.295 -thm append.random_equation
17.296 -thm append.annotated_equation
17.297 +thm append.dseq_equation
17.298 +thm append.random_dseq_equation
17.299
17.300 values "{(ys, xs). append xs ys [0, Suc 0, 2]}"
17.301 values "{zs. append [0, Suc 0, 2] [17, 8] zs}"
17.302 values "{ys. append [0, Suc 0, 2] ys [0, Suc 0, 2, 17, 0, 5]}"
17.303
17.304 -values [depth_limit = 3] "{(xs, ys). append xs ys [1, 2, 3, 4, (5::nat)]}"
17.305 -values [random] 1 "{(ys, zs). append [1::nat, 2] ys zs}"
17.306 +values [expected "{}" dseq 0] 10 "{(xs, ys). append xs ys [1, 2, 3, 4, (5::nat)]}"
17.307 +values [expected "{(([]::nat list), [Suc 0, 2, 3, 4, (5::nat)])}" dseq 1] 10 "{(xs, ys). append xs ys [1, 2, 3, 4, (5::nat)]}"
17.308 +values [dseq 4] 10 "{(xs, ys). append xs ys [1, 2, 3, 4, (5::nat)]}"
17.309 +values [dseq 6] 10 "{(xs, ys). append xs ys [1, 2, 3, 4, (5::nat)]}"
17.310 +values [random_dseq 1, 1, 4] 10 "{(xs, ys). append xs ys [1, 2, 3, 4, (5::nat)]}"
17.311 +values [random_dseq 1, 1, 1] 10 "{(xs, ys, zs::int list). append xs ys zs}"
17.312 +values [random_dseq 1, 1, 3] 10 "{(xs, ys, zs::int list). append xs ys zs}"
17.313 +values [random_dseq 3, 1, 3] 10 "{(xs, ys, zs::int list). append xs ys zs}"
17.314 +values [random_dseq 1, 3, 3] 10 "{(xs, ys, zs::int list). append xs ys zs}"
17.315 +values [random_dseq 1, 1, 4] 10 "{(xs, ys, zs::int list). append xs ys zs}"
17.316
17.317 value [code] "Predicate.the (concat [0::int, 1, 2] [3, 4, 5])"
17.318 value [code] "Predicate.the (slice ([]::int list))"
17.319 @@ -320,11 +392,11 @@
17.320 from append2(1) show thesis
17.321 proof
17.322 fix xs
17.323 - assume "a1 = []" "a2 = xs" "a3 = xs"
17.324 + assume "xa = []" "xb = xs" "xc = xs"
17.325 from this append2(2) show thesis by simp
17.326 next
17.327 fix xs ys zs x
17.328 - assume "a1 = x # xs" "a2 = ys" "a3 = x # zs" "append2 xs ys zs"
17.329 + assume "xa = x # xs" "xb = ys" "xc = x # zs" "append2 xs ys zs"
17.330 from this append2(3) show thesis by fastsimp
17.331 qed
17.332 qed
17.333 @@ -336,11 +408,10 @@
17.334
17.335 code_pred (expected_modes: i * i * o => bool, o * o * i => bool, o * i * i => bool,
17.336 i * o * i => bool, i * i * i => bool) tupled_append .
17.337 -code_pred [random] tupled_append .
17.338 +code_pred [random_dseq] tupled_append .
17.339 thm tupled_append.equation
17.340
17.341 -(*TODO: values with tupled modes*)
17.342 -(*values "{xs. tupled_append ([1,2,3], [4,5], xs)}"*)
17.343 +values "{xs. tupled_append ([(1::nat), 2, 3], [4, 5], xs)}"
17.344
17.345 inductive tupled_append'
17.346 where
17.347 @@ -358,7 +429,7 @@
17.348 | "ys = fst yszs ==> x # zs = snd yszs ==> tupled_append'' (xs, ys, zs) \<Longrightarrow> tupled_append'' (x # xs, yszs)"
17.349
17.350 code_pred (expected_modes: i * i * o => bool, o * o * i => bool, o * i * i => bool,
17.351 - i * o * i => bool, i * i * i => bool) [inductify] tupled_append'' .
17.352 + i * o * i => bool, i * i * i => bool) tupled_append'' .
17.353 thm tupled_append''.equation
17.354
17.355 inductive tupled_append''' :: "'a list \<times> 'a list \<times> 'a list \<Rightarrow> bool"
17.356 @@ -367,7 +438,7 @@
17.357 | "yszs = (ys, zs) ==> tupled_append''' (xs, yszs) \<Longrightarrow> tupled_append''' (x # xs, ys, x # zs)"
17.358
17.359 code_pred (expected_modes: i * i * o => bool, o * o * i => bool, o * i * i => bool,
17.360 - i * o * i => bool, i * i * i => bool) [inductify] tupled_append''' .
17.361 + i * o * i => bool, i * i * i => bool) tupled_append''' .
17.362 thm tupled_append'''.equation
17.363
17.364 subsection {* map_ofP predicate *}
17.365 @@ -390,39 +461,46 @@
17.366 | "\<not> P x ==> filter1 P xs ys ==> filter1 P (x#xs) ys"
17.367
17.368 code_pred (expected_modes: (i => bool) => i => o => bool, (i => bool) => i => i => bool) filter1 .
17.369 -code_pred [depth_limited] filter1 .
17.370 -code_pred [random] filter1 .
17.371 +code_pred [dseq] filter1 .
17.372 +code_pred [random_dseq] filter1 .
17.373
17.374 thm filter1.equation
17.375
17.376 +values [expected "{[0::nat, 2, 4]}"] "{xs. filter1 even [0, 1, 2, 3, 4] xs}"
17.377 +values [expected "{}" dseq 9] "{xs. filter1 even [0, 1, 2, 3, 4] xs}"
17.378 +values [expected "{[0::nat, 2, 4]}" dseq 10] "{xs. filter1 even [0, 1, 2, 3, 4] xs}"
17.379 +
17.380 inductive filter2
17.381 where
17.382 "filter2 P [] []"
17.383 | "P x ==> filter2 P xs ys ==> filter2 P (x#xs) (x#ys)"
17.384 | "\<not> P x ==> filter2 P xs ys ==> filter2 P (x#xs) ys"
17.385
17.386 -code_pred (expected_modes: i => i => i => bool, i => i => o => bool) filter2 .
17.387 -code_pred [depth_limited] filter2 .
17.388 -code_pred [random] filter2 .
17.389 +code_pred (expected_modes: (i => bool) => i => i => bool, (i => bool) => i => o => bool) filter2 .
17.390 +code_pred [dseq] filter2 .
17.391 +code_pred [random_dseq] filter2 .
17.392 +
17.393 thm filter2.equation
17.394 -thm filter2.random_equation
17.395 +thm filter2.random_dseq_equation
17.396
17.397 +(*
17.398 inductive filter3
17.399 for P
17.400 where
17.401 "List.filter P xs = ys ==> filter3 P xs ys"
17.402
17.403 -code_pred (expected_modes: (o => bool) => i => o => bool, (o => bool) => i => i => bool , (i => bool) => i => o => bool, (i => bool) => i => i => bool) filter3 .
17.404 -code_pred [depth_limited] filter3 .
17.405 -thm filter3.depth_limited_equation
17.406 +code_pred (expected_modes: (o => bool) => i => o => bool, (o => bool) => i => i => bool , (i => bool) => i => o => bool, (i => bool) => i => i => bool) [skip_proof] filter3 .
17.407
17.408 +code_pred [dseq] filter3 .
17.409 +thm filter3.dseq_equation
17.410 +*)
17.411 inductive filter4
17.412 where
17.413 "List.filter P xs = ys ==> filter4 P xs ys"
17.414
17.415 -code_pred (expected_modes: i => i => o => bool, i => i => i => bool) filter4 .
17.416 -code_pred [depth_limited] filter4 .
17.417 -code_pred [random] filter4 .
17.418 +(*code_pred (expected_modes: i => i => o => bool, i => i => i => bool) filter4 .*)
17.419 +(*code_pred [depth_limited] filter4 .*)
17.420 +(*code_pred [random] filter4 .*)
17.421
17.422 subsection {* reverse predicate *}
17.423
17.424 @@ -452,9 +530,10 @@
17.425 | "\<not> f x \<Longrightarrow> partition f xs ys zs \<Longrightarrow> partition f (x # xs) ys (x # zs)"
17.426
17.427 code_pred (expected_modes: (i => bool) => i => o => o => bool, (i => bool) => o => i => i => bool,
17.428 - (i => bool) => i => i => o => bool, (i => bool) => i => o => i => bool, (i => bool) => i => i => i => bool) partition .
17.429 -code_pred [depth_limited] partition .
17.430 -code_pred [random] partition .
17.431 + (i => bool) => i => i => o => bool, (i => bool) => i => o => i => bool, (i => bool) => i => i => i => bool)
17.432 + partition .
17.433 +code_pred [dseq] partition .
17.434 +code_pred [random_dseq] partition .
17.435
17.436 values 10 "{(ys, zs). partition is_even
17.437 [0, Suc 0, 2, 3, 4, 5, 6, 7] ys zs}"
17.438 @@ -489,19 +568,44 @@
17.439 from this converse_tranclpE[OF this(1)] show thesis by metis
17.440 qed
17.441
17.442 -code_pred [depth_limited] tranclp .
17.443 -code_pred [random] tranclp .
17.444 +
17.445 +code_pred [dseq] tranclp .
17.446 +code_pred [random_dseq] tranclp .
17.447 thm tranclp.equation
17.448 -thm tranclp.random_equation
17.449 +thm tranclp.random_dseq_equation
17.450 +
17.451 +inductive rtrancl' :: "'a => 'a => ('a => 'a => bool) => bool"
17.452 +where
17.453 + "rtrancl' x x r"
17.454 +| "r x y ==> rtrancl' y z r ==> rtrancl' x z r"
17.455 +
17.456 +code_pred [random_dseq] rtrancl' .
17.457 +
17.458 +thm rtrancl'.random_dseq_equation
17.459 +
17.460 +inductive rtrancl'' :: "('a * 'a * ('a \<Rightarrow> 'a \<Rightarrow> bool)) \<Rightarrow> bool"
17.461 +where
17.462 + "rtrancl'' (x, x, r)"
17.463 +| "r x y \<Longrightarrow> rtrancl'' (y, z, r) \<Longrightarrow> rtrancl'' (x, z, r)"
17.464 +
17.465 +code_pred rtrancl'' .
17.466 +
17.467 +inductive rtrancl''' :: "('a * ('a * 'a) * ('a * 'a => bool)) => bool"
17.468 +where
17.469 + "rtrancl''' (x, (x, x), r)"
17.470 +| "r (x, y) ==> rtrancl''' (y, (z, z), r) ==> rtrancl''' (x, (z, z), r)"
17.471 +
17.472 +code_pred rtrancl''' .
17.473 +
17.474
17.475 inductive succ :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
17.476 "succ 0 1"
17.477 | "succ m n \<Longrightarrow> succ (Suc m) (Suc n)"
17.478
17.479 -code_pred succ .
17.480 -code_pred [random] succ .
17.481 +code_pred (modes: i => i => bool, i => o => bool, o => i => bool, o => o => bool) succ .
17.482 +code_pred [random_dseq] succ .
17.483 thm succ.equation
17.484 -thm succ.random_equation
17.485 +thm succ.random_dseq_equation
17.486
17.487 values 10 "{(m, n). succ n m}"
17.488 values "{m. succ 0 m}"
17.489 @@ -531,10 +635,55 @@
17.490 code_pred (expected_modes: i => i => bool) not_reachable_in_example_graph .
17.491
17.492 thm not_reachable_in_example_graph.equation
17.493 -
17.494 +thm tranclp.equation
17.495 value "not_reachable_in_example_graph 0 3"
17.496 value "not_reachable_in_example_graph 4 8"
17.497 value "not_reachable_in_example_graph 5 6"
17.498 +text {* rtrancl compilation is strange! *}
17.499 +(*
17.500 +value "not_reachable_in_example_graph 0 4"
17.501 +value "not_reachable_in_example_graph 1 6"
17.502 +value "not_reachable_in_example_graph 8 4"*)
17.503 +
17.504 +code_pred [dseq] not_reachable_in_example_graph .
17.505 +
17.506 +values [dseq 6] "{x. tranclp example_graph 0 3}"
17.507 +
17.508 +values [dseq 0] "{x. not_reachable_in_example_graph 0 3}"
17.509 +values [dseq 0] "{x. not_reachable_in_example_graph 0 4}"
17.510 +values [dseq 20] "{x. not_reachable_in_example_graph 0 4}"
17.511 +values [dseq 6] "{x. not_reachable_in_example_graph 0 3}"
17.512 +values [dseq 3] "{x. not_reachable_in_example_graph 4 2}"
17.513 +values [dseq 6] "{x. not_reachable_in_example_graph 4 2}"
17.514 +
17.515 +
17.516 +inductive not_reachable_in_example_graph' :: "int => int => bool"
17.517 +where "\<not> (rtranclp example_graph x y) ==> not_reachable_in_example_graph' x y"
17.518 +
17.519 +code_pred not_reachable_in_example_graph' .
17.520 +
17.521 +value "not_reachable_in_example_graph' 0 3"
17.522 +(* value "not_reachable_in_example_graph' 0 5" would not terminate *)
17.523 +
17.524 +
17.525 +(*values [depth_limited 0] "{x. not_reachable_in_example_graph' 0 3}"*)
17.526 +(*values [depth_limited 3] "{x. not_reachable_in_example_graph' 0 3}"*) (* fails with undefined *)
17.527 +(*values [depth_limited 5] "{x. not_reachable_in_example_graph' 0 3}"*)
17.528 +(*values [depth_limited 1] "{x. not_reachable_in_example_graph' 0 4}"*)
17.529 +(*values [depth_limit = 4] "{x. not_reachable_in_example_graph' 0 4}"*) (* fails with undefined *)
17.530 +(*values [depth_limit = 20] "{x. not_reachable_in_example_graph' 0 4}"*) (* fails with undefined *)
17.531 +
17.532 +code_pred [dseq] not_reachable_in_example_graph' .
17.533 +
17.534 +(*thm not_reachable_in_example_graph'.dseq_equation*)
17.535 +
17.536 +(*values [dseq 0] "{x. not_reachable_in_example_graph' 0 3}"*)
17.537 +(*values [depth_limited 3] "{x. not_reachable_in_example_graph' 0 3}"*) (* fails with undefined *)
17.538 +(*values [depth_limited 5] "{x. not_reachable_in_example_graph' 0 3}"
17.539 +values [depth_limited 1] "{x. not_reachable_in_example_graph' 0 4}"*)
17.540 +(*values [depth_limit = 4] "{x. not_reachable_in_example_graph' 0 4}"*) (* fails with undefined *)
17.541 +(*values [depth_limit = 20] "{x. not_reachable_in_example_graph' 0 4}"*) (* fails with undefined *)
17.542 +
17.543
17.544 subsection {* IMP *}
17.545
17.546 @@ -564,6 +713,7 @@
17.547 (While (%s. s!0 > 0) (Seq (Ass 0 (%s. s!0 - 1)) (Ass 1 (%s. s!1 + 1))))
17.548 [3,5] t}"
17.549
17.550 +
17.551 inductive tupled_exec :: "(com \<times> state \<times> state) \<Rightarrow> bool" where
17.552 "tupled_exec (Skip, s, s)" |
17.553 "tupled_exec (Ass x e, s, s[x := e(s)])" |
17.554 @@ -575,6 +725,8 @@
17.555
17.556 code_pred tupled_exec .
17.557
17.558 +values "{s. tupled_exec (While (%s. s!0 > 0) (Seq (Ass 0 (%s. s!0 - 1)) (Ass 1 (%s. s!1 + 1))), [3, 5], s)}"
17.559 +
17.560 subsection {* CCS *}
17.561
17.562 text{* This example formalizes finite CCS processes without communication or
17.563 @@ -633,13 +785,16 @@
17.564 where "Min s r x \<equiv> s x \<and> (\<forall>y. r x y \<longrightarrow> x = y)"
17.565
17.566 code_pred [inductify] Min .
17.567 +thm Min.equation
17.568
17.569 subsection {* Lexicographic order *}
17.570
17.571 +declare lexord_def[code_pred_def]
17.572 code_pred [inductify] lexord .
17.573 -code_pred [inductify, random] lexord .
17.574 +code_pred [random_dseq inductify] lexord .
17.575 +
17.576 thm lexord.equation
17.577 -thm lexord.random_equation
17.578 +thm lexord.random_dseq_equation
17.579
17.580 inductive less_than_nat :: "nat * nat => bool"
17.581 where
17.582 @@ -648,38 +803,100 @@
17.583
17.584 code_pred less_than_nat .
17.585
17.586 -code_pred [depth_limited] less_than_nat .
17.587 -code_pred [random] less_than_nat .
17.588 +code_pred [dseq] less_than_nat .
17.589 +code_pred [random_dseq] less_than_nat .
17.590
17.591 inductive test_lexord :: "nat list * nat list => bool"
17.592 where
17.593 "lexord less_than_nat (xs, ys) ==> test_lexord (xs, ys)"
17.594
17.595 -code_pred [random] test_lexord .
17.596 -code_pred [depth_limited] test_lexord .
17.597 -thm test_lexord.depth_limited_equation
17.598 -thm test_lexord.random_equation
17.599 +code_pred test_lexord .
17.600 +code_pred [dseq] test_lexord .
17.601 +code_pred [random_dseq] test_lexord .
17.602 +thm test_lexord.dseq_equation
17.603 +thm test_lexord.random_dseq_equation
17.604
17.605 values "{x. test_lexord ([1, 2, 3], [1, 2, 5])}"
17.606 -values [depth_limit = 5] "{x. test_lexord ([1, 2, 3], [1, 2, 5])}"
17.607 +(*values [depth_limited 5] "{x. test_lexord ([1, 2, 3], [1, 2, 5])}"*)
17.608
17.609 +declare list.size(3,4)[code_pred_def]
17.610 lemmas [code_pred_def] = lexn_conv lex_conv lenlex_conv
17.611 -
17.612 +(*
17.613 code_pred [inductify] lexn .
17.614 thm lexn.equation
17.615 +*)
17.616 +(*
17.617 +code_pred [random_dseq inductify] lexn .
17.618 +thm lexn.random_dseq_equation
17.619
17.620 -code_pred [random] lexn .
17.621 +values [random_dseq 4, 4, 6] 100 "{(n, xs, ys::int list). lexn (%(x, y). x <= y) n (xs, ys)}"
17.622 +*)
17.623 +inductive has_length
17.624 +where
17.625 + "has_length [] 0"
17.626 +| "has_length xs i ==> has_length (x # xs) (Suc i)"
17.627
17.628 -thm lexn.random_equation
17.629 +lemma has_length:
17.630 + "has_length xs n = (length xs = n)"
17.631 +proof (rule iffI)
17.632 + assume "has_length xs n"
17.633 + from this show "length xs = n"
17.634 + by (rule has_length.induct) auto
17.635 +next
17.636 + assume "length xs = n"
17.637 + from this show "has_length xs n"
17.638 + by (induct xs arbitrary: n) (auto intro: has_length.intros)
17.639 +qed
17.640 +
17.641 +lemma lexn_intros [code_pred_intro]:
17.642 + "has_length xs i ==> has_length ys i ==> r (x, y) ==> lexn r (Suc i) (x # xs, y # ys)"
17.643 + "lexn r i (xs, ys) ==> lexn r (Suc i) (x # xs, x # ys)"
17.644 +proof -
17.645 + assume "has_length xs i" "has_length ys i" "r (x, y)"
17.646 + from this has_length show "lexn r (Suc i) (x # xs, y # ys)"
17.647 + unfolding lexn_conv Collect_def mem_def
17.648 + by fastsimp
17.649 +next
17.650 + assume "lexn r i (xs, ys)"
17.651 + thm lexn_conv
17.652 + from this show "lexn r (Suc i) (x#xs, x#ys)"
17.653 + unfolding Collect_def mem_def lexn_conv
17.654 + apply auto
17.655 + apply (rule_tac x="x # xys" in exI)
17.656 + by auto
17.657 +qed
17.658 +
17.659 +code_pred [random_dseq inductify] lexn
17.660 +proof -
17.661 + fix n xs ys
17.662 + assume 1: "lexn r n (xs, ys)"
17.663 + assume 2: "\<And>i x xs' y ys'. r = r ==> n = Suc i ==> (xs, ys) = (x # xs', y # ys') ==> has_length xs' i ==> has_length ys' i ==> r (x, y) ==> thesis"
17.664 + assume 3: "\<And>i x xs' ys'. r = r ==> n = Suc i ==> (xs, ys) = (x # xs', x # ys') ==> lexn r i (xs', ys') ==> thesis"
17.665 + from 1 2 3 show thesis
17.666 + unfolding lexn_conv Collect_def mem_def
17.667 + apply (auto simp add: has_length)
17.668 + apply (case_tac xys)
17.669 + apply auto
17.670 + apply fastsimp
17.671 + apply fastsimp done
17.672 +qed
17.673 +
17.674 +
17.675 +values [random_dseq 1, 2, 5] 10 "{(n, xs, ys::int list). lexn (%(x, y). x <= y) n (xs, ys)}"
17.676 +
17.677
17.678 code_pred [inductify] lenlex .
17.679 thm lenlex.equation
17.680
17.681 -code_pred [inductify, random] lenlex .
17.682 -thm lenlex.random_equation
17.683 +code_pred [random_dseq inductify] lenlex .
17.684 +thm lenlex.random_dseq_equation
17.685
17.686 +values [random_dseq 4, 2, 4] 100 "{(xs, ys::int list). lenlex (%(x, y). x <= y) (xs, ys)}"
17.687 +thm lists.intros
17.688 +(*
17.689 code_pred [inductify] lists .
17.690 -thm lists.equation
17.691 +*)
17.692 +(*thm lists.equation*)
17.693
17.694 subsection {* AVL Tree *}
17.695
17.696 @@ -693,12 +910,14 @@
17.697 "avl ET = True"
17.698 "avl (MKT x l r h) = ((height l = height r \<or> height l = 1 + height r \<or> height r = 1+height l) \<and>
17.699 h = max (height l) (height r) + 1 \<and> avl l \<and> avl r)"
17.700 +(*
17.701 +code_pred [inductify] avl .
17.702 +thm avl.equation*)
17.703
17.704 -code_pred [inductify] avl .
17.705 -thm avl.equation
17.706 +code_pred [random_dseq inductify] avl .
17.707 +thm avl.random_dseq_equation
17.708
17.709 -code_pred [random] avl .
17.710 -thm avl.random_equation
17.711 +values [random_dseq 2, 1, 7] 5 "{t:: int tree. avl t}"
17.712
17.713 fun set_of
17.714 where
17.715 @@ -714,30 +933,57 @@
17.716 code_pred (expected_modes: i => o => bool, i => i => bool) [inductify] set_of .
17.717 thm set_of.equation
17.718
17.719 -code_pred [inductify] is_ord .
17.720 +code_pred (expected_modes: i => bool) [inductify] is_ord .
17.721 thm is_ord_aux.equation
17.722 thm is_ord.equation
17.723
17.724
17.725 subsection {* Definitions about Relations *}
17.726 +term "converse"
17.727 +code_pred (modes:
17.728 + (i * i => bool) => i * i => bool,
17.729 + (i * o => bool) => o * i => bool,
17.730 + (i * o => bool) => i * i => bool,
17.731 + (o * i => bool) => i * o => bool,
17.732 + (o * i => bool) => i * i => bool,
17.733 + (o * o => bool) => o * o => bool,
17.734 + (o * o => bool) => i * o => bool,
17.735 + (o * o => bool) => o * i => bool,
17.736 + (o * o => bool) => i * i => bool) [inductify] converse .
17.737
17.738 -code_pred [inductify] converse .
17.739 thm converse.equation
17.740 code_pred [inductify] rel_comp .
17.741 thm rel_comp.equation
17.742 code_pred [inductify] Image .
17.743 thm Image.equation
17.744 -code_pred (expected_modes: (o => bool) => o => bool, (o => bool) => i * o => bool,
17.745 - (o => bool) => o * i => bool, (o => bool) => i => bool) [inductify] Id_on .
17.746 +declare singleton_iff[code_pred_inline]
17.747 +declare Id_on_def[unfolded Bex_def UNION_def singleton_iff, code_pred_def]
17.748 +
17.749 +code_pred (expected_modes:
17.750 + (o => bool) => o => bool,
17.751 + (o => bool) => i * o => bool,
17.752 + (o => bool) => o * i => bool,
17.753 + (o => bool) => i => bool,
17.754 + (i => bool) => i * o => bool,
17.755 + (i => bool) => o * i => bool,
17.756 + (i => bool) => i => bool) [inductify] Id_on .
17.757 thm Id_on.equation
17.758 -code_pred [inductify] Domain .
17.759 +thm Domain_def
17.760 +code_pred (modes:
17.761 + (o * o => bool) => o => bool,
17.762 + (o * o => bool) => i => bool,
17.763 + (i * o => bool) => i => bool) [inductify] Domain .
17.764 thm Domain.equation
17.765 -code_pred [inductify] Range .
17.766 +code_pred (modes:
17.767 + (o * o => bool) => o => bool,
17.768 + (o * o => bool) => i => bool,
17.769 + (o * i => bool) => i => bool) [inductify] Range .
17.770 thm Range.equation
17.771 code_pred [inductify] Field .
17.772 thm Field.equation
17.773 +(*thm refl_on_def
17.774 code_pred [inductify] refl_on .
17.775 -thm refl_on.equation
17.776 +thm refl_on.equation*)
17.777 code_pred [inductify] total_on .
17.778 thm total_on.equation
17.779 code_pred [inductify] antisym .
17.780 @@ -751,11 +997,11 @@
17.781
17.782 subsection {* Inverting list functions *}
17.783
17.784 -code_pred [inductify] length .
17.785 -code_pred [inductify, random] length .
17.786 +(*code_pred [inductify] length .
17.787 +code_pred [random inductify] length .
17.788 thm size_listP.equation
17.789 thm size_listP.random_equation
17.790 -
17.791 +*)
17.792 (*values [random] 1 "{xs. size_listP (xs::nat list) (5::nat)}"*)
17.793
17.794 code_pred (expected_modes: i => o => bool, o => i => bool, i => i => bool) [inductify] List.concat .
17.795 @@ -764,19 +1010,19 @@
17.796 values "{ys. concatP [[1, 2], [3, (4::int)]] ys}"
17.797 values "{ys. concatP [[1, 2], [3]] [1, 2, (3::nat)]}"
17.798
17.799 -code_pred [inductify, depth_limited] List.concat .
17.800 -thm concatP.depth_limited_equation
17.801 +code_pred [dseq inductify] List.concat .
17.802 +thm concatP.dseq_equation
17.803
17.804 -values [depth_limit = 3] 3
17.805 +values [dseq 3] 3
17.806 "{xs. concatP xs ([0] :: nat list)}"
17.807
17.808 -values [depth_limit = 5] 3
17.809 +values [dseq 5] 3
17.810 "{xs. concatP xs ([1] :: int list)}"
17.811
17.812 -values [depth_limit = 5] 3
17.813 +values [dseq 5] 3
17.814 "{xs. concatP xs ([1] :: nat list)}"
17.815
17.816 -values [depth_limit = 5] 3
17.817 +values [dseq 5] 3
17.818 "{xs. concatP xs [(1::int), 2]}"
17.819
17.820 code_pred (expected_modes: i => o => bool, i => i => bool) [inductify] hd .
17.821 @@ -803,11 +1049,11 @@
17.822 code_pred [inductify] zip .
17.823 thm zipP.equation
17.824
17.825 -(*code_pred [inductify] upt .*)
17.826 +code_pred [inductify] upt .
17.827 code_pred [inductify] remdups .
17.828 thm remdupsP.equation
17.829 -code_pred [inductify, depth_limited] remdups .
17.830 -values [depth_limit = 4] 5 "{xs. remdupsP xs [1, (2::int)]}"
17.831 +code_pred [dseq inductify] remdups .
17.832 +values [dseq 4] 5 "{xs. remdupsP xs [1, (2::int)]}"
17.833
17.834 code_pred [inductify] remove1 .
17.835 thm remove1P.equation
17.836 @@ -815,13 +1061,12 @@
17.837
17.838 code_pred [inductify] removeAll .
17.839 thm removeAllP.equation
17.840 -code_pred [inductify, depth_limited] removeAll .
17.841 +code_pred [dseq inductify] removeAll .
17.842
17.843 -values [depth_limit = 4] 10 "{xs. removeAllP 1 xs [(2::nat)]}"
17.844 +values [dseq 4] 10 "{xs. removeAllP 1 xs [(2::nat)]}"
17.845
17.846 code_pred [inductify] distinct .
17.847 thm distinct.equation
17.848 -
17.849 code_pred [inductify] replicate .
17.850 thm replicateP.equation
17.851 values 5 "{(n, xs). replicateP n (0::int) xs}"
17.852 @@ -837,7 +1082,7 @@
17.853 code_pred [inductify] foldr .
17.854 code_pred [inductify] foldl .
17.855 code_pred [inductify] filter .
17.856 -code_pred [inductify, random] filter .
17.857 +code_pred [random_dseq inductify] filter .
17.858
17.859 subsection {* Context Free Grammar *}
17.860
17.861 @@ -852,11 +1097,11 @@
17.862 | "\<lbrakk>v \<in> B\<^isub>1; v \<in> B\<^isub>1\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^isub>1"
17.863
17.864 code_pred [inductify] S\<^isub>1p .
17.865 -code_pred [inductify, random] S\<^isub>1p .
17.866 +code_pred [random_dseq inductify] S\<^isub>1p .
17.867 thm S\<^isub>1p.equation
17.868 -thm S\<^isub>1p.random_equation
17.869 +thm S\<^isub>1p.random_dseq_equation
17.870
17.871 -values [random] 5 "{x. S\<^isub>1p x}"
17.872 +values [random_dseq 5, 5, 5] 5 "{x. S\<^isub>1p x}"
17.873
17.874 inductive_set S\<^isub>2 and A\<^isub>2 and B\<^isub>2 where
17.875 "[] \<in> S\<^isub>2"
17.876 @@ -866,12 +1111,12 @@
17.877 | "w \<in> S\<^isub>2 \<Longrightarrow> b # w \<in> B\<^isub>2"
17.878 | "\<lbrakk>v \<in> B\<^isub>2; v \<in> B\<^isub>2\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^isub>2"
17.879
17.880 -code_pred [inductify, random] S\<^isub>2 .
17.881 -thm S\<^isub>2.random_equation
17.882 -thm A\<^isub>2.random_equation
17.883 -thm B\<^isub>2.random_equation
17.884 +code_pred [random_dseq inductify] S\<^isub>2p .
17.885 +thm S\<^isub>2p.random_dseq_equation
17.886 +thm A\<^isub>2p.random_dseq_equation
17.887 +thm B\<^isub>2p.random_dseq_equation
17.888
17.889 -values [random] 10 "{x. S\<^isub>2 x}"
17.890 +values [random_dseq 5, 5, 5] 10 "{x. S\<^isub>2p x}"
17.891
17.892 inductive_set S\<^isub>3 and A\<^isub>3 and B\<^isub>3 where
17.893 "[] \<in> S\<^isub>3"
17.894 @@ -881,10 +1126,10 @@
17.895 | "w \<in> S\<^isub>3 \<Longrightarrow> b # w \<in> B\<^isub>3"
17.896 | "\<lbrakk>v \<in> B\<^isub>3; w \<in> B\<^isub>3\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^isub>3"
17.897
17.898 -code_pred [inductify] S\<^isub>3 .
17.899 -thm S\<^isub>3.equation
17.900 +code_pred [inductify] S\<^isub>3p .
17.901 +thm S\<^isub>3p.equation
17.902
17.903 -values 10 "{x. S\<^isub>3 x}"
17.904 +values 10 "{x. S\<^isub>3p x}"
17.905
17.906 inductive_set S\<^isub>4 and A\<^isub>4 and B\<^isub>4 where
17.907 "[] \<in> S\<^isub>4"
17.908 @@ -950,7 +1195,7 @@
17.909 code_pred (expected_modes: i => i => o => bool, i => i => i => bool) typing .
17.910 thm typing.equation
17.911
17.912 -code_pred (modes: i => o => bool as reduce') beta .
17.913 +code_pred (modes: i => i => bool, i => o => bool as reduce') beta .
17.914 thm beta.equation
17.915
17.916 values "{x. App (Abs (Atom 0) (Var 0)) (Var 1) \<rightarrow>\<^sub>\<beta> x}"
17.917 @@ -959,18 +1204,19 @@
17.918
17.919 value "reduce (App (Abs (Atom 0) (Var 0)) (Var 1))"
17.920
17.921 -code_pred [random] typing .
17.922 +code_pred [dseq] typing .
17.923 +code_pred [random_dseq] typing .
17.924
17.925 -values [random] 1 "{(\<Gamma>, t, T). \<Gamma> \<turnstile> t : T}"
17.926 +values [random_dseq 1,1,5] 10 "{(\<Gamma>, t, T). \<Gamma> \<turnstile> t : T}"
17.927
17.928 subsection {* A minimal example of yet another semantics *}
17.929
17.930 text {* thanks to Elke Salecker *}
17.931
17.932 types
17.933 -vname = nat
17.934 -vvalue = int
17.935 -var_assign = "vname \<Rightarrow> vvalue" --"variable assignment"
17.936 + vname = nat
17.937 + vvalue = int
17.938 + var_assign = "vname \<Rightarrow> vvalue" --"variable assignment"
17.939
17.940 datatype ir_expr =
17.941 IrConst vvalue
17.942 @@ -981,10 +1227,10 @@
17.943 IntVal vvalue
17.944
17.945 record configuration =
17.946 -Env :: var_assign
17.947 + Env :: var_assign
17.948
17.949 inductive eval_var ::
17.950 -"ir_expr \<Rightarrow> configuration \<Rightarrow> val \<Rightarrow> bool"
17.951 + "ir_expr \<Rightarrow> configuration \<Rightarrow> val \<Rightarrow> bool"
17.952 where
17.953 irconst: "eval_var (IrConst i) conf (IntVal i)"
17.954 | objaddr: "\<lbrakk> Env conf n = i \<rbrakk> \<Longrightarrow> eval_var (ObjAddr n) conf (IntVal i)"
18.1 --- a/src/Pure/Isar/spec_rules.ML Sat Jan 16 21:14:15 2010 +0100
18.2 +++ b/src/Pure/Isar/spec_rules.ML Wed Jan 20 11:56:45 2010 +0100
18.3 @@ -12,6 +12,8 @@
18.4 type spec = rough_classification * (term list * thm list)
18.5 val get: Proof.context -> spec list
18.6 val get_global: theory -> spec list
18.7 + val retrieve: Proof.context -> term -> spec list
18.8 + val retrieve_global: theory -> term -> spec list
18.9 val add: rough_classification -> term list * thm list -> local_theory -> local_theory
18.10 val add_global: rough_classification -> term list * thm list -> theory -> theory
18.11 end;
18.12 @@ -41,6 +43,9 @@
18.13 val get = Item_Net.content o Rules.get o Context.Proof;
18.14 val get_global = Item_Net.content o Rules.get o Context.Theory;
18.15
18.16 +val retrieve = Item_Net.retrieve o Rules.get o Context.Proof;
18.17 +val retrieve_global = Item_Net.retrieve o Rules.get o Context.Theory;
18.18 +
18.19 fun add class (ts, ths) lthy =
18.20 let
18.21 val cts = map (Thm.cterm_of (ProofContext.theory_of lthy)) ts;
19.1 --- a/src/Tools/quickcheck.ML Sat Jan 16 21:14:15 2010 +0100
19.2 +++ b/src/Tools/quickcheck.ML Wed Jan 20 11:56:45 2010 +0100
19.3 @@ -7,6 +7,7 @@
19.4 signature QUICKCHECK =
19.5 sig
19.6 val auto: bool Unsynchronized.ref
19.7 + val timing : bool Unsynchronized.ref
19.8 val test_term: Proof.context -> bool -> string option -> int -> int -> term ->
19.9 (string * term) list option
19.10 val add_generator: string * (Proof.context -> term -> int -> term list option) -> theory -> theory
19.11 @@ -21,6 +22,8 @@
19.12
19.13 val auto = Unsynchronized.ref false;
19.14
19.15 +val timing = Unsynchronized.ref false;
19.16 +
19.17 val _ =
19.18 ProofGeneralPgip.add_preference Preferences.category_tracing
19.19 (setmp_CRITICAL auto true (fn () =>
19.20 @@ -97,9 +100,10 @@
19.21 fun test_term ctxt quiet generator_name size i t =
19.22 let
19.23 val (names, t') = prep_test_term t;
19.24 - val testers = case generator_name
19.25 - of NONE => if quiet then mk_testers ctxt t' else mk_testers_strict ctxt t'
19.26 - | SOME name => [mk_tester_select name ctxt t'];
19.27 + val testers = (*cond_timeit (!timing) "quickcheck compilation"
19.28 + (fn () => *)(case generator_name
19.29 + of NONE => if quiet then mk_testers ctxt t' else mk_testers_strict ctxt t'
19.30 + | SOME name => [mk_tester_select name ctxt t']);
19.31 fun iterate f 0 = NONE
19.32 | iterate f j = case f () handle Match => (if quiet then ()
19.33 else warning "Exception Match raised during quickcheck"; NONE)
19.34 @@ -113,9 +117,11 @@
19.35 else (if quiet then () else priority ("Test data size: " ^ string_of_int k);
19.36 case with_testers k testers
19.37 of NONE => with_size (k + 1) | SOME q => SOME q);
19.38 - in case with_size 1
19.39 - of NONE => NONE
19.40 - | SOME ts => SOME (names ~~ ts)
19.41 + in
19.42 + cond_timeit (!timing) "quickcheck execution"
19.43 + (fn () => case with_size 1
19.44 + of NONE => NONE
19.45 + | SOME ts => SOME (names ~~ ts))
19.46 end;
19.47
19.48 fun monomorphic_term thy insts default_T =