3

これは、 Mathematica でワイヤフレームに関する私の質問に対する答えを見つけようとする私の試みの一部です。

一連の線分が与えられた場合、接続されていて同じ線上にある 2 つの線分を結合するにはどうすればよいでしょうか。たとえば、線分l1 = {(0,0), (1,1)}と を考えてみましょうl2 = {(1,1), (2,2)}。これらの 2 つの線分は、1 つの線分、つまり に結合できますl3 = {(0,0), (2,2)}。これは、l1とl2が点を共有し、(1,1)各線分の傾きが同じであるためです。ここにビジュアルがあります：

l1 = JoinedCurve[{{{0, 2, 0}}}, {{{0, 0}, {1, 1}}}, CurveClosed -> {0}];
l2 = JoinedCurve[{{{0, 2, 0}}}, {{{1, 1}, {2, 2}}}, CurveClosed -> {0}];
Graphics[{Red, l1, Blue, l2}, Frame -> True]

出力

注意すべきことの 1 つは、上記の例l1で とl2を 3 つの点で指定された 1 つの線に結合できること{{0,0},{1,1},{2,2}}です。

この質問の最初の部分は次のとおりです。2 つの点で指定された線分のセットが与えられた場合、このセットを減らして、重複する点の数を最小限に抑えるにはどうすればよいでしょうか。この構成例を考えてみましょう:

lines = {
  {{0,0}, {1,1}},
  {{3,3}, {2,2}},
  {{2,2}, {1,1}},
  {{1,1}, {0.5,0.5}},
  {{0,1}, {0,2}},
  {{2,3}, {0,1}}
}

私が欲しいのはREDUCE、次の出力を与える関数 say です。

R = {
{{0,0}, {1,1}, {2,2}, {3,3}},
{{1,1}, {0.5,0.5}},
{{2,1}, {0,1}, {0,2}}
}

必要な重複は だけです{1,1}。私がこれを行った方法は次のとおりです: 最初の行を に置き、次の行Rを見て、 のlines行の端点と一致する端点がないことに気付いたRので、この新しい行を に追加しましたR。の次の行はlinesです{{2,2},{1,1}}。エンドポイント{1,1}は の最初の行と一致するRため、 の行に追加{2,2}しましたR。に追加{{1,1}, {0.5,0.5}}しR、 も追加し{{0,1}, {0,2}}ます。の最後の行にlinesは のエンドポイントと一致するエンドポイントがあるRので、それを追加したので、{{2,1}, {0,1}, {0,2}}. 最後に、すべての行をR見て、いずれかの端点が一致するかどうかを確認します。この場合、行{{3,3}, {2,2}}は最初の行の右端点と一致しますRしたがって、追加{3,3}する必要がなくなります{2,2}。

これは、最適な削減が得られないという意味で、最適な方法ではない可能性があります。いずれにせよ、この縮小関数があると仮定すると、線を記述するためにすべての点が必要かどうかを確認できます。これは次のように行うことができます。

線を表す点が 3 つ以上ある場合は、最初の 3 つの点が同一線上にあるかどうかを確認します。同一線上にある場合は、中央の点を削除し、2 つの端点と新しい点のセットでチェックを行います。それらが同一線上にない場合は、1 点ずらして次の 3 点を確認します。

この質問をしている理由は、2D 図形を記述するために必要なポイントの量を減らしたいからです。次のことを試してください。

g1 = ListPlot3D[
   {{0, -1, 0}, {0, 1, 0}, {-1, 0, 1}, {1, 0, 1}, {-1, 1, 1}},
   Mesh -> {2, 2},
   Boxed -> False,
   Axes -> False,
   ViewPoint -> {2, -2, 1},
   ViewVertical -> {0, 0, 1}
]

出力

次のMathematica 8関数は、3Dオブジェクトを、オブジェクトのワイヤーフレームを表す線のリスト(線は2点のリスト)に変更します:

G3TOG2INFO[g_] := Module[{obj, opt},
  obj = ImportString[ExportString[g, "PDF", Background -> None], "PDF"][[1]];
  opt = Options[obj];
  obj = Cases[obj, _JoinedCurve, \[Infinity]];
  obj = Map[#[[2]][[1]] &, obj];
  {obj, opt}
]

Mathematica 7では、 で置換_JoinedCurveする必要があることに注意してください_Line。g1取得した関数を適用する

{lines, opt} = G3TOG2INFO[g1];
Row[{Graphics[Map[Line[#] &, lines], opt], Length@lines}]

出力

そこには 90 個の線分がありますが、必要なのは 12 個だけです (直線の数え方を間違えていなければ)。

そこで、あなたは挑戦します。lines図を説明するために必要な最小限の情報を得るには、どのように操作すればよいでしょうか。

4

2 に答える 2

3

ステップ 1 は、線が同じ投影上にあるかどうかを調べることです。これは、最初の線の勾配が、最初の線の最後から 2 番目の点から 2 番目の線の 2 番目の点までの作成された線分の勾配と等しい場合に当てはまります。

仕事用のマシンに Mathematica がないため、これをテストすることはできませんが (構文エラーがある可能性があります)、次のようなものは機能するはずです。

(( #2[[2,2]]-#1[[-2,2]])/(#2[[2,1]]-#1[[-2,1]])) ==
(( #1[[-1,2]]-#1[[-2,2]])/(#1[[-1,1]]-#1[[-2,1]])) & 
 @@@ (Transpose[{Most[lines],Rest[lines]}])

基本的に、これが行うのは、最初の線分の「上昇」が結合された線分の「上昇」に等しいことをテストすることだけです。

:lines: は JoinedCurve 要素のリストではなく、点の n*2 リストの単純なリストであると想定しています。また、各線分を定義するポイントのペアは、ポイントが x 方向に昇順である標準的な順序になっていると想定しています。つまり、最初の点の最初の要素の値は、2 番目の点の最初の要素よりも低くなります。そうでない場合は、最初に並べ替えます。

ステップ2は実際にポイントを結合しています。これにより、手順 1 のテストが適用され、2 つの行が 1 つの結合された行に置き換えられます。これを FixedPoint でラップして、同じ射影にあるすべての線を結合できます。

If[(( #2[[2,2]]-#1[[-2,2]])/(#2[[2,1]]-#1[[-2,1]])) ==
(( #1[[-1,2]]-#1[[-2,2]])/(#1[[-1,1]]-#1[[-2,1]])), {#1[[-2]],#2[[2]]}] & 
 @@@ (Transpose[{Most[lines],Rest[lines]}])

これはすべて、比較する行のペアがリスト内で隣接していることを前提としています。それらがコレクション内のいずれかの行である可能性がある場合は、最初に、上記の Transpose 関数の代わりに Tuples[listOfLines, {2}] を使用して、比較する可能性のある行のすべてのペアのリストを生成する必要があります。

わかりました、これをすべてまとめると：

f = If[(( #2[[2,2]]-#1[[-2,2]])/(#2[[2,1]]-#1[[-2,1]])) ==
(( #1[[-1,2]]-#1[[-2,2]])/(#1[[-1,1]]-#1[[-2,1]])), {#1[[-2]],#2[[2]]}] & ;
FixedPoint[f @@@ #, Tuples[Sort[listOfLines],{2}] ]

# が混乱しないように、ステップ 2 のテストと置換関数を名前付きの純粋な関数に分割しました。

于 2011-06-16T05:07:41.830 に答える
1

これがまだ興味深い場合は、別の実装を次に示します。

ClearAll[collinearQ]
collinearQ[{{{x1_, y1_}, {x2_, y2_}}, {{x3_, y3_}, {x4_, y4_}}}] := (
 (y1 - y2)*(x1 - x3) == (y1 - y3)*(x1 - x2)) && (y1 - y2)*(x1 - x4) == 
  (y1 - y4)*(x1 - x2)

ClearAll[removeExtraPts];
removeExtraPts[{{{x1_, y1_}, {x2_, y2_}}, {{x3_, y3_}, {x4_, y4_}}}] :=
If[collinearQ[{{{x1, y1}, {x2, y2}}, {{x3, y3}, {x4, y4}}}],{First@#, Last@#} &@
 SortBy[{{x1, y1}, {x2, y2}, {x3, y3}, {x4, y4}}, #[[1]] &],
    {{{x1, y1}, {x2, y2}}, {{x3, y3}, {x4, y4}}}]

そのため、if thenlines={{{0, 0}, {1, 2}}, {{1, 1}, {2, 2}}}は戻り{{{0, 0}, {1, 2}}, {{1, 1}, {2, 2}}}、ifthenはを与えます。lines2 = {{{0, 0}, {1, 2}}, {{1, 1}, {2, 2}}}removeExtraPts[lines2]{{0, 0}, {2, 2}}

これは、垂直線、水平線などで機能します（ゼロで除算する危険はありません）。

あなたが持っているものが行のリストである場合、あなたはそれらの間のすべての別個のペアリングをこうして生成することができます：

ClearAll[permsnodupsv2]
permsnodupsv2 = Last@Last@
 Reap[Do[Sow[{#[[i]], #[[j]]}], {i, 1, Length@# - 1}, {j, i + 1, 
    Length@#}]] &;

（ここで説明した方法で機能的に実行できますが、このバージョンを一目で理解しやすくなります）。例えば、

 lines = {l1, l2, l3, l4, l5, l6, l7, l8, l9}; 
 permsnodups[lines]
 (*
 ---> {{l1, l2}, {l1, l3}, {l1, l4}, {l1, l5}, {l1, l6}, {l1, l7}, {l1, l8}, 
       {l1, l9}, {l2, l3}, {l2, l4}, {l2, l5}, {l2, l6}, {l2, l7}, 
       {l2, l8}, {l2, l9}, {l3, l4}, {l3, l5}, {l3, l6}, {l3,l7}, 
       {l3, l8}, {l3, l9}, {l4, l5}, {l4, l6}, {l4, l7}, {l4, l8}, 
       {l4, l9}, {l5, l6}, {l5, l7}, {l5, l8}, {l5, l9}, {l6, l7}, 
       {l6, l8}, {l6, l9}, {l7, l8}, {l7, l9}, {l8, l9}}
 *)

などの場合l1={{pt1,pt2},{pt3,pt4}}は、これを単純にマッピングremoveExtraPtsし、結果をフラット化して（のようなものを使用しFlatten[#,1]&ますが、正確な形式は入力構造によって異なります）、変更が停止するまで繰り返します（@Verbeiaが言っFixedPointたように、停止させるために使用できます）。変更されなくなったら）。これはすべてのラインアップに参加する必要があります。

于 2011-06-19T19:36:50.627 に答える