axiom-source 20170501-3 / usr / share / axiom-20170501 / src / algebra / PATTERN.spad

)abbrev domain PATTERN Pattern
++ Author: Manuel Bronstein
++ Date Created: 10 Nov 1988
++ Date Last Updated: 20 June 1991
++ Description:
++ Patterns for use by the pattern matcher.
-- Not exposed.
-- Patterns are optimized for quick answers to structural questions.

Pattern(R) : SIG == CODE where
  R : SetCategory

  B   ==> Boolean
  SI  ==> SingleInteger
  Z   ==> Integer
  SY  ==> Symbol
  O   ==> OutputForm
  BOP ==> BasicOperator
  QOT ==> Record(num:%, den:%)
  REC ==> Record(val:%, exponent:NonNegativeInteger)
  RSY ==> Record(tag:SI, val: SY, pred:List Any, bad:List Any)
  KER ==> Record(tag:SI, op:BOP, arg:List %)
  PAT ==> Union(ret:R, ker: KER, exp:REC, qot: QOT, sym:RSY)
  -- the following MUST be the name of the formal exponentiation operator
  POWER ==> "%power"::Symbol
  -- the 4 SYM_ constants must be disting powers of 2 (bitwise arithmetic)
  SYM_GENERIC  ==> 1::SI
  SYM_MULTIPLE ==> 2::SI
  SYM_OPTIONAL ==> 4::SI
  PAT_PLUS     ==> 1::SI
  PAT_TIMES    ==> 2::SI
  PAT_LIST     ==> 3::SI
  PAT_ZERO     ==> 4::SI
  PAT_ONE      ==> 5::SI
  PAT_EXPT     ==> 6::SI
 
  SIG ==> Join(SetCategory, RetractableTo R, RetractableTo SY) with

    0 : constant -> %
      ++ \spad{0} is constant

    1 : constant -> %
      ++ \spad{1} is constant

    isPlus : % -> Union(List %, "failed")
      ++ isPlus(p) returns \spad{[a1,...,an]} if \spad{n > 1}
      ++  and \spad{p = a1 + ... + an},
      ++ and "failed" otherwise.

    isTimes : % -> Union(List %, "failed")
      ++ isTimes(p) returns \spad{[a1,...,an]} if \spad{n > 1} and 
      ++ \spad{p = a1 * ... * an}, and
      ++ "failed" otherwise.

    isOp : (%, BOP) -> Union(List %, "failed")
      ++ isOp(p, op) returns \spad{[a1,...,an]} if \spad{p = op(a1,...,an)},
      ++ and "failed" otherwise.

    isOp : % -> Union(Record(op:BOP, arg:List %), "failed")
      ++ isOp(p) returns \spad{[op, [a1,...,an]]} if 
      ++ \spad{p = op(a1,...,an)}, and
      ++ "failed" otherwise;

    isExpt : % -> Union(REC, "failed")
      ++ isExpt(p) returns \spad{[q, n]} if \spad{n > 0} and \spad{p = q ** n},
      ++ and "failed" otherwise.

    isQuotient : % -> Union(QOT, "failed")
      ++ isQuotient(p) returns \spad{[a, b]} if \spad{p = a / b}, and
      ++ "failed" otherwise.

    isList : % -> Union(List %, "failed")
      ++ isList(p) returns \spad{[a1,...,an]} if \spad{p = [a1,...,an]},
      ++ "failed" otherwise;

    isPower : % -> Union(Record(val:%, exponent:%), "failed")
      ++ isPower(p) returns \spad{[a, b]} if \spad{p = a ** b}, and
      ++ "failed" otherwise.

    elt : (BOP, List %) -> %
      ++ \spad{elt(op, [a1,...,an])} returns \spad{op(a1,...,an)}.

    "+" : (%, %) -> %
      ++ \spad{a + b} returns the pattern \spad{a + b}.

    "*" : (%, %) -> %
      ++ \spad{a * b} returns the pattern \spad{a * b}.

    "**" : (%, NonNegativeInteger) -> %
      ++ \spad{a ** n} returns the pattern \spad{a ** n}.

    "**" : (%, %) -> %
      ++ \spad{a ** b} returns the pattern \spad{a ** b}.

    "/" : (%, %) -> %
      ++ \spad{a / b} returns the pattern \spad{a / b}.

    depth : % -> NonNegativeInteger
      ++ depth(p) returns the nesting level of p.

    convert : List % -> %
      ++ \spad{convert([a1,...,an])} returns the pattern \spad{[a1,...,an]}.

    copy : %  -> %
      ++ copy(p) returns a recursive copy of p.

    inR? : %  -> B
      ++ inR?(p) tests if p is an atom (an element of R).

    quoted? : %  -> B
      ++ quoted?(p) tests if p is of the form 's for a symbol s.

    symbol? : %  -> B
      ++ symbol?(p) tests if p is a symbol.

    constant? : %  -> B
      ++ constant?(p) tests if p contains no matching variables.

    generic? : %  -> B
      ++ generic?(p) tests if p is a single matching variable.

    multiple? : %  -> B
      ++ multiple?(p) tests if p is a single matching variable
      ++ allowing list matching or multiple term matching in a
      ++ sum or product.

    optional? : %  -> B
      ++ optional?(p) tests if p is a single matching variable
      ++ which can match an identity.

    hasPredicate? : %  -> B
      ++ hasPredicate?(p) tests if p has predicates attached to it.

    predicates : %  -> List Any
      ++ predicates(p) returns \spad{[p1,...,pn]} such that the predicate
      ++ attached to p is p1 and ... and pn.

    setPredicates : (%, List Any) -> %
      ++ \spad{setPredicates(p, [p1,...,pn])} attaches the predicate
      ++ p1 and ... and pn to p.

    withPredicates : (%, List Any) -> %
      ++ \spad{withPredicates(p, [p1,...,pn])} makes a copy of p and attaches
      ++ the predicate p1 and ... and pn to the copy, which is
      ++ returned.

    patternVariable : (SY, B, B, B) -> %
      ++ patternVariable(x, c?, o?, m?) creates a pattern variable x,
      ++ which is constant if \spad{c? = true}, optional if \spad{o? = true}, 
      ++ and multiple if \spad{m? = true}.

    setTopPredicate : (%, List SY, Any) -> %
      ++ \spad{setTopPredicate(x, [a1,...,an], f)} returns x with
      ++ the top-level predicate set to \spad{f(a1,...,an)}.

    topPredicate : % -> Record(var:List SY, pred:Any)
      ++ topPredicate(x) returns \spad{[[a1,...,an], f]} where the top-level
      ++ predicate of x is \spad{f(a1,...,an)}. 
      ++ Note: n is 0 if x has no top-level
      ++ predicate.

    hasTopPredicate? : % -> B
      ++ hasTopPredicate?(p) tests if p has a top-level predicate.

    resetBadValues : % -> %
      ++ resetBadValues(p) initializes the list of "bad values" for p
      ++ to \spad{[]}.
      ++ Note: p is not allowed to match any of its "bad values".

    addBadValue : (%, Any) -> %
      ++ addBadValue(p, v) adds v to the list of "bad values" for p.
      ++ Note: p is not allowed to match any of its "bad values".

    getBadValues : % -> List Any
      ++ getBadValues(p) returns the list of "bad values" for p.
      ++ Note: p is not allowed to match any of its "bad values".

    variables : % -> List %
      ++ variables(p) returns the list of matching variables
      ++ appearing in p.

    optpair : List % -> Union(List %, "failed")
      ++ optpair(l) returns l has the form \spad{[a, b]} and
      ++ a is optional, and
      ++ "failed" otherwise;
 
  CODE ==> add

    Rep := Record(cons?: B, pat:PAT, lev: NonNegativeInteger,
                  topvar: List SY, toppred: Any)
 
    dummy:BOP := operator(new()$Symbol)

    nopred    := coerce(0$Integer)$AnyFunctions1(Integer)
 
    mkPat     : (B, PAT, NonNegativeInteger) -> %

    mkrsy     : (SY, B, B, B)  -> RSY

    SYM2O     : RSY -> O

    PAT2O     : PAT -> O

    patcopy   : PAT -> PAT

    bitSet?   : (SI ,  SI) -> B

    pateq?    : (PAT, PAT) -> B

    LPAT2O    : ((O, O) -> O, List %) -> O

    taggedElt : (SI, List %) -> %

    isTaggedOp: (%, SI) -> Union(List %, "failed")

    incmax    : List % -> NonNegativeInteger
 
    coerce(r:R):%   == mkPat(true, [r], 0)

    mkPat(c, p, l)  == [c, p, l, empty(), nopred]

    hasTopPredicate? x == not empty?(x.topvar)

    topPredicate x  == [x.topvar, x.toppred]

    setTopPredicate(x, l, f) == (x.topvar := l; x.toppred := f; x)

    constant? p     == p.cons?

    depth p         == p.lev

    inR? p          == p.pat case ret

    symbol? p       == p.pat case sym

    isPlus p        == isTaggedOp(p, PAT_PLUS)

    isTimes p       == isTaggedOp(p, PAT_TIMES)

    isList p        == isTaggedOp(p, PAT_LIST)

    isExpt p        == (p.pat case exp => p.pat.exp; "failed")

    isQuotient p    == (p.pat case qot => p.pat.qot; "failed")

    hasPredicate? p == not empty? predicates p

    quoted? p       == symbol? p and zero?(p.pat.sym.tag)

    generic? p      == symbol? p and bitSet?(p.pat.sym.tag, SYM_GENERIC)

    multiple? p     == symbol? p and bitSet?(p.pat.sym.tag,SYM_MULTIPLE)

    optional? p     == symbol? p and bitSet?(p.pat.sym.tag,SYM_OPTIONAL)

    bitSet?(a, b)   == And(a, b) ^= 0

    coerce(p:%):O   == PAT2O(p.pat)

    p1:% ** p2:%    == taggedElt(PAT_EXPT, [p1, p2])

    LPAT2O(f, l)    == reduce(f, [x::O for x in l])$List(O)

    retract(p:%):R  == (inR? p => p.pat.ret; error "Not retractable")

    convert(l:List %):%                 == taggedElt(PAT_LIST, l)

    retractIfCan(p:%):Union(R,"failed") ==(inR? p => p.pat.ret;"failed")

    withPredicates(p, l)                == setPredicates(copy p, l)

    coerce(sy:SY):%          == patternVariable(sy, false, false, false)

    copy p  == [constant? p, patcopy(p.pat), p.lev, p.topvar, p.toppred]
 
    -- returns [a, b] if #l = 2 and optional? a, "failed" otherwise
    optpair l ==
      empty? rest rest l =>
        b := first rest l
        optional?(a := first l) => l
        optional? b => reverse l
        "failed"
      "failed"
 
    incmax l ==
      1 + reduce("max", [p.lev for p in l], 0)$List(NonNegativeInteger)
 
    p1 = p2 ==
      (p1.cons? = p2.cons?) and (p1.lev = p2.lev) and
        (p1.topvar = p2.topvar) and
          ((EQ(p1.toppred, p2.toppred)$Lisp) pretend B) and
            pateq?(p1.pat, p2.pat)
 
    isPower p ==
      (u := isTaggedOp(p, PAT_EXPT)) case "failed" => "failed"
      [first(u::List(%)), second(u::List(%))]
 
    taggedElt(n, l) ==
      mkPat(every?(constant?, l), [[n, dummy, l]$KER], incmax l)
 
    elt(o, l) ==
      is?(o, POWER) and #l = 2 => first(l) ** last(l)
      mkPat(every?(constant?, l), [[0, o, l]$KER], incmax l)
 
    isOp p ==
      (p.pat case ker) and zero?(p.pat.ker.tag) =>
        [p.pat.ker.op, p.pat.ker.arg]
      "failed"
 
    isTaggedOp(p,t) ==
      (p.pat case ker) and (p.pat.ker.tag = t) => p.pat.ker.arg
      "failed"
 
    if R has Monoid then

      1 == 1::R::%

    else

      1 == taggedElt(PAT_ONE,  empty())
 
    if R has AbelianMonoid then

      0 == 0::R::%

    else

      0 == taggedElt(PAT_ZERO, empty())
 
    p:% ** n:NonNegativeInteger ==
      p = 0 and n > 0 => 0
      p = 1 or zero? n => 1
      (n = 1) => p
      mkPat(constant? p, [[p, n]$REC], 1 + (p.lev))
 
    p1 / p2 ==
      p2 = 1 => p1
      mkPat(constant? p1 and constant? p2, [[p1, p2]$QOT],
                                      1 + max(p1.lev, p2.lev))
 
    p1 + p2 ==
      p1 = 0 => p2
      p2 = 0 => p1
      (u1 := isPlus p1) case List(%) =>
        (u2 := isPlus p2) case List(%) =>
          taggedElt(PAT_PLUS, concat(u1::List %, u2::List %))
        taggedElt(PAT_PLUS, concat(u1::List %, p2))
      (u2 := isPlus p2) case List(%) =>
        taggedElt(PAT_PLUS, concat(p1, u2::List %))
      taggedElt(PAT_PLUS, [p1, p2])
 
    p1 * p2 ==
      p1 = 0 or p2 = 0 => 0
      p1 = 1 => p2
      p2 = 1 => p1
      (u1 := isTimes p1) case List(%) =>
        (u2 := isTimes p2) case List(%) =>
          taggedElt(PAT_TIMES, concat(u1::List %, u2::List %))
        taggedElt(PAT_TIMES, concat(u1::List %, p2))
      (u2 := isTimes p2) case List(%) =>
        taggedElt(PAT_TIMES, concat(p1, u2::List %))
      taggedElt(PAT_TIMES, [p1, p2])
 
    isOp(p, o) ==
      (p.pat case ker) and zero?(p.pat.ker.tag) and (p.pat.ker.op =o) =>
        p.pat.ker.arg
      "failed"
 
    predicates p ==
      symbol? p => p.pat.sym.pred
      empty()
 
    setPredicates(p, l) ==
      generic? p => (p.pat.sym.pred := l; p)
      error "Can only attach predicates to generic symbol"
 
    resetBadValues p ==
      generic? p => (p.pat.sym.bad := empty()$List(Any); p)
      error "Can only attach bad values to generic symbol"
 
    addBadValue(p, a) ==
      generic? p =>
        if not member?(a, p.pat.sym.bad) then
          p.pat.sym.bad := concat(a, p.pat.sym.bad)
        p
      error "Can only attach bad values to generic symbol"
 
    getBadValues p ==
      generic? p => p.pat.sym.bad
      error "Not a generic symbol"
 
    SYM2O p ==
      sy := (p.val)::O
      empty?(p.pred) => sy
      paren infix(" | "::O, sy,
        reduce("and",[sub("f"::O, i::O) for i in 1..#(p.pred)])$List(O))
 
    variables p ==
      constant? p => empty()
      generic? p => [p]
      q := p.pat
      q case ret => empty()
      q case exp => variables(q.exp.val)
      q case qot => concat_!(variables(q.qot.num), variables(q.qot.den))
      q case ker => concat [variables r for r in q.ker.arg]
      empty()
 
    PAT2O p ==
      p case ret => (p.ret)::O
      p case sym => SYM2O(p.sym)
      p case exp => (p.exp.val)::O ** (p.exp.exponent)::O
      p case qot => (p.qot.num)::O / (p.qot.den)::O
      p.ker.tag = PAT_PLUS  => LPAT2O("+", p.ker.arg)
      p.ker.tag = PAT_TIMES => LPAT2O("*", p.ker.arg)
      p.ker.tag = PAT_LIST => (p.ker.arg)::O
      p.ker.tag = PAT_ZERO => 0::Integer::O
      p.ker.tag = PAT_ONE  => 1::Integer::O
      l := [x::O for x in p.ker.arg]$List(O)
      (u:=display(p.ker.op)) case "failed" =>prefix(name(p.ker.op)::O,l)
      (u::(List O -> O)) l
 
    patcopy p ==
      p case ret => [p.ret]
      p case sym =>
        [[p.sym.tag, p.sym.val, copy(p.sym.pred), copy(p.sym.bad)]$RSY]
      p case ker=>[[p.ker.tag,p.ker.op,[copy x for x in p.ker.arg]]$KER]
      p case qot => [[copy(p.qot.num), copy(p.qot.den)]$QOT]
      [[copy(p.exp.val), p.exp.exponent]$REC]
 
    pateq?(p1, p2) ==
      p1 case ret => (p2 case ret) and (p1.ret = p2.ret)
      p1 case qot =>
        (p2 case qot) and (p1.qot.num = p2.qot.num)
                      and (p1.qot.den = p2.qot.den)
      p1 case sym =>
        (p2 case sym) and (p1.sym.val = p2.sym.val)
                      and {p1.sym.pred} =$Set(Any) {p2.sym.pred}
                        and {p1.sym.bad} =$Set(Any) {p2.sym.bad}
      p1 case ker =>
        (p2 case ker) and (p1.ker.tag = p2.ker.tag)
               and (p1.ker.op = p2.ker.op) and (p1.ker.arg = p2.ker.arg)
      (p2 case exp) and (p1.exp.exponent = p2.exp.exponent)
                    and (p1.exp.val = p2.exp.val)
 
    retractIfCan(p:%):Union(SY, "failed") ==
      symbol? p => p.pat.sym.val
      "failed"
 
    mkrsy(t, c?, o?, m?) ==
      c? => [0, t, empty(), empty()]
      mlt := (m? => SYM_MULTIPLE; 0)
      opt := (o? => SYM_OPTIONAL; 0)
      [Or(Or(SYM_GENERIC, mlt), opt), t, empty(), empty()]
 
    patternVariable(sy, c?, o?, m?) ==
      rsy := mkrsy(sy, c?, o?, m?)
      mkPat(zero?(rsy.tag), [rsy], 0)