src/HOL/Tools/refute_isar.ML
author wenzelm
Tue, 16 Aug 2005 13:42:26 +0200
changeset 17057 0934ac31985f
parent 15570 8d8c70b41bab
child 17273 e95f7141ba2f
permissions -rw-r--r--
OuterKeyword;
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
14350
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
     1
(*  Title:      HOL/Tools/refute_isar.ML
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
     2
    ID:         $Id$
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
     3
    Author:     Tjark Weber
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
     4
    Copyright   2003-2004
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
     5
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
     6
Adds the 'refute' and 'refute_params' commands to Isabelle/Isar's outer
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
     7
syntax.
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
     8
*)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
     9
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    10
structure RefuteIsar =
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    11
struct
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    12
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    13
(* ------------------------------------------------------------------------- *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    14
(* common functions for argument parsing/scanning                            *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    15
(* ------------------------------------------------------------------------- *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    16
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    17
(* ------------------------------------------------------------------------- *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    18
(* both 'refute' and 'refute_params' take an optional list of arguments of   *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    19
(* the form [name1=value1, name2=value2, ...]                                *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    20
(* ------------------------------------------------------------------------- *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    21
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    22
	fun repeatd delim scan = scan -- Scan.repeat (OuterParse.$$$ delim |-- scan) >> op :: || Scan.succeed [];
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    23
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    24
	val scan_parm = (OuterParse.name -- (OuterParse.$$$ "=" |-- OuterParse.name));
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    25
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    26
	val scan_parms = Scan.option (OuterParse.$$$ "[" |-- (repeatd "," scan_parm) --| OuterParse.$$$ "]");
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    27
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    28
(* ------------------------------------------------------------------------- *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    29
(* set up the 'refute' command                                               *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    30
(* ------------------------------------------------------------------------- *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    31
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    32
(* ------------------------------------------------------------------------- *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    33
(* 'refute' takes an optional list of parameters, followed by an optional    *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    34
(* subgoal number                                                            *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    35
(* ------------------------------------------------------------------------- *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    36
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    37
	val refute_scan_args = scan_parms -- (Scan.option OuterParse.nat);
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    38
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    39
(* ------------------------------------------------------------------------- *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    40
(* the 'refute' command is mapped to 'Refute.refute_subgoal'                 *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    41
(* ------------------------------------------------------------------------- *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    42
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    43
	fun refute_trans args =
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    44
		Toplevel.keep
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    45
			(fn state =>
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    46
				(let
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    47
					val (parms, subgoal) = args
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    48
					val thy              = (Toplevel.theory_of state)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    49
					val thm              = ((snd o snd) (Proof.get_goal (Toplevel.proof_of state)))
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    50
				in
15570
8d8c70b41bab Move towards standard functions.
skalberg
parents: 14454
diff changeset
    51
					Refute.refute_subgoal thy (getOpt (parms, [])) thm ((getOpt (subgoal, 1))-1)
14350
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    52
				end)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    53
			);
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    54
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    55
	fun refute_parser tokens = (refute_scan_args tokens) |>> refute_trans;
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    56
17057
0934ac31985f OuterKeyword;
wenzelm
parents: 15570
diff changeset
    57
	val refute_cmd = OuterSyntax.improper_command "refute" "try to find a model that refutes a given subgoal" OuterKeyword.diag refute_parser;
14350
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    58
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    59
(* ------------------------------------------------------------------------- *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    60
(* set up the 'refute_params' command                                        *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    61
(* ------------------------------------------------------------------------- *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    62
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    63
(* ------------------------------------------------------------------------- *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    64
(* 'refute_params' takes an optional list of parameters                      *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    65
(* ------------------------------------------------------------------------- *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    66
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    67
	val refute_params_scan_args = scan_parms;
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    68
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    69
(* ------------------------------------------------------------------------- *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    70
(* the 'refute_params' command is mapped to (multiple calls of)              *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    71
(* 'Refute.set_default_param'; then the (new) default parameters are         *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    72
(* displayed                                                                 *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    73
(* ------------------------------------------------------------------------- *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    74
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    75
	fun refute_params_trans args =
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    76
		let
14454
8a8330bef1f8 *** empty log message ***
webertj
parents: 14350
diff changeset
    77
			fun add_params (thy, [])    = thy
8a8330bef1f8 *** empty log message ***
webertj
parents: 14350
diff changeset
    78
			  | add_params (thy, p::ps) = add_params (Refute.set_default_param p thy, ps)
14350
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    79
		in
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    80
			Toplevel.theory (fn thy =>
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    81
				let
15570
8d8c70b41bab Move towards standard functions.
skalberg
parents: 14454
diff changeset
    82
					val thy'               = add_params (thy, (getOpt (args, [])))
14350
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    83
					val new_default_params = Refute.get_default_params thy'
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    84
					val output             = if new_default_params=[] then "none" else (space_implode "\n" (map (fn (name,value) => name ^ "=" ^ value) new_default_params))
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    85
				in
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    86
					writeln ("Default parameters for 'refute':\n" ^ output);
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    87
					thy'
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    88
				end)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    89
		end;
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    90
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    91
	fun refute_params_parser tokens = (refute_params_scan_args tokens) |>> refute_params_trans;
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    92
17057
0934ac31985f OuterKeyword;
wenzelm
parents: 15570
diff changeset
    93
	val refute_params_cmd = OuterSyntax.command "refute_params" "show/store default parameters for the 'refute' command" OuterKeyword.thy_decl refute_params_parser;
14350
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    94
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    95
end;
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    96
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    97
(* ------------------------------------------------------------------------- *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    98
(* add the two new commands 'refute' and 'refute_params' to Isabelle/Isar's  *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
    99
(* outer syntax                                                              *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
   100
(* ------------------------------------------------------------------------- *)
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
   101
41b32020d0b3 Adding 'refute' to HOL.
webertj
parents:
diff changeset
   102
OuterSyntax.add_parsers [RefuteIsar.refute_cmd, RefuteIsar.refute_params_cmd];