Making a faster alternative for {PatternSequence[1, PatternSequence[2, 3 ..] ..] ..}

Question

I need to improve a pattern or switch an approach.

It is best described by an example

For a hierarchy/order given by a list e.g.:

order = {1, 2, 3} 

and a list:

list = {
  1, 2, 3, 2, 3, 3, 2, 3, 3, 2, 3, 3, 2, 3, 2, 3, 2, 3, 2, 3, 2, 3, 3,
   3, 3, 3, 3, 3, 2, 3, 3, 3, 2, 3, 3, 3, 3, 3
  }

I need to verify that list matches a sequence defined by order:

MatchQ[list, {PatternSequence[1, PatternSequence[2, 3 ..] ..] ..}]

This pattern scales very poorly, already that one won't finish evaluating.

The function should only take list as an argument, consider the order constant. The pattern does not need to be constructed automatically.

Answer 1

The following seems to work for me, unless I am missing something:

ClearAll[match]
match[{}][{}] := True;
match[{fst_, rest___}][l_List] :=
  And @@ Map[
    Replace[
      match[{rest}][#], 
      False :> Return[False, Map]
    ]&,
    Replace[
      ReplaceList[
        l, 
        {
          {___, fst, middle : Except[fst] ..., fst, ___} :> {middle}, 
          {___, fst, r : Except[fst] ...} :> {r}
        }
      ],
      {} -> False
    ]
 ]

(The part Replace[match[{rest}][#], False :> Return[False, Map]]& is optional and can in principle be replaced with just match[{rest}]).

Example:

match[{1, 2, 3}][list] // AbsoluteTiming
match[{1, 2, 3}][Append[list, 1]] // AbsoluteTiming

(* {0.00038, True} *)

(* {0.000383, False} *)

Answer 2

This solution tries to reduce the list into a list of a single type of elements, if it succeeds then the list is following the prescribed pattern.

MatchQ[
  SequenceReplace[
   SequenceReplace[list, {2, 3 ..} :> x],
   {1, x ..} :> y
   ],
  {y ..}
  ] // AbsoluteTiming

{0.0019598, True}

This is a take on the state machine that Daniel recommended in a comment:

f[1, 2] = 2;
f[2, 3] = 3;
f[3, 2] = 2;
f[3, 1] = 1;
f[3, 3] = 3;
f[_, _] := Throw[False]

And[
  First[list] == 1 && Last[list] == 3,
  Catch[Fold[f, list]; True]
] // AbsoluteTiming

{0.0000455, True}