I edited the post. I am sorry, I thought that it would appear in the Mathematica section. This question is regarding to the mathematica software.
I would like to make all the possible combinations between two lists with some restrictions. For example, let's say that I have the following lists:
list1=Flatten[Table[{i, j}, {j, 0, 1}, {i, 0, 1}], 1]
{{0, 0}, {1, 0}, {0, 1}, {1, 1}}
list2={a,b}
What I would like to get is a list that makes all the possible combinations between each sublist in list1 and each one in list2, if possible without the elements in list2 taking the same sublist in list1. The solution that I want is:
{{{0, 0, a}, {1, 0, b}}, {{0, 0, a}, {0, 1, b}}, {{0, 0, a}, {1, 1, b}}, {{1, 0, a}, {0, 0, b}}, {{1, 0, a}, {0, 1, b}}, {{1, 0, a}, {1, 1, b}}, {{0, 1, a}, {0, 0, b}}, {{0, 1, a}, {1, 0, b}}, {{0, 1, a}, {1, 1, b}}, {{1, 1, a}, {0, 0, b}}, {{1, 1, a}, {1, 0, b}}, {{1, 1, a}, {0, 1, b}}}
Is there an easy way of doing it?
I would like to do it for larger lists such as the following:
list1=Flatten[Table[{i, j, z}, {z, -2, 2}, {j, -2, 2}, {i, -2, 2}], 2]
{{-2, -2, -2}, {-1, -2, -2}, {0, -2, -2}, {1, -2, -2}, {2, -2, -2},
{-2, -1, -2}, {-1, -1, -2}, {0, -1, -2}, {1, -1, -2}, {2, -1, -2},
{-2, 0, -2}, {-1, 0, -2}, {0, 0, -2}, {1, 0, -2}, {2, 0, -2}, {-2, 1,
-2}, {-1, 1, -2}, {0, 1, -2}, {1, 1, -2}, {2, 1, -2}, {-2, 2, -2}, {-1, 2, -2}, {0, 2, -2}, {1, 2, -2}, {2, 2, -2}, {-2, -2, -1}, {-1,
-2, -1}, {0, -2, -1}, {1, -2, -1}, {2, -2, -1}, {-2, -1, -1}, {-1, -1, -1}, {0, -1, -1}, {1, -1, -1}, {2, -1, -1}, {-2, 0, -1}, {-1, 0, -1}, {0, 0, -1}, {1, 0, -1}, {2, 0, -1}, {-2, 1, -1}, {-1, 1, -1}, {0, 1,
-1}, {1, 1, -1}, {2, 1, -1}, {-2, 2, -1}, {-1, 2, -1}, {0, 2, -1}, {1, 2, -1}, {2, 2, -1}, {-2, -2, 0}, {-1, -2, 0}, {0, -2, 0}, {1, -2, 0},
{2, -2, 0}, {-2, -1, 0}, {-1, -1, 0}, {0, -1, 0}, {1, -1, 0}, {2, -1,
0}, {-2, 0, 0}, {-1, 0, 0}, {0, 0, 0}, {1, 0, 0}, {2, 0, 0}, {-2, 1,
0}, {-1, 1, 0}, {0, 1, 0}, {1, 1, 0}, {2, 1, 0}, {-2, 2, 0}, {-1, 2,
0}, {0, 2, 0}, {1, 2, 0}, {2, 2, 0}, {-2, -2, 1}, {-1, -2, 1}, {0, -2,
1}, {1, -2, 1}, {2, -2, 1}, {-2, -1, 1}, {-1, -1, 1}, {0, -1, 1}, {1,
-1, 1}, {2, -1, 1}, {-2, 0, 1}, {-1, 0, 1}, {0, 0, 1}, {1, 0, 1}, {2, 0, 1}, {-2, 1, 1}, {-1, 1, 1}, {0, 1, 1}, {1, 1, 1}, {2, 1, 1}, {-2,
2, 1}, {-1, 2, 1}, {0, 2, 1}, {1, 2, 1}, {2, 2, 1}, {-2, -2, 2}, {-1,
-2, 2}, {0, -2, 2}, {1, -2, 2}, {2, -2, 2}, {-2, -1, 2}, {-1, -1, 2}, {0, -1, 2}, {1, -1, 2}, {2, -1, 2}, {-2, 0, 2}, {-1, 0, 2}, {0, 0, 2},
{1, 0, 2}, {2, 0, 2}, {-2, 1,2}, {-1, 1, 2}, {0, 1, 2}, {1, 1, 2}, {2,
1, 2}, {-2, 2, 2}, {-1, 2, 2}, {0, 2, 2}, {1, 2, 2}, {2, 2, 2}}
list2={a,b,c,d}
so that the solutions looks like:
{{{-2, -2, -2, a}, {-1, -2, -2, b}, {0, -2, -2, c}, {2, -2, -2, d}},....., {{-2, -2, -2, a}, {-1, -1, -1, b}, {0, 0, 0, c}, {2, 2, 2, d}}
note that the following should not be in the list
{{-2, -2, -2, a},{-2, -2, -2, b},{-2, -2, -2, c},{-2, -2, -2, d}}
Thank you very much.
I am assuming that the specific order of the pairs of triplets is not important.
Your Table construct will be shorter using Tuples.
You can get pairs without duplication using Subsets.
Permutations is used to get all orderings of subsets.
Join and Apply (##) are used to flatten one level of the nested list.
list2 is transformed with List /# {a, b} into {{a}, {b}} for use in:
The final step is to Map the Function Join[#, list2, 2] & onto these subsets.
All together:
list1 = Tuples[{0, 1}, 2]
list2 = List /# {a, b};
Join[#, list2, 2] & /# Join ## Permutations /# Subsets[list1, {2}]
{{{0, 0, a}, {0, 1, b}}, {{0, 1, a}, {0, 0, b}}, {{0, 0, a}, {1, 0, b}},
{{1, 0, a}, {0, 0, b}}, {{0, 0, a}, {1, 1, b}}, {{1, 1, a}, {0, 0, b}},
{{0, 1, a}, {1, 0, b}}, {{1, 0, a}, {0, 1, b}}, {{0, 1, a}, {1, 1, b}},
{{1, 1, a}, {0, 1, b}}, {{1, 0, a}, {1, 1, b}}, {{1, 1, a}, {1, 0, b}}}
Related
I have MainTable and SecondTable what I want to do:
MainTable and SecondTable are mostly same (example):
{{1, 1, 0}, {2, 1, 0}, {3, 1, 0}}
All this is in function:
function[] := Module[{}, Panel[Manipulate[
All is working smoothly but I can't get those grids to their position. It's always print only one. I was searching and spent many hours without any result. I appreciates any help.
Example:
function[] := Module[{}, Panel[Manipulate[
MainTable = {{x, 1, 0}, {2, 1, 0}, {3, 1, 0}};
SecondTable = {{y, 1, 0}, {2, 1, 5}, {5, 5, 5}};
Grid[{MainTable, SecondTable}, Frame -> All],
{{x, 1, "Input 1"}, ControlType -> InputField},
{{y, 1, "Input 2"}, ControlType -> InputField}],
FrameMargins -> Automatic]]
Solution:
function[] :=
Module[{},
Panel[Manipulate[
MainTable = {{x, 1, 0}, {2, 1, 0}, {3, 1, 0}};
SecondTable = {{y, 1, 0}, {2, 1, 5}, {5, 5, 5}};
Grid[{{Grid[MainTable, Frame -> All]}, {Grid[SecondTable, Frame -> All]}}],
{{x, 1, "Input 1"}, ControlType -> InputField},
{{y, 1, "Input 2"}, ControlType -> InputField}, Alignment -> Center]]]
I have a matrix
FT= {{0, 0, 0}, {1, 1, 1}, {1, 1, 2}, {1, 1, 3}, {1, 2, 1}, {1, 2, 2}, {1,
2, 3}, {1, 3, 1}, {1, 3, 2}, {1, 3, 3}, {2, 1, 1}, {2, 1, 2}, {2,
1, 3}, {2, 2, 1}, {2, 2, 2}, {2, 2, 3}, {2, 3, 1}, {2, 3, 2}, {2, 3,
3}, {2, 4, 1}, {2, 4, 2}, {2, 4, 3}, {2, 5, 1}, {2, 5, 2}, {2, 5,
3}, {2, 6, 1}, {2, 6, 2}, {2, 6, 3}, {3, 1, 1}, {3, 1, 2}, {3, 1,
3}, {3, 2, 1}, {3, 2, 2}, {3, 2, 3}, {3, 3, 1}, {3, 3, 2}, {3, 3,
3}, {3, 4, 1}, {3, 4, 2}, {3, 4, 3}, {3, 5, 1}, {3, 5, 2}, {3, 5,
3}, {3, 6, 1}, {3, 6, 2}, {3, 6, 3}, {3, 7, 1}, {3, 7, 2}, {3, 7,
3}, {3, 8, 1}, {3, 8, 2}, {3, 8, 3}, {3, 9, 1}, {3, 9, 2}, {3, 9,
3}, {3, 10, 1}, {3, 10, 2}, {3, 10, 3}, {3, 11, 1}, {3, 11, 2}, {3,
11, 3}, {3, 12, 1}, {3, 12, 2}, {3, 12, 3}}
Where each row represents a kind of address of each element whose first element gives G, second element gives B and the third element gives M. For e.g. for 3rd element G is 1, B is 1 and M is 2 and so on. Now i need to generate a matrix for each element such that whenever my G is 0 or 1 it gives me {0,0,0} and for G>1 it gives me rows with G-1, G-2 and so on till it gives 1; and for B it gives a check for whenever B is even it returns B/2 and whenever B is odd it returns (B+1) /2 and M takes value of 3 every time and finally a row {0,0,0}. For e.g. for last element with FT= {3,12,3} it should give me {{2,6,3}, {1,3,3}, {0,0,0}} and for FT= {2,5,1} it should give me {{1,3,3}, {0,0,0}}.
Can you please help me writing code for this in mathematica.
Thanks in advance :)
For this demo lower-case symbols are used to avoid conflicting with built-in functions, e.g. D, E, I, N
This function defines the basic operation
op[{g_, b_, m_}] := {g - 1, If[EvenQ[b], b/2, (b + 1)/2], 3}
which should be applied repeatedly until a condition is met. NestWhileList is useful for this, e.g.
NestWhileList[op[#] &, {3, 12, 3}, First[#] > 1 &]
{{3, 12, 3}, {2, 6, 3}, {1, 3, 3}}
Another function uses the above if g > 1 :-
f[{g_, b_, m_}] := Append[
If[g > 1, Rest#NestWhileList[op, {g, b, m}, First[#] > 1 &],
{}], {0, 0, 0}]
E.g.
f[{2, 5, 1}]
{{1, 3, 3}, {0, 0, 0}}
Now f can be mapped over ft :-
ft = {
{0, 0, 0}, {1, 1, 1}, {1, 1, 2}, {1, 1, 3}, {1, 2, 1},
{1, 2, 2}, {1, 2, 3}, {1, 3, 1}, {1, 3, 2}, {1, 3, 3},
{2, 1, 1}, {2, 1, 2}, {2, 1, 3}, {2, 2, 1}, {2, 2, 2},
{2, 2, 3}, {2, 3, 1}, {2, 3, 2}, {2, 3, 3}, {2, 4, 1},
{2, 4, 2}, {2, 4, 3}, {2, 5, 1}, {2, 5, 2}, {2, 5, 3},
{2, 6, 1}, {2, 6, 2}, {2, 6, 3}, {3, 1, 1}, {3, 1, 2},
{3, 1, 3}, {3, 2, 1}, {3, 2, 2}, {3, 2, 3}, {3, 3, 1},
{3, 3, 2}, {3, 3, 3}, {3, 4, 1}, {3, 4, 2}, {3, 4, 3},
{3, 5, 1}, {3, 5, 2}, {3, 5, 3}, {3, 6, 1}, {3, 6, 2},
{3, 6, 3}, {3, 7, 1}, {3, 7, 2}, {3, 7, 3}, {3, 8, 1},
{3, 8, 2}, {3, 8, 3}, {3, 9, 1}, {3, 9, 2}, {3, 9, 3},
{3, 10, 1}, {3, 10, 2}, {3, 10, 3}, {3, 11, 1}, {3, 11, 2},
{3, 11, 3}, {3, 12, 1}, {3, 12, 2}, {3, 12, 3}};
matrix = Map[f, ft]
I have a list of lists with inner lists possibly of variable lengths. I need to sort the outer list based on the alphabetical order of the inner list elements. For example, given a list of
{{0, 0, 7}, {5, 0, 2, 3}, {0, 0, 10, 0}, {0, 6, 2}, {5, 1, 2}, {0, 3, 6, 1, 4}}
I want the output after Sort to be
{{0, 0, 10, 0}, {0, 0, 7}, {0, 3, 6, 1, 4}, {0, 6, 2}, {5, 0, 2, 3}, {5, 1, 2}}
I just do not know how to handle the variable lengths of inner lists in order to write a comparison function. Please help.
Edit
BTW, the original list is a numerical one.
Edit 2
For example, I have a list:
{{0, 0, 7}, {5, 0, 2, 3}, {0, 0, 11, 0}, {0, 0, 1, 12}, {0, 6, 2}, {5, 1, 2}, {0, 3, 6, 1, 4}}
The output should be:
{{0, 0, 1, 12}, {0, 0, 11, 0}, {0, 0, 7}, {0, 3, 6, 1, 4}, {0, 6, 2}, {5, 0, 2, 3}, {5, 1, 2}}
The reason is that 1 is lexically less than 11, which is less than 7.
You can set up a lexciographic comparator like this:
lexComp[_, {}] := False;
lexComp[{}, _] := True;
lexComp[{a_, as___}, {b_, bs___}] := a < b || a == b && lexComp[{as}, {bs}];
You can then sort using that to get the desired effect:
Sort[{{0, 0, 7}, {5, 0, 2, 3}, {0, 0, 10, 0}, {0, 6, 2}, {5, 1, 2}, {0, 3, 6, 1, 4}}, lexComp]
{{0, 0, 7}, {0, 0, 10, 0}, {0, 3, 6, 1, 4}, {0, 6, 2}, {5, 0, 2, 3}, {5, 1, 2}}
If you wish to treat the numbers as strings in your sorting, you can modify it like so:
lessAsString[a_, b_] := Order ## (ToString /# {a, b}) === 1;
olexComp[_, {}] := False;
olexComp[{}, _] := True;
olexComp[{a_, as___}, {b_, bs___}] := lessAsString[a, b] || a === b && olexComp[{as}, {bs}];
Here is the example of such a sort:
In[5]:= Sort[{{0, 0, 7}, {5, 0, 2, 3}, {0, 0, 11, 0}, {0, 0, 1, 12}, {0, 6, 2}, {5, 1, 2}, {0, 3, 6, 1, 4}}, olexComp]
Out[5]= {{0, 0, 1, 12}, {0, 0, 11, 0}, {0, 0, 7}, {0, 3, 6, 1, 4}, {0, 6, 2}, {5, 0, 2, 3}, {5, 1, 2}}
alphaSort = #[[ Ordering # Map[ToString, PadRight##, {2}] ]] &;
This works by preparing the data for the default Ordering sort, and then using that order to sort the original list.
In this case, padding all of the lists to the same length keeps this Sort property from interfering:
Sort usually orders expressions by putting shorter ones first, and then comparing parts in a depth-first manner.
ToString is used to get an alphabetical order rather than a numeric one.
This should do it
{{0, 0, 7}, {5, 0, 2, 3}, {0, 0, 10, 0}, {0, 6, 2}, {5, 1, 2}, {0, 3,
6, 1, 4}} // SortBy[#, ToString] &
This works because lexically, comma and space precede the numbers, so {a,b} is lexically before {a,b,c}.
I have a set of points given by this list:
list1 = {{3, 1}, {1, 3}, {-1, 2}, {-1, -1}, {1, -2}};
I would like Mathematica to draw a line from the origin to all the points above. In other words draw vectors from the origin (0,0) to all the individual points in the above set. Is there a way to do this? So far I've tried the Filling option, PlotPoints and VectorPlot but they don't seem to be able to do what I want.
Starting easy, and then increasing difficulty:
Graphics[{Arrow[{{0, 0}, #}] & /# list1}]
Graphics[{Arrow[{{0, 0}, #}] & /# list1}, Axes -> True]
Needs["PlotLegends`"];
list1 = {{3, 1}, {1, 3}, {-1, 2}, {-1, -1}, {1, -2}};
k = ColorData[22, "ColorList"][[;; Length#list1]];
GraphicsRow[{
Graphics[Riffle[k, Arrow[{{0, 0}, #}] & /# #], Axes -> True],
Graphics#Legend[Table[{k[[i]], #[[i]]}, {i, Length##}]]}] &#list1
Needs["PlotLegends`"];
list1 = {{3, 1}, {1, 3}, {-1, 2}, {-1, -1}, {1, -2}};
k = ColorData[22, "ColorList"][[;; Length#list1]];
ls = Sequence[Thick, Line[{{0, 0}, {1, 0}}]];
GraphicsRow[{
Graphics[Riffle[k, Arrow[{{0, 0}, #}] & /# #], Axes -> True],
Graphics#Legend[MapThread[{Graphics[{#1, ls}], #2} &, {k, #}]]}] &#list1
Needs["PlotLegends`"];
list1 = {{3, 1}, {1, 3}, {-1, 2}, {-1, -1}, {1, -2}};
pr = {Min##, Max##} & /# Transpose#list1;
k = ColorData[22, "ColorList"][[;; Length#list1]];
GraphicsRow[{
Graphics[r = Riffle[k, {Thick,Arrow[{{0, 0}, #}]} & /# #], Axes -> True],
Graphics#
Legend[MapThread[
{Graphics[#1, Axes -> True, Ticks -> None, PlotRange -> pr],
Text#Style[#2, 20]} &,
{Partition[r, 2], #}]]}] &#list1
You could also tweak ListVectorPlot, although I don't see why you should do it, as it is not intended to use like this:
list1 = {{3, 1}, {1, 3}, {-1, 2}, {-1, -1}, {1, -2}};
data = Table[{i/2, -i/Norm[i]}, {i, list1}];
ListVectorPlot[data, VectorPoints -> All,
VectorScale -> {1, 1, Norm[{#1, #2}] &},
VectorStyle -> {Arrowheads[{-.05, 0}]}]
Graphics[
{
Line[{{0, 0}, #}] & /# list1
}
]
where /# is the shorthand infix notation for the function Map.
I wonder why you tried Filling, Plotpoints and VectorPlot. I must assume you haven't read the documentation at all, because even a superficial reading would tell you that those commands and options have nothing to do with the functionality you're looking for.
Suppose I have a series of strips of paper placed along an infinite ruler, with start and end points specified by pairs of numbers. I would like to create a list representing the number of layers of paper at points along the ruler.
For example:
strips =
{{-27, 20},
{ -2, -1},
{-47, -28},
{-41, 32},
{ 22, 31},
{ 2, 37},
{-28, 30},
{ -7, 39}}
Should output:
-47 -41 -27 -7 -2 -1 2 20 22 30 31 32 37 39
1 2 3 4 5 4 5 4 5 4 3 2 1 0
What is the most efficient, clean, or terse way to do this, accommodating Real and Rational strip positions?
Here's one approach:
Clear[hasPaper,nStrips]
hasPaper[y_, z_] := Piecewise[{{1, x <= z && x >= y}}, 0];
nStrips[y_, strip___] := Total#(hasPaper ### strip) /. x -> y
You can get the number of strips at any value.
Table[nStrips[i, strips], {i, Sort#Flatten#strips}]
{1, 2, 3, 3, 3, 4, 5, 5, 5, 5, 5, 5, 4, 3, 2, 1}
Also, plot it
Plot[nStrips[x, strips], {x, Min#Flatten#strips, Max#Flatten#strips}]
Here is one solution:
In[305]:=
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}, {22, 31}, {2,
37}, {-28, 30}, {-7, 39}};
In[313]:= int = Interval /# strips;
In[317]:= Thread[{Union[Flatten[strips]],
Join[Count[int, x_ /; IntervalMemberQ[x, #]] & /# (Mean /#
Partition[Union[Flatten[strips]], 2, 1]), {0}]}]
Out[317]= {{-47, 1}, {-41, 2}, {-28, 2}, {-27, 3}, {-7, 4}, {-2,
5}, {-1, 4}, {2, 5}, {20, 4}, {22, 5}, {30, 4}, {31, 3}, {32,
2}, {37, 1}, {39, 0}}
EDIT Using SplitBy and postprocessing the following code gets the shortest list:
In[329]:=
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}, {22, 31}, {2,
37}, {-28, 30}, {-7, 39}};
In[330]:= int = Interval /# strips;
In[339]:=
SplitBy[Thread[{Union[Flatten[strips]],
Join[Count[int, x_ /; IntervalMemberQ[x, #]] & /# (Mean /#
Partition[Union[Flatten[strips]], 2, 1]), {0}]}],
Last] /. {b : {{_, co_} ..} :> First[b]}
Out[339]= {{-47, 1}, {-41, 2}, {-27, 3}, {-7, 4}, {-2, 5}, {-1,
4}, {2, 5}, {20, 4}, {22, 5}, {30, 4}, {31, 3}, {32, 2}, {37,
1}, {39, 0}}
You may regard this as a silly approach, but I'll offer it anyway:
f[x_]:=Sum[UnitStep[x-strips[[k,1]]]-UnitStep[x-strips[[k,2]]],{k,Length[strips]}]
f/#Union[Flatten[strips]]
f[u_, s_] := Total[Piecewise#{{1, #1 <= x < #2}} & ### s /. x -> u]
Usage
f[#, strips] & /# {-47, -41, -27, -7, -2, -1, 2, 20, 22, 30, 31, 32, 37, 39}
->
{1, 2, 3, 4, 5, 4, 5, 4, 5, 4, 3, 2, 1, 0}
For Open/Closed ends, just use <= or <
Here's my approach, similar to belisarius':
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}, {22, 31}, {2,
37}, {-28, 30}, {-7, 39}};
pw = PiecewiseExpand[Total[Boole[# <= x < #2] & ### strips]]
Grid[Transpose[
SplitBy[SortBy[Table[{x, pw}, {x, Flatten[strips]}], First],
Last][[All, 1]]], Alignment -> "."]
Here's my attempt - it works on integers, rationals and reals, but makes no claim to being terribly efficient. (I made the same mistake as Sasha, my original version did not return the shortest list. So I stole the SplitBy fix!)
layers[strips_?MatrixQ] := Module[{equals, points},
points = Union#Flatten#strips;
equals = Function[x, Evaluate[(#1 <= x < #2) & ### strips]];
points = {points, Total /# Boole /# equals /# points}\[Transpose];
SplitBy[points, Last] /. {b:{{_, co_}..} :> First[b]}]
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}, {22, 31},
{2, 37}, {-28, 30}, {-7, 39}};
In[3]:= layers[strips]
Out[3]= {{-47, 1}, {-41, 2}, {-27, 3}, {-7, 4}, {-2, 5}, {-1, 4}, {2, 5},
{20, 4}, {22, 5}, {30, 4}, {31, 3}, {32, 2}, {37, 1}, {39, 0}}
In[4]:= layers[strips/2]
Out[4]:= {{-(47/2), 1}, {-(41/2), 2}, {-(27/2), 3}, {-(7/2), 4},
{-1, 5}, {-(1/2), 4}, {1, 5}, {10, 4}, {11, 5}, {15, 4}, {31/2, 3},
{16, 2}, {37/2, 1}, {39/2, 0}}
In[5]:= layers[strips/3.]
Out[5]= {{-15.6667, 1}, {-13.6667, 2}, {-9., 3}, {-2.33333, 4}, {-0.666667, 5},
{-0.333333, 4}, {0.666667, 5}, {6.66667, 4}, {7.33333, 5}, {10.,4},
{10.3333, 3}, {10.6667, 2}, {12.3333, 1}, {13., 0}}
Splice together abutting strips, determine key points where number of layers
changes, and calculate how many strips each key point inhabits:
splice[s_, {}] := s
splice[s_, vals_] := Module[{h = First[vals]},
splice[(s /. {{x___, {k_, h}, w___, {h, j_}, z___} :> {x, {k, j},
w, z}, {x___, {k_, h}, w___, {h, j_}, z___} :> {x, {k, j}, w,
z}}), Rest[vals]]]
splicedStrips = splice[strips, Union#Flatten#strips];
keyPoints = Union#Flatten#splicedStrips;
({#, Total#(splicedStrips /. {a_, b_} :> Boole[a <= # < b])} & /# keyPoints)
// Transpose // TableForm
EDIT
After some struggling I was able to remove splice and more directly eliminate points that did not need checking (-28, in the strips data we've been using) :
keyPoints = Complement[pts = Union#Flatten#strips,
Cases[pts, x_ /; MemberQ[strips, {x, _}] && MemberQ[strips, {_, x}]]];
({#, Total#(strips /. {a_, b_} :> Boole[a <= # < b])} & /# keyPoints)
One approach of solving this is converting the strips
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}
,{ 22, 31}, { 2, 37}, {-28, 30}, {-7, 39}}
to a list of Delimiters, marking the beginning or end of a strip and sort them by position
StripToLimiters[{start_, end_}] := Sequence[BeginStrip[start], EndStrip[end]]
limiterlist = SortBy[StripToLimiters /# strips, First]
Now we can map the sorted limiters to increments/decrements
LimiterToDiff[BeginStrip[_]] := 1
LimiterToDiff[EndStrip[_]] := -1
and use Accumulate to get the intermediate totals of intersected strips:
In[6]:= Transpose[{First/##,Accumulate[LimiterToDiff/##]}]&[limiterlist]
Out[6]= {{-47,1},{-41,2},{-28,3},{-28,2},{-27,3},{-7,4},{-2,5},{-1,4}
,{2,5},{20,4},{22,5},{30,4},{31,3},{32,2},{37,1},{39,0}}
Or without the intermediate limiterlist:
In[7]:= StripListToCountList[strips_]:=
Transpose[{First/##,Accumulate[LimiterToDiff/##]}]&[
SortBy[StripToLimiters/#strips,First]
]
StripListToCountList[strips]
Out[8]= {{-47,1},{-41,2},{-28,3},{-28,2},{-27,3},{-7,4},{-2,5},{-1,4}
,{2,5},{20,4},{22,5},{30,4},{31,3},{32,2},{37,1},{39,0}}
The following solution assumes that the layer count function will be called a large number of times. It uses layer precomputation and Nearest in order to greatly reduce the amount of time required to compute the layer count at any given point:
layers[strips:{__}] :=
Module[{pred, changes, count}
, changes = Union # Flatten # strips /. {c_, r___} :> {c-1, c, r}
; Evaluate[pred /# changes] = {changes[[1]]} ~Join~ Drop[changes, -1]
; Do[count[x] = Total[(Boole[#[[1]] <= x < #[[2]]]) & /# strips], {x, changes}]
; With[{n = Nearest[changes]}
, (n[#] /. {m_, ___} :> count[If[m > #, pred[m], m]])&
]
]
The following example uses layers to define a new function f that will compute the layer count for the provided sample strips:
$strips={{-27,20},{-2,-1},{-47,-28},{-41,32},{22,31},{2,37},{-28,30},{-7,39}};
f = layers[$strips];
f can now be used to compute the number of layers at a point:
Union # Flatten # $strips /. s_ :> {s, f /# s} // TableForm
Plot[f[x], {x, -50, 50}, PlotPoints -> 1000]
For 1,000 layers and 10,000 points, the precomputation stage can take quite a bit of time, but individual point computation is relatively quick: