Liren Large Software Subsidy 9/09.iso/e/e032/3.ddi/FILES/EXAMPLES.PAK/STRINGPA.M

Text File | 1992-07-29 | 10.8 KB | 381 lines

(* :Title: String Patterns *)

(* :Context: Examples`StringPatterns` *)

(* :Author: John M. Novak *)

(* :Summary: Implements a method of more general pattern
    matching with strings than the built-in * and @.
*)

(* :Package Version: 2.0 *)

(* :Mathematica Version: 2.0 *)

(* :History:
    V 2.0, John M. Novak, July 1991 : switch to Mathematica-like
        patterns.
    V 1.0, John M. Novak, June 1991
*)

(* :Keywords:
    pattern matching, strings
*)

(* :Warning:
    Adds rules to StringMatchQ and StringPosition.
*)

(* :Limitation:
    Certain complex patterns take considerably longer to
    evaluate than one might expect...
*)

(* :Limitation:
    Many instances of variables of the form $nnn may be left
    behind if any of the special patterns (as described below)
    are used.
*)

(* :Discussion:
    This package adds the capability of Mathematica pattern
    matching for strings.  It allows the use of standard Mathematica
    patterns connected by StringJoin to be matched to a string,
    using the functions StringMatchQ and StringPosition.
    The patterns treat a string as a sequence of characters, in
    direct correlation to sequences in normal Mathematica expressions.
    Thus, we can have the pattern:
    "a"<>___<>"b"
    which matches to a string that starts with a, ends with b, and
    has zero or more characters in between.  All standard Mathematica
    patterns are allowed.
    There are also several enhancements, dealing with matching to
    a sequence of characters, for instance:
    "a"<>("bc"..)<>"d"
    matches any string beginning with a, ending with d, and with
    one or more occurences of the substring "bc" in between.
    Note that this diverges from standard Mathematica patterns, as
    (b,c).. is not normally a valid pattern.  The patterns with
    this enhancement are Repeated, RepeatedNull, and Alternatives.

    The implementation is simple enough.  The basic match is
    performed by separating the target string into a list of
    characters, and modifying the pattern to be a list of
    characters and patterns.  The problems come with the
    new pattern cases - replacement rules are used to replace
    the new patterns with valid old patterns that do the
    same thing - unfortunately, the old patterns are often
    rather complex, involving extensive use of Condition[] and
    unique new variables.  This can cause slow evaluation in
    some cases.
*)

(* We need to make sure that the usage messages for StringMatchQ
    and StringPosition are loaded before we attempt to modify
    them. *)

If[!ValueQ[MessageName[StringMatchQ,"usage"]],
    $NewMessage[StringMatchQ,"usage"]
];

If[!ValueQ[MessageName[StringPosition,"usage"]],
    $NewMessage[StringPosition,"usage"]
];

BeginPackage["Examples`StringPatterns`"]

StringMatchQ::usage = MessageName[StringMatchQ,"usage"] <>
    "\nStringMatchQ[string,pattern] determines whether or not
    the string matches the pattern, where the pattern is as
    described in the discussion section of the StringPattern
    package."

StringPosition::usage = MessageName[StringPosition,"usage"] <>
    "\nStringPosition[string,pattern] finds occurences of the
    pattern in the string, where the pattern is as described in
    the discussion section of the StringPattern package.  In this
    usage, an additional option, AnchorMatch, is allowed."

AnchorMatch::usage =
    "An option for StringPosition, used only with a string
    pattern.  Determines whether a pattern should be anchored
    to the head or tail of the string.  Accepts the values of
    AnchorHead, AnchorTail, or False."

AnchorHead::usage =
    "A value for the option AnchorMatch.  Determines that
    the pattern will be anchored to the beginning of the
    string.";

AnchorTail::usage =
    "A value for the option AnchorMatch.  Determines that
    the pattern will be anchored to the end of the
    string.";

CharacterRange::usage =
    "CharacterRange[char1,char2] generates a pattern for use
    with StringMatchQ and StringPosition.  The pattern matches
    any character between char1 and char2, as determined by
    $StringOrder.  Note that this is not case sensitive."

Begin["`Private`"]

Unprotect[StringMatchQ,StringPosition];

StringMatchQ[str_String,pat_?PatternHeadQ,opts___] :=
    StringMatchQ[str,StringJoin[pat],opts]

StringMatchQ[stringi_String,
        StringJoin[pati___],opts___] :=
Module[{ic,string,pat},
    {ic} = {IgnoreCase}/.{opts}/.Options[StringMatchQ];
    If[TrueQ[ic],
        string = ToLowerCase[stringi];
            pat = pati/.s_String :> ToLowerCase[s],
        string = stringi;
        pat = pati
    ];
    MatchQ[Characters[string],
        Map[If[Head[#] === String,
                Sequence @@ Characters[#],
                ReleaseHold[#]]&,
            {pat}/.
                {Literal[Repeated][s_String]:>
                    repstrrule[Unique[],s],
                Literal[RepeatedNull][s_String]:>
                    nrepstrrule[Unique[],s],
                Literal[Repeated][Literal[Alternatives][
                        p1___,p2_String?(StringLength[#] > 1&),
                        p3___]] :>
                    repaltstrrule[Unique[],p1,p2,p3],
                Literal[RepeatedNull][Literal[Alternatives][
                        p1___,p2_String?(StringLength[#] > 1&),
                        p3___]] :>
                    nrepaltstrrule[Unique[],p1,p2,p3],
                Literal[Alternatives][f___,
                        s_String?(StringLength[#] > 1 &),
                        l___] :>
                    altstrrule[Unique[],{f,s,l}]
                }
        ]
    ]
]

StringPosition::anchor =
    "Warning: the option AnchorMatch is valid only if using
    a pattern of the sort defined in the StringPatterns
    package!";

Options[StringPosition] =
    Append[Options[StringPosition],AnchorMatch->False];

StringPosition[str_String,pat_?PatternHeadQ,opts___] :=
    StringPosition[str,StringJoin[pat],opts]

StringPosition[istr_String,ipat_StringJoin,opts___] :=
    Module[{ic,ov,am,str,pat},
        {ic,ov,am} = {IgnoreCase,Overlaps,AnchorMatch}/.
            {opts}/.Options[StringPosition];
        If[TrueQ[ic],
            str = ToLowerCase[istr];
                pat = ipat/.s_String :> ToLowerCase[s],
            str = istr;
                pat = ipat
        ];
        findsegs[am,TrueQ[ov],str,pat]
    ]

StringPosition[arg1___,AnchorMatch -> _,arg2___] :=
    (Message[StringPosition::anchor];
    StringPosition[arg1,arg2])

Protect[StringMatchQ,StringPosition];

(* utility function that returns True if the Head of the expr
    is a known pattern, False otherwise. *)

PatternHeadQ[expr_] :=
    MemberQ[{Repeated,
            RepeatedNull,
            Alternatives,
            Pattern,
            Blank,
            BlankNullSequence,
            BlankSequence,
            Condition,
            PatternTest},
        Head[expr]
    ]

(* utility function that returns True if comp is composed of
    str repeated, False otherwise. *)

RepeatedStringQ[str_String,comp___] :=
    With[{ln = Length[{comp}]/StringLength[str]},
        StringJoin[Table[str,{ln}]] ===
            StringJoin[comp]/;Head[ln] === Integer
    ]

RepeatedStringQ[___] := False

(* similar to above, except if comp is empty (Null) then
    the pattern matches as well. *)

RepeatedNullStringQ[str_,comp___] :=
    TrueQ[{comp} === {} || RepeatedStringQ[str,comp]]

(* Note that RulDelayed::rhs needs to be shut off for a bit -
    Many of the following rules define patterns, which confuses
    SetDelayed, generating a warning.  The warning can be safely
    ignored here, so I just shut it off temporarily. *)

Off[RuleDelayed::rhs]

(* replacement patterns for new pattern types... *)
(* repeated string *)

repstrrule[var_,str_] :=
    Hold[var__/;RepeatedStringQ[str,var]]

(* repeatednull string *)

nrepstrrule[var_,str_] :=
    Hold[var___/;RepeatedNullStringQ[str,var]]

(* repeated with string alternatives *)

repaltstrrule[var_,pats___] :=
    Hold[var___/;rpats[{var},pats]]

(* repeatednull with string alternatives *)

nrepaltstrrule[var_,pats___] :=
    Hold[var___/;apats[{var},pats]]

(* string alternatives - splits up into string and pattern
    alternates, then calls alts sub-rule *)

altstrrule[var_,args_] :=
    Module[{sargs,oargs},
        sargs = Select[args,(Head[#] === String &&
                StringLength[#] > 1)&];
        oargs = Complement[args,sargs];
        alts[var,sargs,oargs]
    ]

(* sub-rule for alternatives - does the match *)

alts[var_,sargs_,{oargs___}] :=
    Alternatives[var___/;MemberQ[sargs,StringJoin[var]],
            oargs]

(* sub-rule for nrepaltstrrule, splits up strings and other
    patterns, then maps an individual comparison across each
    piece of the input *)

apats[input_,pats___] :=
    Module[{spats,opats},
        spats = Select[{pats},Head[#] === String &];
        opats = Complement[{pats},spats];
        MatchQ[input,Map[
            ReleaseHold[ipat[Unique[],spats,opats]]&,input]]
    ]

(* sub-rule for repaltstrrule, much as apats, but uses slightly
    different test for first element. *)

rpats[input_,pats___] :=
    Module[{pat,spats,opats},
        spats = Select[{pats},Head[#] === String &];
        opats = Complement[{pats},spats];
        MatchQ[input,
            Prepend[Map[
                ReleaseHold[ipat[Unique[],spats,opats]]&,input],
                ReleaseHold[inpat[Unique[],spats,opats]]]
        ]
    ]

(* sub-rule for apats, does individual comparison *)

ipat[var_,spats_,opats_] :=
    Hold[var___/;Or[MemberQ[Append[spats,""],StringJoin[var]],
        MatchQ[{var},{Alternatives @@ opats}]]]

inpat[var_,spats_,opats_] :=
    Hold[var___/;Or[MemberQ[spats,StringJoin[var]],
        MatchQ[{var},{Alternatives @@ opats}]]]

(* Pattern for range of characters *)

CharacterRange[c1_String,c2_String] :=
    _?(OrderedQ[{c1,#,c2}]&)

On[RuleDelayed::rhs]

(* Handles the various combinations of an anchored match and
    overlaps for StringPosition. Usually does something like
    generating a table of substring positions, then going
    through and extracting them and comparing each to the
    pattern. Returns the list of sub-string positions where
    the match is good. (within the constraints of the options.) *)

findsegs[AnchorHead,True,str_,pat_] :=
    Module[{n,m,ln = StringLength[str]},
        Select[Table[{1,n},{n,ln}],
            StringMatchQ[StringTake[str,#],pat]&
        ]
    ]

findsegs[AnchorHead,False,str_,pat_] :=
    Module[{n,m,segs,ln = StringLength[str]},
        segs = Table[{1,n},{n,ln}];
        n = 1;
        While[!StringMatchQ[StringTake[str,segs[[n]]],
                pat] && n <= Length[segs],
            n += 1];
        If[n <= Length[segs],{segs[[n]]},{}]
    ]

findsegs[AnchorTail,True,str_,pat_] :=
    Module[{n,m,ln = StringLength[str]},
        Select[Table[{n,ln},{n,ln,1,-1}],
            StringMatchQ[StringTake[str,#],pat]&]
    ]

findsegs[AnchorTail,False,str_,pat_] :=
    Module[{n,m,ln = StringLength[str],segs},
        segs = Table[{n,ln},{n,ln,1,-1}];
        n = 1;
        While[!StringMatchQ[StringTake[str,segs[[n]] ],
                pat] && n <= Length[segs],
            n += 1];
        If[n <= Length[segs],{segs[[n]]},{}]
    ]

findsegs[_,True,str_,pat_] :=
    Module[{n,m,ln = StringLength[str]},
        Select[Flatten[Table[{n,m},{n,ln},{m,n,ln}],1],
            StringMatchQ[StringTake[str,#],pat]&]
    ]

findsegs[_,False,str_,pat_] :=
    Module[{n,m,ln = StringLength[str],out = {}},
        m = 1;
        While[m <= ln,
            n = m;
            While[n <= ln && !StringMatchQ[
                    StringTake[str,{m,n}],pat],
                n += 1];
            If[n <= ln,
                AppendTo[out,{m,n}];m = n,
                m += 1]
        ];
        out
    ]

findsegs[___] := {}

End[]

EndPackage[]