2
$\begingroup$

I posted something here a while ago, but I think it's a bit messy and difficult to understand. So, I'll create a new post to explain the concept and what I want in a different way, hopefully making it easier to grasp.

I have seven pairs of lines or line segments (for simplicity, I'll refer to all of them as lines). They are plotted in the figure below. In each pair, two lines always intersect at one point.
If you observe pairs 1, 2, 3, and 4, you'll notice they share a common characteristic: the lines from each pair form an angle (for pairs 1, 2, and 4) or two angles (pair 3 with upside and downside angles) that span both sides (left and right) of the intersection point. Pairs 5, 6, and 7 also form angles, but they only span on one side (either left or right) of the intersection point.

Now, what I want to do is remove all the pairs where the angle only spans one side of the intersection point (pairs 5, 6, and 7). How can I achieve this?

enter image description here

functions = {
   {ConditionalExpression[-x + 9, x <= 4], 
    ConditionalExpression[2 x - 3, x >= 4]},
   {ConditionalExpression[2.5 x \[Minus] 5.5, x <= 3], 
    ConditionalExpression[\[Minus]x + 5, x >= 3]},
   {ConditionalExpression[3 x + 10, x <= 5], 
    ConditionalExpression[\[Minus]5 x + 30, x <= 4]},
   {ConditionalExpression[3 x, 5 <= x <= 9], 
    ConditionalExpression[20 + 1/2 x, x >= 8]},
   {ConditionalExpression[-0.5 x + 5, x >= 8], 
    ConditionalExpression[0.5 x \[Minus] 3, x >= 8]},
   {ConditionalExpression[x, 0 <= x <= 1], 
    ConditionalExpression[\[Minus]0.5 x + 1.5, x <= 1]},
   {ConditionalExpression[x, x <= 1], 
    ConditionalExpression[\[Minus]0.5 x + 1.5, x <= 1]}};
Plot[Evaluate@functions, {x, -0, 10}, GridLines -> Automatic]
$\endgroup$

2 Answers 2

3
$\begingroup$

We may define a test function that calculates the intersection and the union of the line segments. Depending where the intersection is in relation to the union the question can be decided:

test[{c1_, c2_}] := 
  Module[{intersect, union}, 
   intersect = Reduce[c1[[2]] && c2[[2]] && c1[[1]] == c2[[1]], x];
   union = Reduce[c1[[2]] || c2[[2]], x]; 
   If[union[[2]] == Reals, Return[True]]; Switch[union[[0]]
    , LessEqual, If[intersect[[2]] < union[[2]], True, False]
    , GreaterEqual, If[intersect[[2]] > union[[2]], True, False]]
   ];

Now we may map the test function onto your lines:

sel=test /@ functions

{True, True, True, True, False, False, False}

With the test function, we can easily select the correct lines:

Select[functions, test]

enter image description here

Addendum

Here is an extended version that can deal with collinear lines:

test[{c1_, c2_}] := Module[{intersect, union},
   If[c1[[1]] == c2[[1]] && (Reduce[c1[[2]] && c2[[2]], x] =!= {}), 
    Return[True], Return[False]];
   intersect = Reduce[c1[[2]] && c2[[2]] && c1[[1]] == c2[[1]], x];
   union = Reduce[c1[[2]] || c2[[2]], x];
   If[union[[2]] == Reals, Return[True]];
   Switch[union[[0]]
    , LessEqual, If[intersect[[2]] < union[[2]], True, False]
    , GreaterEqual, If[intersect[[2]] > union[[2]], True, False]
    , Inequality && (union[[2]] == LessEqual), 
    If[union[[1]] < intersect[[2]] < union[[5]], True, False]
    , Inequality && (union[[2]] == GreaterEqual), 
    If[union[[1]] > intersect[[2]] > union[[5]], True, False]
    ]];
$\endgroup$
3
  • $\begingroup$ Could you make it work for these two cases as well? Currently, they don't return to true/false result. test[{ConditionalExpression[x, 1/2 <= x <= 1], ConditionalExpression[1 - x, 0 <= x <= 1/2]}], test[{ConditionalExpression[x, 1/2 <= x <= 1], ConditionalExpression[x, x >= 1/2]}] $\endgroup$
    – hana
    Jul 11, 2023 at 11:29
  • $\begingroup$ Thanks, the updated version seems to work for all cases now (I just tested with around 300 functions and it works). $\endgroup$
    – hana
    Jul 11, 2023 at 13:28
  • $\begingroup$ Glad to be of some help. 😊 $\endgroup$ Jul 12, 2023 at 7:40
3
$\begingroup$
xBounds = First @ RegionBounds @
  ImplicitRegion[Or @@ Map[FunctionDomain[{#, 0 <= x <= 10}, x] &]@#, {x}] &;

pred = FreeQ[{a_Real, a_}] @ N @ ReplaceAll[List/@Thread[x -> xBounds[#]]] @ #&

Plot[Evaluate @ Select[pred] @ functions, {x, 0, 10}, 
 GridLines -> Automatic, ImageSize -> Large]

enter image description here

$\endgroup$
5
  • $\begingroup$ (+1) I'm always impressed by your responses, @kglr! :-) $\endgroup$ Jul 11, 2023 at 10:02
  • $\begingroup$ Thank you. Would it be able modify to include this case as well (to keep this function)? {ConditionalExpression[x, 1/2 <= x <= 1], ConditionalExpression[x, x >= 1]} Also if I have around 1000 functions, would plotting them be slow? $\endgroup$
    – hana
    Jul 11, 2023 at 10:08
  • $\begingroup$ @E.Chan-López, thank you!! $\endgroup$
    – kglr
    Jul 11, 2023 at 10:38
  • 1
    $\begingroup$ @hana, as is, the method for fincding intersections does not work for colinear lines. Re 1000 functions, you might consider generating graphics primitives directly using Graphics/GraphicsComplex. $\endgroup$
    – kglr
    Jul 11, 2023 at 10:41
  • 1
    $\begingroup$ @hana, please try the updated version (which does not require finding intersections). $\endgroup$
    – kglr
    Jul 11, 2023 at 12:26

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.