Вот еще одна попытка, которая рисует числовые линии с более обычными белыми и черными кружками, хотя любой графический элемент, который вы хотите, может быть легко заменен.
Это зависит от LogicalExpand[Simplify@Reduce[expr, x]] и Sort, чтобы получитьвыражение в нечто похожее на каноническую форму, над которой могут работать правила замены.Это не всесторонне проверено и, вероятно, немного хрупко.Например, если значение expr уменьшается до True или False, мой код не умирает изящно.
numLine[expr_, x_Symbol:x, range:{_, _}:{Null, Null},
Optional[hs:_?NumericQ, 1/30], opts:OptionsPattern[]] :=
Module[{le = {LogicalExpand[Simplify@Reduce[expr, x]]} /. Or -> List,
max, min, len, ints = {}, h, disk, hArrow, lt = Less|LessEqual, gt = Greater|GreaterEqual},
If[TrueQ@MatchQ[range, {a_, b_} /; a < b],
{min, max} = range,
{min, max} = Through[{Min, Max}@Cases[le, _?NumericQ, \[Infinity]]]];
len =Max[{max - min, 1}]; h = len hs;
hArrow[{x1_, x2_}, head1_, head2_] := {{Thick, Line[{{x1, h}, {x2, h}}]},
Tooltip[head1, x1], Tooltip[head2, x2]};
disk[a_, ltgt_] := {EdgeForm[{Thick, Black}],
Switch[ltgt, Less | Greater, White, LessEqual | GreaterEqual, Black],
Disk[{a, h}, h]};
With[{p = Position[le, And[_, _]]},
ints = Extract[le, p] /. And -> (SortBy[And[##], First] &);
le = Delete[le, p]];
ints = ints /. (l1 : lt)[a_, x] && (l2 : lt)[x, b_] :>
hArrow[{a, b}, disk[a, l1], disk[b, l2]];
le = le /. {(*_Unequal|True|False:>Null,*)
(l : lt)[x, a_] :> (min = min - .3 len;
hArrow[{a, min}, disk[a, l],
Polygon[{{min, 0}, {min, 2 h}, {min - Sqrt[3] h, h}}]]),
(g : gt)[x, a_] :> (max = max + .3 len;
hArrow[{a, max}, disk[a, g],
Polygon[{{max, 0}, {max, 2 h}, {max + Sqrt[3] h, h}}]])};
Graphics[{ints, le}, opts, Axes -> {True, False},
PlotRange -> {{min - .1 len, max + .1 len}, {-h, 3 h}},
GridLines -> Dynamic[{{#, Gray}} & /@ MousePosition[
{"Graphics", Graphics}, None]],
Method -> {"GridLinesInFront" -> True}]
]
(Примечание: я изначально пытался использовать Arrow и Arrowheadsрисовать линии - но поскольку Arrowheads автоматически изменяет масштаб стрелок относительно ширины охватывающей графики, это доставляет мне слишком много головной боли.)
ОК, некоторые примеры:
numLine[0 < x],
numLine[0 > x]
numLine[0 < x <= 1, ImageSize -> Medium]
numLine[0 < x <= 1 || x > 2, Ticks -> {{0, 1, 2}}]
numLine[x <= 1 && x != 0, Ticks -> {{0, 1}}]
GraphicsColumn[{
numLine[0 < x <= 1 || x >= 2 || x < 0],
numLine[0 < x <= 1 || x >= 2 || x <= 0, x, {0, 2}]
}]
Редактировать: Давайте сравним вышеприведенное с выводом Wolfram | Alpha
WolframAlpha["0 < x <= 1 or x >= 2 or x < 0", {{"NumberLine", 1}, "Content"}]
WolframAlpha["0 < x <= 1 or x >= 2 or x <= 0", {{"NumberLine", 1}, "Content"}]
Обратите внимание (при просмотре вышеупомянутого в сеансе Mathematica или на веб-сайте W | A) показываются всплывающие подсказки о важных точках и серых динамических линиях сетки.Я украл эти идеи и включил их в отредактированный numLine[] код выше.
Вывод WolframAlpha не совсем обычный Graphics объект, поэтому трудно изменить его Options илиобъединить, используя Show.Чтобы увидеть различные объекты нумерации, которые Wolfram | Alpha может вернуть, запустите WolframAlpha["x>0", {{"NumberLine"}}] - «Content», «Cell» и «Input» возвращают в основном один и тот же объект.В любом случае, чтобы получить графический объект из
wa = WolframAlpha["x>0", {{"NumberLine", 1}, "Content"}]
, вы можете, например, запустить
Graphics@@First@Cases[wa, GraphicsBox[__], Infinity, 1]
Затем мы можем изменить графические объекты и объединить их в сетку, чтобы получить
