8
$\begingroup$

I have this list of lists of integers between 1 and 255.

data = Uncompress@"1:eJzdnHvcr+k13n+IU5TquaXY2rSq6tzDVKnpiVIlQlFBp8rURGpKtFVtZEdP9KAlKG3UGIcgWikiRTCOdchMwjglJLZKmJkkWnVo6dF9+eznO+/1rvt673s/7/Ps32//sz4z73/7d63nXmtd17XWW37k3U+48/8dDoenPObXwvvc9ZRPvPPqo//vrsf92n/c9fta+P0tvFULf6CFt27hD7bwNi38oRbetoW3a+HtW3iHFt6xhXdq4Z1b+MMt/JEW/mgLf6yF21r44y28Swt/ooV3beHdWviTLbx7C7e38Kda+NMt/JkW/mwLf66F92jhPVv48y28Vwvv3cJfaOF9WviLLbxvC+/XwuNbeP8WntDCB7TwgS38pRY+qIUPbuFDWvjLLXxoC09s4cNa+PAWPqKFv9LCHS381RY+soW/1sJHtfDRLdzZwl9v4WNauKuFe1v44ha+pIUvbeHLWnhWC1/ewle08JUtPLuFr2rh37fwH1r46hae08J/bOFrWvjaFr6uhee28PUtPK+F/9TCN7TwjS18UwvPb+GbW/iWFr61hfta+LYWvr2F72jhO1v4rha+u4X/3ML3tPC9LXxfC9/fwkMtPNzCIy28soVXtfDqFn6uhf/awn9r4edb+O8t/EILv9jCL7Xwf1toaWnZ+Mbt77+phd/cwm9p4be28Nta+O0t/I4WfmcLv6uFN2nhTVv43S28WQtv3sJbtHClhbds4fe08HsPp5eNT2rhY1t4cgt/o4WPa+HuFv5mCx/fwie08JQWPrGFv9XC327h77TwSS08o4XPbuFzWvjcFv51C5/Xwue38G9a+LctPLOFL2jh37XwhS3c08IXHfbMxhe0cH8LD7TwwhZe1MIPtPBfWvjpFl7ewita+JkWfvYwlo2/3ML/OdTZ+Drt76/bwuu18PotPLaFN2jhN7Twhi28UQu/8XBD2Tj/ml5iNs6/dPPZ+Hdb+OQW/l4Lf7+Fp7bw6S380xb+WQv/vIV/0cJntPAvW/hXLXxmC591SNnYfTRvMBu7T2A3G3+whZe28LIWfrKFay381OF6NuqB7GajnkVl4/8+1Nn4mu3vr9VC+9Ndr324MBvzy3nlcD4bc+WvsrF6L7vZmF+/nI1Vjc3ZWL2DVTZ+Sgv/oIV/2MI/auEft/BPWvi0Qycbq/dS2ViVdWWjHsicjdU7WGWjanGVjXoWlY0vbuElLfx4Cz9xuJ6NeiBVs6tspEgrG//Xoc7G1zicz0Z7Ki0braxbNtpTqWy0ttSy0Z5KZaMVc2WjHkhloz2Glo1WfC0b7TG0bFSzZ9loj6FlowqyZaOeRWVj+63venoLn3o4n432VCobrZgrG+9pwXpOZaMeSNVsy0Z7DC0bq/aQztCykSKtbPyRFn60hR87XM/Gay2oZquNtGy0llHZ+KuHkI16IMlGVW+ykVdS2ahOk2zklVQ2UsKVjXogNSmRjbySykZKuLJRDyRNprLx9hZUs/UsKhspyMpGXkSykZmEF5FstPmD0UPZyItINlqPSHtINlKklY1PO5zJRl5JZSMlXNmoB5ImU9moB1I1m1lI2agHUjVbbaSykReRbLzvcCYbq2HF5hSy0VpGZeMPtfDDh+vZqAdSNVttpCYbsrEaYJSNv3K4KBv1QJKNeiBpI5WNeiCZexh5lI16INVVKhv1QKpmM7czsisb9UCqq1Q26oFUzdbco2zUA6marTZS9VnPorJRnaGeRWUjgwkziZ5FZeMdh+vZaNOwDcJ6FpWNNIo2sdiwomy0lpFsbD/4r2ejCreyUQ+kukplox5I1WzNPcpGPZCq2WojNZ4rG/VAqmarjdRko2dR2UijaBNLNTpXU7OysRpglI0PHq5nox5I1Wy1kZpsNGwrG7vjtLLxfx6GslEPpE02tJGq2TaF00aqZjPjqGZfOZzJRj2QtJGq2cw4qtlqI5nCVbPVRmqyUaOo+sycovpMo2gTsuozjaJNLBUto/pMo2gTSzU6VwOMZaMeSNpI1WxmHNVstZFM4arZaiM12UAWqWarjdRko2Fb9ZlG0SaWanTucjjdcZps1AOpmq02UpONhm3xP5ncUTb+j0OdjXswPHtwmpdIEh4nw3OJ1GVmFNcwPJmNJBvF8DTS8SYwPPPZOM9QztOKl5iNezA889nYZSi7VGPOxgGGp5uNIiLhG8XwFNm4B8NTZWN+/XI2VmxkJh2rbKzey4FsvFkMT87G6h2sslHkZEU/Khu7fOMow1NlIyKNajYMT5GNezA8ykZ7DC0brfhaNtpjaNkoItI4SMtGeyqVjVbMlY0V33gkDI9loz2Glo2VlohwY2zkfS3ogVTNXsPwWDaaZKg2Eoanl40bMzx6FpWNFGRlIy8i2YiyzYtINppuaCIN2cgryditEq5s1ANJk3lHC3ogVbOPk+FRNvIiko3WI1bKtsmI8JLKRj2QqtlqI9cwPGRjJWBrsoHhidm4HcOj+swQDcuobGQwYSZhnKZRvP1wJhu7kiFqIbO3ukpmb9VszT1M3KrZaiOPk+FhnKZRtIml8ll0RW2mcNVstZGabNYwPMrGrp1CwzYMz8XZuAnDo0YRglHZCMGobLQJGapR2WgTy4CATRupms2Mo5qtNpIpXDVbbaQmm+NkeKAalY02sVSj84DFQjVbbaQmGw3baxieAXMPDM+lzNTznNAeHrQ9jGNdIucSZ+p5TmjegzZvJiMbuzN1l/ohGyEdNVM3mmf1TF1lY2Z95l0Te8zU83aKitzpZuMNztQ5Gyv+p2unmJ+pu04KGJ7uTF1lo1gfGB6MPJqpi2ycn6mVjfYYWjZeaQGaZ941scdMPW+nMK5H2VgxPGtmastGewwtG0X9dO0U8zN110mhmp1nastGGHHVbGZqZaNm6l42Ts3UehaVjRRkZSMv4pXD9WyE4ZlyTewxU8/bKWB9lI16IFWzL3GmVjbyIpKNptTcc7iejV07xfxM3XVSqI3MMzXZaPqM2khmamWjZuqYjaMzteozYwu8jrIRQaZiv0ddE3vM1PN2ClE/zDiq2WojL3GmZoChUTTdsBJpKjvF/EzddVJosskztbKxUgs12TBTKxs1U1+cjQMztRpFKB1lI5SOsjFrMQOuiT1m6nk7BbS4arbaSE02lzhTQ+4oG21iyZKh2SnmZ+qsXeeZOmvXzNTKRs3Ug1NMNWevcVKscUiMbs2sWY4Z9VSMGibIxjzF5Il71FMxapggG0fXZMhGaJ5qiqnmbLIRmgc3j6aYNlgPTDHKRhussx64ZorJGmHlAp+fYrI9vNIIR6eYSihkpm6/dX+KsWy0EbvSCEenmEooZKauppjKHs5MjVhdTTGWjRqxmakRq9lJ0BTTy0abYvQsKhsZp7MeuGaKyRph5QKfn2KyPbzSCEenmEooVM0emGKUjbyIZKOm60ojHJ1iKqFQNbs7xVT2cNVsphhlYzXFkI3XDtezUTWbKUbZqClG2agpJmYjU4zqM42isYyVHrhmiskaYeUCn59isj280ghHp5hKKFQbOTDF0DJChhvzaBrh6BRTCYVqI7tTTGUPVxvJFKNsrKYYZaOR4WojmWKUjZpilI2aYi7ORj2QahQZoivO2/TANVNM1ggrF/j8FJPt4ZVGODrFdKWZgSmGcVrZ2OXB0QhHp5iuNNOdYrrSDFMM2WhTTFeaYYphtVXZqCkmZmOWB7MUmC232WibhcIsCpKNecc6C4VZFCQbs++WbGSwbr/1oyq1DTVZKMyi4D2HQ9032lBDNjJY521rspHBGsXa+kYbaq4dDo/uGzXKoFizmKC+sY0y3SnGOO/cNxr7bT6yK4dD6BvNW2bsd+4bjQdnirG+0dYKjf3OfaPx4Ewx1jea1YwpBkHG+kZlI6OMsd+5bzQenCnG+kazmjHFIMhY32gLhkwxCDI4Ha1vJBs1zzDFIMjgdGShVX1jLxuNZUSB6faNxn6bj+xKC92+0bxlxn7nvtF4cNXsqm+0tUJjv3PfaDy4anbVN5rVTDWbvpFsbD/4o6YYZSNTDOU6943Gg6tmV32jWc1Us+kbOQVA32gLhqrZ9I3KRvWNykbrG5WNcD2q2fSNykb1jcpG9Y3KRvWNvWysWMbcNxr7bT6y3Deat8zY79w3Vsxj1TfaWqGx37lvrJjHqm+smEf6RstGPZAMMMbwqGbnvrFiHqu+sWIe6RvtMIVqdsU80jeynUA20jdWzCN9I9sJHKFQNqpvLLKRAYZsrOw7ZGNFgVfEd5WNFQVeEd/muzUjz+2Hw6MrNUcolI0VBV4R37ZybUYespFRptqVIRsZZVBlyMaKAq+Ib7KxMvKQjYwy1a4M2cgogypTXUghGxllUGWwO1Kp6SDJRkYZVBnsjmy1qlK35rHKRio1UiDZaPsHkDtVpYbmqfpGyJ2qUkPz2E4C2YhQSKUmGxmnyUar1NA8do6CbLyjBfpGSEcqNc5w+kZIR/wT9I2QO1Wlhuahb6RSI1vTN0I6UqlxhtM3Qjrin6BScw+AvhHSEf8EiwlUamWjmkf6RkhH/BMsJnB/QpW6l41UahunrVLbOF1VahusyUYbp6tKbYO1VWobrKnUZKON01WltsHaKrUN1lRqW9+ywZpKjcGMbLRxuqrUNlhbpbbBmkp9z+Hw6EptgzWVGoOZHe2xwfq+FlSpMZixuUU26oG0wZpKfa0FVWo2t5SNqtTKRlXqIhthGSubRLUpOJqNFcMzmo3V9mBlooB5rKjGnI3V4ajKRAHzWGUjzSPMIyaK9ls71ZizkeaxykaaR5jHKhtpHmEeMVFU2UjzCPOIiYLthCobaR5hHjFRsJ3AEQq9ja1cV9mIHmgWMip1JcPkSn3lcCYbTYbJlZrBuqrUDNaoMpUMkys1g3VVqRmsUWWqSs1gjSqDwaz91i7D5ErNYF1VagZrVJmqUjNYo8pgMKsqNYM1qgwGMza3qkrNYI0qg8GMzS0O9OhtLLIRdbqy1zLFVBJ1nmKutMDOoEnUeYqBdKymGEhHFOtKos5TDKRjNcVAOqJYV1MMpCOKNebbSqLOUwykYzXFQDqiWFdTDKQjijXm22qKgXREscZ8y1ZrNcVAOqJYY75lq1XZqAdS2dgeyDvvODw6G+fvmNwqO1fzB066V0n2WJTqHiSR/FatQv3yebTn74TcKjtN8wdEulc/9lhE6h78EGlWrRoVaM/f4bhVdobmD3R0r2rssejTPaihwata5SnQnr9zcavs5MwfwOherdhjkaZ7sEKtZLUq00N76o7ErbLzMn9gonsVYo9Fle5BCLVq1SpKRHv0TsOtslMyf8Che3Vhj0WQ7sEFdefVqkeBdt5LF7xTXdrp7GzkLq1aP692y7td2mUvWlRdmraAJHJWqxQF2nnve75LO52diNylVevd1e72PS3sschQdWlC+1oL1apCgXbeq57v0k5n5yB3adX6dLUb3e3SLntRoOrShLaov2oVoId2d295vks7HU9/7tKq9eRq97jbpV22Eb/q0oS2qLXKah/RrvaC57u00/HM5y4t3y9it7fbpV220b3q0rhBVFnZC7Rt8dHqtpEtVd0+WU+61W2jU6xua0PClhdVt5+5YLyxkdzqNhenJHVXVvECbVsstLptZEtVt0/W82112+gUq9tC25YDVbdFsexh1La6DdoS7yordg9tZGOr20a2VHX7ZD3VVreNTrG6zdY83lXVbVEsexihrW6DtsSxyuoc0X7MgjZ128iWK2fRPm3PstVto1PypTe96arbn7+gvbHRuBJEuNZWWYkLtNmwMBFeLzkEul7ytziL9ml7gvWSV/K5HffjIgZqul5yjWGftwC9sZGXlxwaTWjLkFFZdXtoVwYgveQQ6HrJ33xB+xbw3H7sgrZZd0C7upsntPWSawwTY76HUZaX3NCW4aGywka0zXz4hgva+sD1kr/ZgvYt4GnVS17ZBtmA6l5J1EuuMexzF7Q3NqJWYieXDiuraQ/tyvisVg2ns1o18Sy3imeUzXSzLPNtV5e29G2rVRPP8jk9tC/b6Int2NCWramycka0beniDRa0OQT4pgvat4Ank6sYti7Bt929OalWTTzLZy9ob2ykrKRtoS0nW2WVjGjbwtdjF7T1nKs7F7V2q3ge1YlXq1psVnev6Kk7F7UmFXQPo2IldnIJr7IiTiuea67ZVQ61PRTP7FCr3IWVB21U8Ry9PqcJbF7xrGxqhrYUT87IoXj+0nm0s+KZXWv5WlzlUNtD8cwONZOxu7ffRhXPyqtWXXdTlzaveFY2NZu3r7XwigVtFM8C7ax4ZtdavsZWOdT2UDyzQ81uZJjj0Lq0AcVz9Hqa6va84lnZ1Iwnl+L58gVtFM8e2l3FM7vW8rWzyqG2h+KZHWp2gwJipboWNaB4jl4nU92eVzwrm9r9Z9GW4smZMRTPiHaleGbXWr4mVjnU9lA8s0PNbjyojFcetFHFc/T6l1q1ecWzu0cA2lI8OeOF4lmgnRVPq9tT17rMwlTV7U0UT6vbZlLKKyHVS54Vz9HrWuJZ5hVPq9tSuk3fluKpuq1WDcWzQDsrnla3p65hmYWpqtubKJ5Wt82kZHW7e9tqVPEcvV6lyXte8bS6LbTNlybF8+UL2iiePbS7iueaa1NmYarq9iaKp9VtMylZ3e7ejhpVPEevQ2nynlc8rW7jYgFtKZ6ceULxjGhXiueaa05mYarq9iaKp9Xtrq8432YaVTxHry+JbJlXPLsbYaAtxZMzSiieBdpZ8VxzLQnOTS/5Oy9Ab6x46iWvyDO7UphvH40qnqPXjcSmziuevOQ4y81PLsVTL7mKN4pnD+2u4rnmGhF8ul5yjWF7KJ4ftqBtxLhdAcy3hUYVz9HrQWJT5xVPXnLbGgFtKZ6cAULxjGhXiueaaz9oZXrJ33FBe2PFUy95JXqZ9zDf7hlVPEev84hAn1c8u9ueoC3FkzM7KJ49tLuK55prOujgatXeoYf2ZSue+IpN0O6iXYnco4rn6PUbaSbziif6drURhuLJGRsUz4h2pXiuuVaDx0Wt2tsvaG+seLIzYGaV7kteGVhGFc/R6zKSyeYVz+5uL2hL8eRMDIpnRLtSPCuKfPQaDP41deei1vZQPNu/rzSidbu0ypw2qniOXm+5d0F7SvHs7vbev6D94IL2Ty9oL2u9mUszScz00Hy5AaArLi2vFahuj3JppoHldYEpLs3UMEPbuDSTxEwP5XIDXBp7BJlLMzXM0DaRW1zatRakfcKl/eJ5tI1LM0lMaMOm5ssNoF1xaXmt4PYWRrk008DyusAUl2ZqmHVpxqWZJAbaolS53ACXxh5B5tJMDbMuzcxp4tI47g6X1kObCcwkMXgWzA3dyw1Cu8ul5bUCveSjXJppYHldYIpLMzXM5m3j0kwSE9rYHLjcAJfGHkHm0kwNs3nbbMbi0l62oA2XFtGmS+M5h0M1K0t1uSFzaXmtQMV7lEszDSyvC0xxaZWBxdCGSzNJrDK1GJfGHkHm0ioDi9Vt0BaX9tIFbbi0Am3j0kC7ci/ZMsEUl5bXCtSdj3JpesmzEa06yzDApdkKgTGnxqXxklPBQVvduXFp7BFkLo2XnGUwU0UwsIhL4/g3XFoPbXvJUbpBGwGUZYIpLi2vFag7H+XSnrCg3TWZWt0e5dJshcA0sKsL2vaSC20Vb+q2unPj0tgjyFwaLzlkuakioC0u7WUL2nBpEW1ecmvHK7nbXvIBLi2vFWggG+XS9JJnAznsyhSXVpnTDG24NF5ya8wRvo1LY48gc2mVOc1UEdAWl/bSBW24tB7acGmViwW0bZlgikvLawWawUe5NC4pdZdDbAIb5dJshcDcDMalVWhTvDWDG5fGHkHm0mBOTQgzLk1oi0vTt63nHC4tog1Pbg41XnJbJpji0vJagWiXUS6NK2ndxS8a8ykurbIiGtpwadVLTmMu2sW4NPYIMpdWWRHtAgtoi0t76YI2XFpEW8955T6lS7NlgikuLa8V3LagPcClcQGxu9TJ0D3FpVVWxE8+i/bVFtSdV10aQ/czFrTh0tgjyFxaZUW0CyxYER9c0H7ZgvZiRVyDdiZSObtkPXm1U4LrmJ789hbEqtGT69tesxyyBm2jT+nJ4Vng13Ad05OjdHNs6dnTaBt9alsj6slFsYhVoyf/hYT2wEueRRLOLllPXu2L4TqmJ0fppifXt71m8WvNS27SyNUFbXgWoa2BDNcxPTlKN8eWhPbUS27SiG2EqSd/yYI2PXlEe6BLywIoZ5esJ692QXEd05OjdNOTGzE+v9S5pksz2VNoP31BWx+40ebWk6N0qydny3eqSzPZ07Y91ZO/eEGbnryH9ugEls0NquBVT16hrQpuPTlKNz35+/bQHl3YXjOBmaWBnrxCWxXcenKUbvXkbPlOTWBmabBNbvXk+rb1nNOTR7QH2JVsXFLTduUs2t0bDmrarCdH6aYnhzy7wWMMa9gVsyvRk1cvuZo268lRutWTs+U7xa6YXcmuNKgnf/GCNj15D+1R5jSbEt9kQdt68qpLe7sFbXpylG56csizGzy0soY5NSsiPXnVpX36gjY9OUr3vQva+sCnmFOzItoFlgcXtF+yoL1II2tUkWw4tkUh0K5uL6GGqTvHY67u3FaBsqV4O1XEbMag/fQFbXvJ4VnwmKs710vO5YYpVcRsxnZdSS+5WrUfW4BeGvM1imdeJrAlQNCu7qqhhmE9xr1ka355XWA7xdNWCECbMcxecngWPOacXfrSs2iPKp62QmCX0/SS/8iCNi95D+1RN0NeFLIFX+o2rZq95PAsty1o6wO3Fd68CrSdm8HWg6jbtGr2ksOzPGNBm7NLQlsf+JSbwdaDeMmF9oML2j+6oL2MYWucSnkJ0Jb3ecStMTfa3MyoetNtPX/NYdM1TiVb/btaoE0FhzY3M6od4tGbPuVUstU/0H5gQVsf+A+fRfvnz6O93SUOg9dsaoa2udYMfFsNNbQ/tMDYPmte8pt1iYMGDUINIhXhG6MiiyVq1XAz5Escr2rh1S383Hm0t7vEYd92RttMiYa2bf7apy607QOv0FZPfrMucfCIP6uH9nMKtLU0puccxROxs7rE8cqE9naXOKxumynR6raZEq2M2+avlXF94Fa87RGveHKhvdslDh5xGHPQxowK2ix76zlHA8uXOB65EO1NLnFYT26mROvJzZRoLbpt/lqLrjfdGnMW/kwVuVmXODipBmOOAGpo84gLbVVwNLB8iePhMbQv+xKHzdtmSrR520yJNn7b5q+N3x+8oM3QrTJuJduY030vcdClwZhbyRbaVrKFtpq2717Qzpc4Hkpob3eJI/fkeZnA6rYd2bKOvarb1rSB9s26xGF125q26iXnANN9LaCKIIhUlzhUt1/VQXu7Sxx53s7LBFa37ciWTeNV3bahmy7tZl3isLoN2urXqi6N42qayuDJ8yWORy5Ee5NLHJlLy8sEVrftyJYxbVXdNkINnvxmXeKwuo0+IrRZK7C6LbQ1iMOT50scD4+h/ZgF7cu5xJF58rxMYHXbjmwZi17V7Wryrur2bpc4rG5Xk3dVtzmTyQpBvsTxUEJ7u0scWQPLywQmifGSa5PEFLIPWoDuCmG0ajfrEgcvORUctCt25bkL2qLb4MnzJQ695K9MaG9yiSPr23mZwORuXnI2QFG/NYZlkZuhO+vb213i4CVHGqFuM3TzkoO2GFZ48nyJ4+ExtPGlXc4ljuxdycsEZmXhJbd9X73kH7ig3TWwYFfK3pXtLnHwkltjzksutI1G4wQudqV8ieOhC9He5BJH9qXlZQKzqbFEwk4grrUP6KFdHV/JvrTtLnFUaFO8mbw5zQLa0spQRfIlDn3bj1yINm6Gy7nEkT2neZnALKgMX7bdrVbtCQvaXeMprFr2nG53iaN6yWnMYdWMNOXgMSJ3vsTx0Bjal32JI/vJ8zKB2ctpx23fV925qLVsKocxv1mXOKoujaEbxtxoNE7gInvmSxxC++EO2ttd4pjSt03TNNErc2lZ/VbdHuXStrvEkbk0U8MM7ftawHAMl1Zd4oBLe/V5tLe7xDHlXcnnbjOXlp0teslHubTtLnFkLs3UMOvSxKVhQYVLqy5xwKX10N7kEseULy2fu81cWnat6SUf5dK2u8SRuTRTw2zeFpeGBTVf4oBLi2gPeE6nLnFMeU7zudvMpWVHqor3KJe23SWOzKVVBhbQFpf2bQvacGnVJQ64tALt7S5xTPnJ87nbzKVlt3n75w5zadtd4shcGi+56FNjTsWlYUHNlzjg0npob3KJY2pXJJ+7zVxa3iRRdz7KpW13iSNzabzkkOWgLS4NCypcWnWJAy4toj2wBzZ1iWNqDyyfu81cWt4S00A2yqVtd4kjc2mVOQ20xaWxCQiXVl3igEvrob3JJY6pHc987jZzaXkDVDP4KJe23SWOzKXBnJoQBpeG4RgurbrEAZcW0YYnv5xLHJlLs/3tfO42c2l5u1u0yyiXtt0ljsylVVZE0BaXxv4IXFp1iQMuLaJ92Zc4pm4z5HO3mUvLlxueuKA9wKVtd4kjc2mVFfFrFrSft6D97QvaWBHtEgdc2lq0py5x0JPr285U6RTaU1dZ2j/3UUr3zbrEMYW20afqydkSy5c46MlfldAeeMmnLnHQkw/cVJp6yenJ4VmEdnVxyc6VT73kl3iJY+olN2lEPTlbYvTk1SUOevKI9kCXNnWJg57ciPFK4pzq0ujJ4VmMNreeHKV7qku7xEscU12ayZ7qybncQE9eXeKgJ++hvcklDnryt+mhnXvy7gQ2dSlRPTlK99QEdomXOKYmMLM0qCdnJ5CevLrEQU8e0R5gV6YucdCTQ551rUlT7Ao9efWSq2mznhyl+2Zd4phiV8yupJ6cFW968uoSBz15D+1R5nTqEgc9OeRZ13Y4xZzSk1dd2vsvaNOTo3TfrEscU8ypWRGft6D9LQvaSCN2iYOevEB7u0sctgqULcVTqghov9eCtr3k8Cx4zNs//KZd4phSRcxmzA2H5y9A05jbJQ5e8lcmtAcUz6lLHLbml9cFphRP0GYMs5ccngWPOWiPKp6XeIljSvG0FQLuswhtXvLqEgcveQ/tUTfD1CUOW+HNq0BTbgbqNq2aveTwLE9c0NYHPuVmuMRLHFNuBlsPet6C9jctaDOG2SUOXvIC7e0uccCbQYx31/ymnEo84taYG21uZlS96VNOpUu8xDHlVLLVPw4wfcNZtB9Y0OYSB2g/cmugPeVLm7rKog+ceXuNLy0vf9r5Bn3gzNvZl8a2pxZ8zZfGtufPnkf7FF/yKV/a1MUlfeBMYGt8aXn508436ANnAsu+NLY9hbb50tj27KF9Yl3alC9t6pqa3nQmsDW+tLz8aecb9KYzgWVfGtueQtt8aWx7RrRPZwKb8qVNXUpUGWfRc40vLS9/VheXWPTMvjS2PYW2+dLY9izQPkV2ZcqXNnUFVZ0bE9gaX1pe/uQll0dRnRsTWPalse0ptM2XxrZnD+0TY06nfGlTF47VrDOBrfGl5eVPXnKhrWadCSz70tj2FNrmS2PbM6J9OqrIlC8tL39W19QQwtb40vLyZ3VNDSEs+9LY9hTa5ktj27OH9okpnlO+tLz8iT1RaIt2Yd5e40vLy5/YE4W2aBfm7exLY9tTaJsvjW3PiPbpuBmmfGl5+ZPhi70h6NM1vrS8/FndzoM+zb40tj2FtvnS2PaMaJ+OU2nKl5aXP6trahBqa3xpefmzuqYGoZZ9aWx7Cm3zpbHtuRbtI3EhTvnSptBWT45IssaXNoW2enJEkuxLoyfXGGa+NHryn0lon47DeMqXNvWSqydHJFnjS5t6ydWTI5JkXxo9udA2Xxo9eUT7dLYHpnxpU12aenKMS2t8aVNdmnpyjEvZl0ZPLrTNl0ZP3kP7xDaDpnxpUxOYenIksTW+tKkJTD05klj2pdGTC23zpdGTR7RPZ+tvypc2xa6oJ8fhsMaXNsWuqCfH4ZB9afTkQtt8afTkPbRPbKN3ypc2xZw+aUH74xe0b9CXNsWc3rug/RUL2l1fGj250DZfGj15gfYpbutP+dKmVBEsTHcvQN+gL21KFcHC9KwF6K4vjZdcxdt8abzkr0hoDyieR3KJY8qXNqV4Yk8U2mt8aVOKJ/ZEoZ19abzkQtt8abzkPbRH3QxHcmVnypc25WZ40oL2xy1o36AvbcrNcO+C9pctaHd9abzkQtt8abzkBdqneEFrypc25VTCf/zks2jP+9KmnEr4j7/kLNqVLw20v2dBG18aaL/8PNrGpfGSC+jjvI6XubRMpN6xAP1RC8ZdLs1WPjOXlolUW/nMXJqtfBqXhtItc4NxaSjdP5XQpkvTt60v+jgvX2YuLYsktvKZuTRb+by6oF1NYFkksZXPzKXZyqdxaSjdQtu4NJTuiDZ1W4+4mUwrifNmXbXNXFoWQG3lM3NptvIptLtcWhZAbeUzc2m28mlcGkq30DYuDaW7hzbFm7qt3izbF27WxerMpWVzg618Zi7NVj4zl5bNDbbymbk0W/k0Lg2lW2gbl4bSHdGmS9O3bZbi0Zd8lEvLxiW16IxhU1xaNi7Zymfm0mzlM3Np2bhkK5+ZS7OVT+PSULqFtnFpKN09tOnJacfNZDrapY1yadmUeNuC9rsvaI9yadmUaCufmUuzlc/MpWVToq18Zi7NVj6NS0PpFtrGpaF0F2gbl8bIxUvetRSv4dKy4Rie5d0WoEe5tGw4tpXPzKXZymfm0rLh2FY+M5dmK5/GpfGSq3gbl8ZLfi2h/doL2vCleV1gDZeWlwngUIX2FJeWlwls5TNzabbymbm0vExgK5+ZS7OVT+PSeMmFtnFpvOQ9tHnJYVLMvlCtAq3h0vKi0G0L2u+6oD3KpeVFIVv5zFyarXxmLi0vCtnKZ+bSbOXTuDRecqFtXBoveYG2cWmwpCZoV2t+a7i0vASISPIuZ9Ee4NLyEqCtfGYuzVY+rxZoU8HzEqCtfGYuzVY+jUsD7e9Y0IZLA+2fPI+2iV65bpsGZqtAuW7bopBpYLlumyRmddsWhUwDy3XbJDGr23a5weq2LQqZBpbrtkliVrftcoPVbWax+xaMqdvMYj+R0DY3WlW3TQOzNb8rPbSNUOMlr2i0qm6bJGZ125YATQPLddskMavbdrnB6rYtAZoGluu2SWJWt+1yg9VtZjGhbXWbWayHduU0req2aWC2wiu0u3XbFnxNA8t12yQxq9u24GsaWK7bJolZ3bbLDVa3ecTp0iqKvKrbJolZ3bbLDVa3mcWEttVtZrECbRO9ct02DczW80G7qtu2vG8aWK7bJolZ3bblfdPAct02Sczqtl1uuHoWbVveNw0s122TxKxu2+UGq9ug/a0L2tRt0P7x82ibpmloW1uW0bamzdqyjLY1bYa26aHWlmW0rWkztE0PNbTtbIe1ZRlta9oMbdNDDW2+8mcVaPOVP79Am6+8Pex3Pv4M2gbvlIJ9irc21txd0ZOsl/eeFsSCrbmhoSM5unmmY8Q/eB4dK6xTbpJTvI3BhzZ/A0lPqF5KGOk1Ny+4P9hDx5rcKWfXKd6yeNKCzvw9MlU5FTMY5DU3Ku4fQ4eBc8pleYq3J6hUeuOmbgOqEVG/8QULOmtuSrzgQnRMtJlyPJ/irYiqhRi906l2QV0BDO2aGxDc4+uhYwLq1PYBo/rp3HbgZWNot7qDgGq7Cero1LjBqK652XD/GDqYGaY2gZi4TucWAy+bNW72snFhCXTUdKu3xoiiZvoGbyy84EJ0zFg0tZWHt+R0bidU6FhHjbHIdvY0F2n8gZ/WvHODNxH07TxwITqY/KY2ZOGmTufWQfWy0biZyc/2ZzW6akJFHlxzw+AFY+hguJ3aVocnPp3bBFVXwNBjhlvbZRe78IwFHX1Aa24OCJ37EzpId9azDVyOOMVbAlPo2F0JEUBmc15zI4Ce7UUddDBNWM82cMUl+5WPc/d/6mWzGy/i6MyWvGann54toqMPyHq2gYtKp7irP9UV2L0l0ahmI16zg0/P1kMHW7j1bAPXzbIf+Dh366c6art9JqbbbL/m853amadni+jo27GebeDSYPbvHucu/NQ0ancIJUaYTXfNjjs9W0RHz5v1bANXP7Pf9jh316eYHHo2LsCarXbNTjo9Ww8deaX1sr3+WXQqu6zZbrI/9jh3zadYUL1sT13QkWJrdhrzz0ztkPOyvTCho5ft9c6iU9lbzSaT/azHuRs+pSBAgAodiepmf1mz883LFtHRy/a6CzpdO6rZWrL/9Dh3uafUNyg2LqKaXWXNjjYvW0RHxUesQbaPmjHhFHevp5RraAKuHJrhYM1ONeg80EGnWs+pTCV62aa4guPclc5cAegYiQNXYMcH1+xAG1fwA+fRqVblULM5VqKXbYorOM7d5swVUHeMAIUrkMiDL2/NzrJxBT10bG0VNdvMOlNcwXHuImeuwOw4ho64Aok87KSu2TE2rqBAp1ohr9BR3ZniCo5zdzhzBTA5JrzBFUjkweW4ZifYuIIeOo9Z0OHbsZdNrcEUV3Ccu76ZKzCzlKEjrkAiDybzNTu8xhX00LHTKlVXoO5tiis4zt3czBXYIGrzjrgCO3a3ZufWuIICHbiCfLBODfYUV3Ccu7SZK9DLZvQ0TI64AlvMWbMja1xBDx1etu6BOc1AU1zBce6+Zq7AzFKGjrgCW6RZs9NqXEEPHV42hp7HLuggy01xBce5q5q5AhMPjKO+2oItvqzZQTWuoIeOik8+4PbGCzqjXMFx7pZmrqASrVHfnragw+rCmp1R4woiOkw+GKis7hhlfYq7oFZ3hI4x01XdUWugumN3HdbseFrdedGF6MDpVHXHKOtT3N20ugN/Uxk+DB3VHRZ3hc6anUyrOxEdGDcMVFZ3jLI+xV1LqzvGfVYvG+hcbcHuJqzZobS600PHzh68zoKO1R2jrE9xN9LqjukGVVfASPq0BR0W6tbsPFrdKdCxklNNPpVoqjJ0iruM1gZU6Ng0Wt1tZrl1zY6iofPC8+iMKgjZhpg9o2+7YELd2U5ByOZDWjheturu6qiCYOZDu7GaFQQzH37/eXRGFYRsQ8x+a31PZj7cTkHI5kOGU7qC6k7qqIJg5kO7iZoVBDMf9tAZUBCyDTHvKujJM/PhdgpCNh/a5FPR09X6QVdByDdMs4Jg5sMCnVEFIdsQ856PqpKZD7dTELL5ELlHjVsl7VSrO10FId8czQqCmQ976AwoCNmGmHfk1DiY+XA7BSGbD43TqWTRau2tqyDkG6FZQTDzYQ+dAQUh2xDzfql6OzMfbqcgZPOh8aGVpaBaGe0qCPmmZ1YQzHxYoDOqIGQbYt7N1jRkxM52CkI2H+plk9IDYXD3Akx33bqrIOQbnFlBMPNhD50BBSHbEPNdAw2sRuxspyBk86HpcAik+VRBV0HINzOzgmDmwx46AwpCtiHmmyDiFIzY2U5ByOZD07ChDvKZj66CkG9cZgXBzIc9dAYUhGxDzPd0HregA3WwnYKQzYeVO+fJZ9GpTuR0FYR8kzIrCGY+jOhkBcHqztTVSday4Xm2UxCs7ggdk6+rumPszqiCkG9IZgXB6s73XYhOV0GwujN1JZK1bHTt7RQEqzvwN5UrtLIcCp1RBSHffMwKgtWdiE5WEKzuTF11ZC0bonQ7BcHqjpmp7WWr7LqgM6Ag5BuNWUGwutNDZ0BBsLozdYXxcQs6ENrbKQhWd2wRofIdPvksOp9wFp2sIOSbillBsLpToDOqIKy5mmgK91sV6FyigmBtQIWOeafM3nZ3gU5XQcg3ELOCYOh873l0qq7A0OEr0kNXOQzmu4LsOshdgU2j+naym2C+K6i8BlVXYMMpBNxnLZh0uwIbTr/rQnTs2zFBAaUnL8VdOYtO1RVk10HuCmwaRdXpugnmu4LKa1B1BTacQsAJndwV2HAa0bGXrRLj0BLyUpzQyV1Bdh3krsCmUXSDrptgviuovAZXW7CuwIZTCDihk7sCG0576FjdsZJD40ZvnZfiQKfbFWTXQe4KrNDYlFO5Cea7gsprUHUFNpyCzmcu6HS7AhtOC3SqrsDatQoda+Hmu4LsOshdgTVpFTrWuM13BZXXoOoKDB2+os8o0LGuwND5zvPoVP3ZPDq5o6vQyY6R3JXNo1P1cRmdyh1SoWOfEk/ep12Mjn1K951HZw/Xx5r90nyaCnru8Qt2IHbHWTisK9jD9ZG3Su0g1defR2cP18ea/dJ8mgrhQe+eHZ/KG6R7uD7yVqkdpOqhs7HrY81+aT5NBaut0mTHp/IG6R6uj7xVagepCnT2cH2o7tzgfmk+TYWVR92DHZ/KG6R7uD7kQOxuldpBqh46G7s+8FvP75fm01TodWrw7PhU3iDdw/WRt0rtIFUPnY1dH2v2S/NpKrRu9eB2fCpvkO7h+shbpXaQqkBnD9eHddRT+6X5NJVeNrl4NLWaLJc3SPdwfeStUjtI1UNnY9fHmv3SfJoKj5WIBZPl8gbpHq6PvFVqB6l66Gzs+lizX5pPU+FPFPdjslzeIN3D9ZG3Su0gVQ+djV0fa/ZL82kqnNfvuaADxZA3SPdwfeStUjtIFdHZzvWxZr/U6o7QMWsidcdciVnz2cP1kbdKre4890J0NnF9rNkvtboDf1Nt/JgrMWs+e7g+8lap1Z2IznaujzX7pVZ3bl/QqTZ+zJWYNZ89XB95q9TqTg+djV0fa/ZLre7QR1c7JSY8ZM1nD9dH3iq1ulOgs4frY81+qbUBFTqVL/69C3RMVdjD9ZG3Sg2drzuPzh6uj9wV2DSqbyc7RUe7guwZ3cP1kbsCG06fcyE6m7g+cldg0yiqTtcpOtoVZM/oHq6P3BXYcBrR2c71kbsCm0bRDbpO0dGuIHtG93B95K7AhtMeOhu7PnJXYIXGppzKKTraFWTP6B6uj9wV2HBaoLOH6yN3BdakVehY4zbaFWR3wh6uj9wVGDpffR6dPVwfuSubR6fq4yp0srNnD9dHRsc+pWefR2e+Z8ucjmkJV1qYd+ru0bPNe3vne7bM85jc8EUXojPQs2VOx7QEPDlTTt09erZ5b+98z5Z5HpMbIjqjPVvmdExLoCuYcuru0bPNe3uvtjDVs2Wex+SGHjpTPVvmdKwhoKOecuru0bPNe3vne7bM85jcUKAz37PlDuBKC5krGHDq7tGzzXt753u2zPMYOvecR2e+Z8vd8yg6ucveo2eb9/bO92wZHfuUnnkenfn+eA905nvweXTmvdrz6OQvy57BVqnufI8z6Ogpq8TQPVbcjrNxnqdHKyH1U87/1qodlbS5x8LacbbB82RnJYsWv7WKdSVU7rF+dpxN7Tx1WYmcxW+t7qiSHfdYJjvOFnWeiKwky+K3fo3lt7aGZ4/VsONsOOdpxUqA7P3WVeu/x6LXcbaP8yRh9Vs/deK3nm/ub5VmcP63rnL9kzb9rfdo7vf4ree/hOoluuvkf+s9vp35l62qLO1n/v9Q2UK6"

Is there any efficient method to obtain one (not all) minimal length list L such that:

Union[Intersection[#, L] =!= {} & /@ data] === True

It's known that there exist one, because the sublists are non-empty.

Example

data = {{1,2}, {2, 3}, {3, 4}};

Note that the intersection of data is empty. For this set, one possibility is:

L = {2, 4};

Check:

Union[Intersection[#, L]=!={}& /@ data]

{True}

$\endgroup$
3
  • $\begingroup$ I may be having a slow day, but could you clarify what you mean by a list that "intersects" all sublists? Intersection @@ data returns the empty set. $\endgroup$
    – MarcoB
    Commented Aug 2, 2017 at 17:14
  • $\begingroup$ @MarcoB If Intersection @@ data was non-empty, then the result would be the list {First[Intersection @@ data]}. Now that Intersection @@ data is empty, the result must contain more than 1 integer $\endgroup$
    – Coolwater
    Commented Aug 2, 2017 at 17:46
  • $\begingroup$ Got it! Thank you for the explanation. $\endgroup$
    – MarcoB
    Commented Aug 2, 2017 at 18:02

3 Answers 3

10
$\begingroup$

LinearProgramming

By enumerating your lists and associating each element of Union @@ data with set of indices of lists that contain this element, you can translate this problem to a "minimum set cover problem". You're looking for minimal number of sets of indices such that their union gives set of all indices. "Minimal set cover problems" can be formulated as "integer linear programs" that in Mathematica can be solved by LinearProgramming function.

In this case we are looking for vector $x$ of $k = 255$ zeros or ones such that $x_i$ is $1$ when $i$ is in our result set and $0$ if it isn't. So we want to minimize $\sum_{i=1}^k x_i$, in other words c.x with $c$ being vector of ones. So c = ConstantArray[1, k] should be used as first argument of LinearProgramming.

Our first constrain is that for each list from data, number of its elements present in result should be at least $1$ which can be written as m.x >= b with $b$ being vector of ones b = ConstantArray[1, n], $n$ being number of lists n = Length@data, and $m$ being $n \times k$ matrix such that each row corresponds to list from data and has $1$ at positions associated with elements present in list and $0$ at positions associated with elements not present in list. This m should be used as second -, and b as third argument of LinearProgramming.

Second constrain is that for each $i$: $x_i \in \{0, 1\}$. Which can be communicated to Mathematica by using ConstantArray[{0, 1}, k] as fourth argument of LinearProgramming and restricting domain (fifth argument) to Integers.

Putting it together we get:

n = Length@data;
k = 255;
m = ConstantArray[0, {n, k}];
MapIndexed[(m[[First@#2, #1]] = 1) &, data];
(x = LinearProgramming[ConstantArray[1, k], m, ConstantArray[1, n], ConstantArray[{0, 1}, k], Integers]) // MaxMemoryUsed // AbsoluteTiming
res = Flatten@Position[x, 1, {1}, Heads -> False]
(* LinearProgramming::lpip: Warning: integer linear programming will use a machine-precision approximation of the inputs. *)
(* {464.846, 1107448} *)
(* {9, 15, 48, 58, 122} *)

In less than 8 minutes we get result set containing 5 elements: {9, 15, 48, 58, 122}.

Let's check that this is a correct answer:

And @@ (IntersectingQ[res, #] & /@ data)
(* True *)

Random Searches

You could try to search for minimal sets using algorithm similar to one used in other answers but with some randomization added.

We start by defining fast compiled function rejecting sets containing chosen element:

selectNonContaining = Compile[{{searchMatrix, _Integer, 2}, {remaining, _Integer, 1}, {chosen, _Integer}},
  With[{result = Internal`Bag@Most@{0}},
    Do[
      If[Compile`GetElement[searchMatrix, i, chosen] === 0,
        Internal`StuffBag[result, i]
      ],
      {i, remaining}
    ];
    Internal`BagPart[result, All]
  ],
  RuntimeOptions -> "Speed", CompilationTarget -> "C"
];

Final minset function accepting arbitrary function choiceFunc selecting element from all elements of remaining sets.

minset // ClearAll
minset[choiceFunc_, data_, searchMatrix_, indices_] := 
  Module[{remaining = indices, result = {}, chosen},
    While[remaining =!= {},
      chosen = choiceFunc[Join @@ data[[remaining]]];
      result = {result, chosen};
      remaining = selectNonContaining[searchMatrix, remaining, chosen]
    ];
    Flatten@result
  ]

Prepare auxiliary data useful for fast searching:

packedData = Developer`ToPackedArray /@ data;
n = Length@data;
searchMatrix = ConstantArray[0, {n, Max@packedData}];
MapIndexed[(searchMatrix[[First@#2, #1]] = 1) &, data];
indices = Range@n;

With First@*Commonest choice function we recreate greedy algorithm from other answers:

minset[First@*Commonest, packedData, searchMatrix, indices] // RepeatedTiming
(* {0.00035, {36, 17, 8, 10, 35, 44}} *)

As noted in Carl Woll`s answer, instead of first commonest element we can choose random commonest element:

(results = Table[minset[RandomChoice@*Commonest, packedData, searchMatrix, indices], 10^4]) // MaxMemoryUsed // AbsoluteTiming
KeySort@Counts[Length /@ results]
(* {3.51511, 1176080} *)
(* <|6 -> 10000|> *)

But we get only 6-element sets, so it seems that it's highly unlikely for greedy algorithm to find smaller set on this data.

Instead of commonest element we could simply pick random remaining element:

(results = Table[minset[RandomChoice, packedData, searchMatrix, indices], 10^4]) // MaxMemoryUsed // AbsoluteTiming
KeySort@Counts[Length /@ results]
Select[results, Length@# === 5 &]
Function[res, And @@ (IntersectingQ[res, #] & /@ data)] /@ %
(* {1.42398, 1410688} *)
(* <|5 -> 2, 6 -> 43, 7 -> 554, 8 -> 2419, 9 -> 3608, 10 -> 2385, 11 -> 768, 12 -> 189, 13 -> 27, 14 -> 4, 15 -> 1|> *)
(* {{123, 110, 14, 79, 124}, {44, 109, 115, 24, 116}} *)
(* {True, True} *)

In less than one and half second I've found two 5-element sets.

I got best result by balancing greed and randomness, by randomly choosing between random element and random commonest element in each step:

(results = Table[minset[RandomChoice[{RandomChoice@*Commonest, RandomChoice}]@# &, packedData, searchMatrix, indices], 10^4]) // MaxMemoryUsed // AbsoluteTiming
KeySort@Counts[Length /@ results]
Select[results, Length@# === 5 &]
Function[res, And @@ (IntersectingQ[res, #] & /@ data)] /@ %
(* {2.89473, 1263376} *)
(* <|5 -> 36, 6 -> 2852, 7 -> 4073, 8 -> 2359, 9 -> 590, 10 -> 83, 11 -> 7|> *)
(* {{43, 90, 13, 85, 62}, {11, 87, 97, 91, 122}, {92, 76, 126, 101, 2}, {18, 116, 19, 29, 49},
    {47, 84, 49, 58, 48}, {48, 21, 23, 22, 12}, {103, 19, 28, 116, 82}, {101, 37, 105, 66, 46},
    {114, 111, 61, 120, 87}, {103, 40, 113, 93, 122}, {43, 20, 23, 33, 28}, {82, 92, 99, 98, 63},
    {72, 68, 6, 47, 81}, {75, 69, 29, 97, 101}, {42, 37, 40, 84, 72}, {48, 36, 40, 75, 51},
    {124, 37, 105, 59, 126}, {116, 27, 101, 28, 19}, {45, 53, 55, 18, 38}, {6, 12, 15, 106, 81},
    {29, 78, 13, 27, 115}, {95, 31, 11, 15, 96}, {103, 61, 68, 65, 43}, {22, 94, 12, 91, 20},
    {59, 115, 124, 79, 77}, {31, 121, 101, 29, 112}, {78, 109, 59, 57, 68}, {100, 115, 45, 51, 97},
    {78, 105, 97, 103, 28}, {88, 103, 102, 92, 14}, {76, 78, 95, 72, 11}, {117, 51, 118, 91, 102},
    {123, 7, 16, 93, 17}, {7, 5, 14, 114, 45}, {112, 71, 76, 16, 28}, {36, 96, 40, 19, 1}} *)
(* {True, True, True, True, True, True, True, True, True, True, True, True, True, True, True, True, True, True,
    True, True, True, True, True, True, True, True, True, True, True, True, True, True, True, True, True, True} *)

This method found 36 5-element sets in less than three seconds.

Automating Random Search

We can automate random searching function, making it repeat search until it reaches certain specified length of result, or runs out of given time.

minsetRepeated // ClearAll
minsetRepeated // Options = {
  "ChoiceFunction" -> (RandomChoice[{RandomChoice@*Commonest, RandomChoice}]@#&),
  "LengthGoal" -> 1, TimeConstraint -> 1
};
minsetRepeated[data_, OptionsPattern[]] := Module[
  {packedData, n, k, result, lengthGoal, choiceFunc, indices, searchMatrix},
  packedData = DeleteDuplicates[Developer`ToPackedArray /@ data];
  k = Max@packedData;
  result = Range@k;
  TimeConstrained[
    {lengthGoal, choiceFunc} = OptionValue@{"LengthGoal", "ChoiceFunction"};
    n = Length@data;
    indices = Range@n;
    searchMatrix = ConstantArray[0, {n, k}];
    MapIndexed[(searchMatrix[[First@#2, #1]] = 1)&, data];
    While[Length@result > lengthGoal,
      Module[{remaining = indices, bag = Internal`Bag@{}, chosen},
        While[Internal`BagLength@bag < Length@result && remaining =!= {},
          chosen = choiceFunc[Join @@ packedData[[remaining]]];
          Internal`StuffBag[bag, chosen];
          remaining = selectNonContaining[searchMatrix, remaining, chosen]
        ];
        If[Internal`BagLength@bag < Length@result, result = Internal`BagPart[bag, All]]
      ]
    ],
    OptionValue@TimeConstraint
  ];
  Sort@result
]

Default TimeConstraint is one second, so it'll give best result it could find in one second:

SeedRandom@0
minsetRepeated@data
(* {24, 44, 53, 116, 117} *)

Which, as we can see, is enough to find 5-element set.

We can also set specific "LengthGoal", so that function will stop immediately after finding set with given Length:

SeedRandom@0
minsetRepeated[data, "LengthGoal" -> 5] // AbsoluteTiming
(* {0.005669, {24, 44, 53, 116, 117}} *)

Finding first 5-element set took less than six milliseconds.

While it's possible for this random search to find minimal set very fast, it can't guarantee that it actually is set with minimal length.

$\endgroup$
1
  • 1
    $\begingroup$ +1 Very nice answer! LinearProgramming is growing on me. $\endgroup$
    – Carl Woll
    Commented Aug 3, 2017 at 16:41
8
$\begingroup$

Here is another implementation of @FalafelPita's algorithm:

greedy[sets_] := Module[{s = First @ Commonest @ Flatten @ sets},
    Sow[s];
    greedy[Cases[sets, x_ /; FreeQ[x,s]]]
]
greedy[{}] := Null

minset[sets_] := Reap[greedy[sets]][[-1,1]]

For your data set:

res = minset[data]

{36, 17, 8, 10, 35, 44}

Check:

Min[Length[Intersection[res, #]]& /@ data]

1

I don't think this algorithm is guaranteed to find a minimal set, but I can only think of a brute force method to check, and in this case I expect that such a method would take more than 400 hours. I did modify the greedy function to randomize the commonest element it picks, but over a run of 10^4 trials, the minimal set always contained 6 elements. So, perhaps 6 is the length of the minimal set?

$\endgroup$
7
$\begingroup$

Here's one approach for finding such a set. It begins by counting the number of sets in which each element appears. Then, (one of) the most frequently appearing element(s) is Sown, and all sets that contained that element are removed from the list of remaining sets. This process continues until all sets have been removed, and then the list of Sown elements is returned.

findSmallSet[data_] := Module[
  {nSets, remainingSets, remainingElements, common},

  nSets = Length[data];
  remainingSets = DeleteDuplicates[data];
  Reap[
    While[nSets > 0,
      remainingElements = Flatten[remainingSets];
      common = Commonest[remainingElements];
      If[ListQ[common], common = First[common]];
      Sow[common];
      remainingSets = 
       DeleteCases[remainingSets, _?(MemberQ[#, common] &)];
      nSets = Length[remainingSets];
      ];
    ][[2, 1]]
  ]

Older Solution

The first solution I posted was a bit less efficient because it discarded frequencies to create a list of unique elements, but then calculated frequencies later.

freqCounts[elementsList_, sets_] := 
  Function[element, Count[sets, _?(MemberQ[#, element] &)]] /@ 
   elementsList;

findSmallSet[data_] := Module[
  {nSets, remainingSets, remainingElements, frequentElement, 
   freqElemPos},

  nSets = Length[data];
  remainingSets = DeleteDuplicates[data];
  remainingElements = DeleteDuplicates[Flatten[data]];
  Reap[
    While[nSets > 0,
      freqElemPos = 
       Position[#, Max[#]] &[
        freqCounts[remainingElements, remainingSets]];
      If[ListQ[freqElemPos], freqElemPos = First[freqElemPos]];
      Sow[frequentElement = Extract[remainingElements, freqElemPos]];
      remainingSets = 
       DeleteCases[remainingSets, _?(MemberQ[#, frequentElement] &)];
      remainingElements = DeleteDuplicates[Flatten[remainingSets]];
      nSets = Length[remainingSets];
      ];
    ][[2, 1]]
  ]
$\endgroup$

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.