(* isac's rewriter

   (c) Walther Neuper 2000

*)

signature REWRITE =

sig

  exception NO_REWRITE

  val calculate_: theory -> string * Eval_Def.eval_fn -> term -> (term * (string * thm)) option

  val eval__true: theory -> int -> term list -> (term * term) list -> Rule_Set.T -> term list * bool

  val eval_prog_expr: theory -> Rule_Set.T -> term -> term

  val eval_true_: theory -> Rule_Set.T -> term -> bool

  val eval_true: theory -> term list -> Rule_Set.T -> bool

  val rew_sub: theory -> int -> (term * term) list -> Rule_Def.rew_ord_

    -> Rule_Set.T -> bool -> TermC.path -> term -> term -> term * term list * TermC.path * bool

  val rewrite_: theory -> Rule_Def.rew_ord_ -> Rule_Set.T -> bool -> thm ->

    term -> (term * term list) option

  val rewrite_inst_: theory -> Rule_Def.rew_ord_ -> Rule_Set.T -> bool

    -> (term * term) list -> thm -> term -> (term * term list) option

  val rewrite_set_: theory -> bool -> Rule_Set.T -> term -> (term * term list) option

  val rewrite_set_inst_: theory -> bool -> (term * term) list -> Rule_Set.T -> term -> (term * term list) option

  val rewrite_terms_: theory -> Rule_Def.rew_ord_ -> Rule_Set.T -> term list

    -> term -> (term * term list) option

  val trace_on: bool Unsynchronized.ref

  val depth: int Unsynchronized.ref

  val lim_deriv: int Unsynchronized.ref

\<^isac_test>\<open>

  val rewrite__: theory -> int -> (term * term) list -> Rule_Def.rew_ord_ ->

    Rule_Set.T -> bool -> thm -> term -> (term * term list) option

  val rewrite__set_: theory -> int -> bool -> (term * term) list -> Rule_Set.T -> term -> (term * term list) option

  val app_rev: theory -> int -> Rule_Set.T -> term -> term * term list * bool

  val app_sub: theory -> int -> Rule_Set.T -> term -> term * term list * bool

  val trace1: int -> string -> unit

  val trace_eq1 : int -> string -> Rule_Def.rule_set -> theory -> term -> unit;

  val trace_eq2 : int -> string -> theory -> term -> term -> unit;

  val trace_in1 : int -> string -> string -> unit;

  val trace_in2 : int -> string -> theory -> term -> unit;

  val trace_in3 : int -> string -> theory -> (term * 'a) option -> unit;

  val trace_in4 : int -> string -> theory -> term list -> term list -> unit;

  val trace_in5 : int -> string -> theory -> term list -> unit;

\<close>

end

(**)

structure Rewrite(**): REWRITE(**) =

struct

(**)

exception NO_REWRITE;

val trace_on = Unsynchronized.ref false;

(* depth of recursion in traces of the rewriter, if trace_on:=true *)

val depth = Unsynchronized.ref 99999;

(* no of rewrites exceeding this int -> NO rewrite *)

val lim_deriv = Unsynchronized.ref 100;

fun trace i str = 

  if ! trace_on andalso i < ! depth then tracing (idt "#" i ^ str) else ()

fun trace_eq1 i str rrls thy t =

  trace i (" " ^ str ^ ": " ^ Rule_Set.id rrls ^ " on: " ^ UnparseC.term_in_thy thy t)

fun trace_eq2 i str thy t t' =

  trace i (" " ^ str ^ ": \"" ^

    UnparseC.term_in_thy thy t ^ "\" > \"" ^ UnparseC.term_in_thy thy t' ^ "\"");

fun trace1 i str =

  if ! trace_on andalso i < ! depth then tracing (idt "#" (i + 1) ^ str) else ()

fun trace_in1 i str thmid =

  trace1 i (" " ^ str ^ ": \"" ^ thmid ^ "\"")

fun trace_in2 i str thy t =

  trace1 i (" " ^ str ^ ": \"" ^ UnparseC.term_in_thy thy t ^ "\"");

fun trace_in3 i str thy pairopt =

  trace1 i (" " ^ str ^ ": " ^ UnparseC.term_in_thy thy ((fst o the) pairopt));

fun trace_in4 i str thy ts ts' =

  if ! trace_on andalso i < ! depth andalso ts <> []

  then tracing (idt "#" (i + 1) ^ " " ^ str ^ ": " ^ UnparseC.terms_in_thy thy ts ^

  	"   stored: " ^ UnparseC.terms_in_thy thy ts')

  else ();

fun trace_in5 i str thy p' =

  if ! trace_on andalso i < ! depth 

  then tracing (idt "#" (i + 1) ^ " " ^ str ^ ": " ^ UnparseC.terms_in_thy thy p')

  else();

fun msg call thy op_ thmC t = 

  call ^ ": \n" ^

  "Eval.get_pair for " ^ quote op_ ^ " \<longrightarrow> SOME (_, " ^ quote (ThmC.string_of_thm thmC) ^ ")\n" ^

  "but rewrite__ on " ^ quote (UnparseC.term_in_thy thy t) ^ " \<longrightarrow> NONE";

fun rewrite__ thy i bdv tless rls put_asm thm ct =

  let

    val (t', asms, _(*lrd*), rew) = rew_sub thy i bdv tless rls put_asm ([(*root of the term*)]: TermC.path)

		  (TermC.inst_bdv bdv (Eval.norm (Thm.prop_of thm))) ct

  in if rew then SOME (t', distinct op = asms) else NONE end

  (* one rewrite (possibly conditional, ordered) EXOR exn EXOR go into subterms *)

and rew_sub thy i bdv tless rls put_asm lrd r t = 

  (let

    val (lhs, rhs) = (HOLogic.dest_eq o HOLogic.dest_Trueprop o Logic.strip_imp_concl) r

    val r' = (Envir.subst_term (Pattern.match thy (lhs, t) (Vartab.empty, Vartab.empty)) r)

      handle Pattern.MATCH => raise NO_REWRITE

    val p' = map HOLogic.dest_Trueprop ((fst o Logic.strip_prems) (Logic.count_prems r', [], r'))

    val t' = (snd o HOLogic.dest_eq o HOLogic.dest_Trueprop o Logic.strip_imp_concl) r'

    val _ = trace_in2 i "eval asms" thy r';

    val (t'', p'') =                                                      (*conditional rewriting*)

      let val (simpl_p', nofalse) = eval__true thy (i + 1) p' bdv rls 	     

	    in

	      if nofalse

        then (trace_in4 i "asms accepted" thy p' simpl_p'; (t', simpl_p'))(*uncond.rew.from above*)

        else (trace_in5 i "asms false" thy p'; raise NO_REWRITE)   (* don't go into subtm.of cond*)

	    end                                    

  in

    if TermC.perm lhs rhs andalso not (tless bdv (t', t))                     (*ordered rewriting*)

    then (trace_eq2 i "not >" thy t t'; raise NO_REWRITE)

    else (t'', p'', [], true)

  end

  ) handle NO_REWRITE =>

    (case t of

      Const(s, T) => (Const(s, T), [], lrd, false)

    | Free(s, T) => (Free(s, T), [], lrd, false)

    | Var(n, T) => (Var(n, T), [], lrd, false)

    | Bound i => (Bound i, [], lrd, false)

    | Abs(s, T, body) => 

      let val (t', asms, _ (*lrd*), rew) =  rew_sub thy i bdv tless rls put_asm (lrd @ [TermC.D]) r body

       in (Abs(s, T, t'), asms, [], rew) end

    | t1 $ t2 => 

       let val (t2', asm2, lrd, rew2) = rew_sub thy i bdv tless rls put_asm (lrd @ [TermC.R]) r t2

       in

        if rew2 then (t1 $ t2', asm2, lrd, true)

        else

          let val (t1', asm1, lrd, rew1) = rew_sub thy i bdv tless rls put_asm (lrd @ [TermC.L]) r t1

          in if rew1 then (t1' $ t2, asm1, lrd, true) else (t1 $ t2,[], lrd, false) end

    end)

and eval__true thy i asms bdv rls =            (* rewrite asumptions until one evaluates to false*)

  if asms = [@{term True}] orelse asms = [] then ([], true)

  else (* this allows to check Rrls with prepat = ([@{term True}], pat) *)

    if asms = [@{term False}] then ([], false)

    else

      let                            

        fun chk indets [] = (indets, true) (*return asms<>True until false*)

          | chk indets (a :: asms) =

            (case rewrite__set_ thy (i + 1) false bdv rls a of

              NONE => (chk (indets @ [a]) asms)

            | SOME (t, a') =>

              if t = @{term True} then (chk (indets @ a') asms) 

              else if t = @{term False} then ([], false)

            (*asm false .. thm not applied ^^^; continue until False vvv*)

            else chk (indets @ [t] @ a') asms);

      in chk [] asms end

and rewrite__set_ thy (*1*)_ _ _ Rule_Set.Empty t =                         (* rewrite with a rule set*)

    raise ERROR ("rewrite__set_ called with 'Erls' for '" ^ UnparseC.term_in_thy thy t ^ "'")

  | rewrite__set_ (*2*)thy i _ _ (rrls as Rule_Set.Rrls _) t =    (* rewrite with a 'reverse rule set'*)

    let

      val _= trace_eq1 i "rls" rrls thy t;

	    val (t', asm, rew) = app_rev thy (i + 1) rrls t                   

    in if rew then SOME (t', distinct op = asm) else NONE end

  | rewrite__set_ (*3*)thy i put_asm bdv rls ct =           (* Rls, Seq containing Thms or Eval, Cal1 *)

    let

      (* attention with cp to test/..: unbound thy, i, bdv, rls; TODO1803? pull out to rewrite__*)

      datatype switch = Appl | Noap;

      fun rew_once (*1*)_ asm ct Noap [] = (ct, asm) (* ?TODO unify with Prog_Expr.rew_once? *)

        | rew_once (*2*)ruls asm ct Appl [] = 

          (case rls of Rule_Def.Repeat _ => rew_once ruls asm ct Noap ruls

          | Rule_Set.Sequence _ => (ct, asm)

          | rls => raise ERROR ("rew_once not appl. to \"" ^ Rule_Set.id rls ^ "\""))

        | rew_once (*3*)ruls asm ct apno (rul :: thms) =

          case rul of

            Rule.Thm (thmid, thm) =>

              (trace_in1 i "try thm" thmid;

              case rewrite__ thy (i + 1) bdv ((snd o #rew_ord o Rule_Set.rep) rls)

                  ((#erls o Rule_Set.rep) rls) put_asm thm ct of

                NONE => rew_once ruls asm ct apno thms

              | SOME (ct', asm') => 

                (trace_in2 i "rewrites to" thy ct';

                rew_once ruls (union (op =) asm asm') ct' Appl (rul :: thms)))

                (* once again try the same rule, e.g. associativity against "()"*)

          | Rule.Eval (cc as (op_, _)) => 

            let val _ = trace_in1 i "try calc" op_;

            in case Eval.adhoc_thm thy cc ct of

                NONE => rew_once ruls asm ct apno thms

              | SOME (_, thm') => 

                let 

                  val pairopt = rewrite__ thy (i + 1) bdv ((snd o #rew_ord o Rule_Set.rep) rls)

                    ((#erls o Rule_Set.rep) rls) put_asm thm' ct;

                  val _ = if pairopt <> NONE then () else raise ERROR (msg "rew_once" thy op_ thm' ct)

                  val _ = trace_in3 i "calc. to" thy pairopt;

                in rew_once ruls asm ((fst o the) pairopt) Appl (rul :: thms) end

            end

          | Rule.Cal1 (cc as (op_, _)) => 

            let val _ = trace_in1 i "try cal1" op_;

            in case Eval.adhoc_thm1_ thy cc ct of

                NONE => (ct, asm)

              | SOME (_, thm') =>

                let 

                  val pairopt = rewrite__ thy (i + 1) bdv ((snd o #rew_ord o Rule_Set.rep) rls)

                    ((#erls o Rule_Set.rep) rls) put_asm thm' ct;

                  val _ = if pairopt <> NONE then () else raise ERROR ("rewrite_set_, rewrite_ \"" ^

                     ThmC.string_of_thm thm' ^ "\" " ^ UnparseC.term_in_thy thy ct ^ " = NONE")

                  val _ = trace_in3 i "cal1. to" thy pairopt;

                in the pairopt end

            end

          | Rule.Rls_ rls' => 

            (case rewrite__set_ thy (i + 1) put_asm bdv rls' ct of

              SOME (t', asm') => rew_once ruls (union (op =) asm asm') t' Appl thms

            | NONE => rew_once ruls asm ct apno thms)

          | r => raise ERROR ("rew_once not appl. to \"" ^ Rule.to_string r ^ "\"");

      val ruls = (#rules o Rule_Set.rep) rls;

      val _ = trace_eq1 i "rls" rls thy ct

      val (ct', asm') = rew_once ruls [] ct Noap ruls;

	  in if ct = ct' then NONE else SOME (ct', distinct op =  asm') end

(*-------------------------------------------------------------*)

and app_rev thy i rrls t =             (* apply an Rrls; if not applicable proceed with subterms*)

  let (* check a (precond, pattern) of a rev-set; stops with 1st true *)

    fun chk_prepat _ _ [] _ = true

      | chk_prepat thy erls prepat t =

        let

          fun chk (pres, pat) =

            (let 

              val subst: Type.tyenv * Envir.tenv =

                Pattern.match thy (pat, t) (Vartab.empty, Vartab.empty)

             in

              snd (eval__true thy (i + 1) (map (Envir.subst_term subst) pres) [] erls)

             end) handle Pattern.MATCH => false

           fun scan_ _ [] = false

             | scan_ f (pp :: pps) =

               if f pp then true else scan_ f pps;

        in scan_ chk prepat end;

    (* apply the normal_form of a rev-set *)

    fun app_rev' thy (Rule_Set.Rrls {erls, prepat, scr = Rule.Rfuns {normal_form, ...}, ...}) t =

      if chk_prepat thy erls prepat t then normal_form t else NONE

      | app_rev' _ r _ = raise ERROR ("app_rev' not appl. to \"" ^ Rule_Set.id r ^ "\"");

    val opt = app_rev' thy rrls t

  in

    case opt of

      SOME (t', asm) => (t', asm, true)

    | NONE => app_sub thy i rrls t

  end

and app_sub thy i rrls t =                                          (* apply an Rrls to subterms*)

  case t of

    Const (s, T) => (Const(s, T), [], false)

  | Free (s, T) => (Free(s, T), [], false)

  | Var (n, T) => (Var(n, T), [], false)

  | Bound i => (Bound i, [], false)

  | Abs (s, T, body) => 

	  let val (t', asm, rew) = app_rev thy i rrls body

	  in (Abs(s, T, t'), asm, rew) end

  | t1 $ t2 => 

    let val (t2', asm2, rew2) = app_rev thy i rrls t2

    in

      if rew2 then (t1 $ t2', asm2, true)

      else

        let val (t1', asm1, rew1) = app_rev thy i rrls t1

        in if rew1 then (t1' $ t2, asm1, true)

           else (t1 $ t2, [], false)

        end

    end;

(* rewriting without argument [] for rew_ord *)

fun eval_true thy terms rls = (snd o (eval__true thy 1 terms [])) rls;

(* rewriting without internal arguments 1, [] *)

fun rewrite_ thy rew_ord erls bool thm term = rewrite__ thy 1 [] rew_ord erls bool thm term;

fun rewrite_set_ thy bool rls term = rewrite__set_ thy 1 bool [] rls term;

(* variants of rewrite; TODO del. put_asm *)

fun rewrite_inst_  thy rew_ord rls put_asm subst thm ct =

  rewrite__ thy 1 subst rew_ord rls put_asm thm ct;

fun rewrite_set_inst_ thy put_asm subst rls ct = rewrite__set_ thy 1 put_asm subst rls ct;

(* given a list of equalities (lhs = rhs) and a term, 

   replace all occurrences of lhs in the term with rhs;

   thus the order or equalities matters: put variables in lhs first. *)

fun rewrite_terms_ thy ord erls equs t =

  let

	  fun rew_ (t', asm') [] _ = (t', asm')

	    | rew_ (t', asm') (rules as r::rs) t =

	        let

	          val (t'', asm'', _(*lrd*), rew) = rew_sub thy 1 [] ord erls false [] (HOLogic.Trueprop $ r) t

	        in 

	          if rew 

	          then rew_ (t'', asm' @ asm'') rules t''

	          else rew_ (t', asm') rs t'

	        end

	  val (t'', asm'') = rew_ (TermC.empty, []) equs t

    in if t'' = TermC.empty then NONE else SOME (t'', asm'')

    end;

(* search ct for adjacent numerals and calculate them by operator isa_fn *)

fun calculate_ thy (isa_fn as (id, eval_fn)) t =

  case Eval.adhoc_thm thy isa_fn t of

	  NONE => NONE

	| SOME (thmID, thm) =>

	  (let val rew = case rewrite_ thy Rewrite_Ord.dummy_ord Rule_Set.empty false thm t of

        SOME (rew, _) => rew

      | NONE => raise ERROR (msg "calculate_" thy id thm t)

    in SOME (rew, (thmID, thm)) end)

	    handle NO_REWRITE => raise ERROR ("calculate_: " ^ thmID ^ " does not rewrite");

fun eval_prog_expr thy srls t =

  let val rew = rewrite_set_ thy false srls t;

  in case rew of SOME (res,_) => res | NONE => t end;

fun eval_true_ _ _ (Const (\<^const_name>\<open>True\<close>,_)) = true

  | eval_true_ thy rls t =

    case rewrite_set_ thy false rls t of

	   SOME (Const (\<^const_name>\<open>True\<close>,_),_) => true

	 | _ => false;

end