src/Tools/Argo/argo_rewr.ML

HOL-Analysis: move Product_Vector and Inner_Product from Library

(*  Title:      Tools/Argo/argo_rewr.ML
    Author:     Sascha Boehme

Bottom-up rewriting of expressions based on rewrite rules and rewrite functions.
*)

signature ARGO_REWR =
sig
  (* patterns *)
  datatype pattern =
    V of int |
    E of Argo_Expr.expr |
    A of Argo_Expr.kind |
    P of Argo_Expr.kind * pattern list |
    M of pattern |
    X

  (* scanning patterns from strings *)
  val scan: string -> pattern

  (* pattern matching *)
  type env
  val get_all: env -> Argo_Expr.expr list
  val get: env -> int -> Argo_Expr.expr

  (* conversions *)
  type conv = Argo_Expr.expr -> Argo_Expr.expr * Argo_Proof.conv
  val keep: conv
  val seq: conv list -> conv
  val args: conv -> conv
  val rewr: Argo_Proof.rewrite -> Argo_Expr.expr -> conv

  (* context *)
  type context
  val context: context
  val flat: string ->
    (int -> Argo_Expr.expr list -> (Argo_Proof.rewrite * Argo_Expr.expr) option) ->
    context -> context
  val func: string -> (env -> (Argo_Proof.rewrite * pattern) option) -> context -> context
  val rule: Argo_Proof.rewrite -> string -> string -> context -> context

  (* rewriting *)
  val rewrite: context -> conv
  val rewrite_top: context -> conv
  val with_proof: conv -> Argo_Expr.expr * Argo_Proof.proof -> Argo_Proof.context ->
    (Argo_Expr.expr * Argo_Proof.proof) * Argo_Proof.context
end

structure Argo_Rewr: ARGO_REWR =
struct

(* patterns *)

(*
  Patterns are used for matching against expressions and as a schema to construct
  expressions. For matching, only V, E, A and P must be used. For the schema,
  additionally M and X can be used.
*)

datatype pattern =
  V of int | (* indexed placeholder where the index must be greater than 0 *)
  E of Argo_Expr.expr | (* expression without placeholders *)
  A of Argo_Expr.kind | (* placeholder for the arguments of an n-ary expression *)
  P of Argo_Expr.kind * pattern list | (* expression with optional placeholders *)
  M of pattern | (* mapping operator to iterate over an argument list of an n-ary expression *)
  X (* closure argument under a mapping operator representing an expression *)

fun int_of_pattern (E _) = 0
  | int_of_pattern (P _) = 1
  | int_of_pattern (A _) = 2
  | int_of_pattern (V _) = 3
  | int_of_pattern _ = raise Fail "bad pattern"

(*
  Specific patterns are ordered before generic patterns, since pattern matching
  performs a linear search for the most suitable pattern.
*)

fun pattern_ord (E e1, E e2) = Argo_Expr.expr_ord (e1, e2)
  | pattern_ord (P (k1, ps1), P (k2, ps2)) =
      (case Argo_Expr.kind_ord (k1, k2) of EQUAL => list_ord pattern_ord (ps1, ps2) | x => x)
  | pattern_ord (A k1, A k2) = Argo_Expr.kind_ord (k1, k2)
  | pattern_ord (V i1, V i2) = int_ord (i1, i2)
  | pattern_ord (p1, p2) = int_ord (int_of_pattern p1, int_of_pattern p2)


(* scanning patterns from strings *)

(*
  The pattern language is cumbersome to use in other structures. Strings are a more
  lightweight representation. Scanning patterns from strings should be performed at
  compile time to avoid the parsing overhead at runtime.
*)

val kind = Scan.many1 Symbol.is_ascii_letter >> (Argo_Expr.kind_of_string o implode)
val num = Scan.many1 Symbol.is_ascii_digit >> (the o Int.fromString o implode)
val integer = $$ "-" |-- num >> ~ || num
val blank = Scan.many1 Symbol.is_ascii_blank >> K ()

fun pattern xs = (
  kind >> (P o rpair []) ||
  $$ "!" >> K X ||
  $$ "(" -- $$ "#" -- blank |-- pattern --| $$ ")" >> M ||
  $$ "(" -- $$ "?" -- blank |-- num --| $$ ")" >> V ||
  $$ "(" -- Scan.this_string "num" -- blank |-- integer --| $$ ")" >>
    (E o Argo_Expr.mk_num o Rat.of_int) ||
  $$ "(" |-- kind --| blank --| $$ "_" --| $$ ")" >> A ||
  $$ "(" |-- kind -- Scan.repeat1 (blank |-- pattern) --| $$ ")" >> P) xs

fun scan s = fst (pattern (map str (String.explode s) @ [""]))


(* pattern matching *)

exception PATTERN of unit

(*
  The environment stores the matched expressions for the pattern placeholders.
  The expression for an indexed placeholder (V i) can be retrieved by "get env i".
  The argument expressions for an n-ary placeholder (A k) can be retrieved by "get_all env".
*)

type env = Argo_Expr.expr list Inttab.table

val empty_env: env = Inttab.empty
fun get_all env = Inttab.lookup_list env 0
fun get env i = hd (Inttab.lookup_list env i)

fun depth_of (V _) = 0
  | depth_of (E _) = 0
  | depth_of (A _) = 1
  | depth_of (P (_, ps)) = 1 + fold (Integer.max o depth_of) ps 0
  | depth_of (M p) = depth_of p
  | depth_of X = 0

fun match_list f k k' env = if k = k' then f env else raise PATTERN ()

fun match (V i) e env = Inttab.update_new (i, [e]) env
  | match (A k) (Argo_Expr.E (k', es)) env = match_list (Inttab.update_new (0, es)) k k' env
  | match (P (k, ps)) (Argo_Expr.E (k', es)) env = match_list (fold2 match ps es) k k' env
  | match _ _ _ = raise Fail "bad pattern"

fun unfold_index env (V i) _ = get env i
  | unfold_index _ (E e) _ = e
  | unfold_index env (P (k, ps)) e = Argo_Expr.E (k, map (fn p => unfold_index env p e) ps)
  | unfold_index _ X e = e
  | unfold_index _ _ _ = raise Fail "bad pattern"

fun unfold_pattern env (V i) = get env i
  | unfold_pattern _ (E e) = e
  | unfold_pattern env (A k) = Argo_Expr.E (k, get_all env)
  | unfold_pattern env (P (k, [M p])) = Argo_Expr.E (k, map (unfold_index env p) (get_all env))
  | unfold_pattern env (P (k, ps)) = Argo_Expr.E (k, map (unfold_pattern env) ps)
  | unfold_pattern _ _ = raise Fail "bad pattern"


(* conversions *)

(*
  Conversions are atomic rewrite steps. For every conversion there is a corresponding
  inference step.
*)

type conv = Argo_Expr.expr -> Argo_Expr.expr * Argo_Proof.conv

fun keep e = (e, Argo_Proof.keep_conv)

fun seq [] e = keep e
  | seq [cv] e = cv e
  | seq (cv :: cvs) e =
      let val ((e, c2), c1) = cv e |>> seq cvs
      in (e, Argo_Proof.mk_then_conv c1 c2) end

fun args cv (Argo_Expr.E (k, es)) =
  let val (es, cs) = split_list (map cv es)
  in (Argo_Expr.E (k, es), Argo_Proof.mk_args_conv cs) end

fun rewr r e _ = (e, Argo_Proof.mk_rewr_conv r)


(* context *)

(*
  The context stores functions to flatten expressions and functions to rewrite expressions.
  Flattening an n-ary expression of kind k produces an expression whose arguments are not
  of kind k. For instance, flattening (and p (and q r)) produces (and p q r) where p, q and r
  are not conjunctions.
*)

structure Pattab = Table(type key = pattern val ord = pattern_ord)

type context = {
  flats:
    (Argo_Expr.kind * (int -> Argo_Expr.expr list -> (Argo_Proof.rewrite * Argo_Expr.expr) option))
      list, (* expressions that should be flattened before rewriting *)
  rewrs: (env -> (Argo_Proof.rewrite * pattern) option) list Pattab.table}
    (* Looking up matching rules is O(n). This could be optimized. *)

fun mk_context flats rewrs: context = {flats=flats, rewrs=rewrs}
val context = mk_context [] Pattab.empty

fun map_context map_flats map_rewrs ({flats, rewrs}: context) =
  mk_context (map_flats flats) (map_rewrs rewrs)

fun flat lhs f =
  (case scan lhs of
    A k => map_context (cons (k, f)) I
  | _ => raise Fail "bad pattern")

fun func lhs f = map_context I (Pattab.map_default (scan lhs, []) (fn fs => fs @ [f]))
fun rule r lhs rhs = func lhs (K (SOME (r, scan rhs)))


(* rewriting *)

(*
  Rewriting proceeds bottom-up. Whenever a rewrite rule with placeholders is used,
  the arguments are again rewritten, but only up to depth of the placeholders within the
  matched pattern.
*)

fun rewr_rule r env p = rewr r (unfold_pattern env p)

fun try_apply p e f =
  let val env = match p e empty_env
  in (case f env of NONE => NONE | SOME (r, p) => SOME (r, env, p)) end
  handle PATTERN () => NONE

fun all_args cv k (e as Argo_Expr.E (k', _)) = if k = k' then args (all_args cv k) e else cv e
fun all_args_of k (e as Argo_Expr.E (k', es)) = if k = k' then maps (all_args_of k) es else [e]
fun kind_depth_of k (Argo_Expr.E (k', es)) =
  if k = k' then 1 + fold (Integer.max o kind_depth_of k) es 0 else 0

fun descend cv flats (e as Argo_Expr.E (k, _)) =
  if AList.defined Argo_Expr.eq_kind flats k then all_args cv k e
  else args cv e

fun flatten flats (e as Argo_Expr.E (k, _)) =
  (case AList.lookup Argo_Expr.eq_kind flats k of
    NONE => keep e
  | SOME f =>
      (case f (kind_depth_of k e) (all_args_of k e) of
        NONE => keep e
      | SOME (r, e') => rewr r e' e))

fun exhaust cv rewrs e =
  (case Pattab.get_first (fn (p, fs) => get_first (try_apply p e) fs) rewrs of
    NONE => keep e
  | SOME (r, env, p) => seq [rewr_rule r env p, cv (depth_of p)] e)

fun norm (cx as {flats, rewrs}: context) d e =
  seq [
    if d = 0 then keep else descend (norm cx (d - 1)) flats,
    flatten flats,
    exhaust (norm cx) rewrs] e

fun rewrite cx = norm cx ~1   (* bottom-up rewriting *)
fun rewrite_top cx = norm cx 0   (* top-down rewriting *)

fun with_proof cv (e, p) prf =
  let
    val (e, c) = cv e
    val (p, prf) = Argo_Proof.mk_rewrite c p prf
  in ((e, p), prf) end

end