paulson@1593

1 
(* Title: Pure/deriv.ML

paulson@1593

2 
ID: $Id$

paulson@1593

3 
Author: Lawrence C Paulson, Cambridge University Computer Laboratory

paulson@1593

4 
Copyright 1996 University of Cambridge

paulson@1593

5 

paulson@1593

6 
Derivations (proof objects) and functions for examining them

paulson@1593

7 
*)

paulson@1593

8 

paulson@1593

9 
signature DERIV =

paulson@1593

10 
sig

paulson@1593

11 
(*Objectlevel rules*)

paulson@1593

12 
datatype orule = Subgoal of cterm

paulson@1593

13 
 Asm of int

paulson@1593

14 
 Res of deriv

paulson@1593

15 
 Equal of deriv

paulson@1601

16 
 Thm of string

paulson@1593

17 
 Other of deriv;

paulson@1593

18 

paulson@1593

19 
val size : deriv > int

paulson@1593

20 
val drop : 'a mtree * int > 'a mtree

paulson@1593

21 
val linear : deriv > deriv list

paulson@1593

22 
val tree : deriv > orule mtree

paulson@1593

23 
end;

paulson@1593

24 

paulson@1593

25 
structure Deriv : DERIV =

paulson@1593

26 
struct

paulson@1593

27 

paulson@1593

28 
fun size (Join(Theorem _, _)) = 1

paulson@1593

29 
 size (Join(_, ders)) = foldl op+ (1, map size ders);

paulson@1593

30 

paulson@1593

31 
(*Conversion to linear format. Children of a node are the LIST of inferences

paulson@1593

32 
justifying ONE of the premises*)

paulson@1593

33 
fun rev_deriv (Join (rl, [])) = [Join(rl,[])]

paulson@1601

34 
 rev_deriv (Join (Theorem name, _)) = [Join(Theorem name, [])]

paulson@1593

35 
 rev_deriv (Join (Assumption arg, [der])) =

paulson@1593

36 
Join(Assumption arg,[]) :: rev_deriv der

paulson@1593

37 
 rev_deriv (Join (Bicompose arg, [rder, sder])) =

paulson@1593

38 
Join (Bicompose arg, linear rder) :: rev_deriv sder

paulson@1593

39 
 rev_deriv (Join (_, [der])) = rev_deriv der

paulson@1593

40 
 rev_deriv (Join (rl, der::ders)) = (*catchall case; doubtful?*)

paulson@2672

41 
Join(rl, List.concat (map linear ders)) :: rev_deriv der

paulson@1593

42 
and linear der = rev (rev_deriv der);

paulson@1593

43 

paulson@1593

44 

paulson@1593

45 
(*** Conversion of objectlevel proof trees ***)

paulson@1593

46 

paulson@1593

47 
(*Objectlevel rules*)

paulson@1593

48 
datatype orule = Subgoal of cterm

paulson@1593

49 
 Asm of int

paulson@1593

50 
 Res of deriv

paulson@1593

51 
 Equal of deriv

paulson@1601

52 
 Thm of string

paulson@1593

53 
 Other of deriv;

paulson@1593

54 

paulson@1593

55 
(*At position i, splice in value x, removing ngoal elements*)

paulson@1593

56 
fun splice (i,x,ngoal,prfs) =

paulson@1593

57 
let val prfs0 = take(i1,prfs)

paulson@1593

58 
and prfs1 = drop(i1,prfs)

paulson@1593

59 
val prfs2 = Join (x, take(ngoal, prfs1)) :: drop(ngoal, prfs1)

paulson@1593

60 
in prfs0 @ prfs2 end;

paulson@1593

61 

paulson@1593

62 
(*Deletes trivial uses of Equal_elim; hides derivations of Theorems*)

paulson@1593

63 
fun simp_deriv (Join (Equal_elim, [Join (Rewrite_cterm _, []), der])) =

paulson@1593

64 
simp_deriv der

paulson@1593

65 
 simp_deriv (Join (Equal_elim, [Join (Reflexive _, []), der])) =

paulson@1593

66 
simp_deriv der

paulson@1601

67 
 simp_deriv (Join (rule as Theorem name, [_])) = Join (rule, [])

paulson@1593

68 
 simp_deriv (Join (rule, ders)) = Join (rule, map simp_deriv ders);

paulson@1593

69 

paulson@1593

70 
(*Proof term is an equality: first premise of equal_elim.

paulson@1593

71 
Attempt to decode proof terms made by Drule.goals_conv.

paulson@1593

72 
Subgoal numbers are returned; they are wrong if original subgoal

paulson@1593

73 
had flexflex pairs!

paulson@1593

74 
NEGATIVE i means "could affect all subgoals starting from i"*)

paulson@1593

75 
fun scan_equals (i, Join (Combination,

paulson@1593

76 
[Join (Combination, [_, der1]), der2])) =

paulson@1593

77 
(case der1 of (*ignore trivial cases*)

paulson@1593

78 
Join (Reflexive _, _) => scan_equals (i+1, der2)

paulson@1593

79 
 Join (Rewrite_cterm _, []) => scan_equals (i+1, der2)

paulson@1593

80 
 Join (Rewrite_cterm _, _) => (i,der1) :: scan_equals (i+1, der2)

paulson@1593

81 
 _ (*impossible in gconv*) => [])

paulson@1593

82 
 scan_equals (i, Join (Reflexive _, [])) = []

paulson@1593

83 
 scan_equals (i, Join (Rewrite_cterm _, [])) = []

paulson@1593

84 
(*Anything else could affect ALL following goals*)

paulson@1593

85 
 scan_equals (i, der) = [(~i,der)];

paulson@1593

86 

paulson@1593

87 
(*Record uses of equality reasoning on 1 or more subgoals*)

paulson@1593

88 
fun update_equals ((i,der), prfs) =

paulson@1593

89 
if i>0 then splice (i, Equal (simp_deriv der), 1, prfs)

paulson@1593

90 
else take (~i1, prfs) @

paulson@1593

91 
map (fn prf => Join (Equal (simp_deriv der), [prf]))

paulson@1593

92 
(drop (~i1, prfs));

paulson@1593

93 

paulson@1593

94 
fun delift (Join (Lift_rule _, [der])) = der

paulson@1593

95 
 delift der = der;

paulson@1593

96 

paulson@1593

97 
(*Conversion to an objectlevel proof tree.

paulson@1593

98 
Uses embedded Lift_rules to "annotate" the proof tree with subgoals;

paulson@1593

99 
 assumes that Lift_rule never occurs except with resolution

paulson@1593

100 
 may contain Vars that, in fact, are instantiated in that step*)

paulson@1593

101 
fun tree_aux (Join (Trivial ct, []), prfs) = Join(Subgoal ct, prfs)

paulson@1593

102 
 tree_aux (Join (Assumption(i,_), [der]), prfs) =

paulson@1593

103 
tree_aux (der, splice (i, Asm i, 0, prfs))

paulson@1593

104 
 tree_aux (Join (Equal_elim, [der1,der2]), prfs) =

paulson@1593

105 
tree_aux (der2, foldr update_equals (scan_equals (1, der1), prfs))

paulson@1593

106 
 tree_aux (Join (Bicompose (match,true,i,ngoal,env), ders), prfs) =

paulson@1593

107 
(*change eresolve_tac to proof by assumption*)

paulson@1593

108 
tree_aux (Join (Assumption(i, Some env),

paulson@1593

109 
[Join (Bicompose (match,false,i,ngoal,env), ders)]),

paulson@1593

110 
prfs)

paulson@1593

111 
 tree_aux (Join (Lift_rule (ct,i), [der]), prfs) =

paulson@1593

112 
tree_aux (der, splice (i, Subgoal ct, 1, prfs))

paulson@1593

113 
 tree_aux (Join (Bicompose arg,

paulson@1593

114 
[Join (Instantiate _, [rder]), sder]), prfs) =

paulson@1593

115 
(*Ignore Instantiate*)

paulson@1593

116 
tree_aux (Join (Bicompose arg, [rder, sder]), prfs)

paulson@1593

117 
 tree_aux (Join (Bicompose arg,

paulson@1593

118 
[Join (Lift_rule larg, [rder]), sder]), prfs) =

paulson@1593

119 
(*Move Lift_rule: to make a Subgoal on the result*)

paulson@1593

120 
tree_aux (Join (Bicompose arg, [rder,

paulson@1593

121 
Join(Lift_rule larg, [sder])]), prfs)

paulson@1593

122 
 tree_aux (Join (Bicompose (match,ef,i,ngoal,env),

paulson@1593

123 
[Join (Bicompose (match',ef',i',ngoal',env'),

paulson@1593

124 
[der1,der2]),

paulson@1593

125 
der3]), prfs) =

paulson@1593

126 
(*associate resolutions to the right*)

paulson@1593

127 
tree_aux (Join (Bicompose (match', ef', i'+i1, ngoal', env'),

paulson@1593

128 
[delift der1, (*This Lift_rule would be wrong!*)

paulson@1593

129 
Join (Bicompose (match, ef, i, ngoalngoal'+1, env),

paulson@1593

130 
[der2, der3])]), prfs)

paulson@1593

131 
 tree_aux (Join (Bicompose (arg as (_,_,i,ngoal,_)),

paulson@1593

132 
[rder, sder]), prfs) =

paulson@1593

133 
(*resolution with basic rule/assumption  we hope!*)

paulson@1593

134 
tree_aux (sder, splice (i, Res (simp_deriv rder), ngoal, prfs))

paulson@1601

135 
 tree_aux (Join (Theorem name, _), prfs) = Join(Thm name, prfs)

paulson@1593

136 
 tree_aux (Join (_, [der]), prfs) = tree_aux (der,prfs)

paulson@1593

137 
 tree_aux (der, prfs) = Join(Other (simp_deriv der), prfs);

paulson@1593

138 

paulson@1593

139 

paulson@1593

140 
fun tree der = tree_aux (der,[]);

paulson@1593

141 

paulson@1593

142 
(*Currently declared at end, to avoid conflicting with library's drop

paulson@1593

143 
Can put it after "size" once we switch to List.drop*)

paulson@1593

144 
fun drop (der,0) = der

paulson@2042

145 
 drop (Join (_, der::_), n) = drop (der, n1)

paulson@2042

146 
 drop (der,_) = der;

paulson@1593

147 

paulson@1593

148 
end;

paulson@1593

149 

paulson@1593

150 

paulson@1593

151 
(*We do NOT open this structure*)
