(* Title:  BaseDefinitions/rule-set.sml

   Author: Walther Neuper

   (c) due to copyright terms

In ISAC a Rule_Set serves rewriting. Know_Store holds all rule-sets for ubiquitous access.

*)                                       

signature RULE_SET =

sig

  datatype T = datatype Rule_Def.rule_set

  eqtype id

  val id: T -> string

  val rep: T -> {calc: Rule_Def.calc list, erls: T, errpats: Rule_Def.errpatID list, id: string,

    preconds: term list, rew_ord: Rewrite_Ord.T, rules: Rule_Def.rule list, scr: Rule_Def.program, srls: T}

  val to_string: T -> string

  val append_rules: string -> T -> Rule_Def.rule list -> T

  val append_erls_rules: string -> T -> Rule_Def.rule list -> T

  val keep_unique_rules: string -> T ->  Rule_Def.rule list -> T

  val merge: string -> T -> T -> T

  val get_rules: T -> Rule_Def.rule list

  val id_from_rule: Rule.rule -> string

  val contains: Rule.rule -> T -> bool

  type for_kestore

  val equal: (''a * ('b * 'c)) * (''a * ('d * 'e)) -> bool

  val to_kestore: for_kestore list * for_kestore list -> for_kestore list

(*/------- this will disappear eventually ----------------------------------------------------\*)

  val empty: T

  type rrlsstate = term * term * Rule_Def.rule list list * (Rule_Def.rule * (term * term list)) list

  val e_rrlsstate: rrlsstate

  val e_rrls: T

(*\------- this will disappear eventually ----------------------------------------------------/*)

\<^isac_test>\<open>

  val insert_merge: for_kestore -> for_kestore list -> for_kestore list

\<close>

end

(**)

structure Rule_Set(**): RULE_SET(**) =

struct

(**)

datatype T = datatype Rule_Def.rule_set;

type id = string;

(*/------- this will disappear eventually ----------------------------------------------------\*)

fun dummy_ord (_: LibraryC.subst) (_: term, _: term) = true;

val empty =

  Rule_Def.Repeat {id = "empty", preconds = [], rew_ord = ("dummy_ord", dummy_ord), erls = Rule_Def.Empty,

    srls = Rule_Def.Empty, calc = [], rules = [], errpatts = [], scr = Rule_Def.Empty_Prog}

(*\------- this will disappear eventually ----------------------------------------------------/*)

val id = Rule.set_id;

fun rep Rule_Def.Empty = rep empty

  | rep (Rule_Def.Repeat {id, preconds, rew_ord, erls, srls, calc, errpatts, rules, scr}) =

    {id = id, preconds = preconds, rew_ord = rew_ord, erls = erls, srls = srls, errpats = errpatts,

      calc = calc, rules = rules, scr = scr}

  | rep (Rule_Def.Sequence {id, preconds, rew_ord, erls, srls, calc, errpatts, rules, scr}) =

    {id = id, preconds = preconds, rew_ord = rew_ord, erls = erls, srls = srls, errpats = errpatts,

      calc = calc, rules = rules, scr = scr}

  | rep (Rule_Def.Rrls _)  = rep empty

fun to_string Rule_Def.Empty = "Rule_Set.Empty"

  | to_string (Rule_Def.Repeat {id, preconds, rew_ord, erls = _, srls = _, calc = _, errpatts = _, rules, scr}) =

    "(Rule_Def.Repeat {id = " ^ id ^ ", preconds = " ^ UnparseC.terms preconds ^ ", rew_ord = " ^ Rewrite_Ord.to_string rew_ord

    ^ ",\n  erls = _, srls = _, calc = _, errpatts = _, "

    ^ ",\n  rules = " ^ Rule.s_to_string rules

    ^ ",\n  rules = " ^ Rule_Def.program_to_string scr ^ "})"

  | to_string (Rule_Def.Sequence {id, preconds, rew_ord, erls = _, srls = _, calc = _, errpatts = _, rules, scr}) =

    "(Rule_Def.Repeat {id = " ^ id ^ ", preconds = " ^ UnparseC.terms preconds ^ ", rew_ord = " ^ Rewrite_Ord.to_string rew_ord

    ^ ",\n  erls = _, srls = _, calc = _, errpatts = _, "

    ^ ",\n  rules = " ^ Rule.s_to_string rules

    ^ ",\n  rules = " ^ Rule_Def.program_to_string scr ^ "})"

  | to_string (Rule_Def.Rrls _)  = "Rule_Def.Rrls _"

fun append_rules id Rule_Def.Empty r = (*.. required for append_erls_rules *)

    Rule_Def.Repeat {id = id, preconds = [], rew_ord = ("dummy_ord", dummy_ord), erls = Rule_Def.Empty, 

      srls = Rule_Def.Empty, calc = [], rules = r, errpatts = [], scr = Rule_Def.Empty_Prog}

  | append_rules id (Rule_Def.Repeat {id = _, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,

			rules = rs, errpatts = errpatts, scr = sc}) r =

    Rule_Def.Repeat {id = id, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,

      rules = rs @ r, errpatts = errpatts, scr = sc}

  | append_rules id (Rule_Def.Sequence {id = _, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,

			rules = rs, errpatts = errpatts, scr = sc}) r =

    Rule_Def.Sequence {id = id, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,

      rules = rs @ r, errpatts = errpatts, scr = sc}

  | append_rules id (Rule_Def.Rrls _) _ = raise ERROR ("append_rules: not for reverse-rewrite-rule-set " ^ id);

fun append_erls_rules id_erls Rule_Def.Empty _ =

    raise ERROR ("append_erls_rules: with \"" ^ id_erls ^ "\" not for Rule_Def.Empty")

  | append_erls_rules id_erls (Rule_Def.Repeat 

    {id = id, preconds = pc, rew_ord = ro, erls = erls, srls = sr, calc = ca,

			rules = rules, errpatts = errpatts, scr = sc}) rs =

    Rule_Def.Repeat {id = id, preconds = pc, rew_ord = ro, erls = append_rules id_erls erls rs, 

      srls = sr, calc = ca, rules = rules, errpatts = errpatts, scr = sc}

  | append_erls_rules id_erls (Rule_Def.Sequence

    {id = id, preconds = pc, rew_ord = ro, erls = erls, srls = sr, calc = ca,

			rules = rules, errpatts = errpatts, scr = sc}) rs =

    Rule_Def.Sequence {id = id, preconds = pc, rew_ord = ro, erls = append_rules id_erls erls rs,

      srls = sr, calc = ca, rules = rules, errpatts = errpatts, scr = sc}

  | append_erls_rules id_erls (Rule_Def.Rrls _) _ =

    raise ERROR ("append_erls_rules: not for reverse-rewrite-rule-set " ^ id_erls);

fun merge_ids rls1 rls2 =

  let 

    val id1 = (#id o rep) rls1

    val id2 = (#id o rep) rls2

  in

    if id1 = id2 then id1 else "merged_" ^ id1 ^ "_" ^ id2

  end

fun merge _ Rule_Def.Empty rls = rls

  | merge _ rls Rule_Def.Empty = rls

  | merge _ (Rrls x) _ = Rrls x (* required for merging Theory_Data *)

  | merge _ _ (Rrls x) = Rrls x

  | merge id

	  (Rule_Def.Repeat {preconds = pc1, rew_ord = ro1, erls = er1, srls = sr1, calc = ca1,

	    rules = rs1, errpatts = eps1, scr = sc1, ...})

	  (Rule_Def.Repeat {preconds = pc2, erls = er2, srls = sr2, calc = ca2,

	    rules = rs2, errpatts = eps2, ...})

    =

	  Rule_Def.Repeat {id = id, rew_ord = ro1, scr = sc1,

	    preconds = union (op =) pc1 pc2,	    

	    erls = merge (merge_ids er1 er2) er1 er2,

	    srls = merge (merge_ids sr1 sr2) sr1 sr2,

	    calc = union Eval_Def.calc_eq ca1 ca2,

		  rules = union Rule.equal rs1 rs2,

      errpatts = union (op =) eps1 eps2}

  | merge id

	  (Rule_Def.Sequence {preconds = pc1, rew_ord = ro1, erls = er1, srls = sr1, calc = ca1,

	    rules = rs1, errpatts = eps1, scr = sc1, ...})

	  (Rule_Def.Sequence {preconds = pc2, erls = er2, srls = sr2, calc = ca2,

	    rules = rs2, errpatts = eps2, ...})

    =

	  Rule_Def.Sequence {id = id, rew_ord = ro1, scr = sc1,

	    preconds = union (op =) pc1 pc2,	    

	    erls = merge (merge_ids er1 er2) er1 er2,

	    srls = merge (merge_ids sr1 sr2) sr1 sr2,

	    calc = union Eval_Def.calc_eq ca1 ca2,

		  rules = union Rule.equal rs1 rs2,

      errpatts = union (op =) eps1 eps2}

  | merge id _ _ = raise ERROR ("merge: \"" ^ id ^ 

    "\"; not for reverse-rewrite-rule-sets and not for mixed Rls -- Rule_Def.Sequence");

(* datastructure for KEStore_Elems, intermediate for thehier *)

type for_kestore = 

  (id *     (* id unique within Isac *)

  (ThyC.id *  (* just for assignment in thehier, not appropriate for parsing etc *)

    T))     (* ((#id o rep) T) = id   by coding discipline *)

fun equal ((id1, (_, _)), (id2, (_, _))) = id1 = id2

fun insert_merge (re as (id, (thyID, r1))) ys = 

    case get_index (fn y => if curry equal re y then SOME y else NONE) ys of

      NONE => re :: ys

    | SOME (i, (_, (_, r2))) => 

      let

        val r12 = merge id r1 r2

      in list_update ys i (id, (thyID, r12)) end

fun to_kestore (s1, s2) = fold insert_merge s1 s2;

(* used only for one hack *)

fun keep_unique_rules id 

     (Rule_Def.Repeat {id = _, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,

  		  rules = rs, errpatts = eps, scr = sc}) r =

      Rule_Def.Repeat {id = id, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,

  	    rules = gen_rems Rule.equal (rs, r),

  	    errpatts = eps,

  	    scr = sc}

  | keep_unique_rules id

     (Rule_Def.Sequence {id = _, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,

  		  rules = rs, errpatts = eps, scr = sc}) r =

      Rule_Def.Sequence {id = id, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,

  	    rules = gen_rems Rule.equal (rs, r),

  	    errpatts = eps,

  	    scr = sc}

  | keep_unique_rules id (Rule_Def.Rrls _) _ = raise ERROR ("keep_unique_rules: not for reverse-rewrite-rule-set "^id)

  | keep_unique_rules _ rls _ = raise ERROR ("remove_rls called with " ^ id rls);

fun get_rules Rule_Def.Empty = []

  | get_rules (Rule_Def.Repeat {rules, ...}) = rules

  | get_rules (Rule_Def.Sequence {rules, ...}) = rules

  | get_rules (Rule_Def.Rrls _) = [];

fun id_from_rule (Rule.Rls_ rls) = id rls

  | id_from_rule r = raise ERROR ("id_from_rule: not defined for " ^ Rule.to_string r);

(* check if a rule is contained in a rule-set (recursivley down in Rls_);

   this rule can even be a rule-set itself                             *)

fun contains r rls = 

  let 

    fun (*find (_, Rls_ rls) = finds (get_rules rls)

      | find r12 = equal r12

    and*) finds [] = false

    | finds (r1 :: rs) = if Rule.equal (r, r1) then true else finds rs

  in 

    finds (get_rules rls) 

  end

(*/------- this will disappear eventually -----------\*)

type rrlsstate =  (* state for reverse rewriting, comments see type rule and scr | Rfuns *)

  (term * term * Rule_Def.rule list list * (Rule_Def.rule * (term * term list)) list);

val e_rrlsstate = (UnparseC.term_empty, UnparseC.term_empty, [[Rule_Def.Erule]], [(Rule_Def.Erule, (UnparseC.term_empty, []))]) : rrlsstate;

local           

    fun ii (_: term) = e_rrlsstate;

    fun no (_: term) = SOME (UnparseC.term_empty, [UnparseC.term_empty]);

    fun lo (_: Rule_Def.rule list list) (_: term) (_: Rule_Def.rule) = [(Rule_Def.Erule, (UnparseC.term_empty, [UnparseC.term_empty]))];

    fun ne (_: Rule_Def.rule list list) (_: term) = SOME Rule_Def.Erule;

    fun fo (_: Rule_Def.rule list list) (_: term) (_: term) = [(Rule_Def.Erule, (UnparseC.term_empty, [UnparseC.term_empty]))];

in

val e_rfuns = Rule_Def.Rfuns {init_state = ii, normal_form = no, locate_rule = lo,

		  next_rule = ne, attach_form = fo};

end;

val e_rrls =

  Rule_Def.Rrls {id = "e_rrls", prepat = [], rew_ord = ("dummy_ord", dummy_ord), erls = Rule_Def.Empty,

    calc = [], errpatts = [], scr = e_rfuns}

(*\------- this will disappear eventually -----------/*)

(**)end(**)