悠闲数学娱乐论坛(第2版) » Mathematica » 寻找直线上距离相等的点对

hbghlyj 发表于 2021-6-22 01:58

寻找直线上距离相等的点对

[i=s] 本帖最后由 hbghlyj 于 2021-7-2 02:21 编辑 [/i]

在(x1,x2,...,xn)中找出四个点(xi,xj,xk,xl),i<j<k<l,使xi-xj=xk-xl
比如n=6时,给定(x1,x2,x3,x4,x5,x6)=(1,4,5,8,10,14),就要找到(1,4,5,8)和(1,5,10,14)
算法1.直接找出"距离相等"的点对
算法2.找出"中点重合"的点对
算法3.对jk循环,把其它点到中点的距离排序
算法4.将点组排序,对jk循环,对il循环,若ij距离<kl距离则i--,若ij距离>kl距离则l++

hbghlyj 发表于 2021-6-30 01:04

[i=s] 本帖最后由 hbghlyj 于 2021-7-2 01:44 编辑 [/i]

以这组点为例:
L = DeleteDuplicates[Table[RandomInteger[{0, 1000000}], 100]]
输出为
{111988, 91827, 418006, 23684, 152143, 815641, 589995, 944654,
850248, 993531, 736348, 561984, 439202, 290744, 47756, 336557,
421330, 925291, 447834, 278393, 859888, 627030, 523926, 614873,
977777, 340880, 763863, 171909, 441676, 243728, 697049, 988835,
943911, 238207, 717667, 212786, 37319, 765158, 356441, 99623, 151717,
81172, 394806, 560386, 228408, 559788, 722764, 374600, 833726,
532868, 274918, 399552, 900602, 581973, 132044, 381181, 445016,
362752, 433424, 57090, 347405, 113425, 899909, 903147, 521921,
923471, 484862, 839227, 519225, 344360, 537103, 607180, 855724,
861408, 955922, 983303, 811503, 190691, 491088, 258497, 895099,
599895, 562591, 124538, 271507, 190306, 980727, 918464, 412639,
172971, 813125, 417767, 852197, 622839, 692846, 674402, 3591, 777488,
339130, 86852}
---------
算法1.其中用了[url=http://kuing.orzweb.net/viewthread.php?tid=8037&extra=page%3D1]这帖的FindDuplicates[/url][code]AbsoluteTiming[
Module[{},
  position =
   Flatten[Table[{i, j}, {i, 1, Length[L] - 1}, {j, i + 1,
      Length[L]}], 1];
  Flatten[
   Subsets[#, {2}] & /@
    Map[position[[#]] &,
     FindDuplicates[
      Flatten[Table[
        Abs[L[[i]] - L[[j]]], {i, 1, Length[L] - 1}, {j, i + 1,
         Length[L]}]]], {2}], 1]]][/code]输出为
{0.0120459, {{{2, 48}, {6, 50}}, {{2, 50}, {6, 48}}, {{4, 41}, {39,
    45}}, {{4, 45}, {39, 41}}, {{5, 34}, {18, 68}}, {{5, 68}, {18,
    34}}, {{14, 74}, {76, 89}}, {{14, 89}, {74, 76}}, {{27, 56}, {43,
    98}}, {{27, 98}, {43, 56}}, {{42, 69}, {83, 84}}, {{42, 84}, {69,
    83}}}}
测试多次,实际用时0.011~0.012秒
------------
算法2.其中用了[url=http://kuing.orzweb.net/viewthread.php?tid=8037&extra=page%3D1]这帖的FindDuplicates[/url][code]AbsoluteTiming[
Module[{},
  position =
   Flatten[Table[{i, j}, {i, 1, Length[L] - 1}, {j, i + 1,
      Length[L]}], 1];
  g[{{a_, b_}, {c_, d_}}] = {{{a, c}, {b, d}}, {{a, d}, {b, c}}};
  Flatten[g /@ Subsets[#, {2}] & /@
    Map[position[[#]] &,
     FindDuplicates[
      Flatten[Table[
        L[[i]] + L[[j]], {i, 1, Length[L] - 1}, {j, i + 1,
         Length[L]}]]], {2}], 2]]][/code]输出为
{0.0087029, {{{2, 48}, {6, 50}}, {{2, 50}, {6, 48}}, {{4, 41}, {39,
    45}}, {{4, 45}, {39, 41}}, {{5, 34}, {18, 68}}, {{5, 68}, {18,
    34}}, {{14, 74}, {76, 89}}, {{14, 89}, {76, 74}}, {{27, 56}, {43,
    98}}, {{27, 98}, {43, 56}}, {{42, 69}, {83, 84}}, {{42, 84}, {83,
    69}}}}
测试多次,实际用时0.008~0.009秒

hbghlyj 发表于 2021-7-1 23:34

[i=s] 本帖最后由 hbghlyj 于 2021-7-2 01:44 编辑 [/i]

算法3.其中用了[url=http://kuing.orzweb.net/viewthread.php?tid=8037&extra=page%3D1]这帖的FindDuplicates[/url]
AbsoluteTiming[
Module[{}, S = {};
  For[j = 1, j <= Length[L] - 1, j++,
   For[k = j + 1, k <= Length[L], k++, f[{a_, b_}] = {{a, j}, {b, k}};
     g[{a_, b_}] = {{a, k}, {b, j}}; m = (L[[j]] + L[[k]])/2;
    dup = FindDuplicates[
      Abs[# - m] & /@ ReplacePart[L[[;; k]], j -> x]];
    If[dup != {},
     se = Select[Flatten[Subsets[#, {2}] & /@ dup, 1],
       L[[#[[1]]]] != L[[#[[2]]]] &];
     S = S~Join~(f /@ se)~Join~(g /@ se)]]]]; S]
输出为
{0.645915, {{{5, 34}, {18, 68}}, {{5, 68}, {18, 34}}, {{4, 41}, {39,
    45}}, {{4, 45}, {39, 41}}, {{2, 48}, {6, 50}}, {{2, 50}, {6,
    48}}, {{27, 56}, {43, 98}}, {{27, 98}, {43, 56}}, {{42, 69}, {83,
    84}}, {{42, 84}, {83, 69}}, {{14, 74}, {76, 89}}, {{14, 89}, {76,
    74}}}}
测试多次,实际用时0.64~0.65秒

hbghlyj 发表于 2021-7-2 00:29

[i=s] 本帖最后由 hbghlyj 于 2021-7-2 02:14 编辑 [/i]

算法4.
AbsoluteTiming[
Module[{L = LL}, S = {}; length = Length[L];
  dict = #[[2]] & /@
    SortBy[Table[{L[[u]], u}, {u, 1, length}], First]; Ls = Sort[L];
  For[j = 2, j <= length - 2, j++, Lj = Ls[[j]];
   For[k = j + 1, k <= length - 1, k++, Lk = Ls[[k]]; i = j - 1;
    l = k + 1; Label[b]; p = (Lj - Ls[[i]]) - (Ls[[l]] - Lk);
    If[p == 0, S = S~Join~{{{i, j}, {k, l}}, {{i, k}, {j, l}}};
     If[l == length, If[i == 1, Continue[], i--], l++],
     If[p < 0, i--, l++]; If[i < 1 || l > length, Continue[]]];
    Goto[b]]]; S /. Thread[Range[length] -> dict]]]
输出为
{0.588293, {{{42, 84}, {69, 83}}, {{42, 69}, {84, 83}}, {{4, 41}, {45,
     39}}, {{4, 45}, {41, 39}}, {{5, 34}, {68, 18}}, {{5, 68}, {34,
    18}}, {{2, 48}, {50, 6}}, {{2, 50}, {48, 6}}, {{56, 43}, {27,
    98}}, {{56, 27}, {43, 98}}, {{14, 89}, {74, 76}}, {{14, 74}, {89,
    76}}}}
测试多次,实际用时0.58~0.59秒

hbghlyj 发表于 2021-7-2 02:22

结论:
算法2应该是最快的

查看完整版本: 寻找直线上距离相等的点对