How to make a ReplaceAll Rule for adjacent items in a list?

Question

I would like to make only one pass of a list of 2D items and replace adjacent items that have matching $x$ or $y$ coordinates with a series of linearly interpolated points between the two points. My attempt to construct this rule for matching $x$ coordinates is being met by a syntax error.

Minimal example:

{{4, 5}, {1, 2}, {1, 5}, {3, 5}} /. ({x_, j_}, {x_, k_}) -> 
  Table[{x, j + n (k - j)/3}, {n, 0, 3}]
Syntax::sntxf: "(" cannot be followed by "{x_,j_},{x_,k_})".

I am expecting

{{4, 5}, {1, 2}, {1, 3}, {1, 4}, {1, 5}, {3, 5}}

Will there ever be lists where there are three adjacent pairs with the same first element? — march, Oct 01 '15 at 20:40
And will the second elements of the list always be in order from largest to smallest? — march, Oct 01 '15 at 20:46
@march Yes, there is no limit to how many adjacent elements there are. I thought the rule would pick these up due to the way rules work. Largest to smallest does not matter as the formula will still work. It will subtract instead of add in this case. — Edmund, Oct 01 '15 at 20:55
In that case, I think it will be very difficult to do this in precisely "one pass". I think I have a solution in "three" passes, but I'm still working on it. Oh and one more question: You always want to fill in exactly two more points between the adjacent ones, or does it depend on the difference between the second elements of the adjacent pairs? — march, Oct 01 '15 at 20:59
@march The number of interpolated points will be variable. I just picked 2 and integers for the example to keep it simple. — Edmund, Oct 01 '15 at 22:11

Dr. belisarius · Answer 1 · 2015-10-02T15:27:11.190

10

{{4, 5}, {1, 2}, {1, 5}, {3, 5}} /. 
          {a : ___,  b : PatternSequence[{x_, j_}, {x_, k_}], c : ___} :> 
             {a, Sequence @@ Table[{x, j + n (k - j)/3}, {n, 0, 3}], c}

(* {{4, 5}, {1, 2}, {1, 3}, {1, 4}, {1, 5}, {3, 5}} *)

Edit

For supporting multiple adjacent values you may do the much more convoluted:

g[x_] := Module[{s = 3 Length@x - 2},
             {x[[1, 1]], Interpolation[x[[All, 2]], InterpolationOrder -> 1][#]} & /@ 
                         Rescale[Range@s, {1, s}, {1, Length@x}]]
g[x : {{__}}] := x
f[l_] := Flatten[g /@ SplitBy[l, First], 1]

l = {{4, 5}, {1, 2}, {1, 5}, {1, 8}, {3, 5}, {3, 7}};
f@l

(*
{{4, 5}, 
  {1, 2}, {1, 3}, {1, 4}, {1, 5}, {1, 6}, {1, 7}, {1, 8}, 
  {3, 5}, {3, 17/3}, {3, 19/3}, {3, 7}}
*)

edited Oct 02 '15 at 15:27

answered Oct 01 '15 at 20:07

Dr. belisarius

115,881
13
203
453

There is a problem! See @Edmund's comment on his question! – march Oct 01 '15 at 20:59
2

@march I try to disregard "and this case too" question-upgrading comments. – Dr. belisarius Oct 01 '15 at 21:03
Yeah, that seems like a reasonable practice, actually. I mean, I've just made more work for myself. – march Oct 01 '15 at 21:06
1

@march The full solution to a problem always include corner cases the OP should try to work out on his own.[{3,4},{1,2},{1,2},{8,7}} ..... – Dr. belisarius Oct 01 '15 at 21:41
@march Well, just this time :) – Dr. belisarius Oct 01 '15 at 22:03
1

Very nice. Sorry to make you work harder :) – march Oct 01 '15 at 22:45
Many thanks for assisting with this but the FoldList (although I did ask for ReplaceAll answer seems like it will be easier to follow so easier to support. – Edmund Oct 19 '15 at 19:15

SquareOne · Accepted Answer · 2015-10-02T11:24:14.117

You might find useful this other approach which is not using ReplaceAll:

foo[___, {x_, j_}, {x_, k_}] := 
 Sequence @@ Rest@Table[{x, j + n (k - j)/3}, {n, 0, 3}]

foo[__, s_] := s

then for any number of adjacent items with matching x, for example

testlist = {{4, 5}, {1, 2}, {1, 5}, {1, 7}, {3, 7}}

just run

FoldList[foo,testlist]
(* FoldList[foo, First@testlist, Rest@testlist] for versions < 10 *)

{{4, 5}, {1, 2}, {1, 3}, {1, 4}, {1, 5}, {1, 17/3}, {1, 19/3}, {1, 7}, {3, 7}}

If you need also, as I understand, the same interpolation when adjacent y are the same, just add the definition:

foo[___, {j_, y_}, {k_, y_}] := 
 Sequence @@ Rest@Table[{j + n (k - j)/3, y}, {n, 0, 3}]

then with the same FoldList command than above you get now

{{4, 5}, {1, 2}, {1, 3}, {1, 4}, {1, 5}, {1, 17/3}, {1, 19/3}, {1, 7}, {5/3, 7},

{7/3, 7}, {3, 7}}

The FoldList two arguments syntax has been introduced silently with version 10. I added the traditional 3 arguments syntax for older versions. — SquareOne, Oct 02 '15 at 11:27
I was not originally looking for FoldList but this answer will be the easiest to follow when I (or more importantly, someone else) comes across it again so I have selected it. — Edmund, Oct 19 '15 at 19:18

score 4 · Answer 3 · edited Apr 13 '17 at 12:55

Here is my extension of the belisarius' first solution for the case of arbitrary number of elements in the sequence with matching $x$ coordinate (the sequence is still allowed to be only one):

{{4, 5}, {1, 2}, {1, 8}, {1, 7}, {3, 5}} /. 
   {a : ___, b : Longest@Repeated[{x_, _}, {2, Infinity}], c : ___} :> 
   {a, 
    Sequence @@ 
     Transpose[PadLeft[{Append[
      Flatten[MovingMap[Most[Subdivide[#[[1]], #[[2]], 3]] &, {b}[[;; , 2]], 1]], 
      {b}[[-1, 2]]]}, {2, Automatic}, x]], 
    c}

{{4, 5}, {1, 2}, {1, 4}, {1, 6}, {1, 8}, {1, 23/3}, {1, 22/3}, {1, 7}, {3, 5}}

If the number of sequences with matching $x$ coordinate is arbitrary, there probably is no way to avoid Split:

l = {{4, 5}, {1, 2}, {1, 8}, {1, 7}, {3, 5}, {3, 7}, {3, 4}};

subd[s : {{_, _}}] := s;
subd[s : {{x_, _} ..}] := 
  Transpose[PadLeft[{Append[
      Flatten[BlockMap[Most[Subdivide[#[[1]], #[[2]], 3]] &, s[[;; , 2]], 2, 1]], 
      s[[-1, 2]]]}, {2, Automatic}, x]];

Flatten[subd /@ SplitBy[l, First], 1]

{{4, 5}, {1, 2}, {1, 4}, {1, 6}, {1, 8}, {1, 23/3}, {1, 22/3}, {1, 7}, {3, 5}, 
 {3, 17/3}, {3, 19/3}, {3, 7}, {3, 6}, {3, 5}, {3, 4}}

Many thanks for assisting with this but the FoldList (although I did ask for ReplaceAll answer seems like it will be easier to follow so easier to support. — Edmund, Oct 19 '15 at 19:16

How to make a ReplaceAll Rule for adjacent items in a list?

3 Answers3