%****************************************************************************%
% FILE          : rewrite_rules.ml                                           %
% DESCRIPTION   : Using axioms and lemmas as rewrite rules.                  %
%                                                                            %
% READS FILES   : <none>                                                     %
% WRITES FILES  : <none>                                                     %
%                                                                            %
% AUTHOR        : R.J.Boulton                                                %
% DATE          : 14th May 1991                                              %
%                                                                            %
% LAST MODIFIED : R.J.Boulton                                                %
% DATE          : 15th October 1992                                          %
%****************************************************************************%

%----------------------------------------------------------------------------%
% is_permutative : term -> bool                                              %
%                                                                            %
% Determines whether or not an equation is permutative (the left-hand and    %
% right-hand sides are instances of one another). A permutative equation may %
% cause looping when it is used for rewriting.                               %
%----------------------------------------------------------------------------%

let is_permutative tm =
 (let (l,r) = dest_eq tm
  in  let bind1 = match l r
      and bind2 = match r l
  in  true
 ) ? false;;

%----------------------------------------------------------------------------%
% string_less : string -> string -> bool                                     %
%                                                                            %
% Lexicographical less-than on strings.                                      %
%----------------------------------------------------------------------------%

let string_less s1 s2 =
   letrec string_less' l1 l2 =
      if (null l2) then false
      if (null l1) then true
      else let a1 = ascii_code (hd l1)
           and a2 = ascii_code (hd l2)
           in  if (a1 < a2) then true
               if (a1 = a2) then string_less' (tl l1) (tl l2)
               else false
   in string_less' (explode s1) (explode s2);;

%----------------------------------------------------------------------------%
% lex_smaller_term : term -> term -> bool                                    %
%                                                                            %
% Computes whether the first term is `alphabetically' smaller than the       %
% second term. Used to avoid looping when rewriting with permutative rules.  %
%                                                                            %
% A constant is considered to be smaller than a variable which in turn is    %
% considered to be smaller than an application. Two variables or two         %
% constants are compared alphabetically by name. An application (f1 x1) is   %
% considered to be smaller than another application (f2 x2) if either f1 is  %
% smaller than f2, or f1 equals f2 and x1 is smaller than x2.                %
%----------------------------------------------------------------------------%

letrec lex_smaller_term tm1 tm2 =
 (if (is_const tm1) then
     (if (is_const tm2)
      then let (name1,type1) = dest_const tm1
           and (name2,type2) = dest_const tm2
           in  (if (type1 = type2)
                then string_less name1 name2
                else fail)
      else true)
  if (is_var tm1) then
     (if (is_const tm2) then false
      if (is_var tm2)
      then let (name1,type1) = dest_var tm1
           and (name2,type2) = dest_var tm2
           in  (if (type1 = type2)
                then string_less name1 name2
                else fail)
      else true)
  if (is_comb tm1) then
     (if (is_comb tm2)
      then let (rator1,rand1) = dest_comb tm1
           and (rator2,rand2) = dest_comb tm2
           in  (lex_smaller_term rator1 rator2) or
               ((rator1 = rator2) & (lex_smaller_term rand1 rand2))
      else false)
  else fail
 ) ? failwith `lex_smaller_term`;;

%----------------------------------------------------------------------------%
% inst_eq_thm : ((term # term) list # (type # type) list) -> thm -> thm      %
%                                                                            %
% Instantiates a theorem (possibly having hypotheses) with a binding.        %
% Assumes the conclusion is an equality, so that discharging then undisching %
% cannot cause parts of the conclusion to be moved into the hypotheses.      %
%----------------------------------------------------------------------------%

let inst_eq_thm (tm_bind,ty_bind) th =
   let (insts,vars) = split tm_bind
   in  (UNDISCH_ALL o (SPECL insts) o (GENL vars) o
        (INST_TYPE ty_bind) o DISCH_ALL) th;;

%----------------------------------------------------------------------------%
% applicable_rewrites : term -> thm list                                     %
%                                                                            %
% Returns the results of rewriting the term with those rewrite rules that    %
% are applicable to it. A rewrite rule is not applicable if it's permutative %
% and the rewriting does not produce an alphabetically smaller term.         %
%----------------------------------------------------------------------------%

let applicable_rewrites tm =
   let applicable_rewrite tm th =
      let conc = concl th
      in  let instth = inst_eq_thm (match (lhs conc) tm) th
      in  if (is_permutative conc)
          then (let (l,r) = dest_eq (concl instth)
                in  if (lex_smaller_term r l)
                    then instth
                    else fail)
          else instth
   in  mapfilter ((applicable_rewrite tm) o snd) system_rewrites;;

%----------------------------------------------------------------------------%
% ARGS_CONV : conv -> conv                                                   %
%                                                                            %
% Applies a conversion to every argument of an application of the form       %
% "f x1 ... xn".                                                             %
%----------------------------------------------------------------------------%

letrec ARGS_CONV conv tm =
 ((RATOR_CONV (ARGS_CONV conv)) THENC (RAND_CONV conv)) tm
 ? ALL_CONV tm;;

%----------------------------------------------------------------------------%
% assump_inst_hyps : term list ->                                            %
%                    term ->                                                 %
%                    term list ->                                            %
%                    ((term # term) list # (type # type) list)               %
%                                                                            %
% Searches a list of hypotheses for one that matches the specified           %
% assumption such that the variables instantiated are precisely those in the %
% list of variables given. If such a hypothesis is found, the binding        %
% produced by the match is returned.                                         %
%----------------------------------------------------------------------------%

letrec assump_inst_hyps vars assump hyps =
 (let bind = match (hd hyps) assump
  in  if (set_equal vars (map snd (fst bind)))
      then bind
      else fail)
 ? (assump_inst_hyps vars assump (tl hyps))
 ? failwith `assump_inst_hyps`;;

%----------------------------------------------------------------------------%
% assumps_inst_hyps : term list ->                                           %
%                     term list ->                                           %
%                     term list ->                                           %
%                     ((term # term) list # (type # type) list)              %
%                                                                            %
% Searches a list of hypotheses and a list of assumptions for a pairing that %
% match (the assumption is an instance of the hypothesis) such that the      %
% variables instantiated are precisely those in the list of variables given. %
% If such a pair is found, the binding produced by the match is returned.    %
%----------------------------------------------------------------------------%

letrec assumps_inst_hyps vars assumps hyps =
 (assump_inst_hyps vars (hd assumps) hyps)
 ? (assumps_inst_hyps vars (tl assumps) hyps)
 ? failwith `assumps_inst_hyps`;;

%----------------------------------------------------------------------------%
% inst_frees_in_hyps : term list -> thm -> thm                               %
%                                                                            %
% Takes a theorem (possibly with hypotheses) and computes a list of          %
% variables that are free in the hypotheses but not in the conclusion.       %
% If this list of variables is empty the original theorem is returned.       %
% The function also takes a list of assumptions as another argument. Once it %
% has the list of variables it searches for an assumption and a hypothesis   %
% such that the hypothesis matches the assumption binding precisely those    %
% variables in the list. If this is successful the original theorem is       %
% returned having had the variables in the list instantiated.                %
%----------------------------------------------------------------------------%

let inst_frees_in_hyps assumps th =
 (let hyps = hyp th
  in  let hyp_frees = setify (flat (map frees hyps))
  in  let vars = subtract hyp_frees (frees (concl th))
  in  if (null vars)
      then th
      else let bind = assumps_inst_hyps vars assumps hyps
           in  inst_eq_thm bind th
 ) ? failwith `inst_frees_in_hyps`;;

%----------------------------------------------------------------------------%
% NOT_IMP_EQ_EQ_EQ_OR = |- (~x ==> (y = y')) = ((y \/ x) = (y' \/ x))        %
%----------------------------------------------------------------------------%

let NOT_IMP_EQ_EQ_EQ_OR =
 prove
  ("(~x ==> (y = y')) = ((y \/ x) = (y' \/ x))",
   BOOL_CASES_TAC "x:bool" THEN
   BOOL_CASES_TAC "y:bool" THEN
   BOOL_CASES_TAC "y':bool" THEN
   REWRITE_TAC []);;

%----------------------------------------------------------------------------%
% IMP_EQ_EQ_EQ_OR_NOT = |- (x ==> (y = y')) = ((y \/ ~x) = (y' \/ ~x))       %
%----------------------------------------------------------------------------%

let IMP_EQ_EQ_EQ_OR_NOT =
 prove
  ("(x ==> (y = y')) = ((y \/ ~x) = (y' \/ ~x))",
   BOOL_CASES_TAC "x:bool" THEN
   BOOL_CASES_TAC "y:bool" THEN
   BOOL_CASES_TAC "y':bool" THEN
   REWRITE_TAC []);;

%----------------------------------------------------------------------------%
% NOT_IMP_EQ_OR_EQ_EQ_OR_OR =                                                %
% |- (~x ==> ((y \/ t) = (y' \/ t))) = ((y \/ (x \/ t)) = (y' \/ (x \/ t)))  %
%----------------------------------------------------------------------------%

let NOT_IMP_EQ_OR_EQ_EQ_OR_OR =
 prove
  ("(~x ==> ((y \/ t) = (y' \/ t))) = ((y \/ (x \/ t)) = (y' \/ (x \/ t)))",
   BOOL_CASES_TAC "x:bool" THEN
   BOOL_CASES_TAC "y:bool" THEN
   BOOL_CASES_TAC "y':bool" THEN
   BOOL_CASES_TAC "t:bool" THEN
   REWRITE_TAC []);;

%----------------------------------------------------------------------------%
% IMP_EQ_OR_EQ_EQ_OR_NOT_OR =                                                %
% |- (x ==> ((y \/ t) = (y' \/ t))) = ((y \/ (~x \/ t)) = (y' \/ (~x \/ t))) %
%----------------------------------------------------------------------------%

let IMP_EQ_OR_EQ_EQ_OR_NOT_OR =
 prove
  ("(x ==> ((y \/ t) = (y' \/ t))) = ((y \/ (~x \/ t)) = (y' \/ (~x \/ t)))",
   BOOL_CASES_TAC "x:bool" THEN
   BOOL_CASES_TAC "y:bool" THEN
   BOOL_CASES_TAC "y':bool" THEN
   BOOL_CASES_TAC "t:bool" THEN
   REWRITE_TAC []);;

%----------------------------------------------------------------------------%
% IMP_EQ_EQ_EQ_NOT_OR = |- (x ==> (t = t')) = ((~x \/ t) = (~x \/ t'))       %
%----------------------------------------------------------------------------%

let IMP_EQ_EQ_EQ_NOT_OR =
 prove
  ("(x ==> (t = t')) = ((~x \/ t) = (~x \/ t'))",
   BOOL_CASES_TAC "x:bool" THEN
   BOOL_CASES_TAC "t:bool" THEN
   BOOL_CASES_TAC "t':bool" THEN
   REWRITE_TAC []);;

%----------------------------------------------------------------------------%
% IMP_NOT_EQ_EQ_EQ_OR = |- (~x ==> (t = t')) = ((x \/ t) = (x \/ t'))        %
%----------------------------------------------------------------------------%

let IMP_NOT_EQ_EQ_EQ_OR =
 prove
  ("(~x ==> (t = t')) = ((x \/ t) = (x \/ t'))",
   BOOL_CASES_TAC "x:bool" THEN
   BOOL_CASES_TAC "t:bool" THEN
   BOOL_CASES_TAC "t':bool" THEN
   REWRITE_TAC []);;

%----------------------------------------------------------------------------%
% T_OR = |- T \/ t = T                                                       %
% OR_T = |- t \/ T = T                                                       %
% F_OR = |- F \/ t = t                                                       %
% OR_F = |- t \/ F = t                                                       %
%----------------------------------------------------------------------------%

let [T_OR;OR_T;F_OR;OR_F;_] = CONJUNCTS (SPEC_ALL OR_CLAUSES);;

%----------------------------------------------------------------------------%
% UNDER_DISJ_DISCH : term -> thm -> thm                                      %
%                                                                            %
%    A, ~x |- y \/ t = y' \/ t          A, x |- y \/ t = y' \/ t             %
%    -------------------------------    ---------------------------------    %
%    A |- y \/ x \/ t = y' \/ x \/ t    A |- y \/ ~x \/ t = y' \/ ~x \/ t    %
%                                                                            %
%    A, ~x |- y = y'                    A, x |- y = y'                       %
%    ---------------------              -----------------------              %
%    A |- y \/ x = y' \/ x              A |- y \/ ~x = y' \/ ~x              %
%                                                                            %
% The function assumes that y is a literal, so it is valid to test the LHS   %
% of the theorem to see if it is a disjunction in order to determine which   %
% rule to use.                                                               %
%----------------------------------------------------------------------------%

let UNDER_DISJ_DISCH tm th =
 (let rewrite =
     if (is_disj (lhs (concl th)))
     then if (is_neg tm)
          then NOT_IMP_EQ_OR_EQ_EQ_OR_OR
          else IMP_EQ_OR_EQ_EQ_OR_NOT_OR
     else if (is_neg tm)
          then NOT_IMP_EQ_EQ_EQ_OR
          else IMP_EQ_EQ_EQ_OR_NOT
  in  CONV_RULE (REWR_CONV rewrite) (DISCH tm th)
 ) ? failwith `UNDER_DISJ_DISCH`;;

%----------------------------------------------------------------------------%
% OVER_DISJ_DISCH : term -> thm -> thm                                       %
%                                                                            %
%    A, ~x |- t = t'                    A, x |- t = t'                       %
%    ---------------------              -----------------------              %
%    A |- x \/ t = x \/ t'              A |- ~x \/ t = ~x \/ t'              %
%----------------------------------------------------------------------------%

let OVER_DISJ_DISCH tm th =
 (let rewrite =
     if (is_neg tm)
     then IMP_NOT_EQ_EQ_EQ_OR
     else IMP_EQ_EQ_EQ_NOT_OR
  in  CONV_RULE (REWR_CONV rewrite) (DISCH tm th)
 ) ? failwith `OVER_DISJ_DISCH`;;

%----------------------------------------------------------------------------%
% MULTI_DISJ_DISCH : (term list # term list) -> thm -> thm                   %
%                                                                            %
% Examples:                                                                  %
%                                                                            %
%    MULTI_DISJ_DISCH (["x1"; "x2"],["~x3"; "x4"]) x1, ~x3, x4, x2 |- y = y' %
%    --->                                                                    %
%    |- ~x1 \/ ~x2 \/ y \/ x3 \/ ~x4 = ~x1 \/ ~x2 \/ y' \/ x3 \/ ~x4         %
%                                                                            %
%                                                                            %
%    MULTI_DISJ_DISCH (["x1"; "x2"],["~x3"; "x4"]) x1, ~x3, x4, x2 |- y = F  %
%    --->                                                                    %
%    |- ~x1 \/ ~x2 \/ y \/ x3 \/ ~x4 = ~x1 \/ ~x2 \/ x3 \/ ~x4               %
%                                                                            %
%                                                                            %
%    MULTI_DISJ_DISCH (["x1"; "x2"],["~x3"; "x4"]) x1, ~x3, x4, x2 |- y = T  %
%    --->                                                                    %
%    |- ~x1 \/ ~x2 \/ y \/ x3 \/ ~x4 = T                                     %
%----------------------------------------------------------------------------%

let MULTI_DISJ_DISCH (overs,unders) th =
 (let th1 = itlist UNDER_DISJ_DISCH unders th
  in  let tm1 = rhs (concl th1)
  in  let th2 = 
         if (is_T (fst (dest_disj tm1)) ? false) then
            (CONV_RULE (RAND_CONV (REWR_CONV T_OR)) th1)
         if (is_F (fst (dest_disj tm1)) ? false) then
            (CONV_RULE (RAND_CONV (REWR_CONV F_OR)) th1)
         else th1
  in  let tm2 = rhs (concl th2)
  in  let rule =
         if (is_T tm2) then CONV_RULE (RAND_CONV (REWR_CONV OR_T)) else I
  in  itlist (\tm th. rule (OVER_DISJ_DISCH tm th)) overs th2
 ) ? failwith `MULTI_DISJ_DISCH`;;
