54
\$\begingroup\$

In the game of Freecell, you are tasked with building four foundation piles in suit from ace to king, on a layout where you build downward in alternating colours. However, you can only build one card at a time, so you are given four "free cells" each of which can contain one card to help you move entire sequences. The idea is that you weave individual cards in and out of the free cells as required to help you solve the game.

Your task is to build a program that will solve these games in the fewest moves possible.

Your program will take as input a sequence of 52 cards, in the following format:

2S 9H 10C 6H 4H 7S 2D QD KD QC 10S AC ...

Which will be dealt in the initial layout in this order:

01 02 03 04 05 06 07 08
09 10 11 12 13 14 15 16
17 18 19 20 21 22 23 24
25 26 27 28 29 30 31 32
33 34 35 36 37 38 39 40
41 42 43 44 45 46 47 48
49 50 51 52

And return a list of moves to solve the game. Each move will be in this format:

  • A number representing the pile number (1 through 8), or a free cell (A to D), representing the source pile.
  • Another number or letter representing the destination pile or free cell, or F for the foundation of that suit.

The output will look something like this:

18 28 3A 8B 8C 85 B5 35 4F etc.

Once a card is put into the foundation, it cannot be removed. Since only one card is moved at a time, moving a sequence of 3 cards requires 5 moves, and a sequence of 5 cards requires 9 moves.

If a game is unsolvable, your program should indicate as such. However, your program must be able to solve any solvable game.

Your program will be judged on the 32,768 deals found in the original Microsoft FreeCell program. In order to be valid, your program must successfully solve every deal except deal #11,982, which is unsolvable. Your score will be the total number of moves it takes to solve these 32,767 deals, with shorter code being a tie-breaker.


A file with all the decks in the format required by the above specification is available for download here (5.00 MB file): https://github.com/joezeng/pcg-se-files/raw/master/freecell_decks

\$\endgroup\$
20
  • 1
    \$\begingroup\$ Now I just need to nab the random number generator that they used to generate those 32,768 games. :S \$\endgroup\$
    – Joe Z.
    Jan 3, 2015 at 18:49
  • 3
    \$\begingroup\$ The generator is here: rosettacode.org/wiki/Deal_cards_for_FreeCell \$\endgroup\$
    – nutki
    Jan 3, 2015 at 19:25
  • 1
    \$\begingroup\$ That's a good point. How would you deal with the case in which, say, two cards of the same colour and number (such as 7C and 7S) are both in free cells? Then if you move from "C" to a black 8, it could be either of those two cards. \$\endgroup\$
    – Joe Z.
    Mar 18, 2015 at 15:14
  • 2
    \$\begingroup\$ You could possibly get some answers by removing the restriction that all solvable deals must be solved by the submission. Then, score based on number of deals solved, then by fewest moves. \$\endgroup\$
    – mbomb007
    Feb 16, 2017 at 21:59
  • 1
    \$\begingroup\$ can the cards be 0-Indexed? \$\endgroup\$
    – tuskiomi
    Jul 11, 2017 at 15:45

2 Answers 2

21
+750
\$\begingroup\$

C 64,643 bytes, Score: ~6.5 million

The following Stack Snippet (courtesy of Mego) outputs all of the code as a single standalone C file:

$("#a").text(pako.inflate(atob('eJztPWt347ax3/UrsO6JTVrSVpKd1FlZzslJ2iZtzr233faT10eHoqg1E1lSRWrTbVb//WLwIB4EQJCSvOmGc3YpCcQMBsDMYAYv/y5dxcvdPEG3WT5P1y8f7zq/k5OW6UxLS6Jt/Kjn26art5DWwV93cY7oxzSOtvNp3vmlgzBkj+ttjkjSavc0ltLmSfzTuLMfdzr5+00yTxbIRIai5jgX+508bfL35OVYLzjLo/inouR0lSNcJMma0YIlktn98MsHV/GMGFrE/KupvDwpyhMZEfnM7m8elGIX2ySJk+Uyu79mL4BFaAaa4uQFCkLsc9x5t07nmOxqvUr/k9DXAc90SbOF4w6Qp6nx+mkTbZMgXq+yHBFsnG3YQ2rCKGSkKVa6SnMDWZ4Cr9NoOd1lyZazuJ7GQfwYbUl2kA+cv/gNOaJsSl8YCMs9DkRHm2S7lMgJWiQLvB1BvkBCxFUy5N+MdlMugzOMQCUQ/5Cz90h/XBbCOk0z/LFcQpVJ/t1oo1BRKyqJHZNO0veQZ5vgRp6gAAVBcMmy300uoosQnZ8jkXY7ufjPRRiir6S07sXXF32S9RUqEkNGPV2ggBKfIJwvJImUD4Btku+2KzSk0rYnz2SZJTLexV+saE48dPE3K+LIjfhXK+KVG3FoQwwuA9oy3WFIcg4uwq+Gg1fmGlCCdzjbiPUASbjFCV/i5rcUAXn6QFinac4/4Nn2HQxCgEDfueTAdy43JCnmUlNIC8miyApJUSSFpKhyQpIYpz8/pssEBQWDAEGMXuDqfkeomt68tr751vrmG+sbZH3zZlBucWC+2x0Xv4/aGnuhOTERle+YUJX7rhAYmvF1OePQmPHbcsaRMeM35YxXY1WuVK72nWojyeVJ5BOj0EtuvnCL6taMGswiJ7QZy0VElr7uSPxQ0sASEV0g9RRtplf3w+sHPKBh5F/QGTrrobOv4TGCxxU8ruHxOTy+gMcf4HEDjy/hMRzA8y/w+Bs8/nqGYGQ8iiXnNhqMALQCtgEDKknwCxuA4VVJGjG9Vbx5HxC6Ui0xxkMP3i6TVaClh9gOCfm91PkAeSadAMVXmBNb8QNj4QOPohWjyPoSUxJdSVuZ9nrhqpXb19W6VHqgelp1iPCXEGXDoFSYyM9IqpCiGOXs30nZNavPWRqG5rY9ey3hlrBGNqxvXVhXNqxvNCxLNrn25p7y9IQ050RufUpd1yvFWvRop58bPCOOS4c1bjgIQpeJJ5TfM3lVpmoZ/HwwJIPeAIxAwb/RoYU3uk8LaaPCJpI3rAD8bgiKqCaGhMjYmH1kyT6SvLF42L8rjOwdxhE/a3lnCp1bHzr9EiGT6mGyRDgpa9QB4Rl+URRLZU9QLrFJ6N360utbCbrxBjoa8axYiIOjLu8Qpzw+EjFgiFIUdxlmw5A2e4YNaymEHFnRRgqaPmYWrJ4zgT2nQkrk3yeyYzX4V4ZtM33Zv6MhZw/dYNXDmOtFIFgKe2obcdVTCBTRaQ9dFzRobbn2CnTOqCNOZEw+JU9ZkgcBZMctA696aFAUwLBCSrNBwMqKYc2LS4ufNgHOmI16xiII5oL4S5dZj3zk69dKBEfdmV46GfR+nAxEpI5Vj/8kLnUQT3DY0e2GssQrosspE59gwp17oY+YwgR84243Heuvgh9vr8/P08nkD+GHD8GPdxP664tQHS3L+lLQmAzGxhfd7o/mFyq7F29WF5jjUs59KQVnl911opj1JgnklodEnMamiuAr1rOnaLlcx8FowP0lTh93vOgh3KFjldCW595iIrSwkh7LBIkon2OirJgFGYgJF6FKqqC0WGMvFLd1dnszBmlgVlcxu9mLycBmF6kskdA+pCHR6kLt43L/wujaVTtR7RYtw17qR+A3xvyOY86sxjBnOlaYNjPCmJe4R/KkhqiQr9QaalauHefwknSGqcnsBcy2SfSTTwHGNlZ+MudEC8VEHMUhAHl6ySYFgyx8eEkHh3J6MV/5QFwN/C0cG9CLbJjB8rAoG0SiHsJbrJqD0/VQ0hdIkmcw8b9eMXlJfrAxBvOlTHBGZd9PvHyK/j0taoNJiLzMWFIeSGuArQ6ZIRgORteh0L8Iy3N0ez2OhP7xVikFjHS4o5xHRR3gm82/5eLGc+JRnUgd0oROeQ9zUMqMQ7bBNckXbKIKO/efXWVI/s/gu/5nwwy9Js9vyfMbeL5ZnfVK0id5/vowTgJE+VdYD32ooA/roo8U9FFd9CsF/UpHpy2Na2hIHRpTR8ZUTHhs6h0pdAHLjzur3+8j6T/uDT4eVCC+wS5vHzn+U1LUWZK1AYvQwDnCyKIZEGMIKmw2FCjEHr9C3jYc6TxUU7ZYIDLOMIXCzPOvt0oBRXK5WqTWpBEQVBxl6nAl8yxPKuB6VrPsMb7GUS5UFdLOQteAW5qXMBCtkBSwAWc9i2qwimR87ODVVexusS5Q5lF80+smRFmfESLGf8+C7mU8hZ7Lkn/tklWcTJ/W7xIxpwx5cMABcwVqGhjSpyJJniKir4yTRIwFSrBrDpAF+tCCProMOAXzjJAgMSp5bXzW/0oigrqoktKVldK1RKl7VUXn2krnc5nO5046dxP0eeVSy74jvIDNNnlHvfSMLh+CzkiJ1CbJA7fx5W4FkWUyl9/CxzafRjnNVlDP0yeO2qHrobPd22ma43Bhvcs3u1yQlV5RluUM3MXBbst6ucvT9apUkdILGnCul++SKbY2WrTNYlVa8CZ/lOfQiMpRVc3EurYlpsCFJz9T4sLxUeKWRQxuSMYWndl3ibhMvXjXQ3nytJmK0qizNRM/4keyxE44gdmEnGLQ7xDaUcJFL3B3l1he4ATGHPiEcQc+rWOPbm3hszT8WCMgzSXfSxJNgiegBjpxYxoiFhDLLGLs/C1i9wgh+BSeBUZn7jhRGI3NMh0Du4JZ9RvRw1jS5TI14COQdEQbYQwyi2WdCGN3qGYtZ2OOMp/IIc4zVg4DTX3Q0F7fkwIfSNCrRg/nfOFeQbfP13GBqyFfhRJQT6RazlSPvUC39QAL4eykWaRWEOoPwwek9ZMqXNSzhAQyJNOFtBCwQBaKZEnm+vKaBOWxPO0SFEYkBIZZ04/LGQurQFaZCiRbzRw5imbtDx/GR6SFGZN28TgJC7S+qa6Bgmxr+W4X6UJK+16ZZT0XlEyZH+l66NDwDvp/RrdISVR6pXwySFrvzugcS92o2gRoRWZ53pWI6v/884cffGdVpIEFN5LmGPSddTDPRfL2DpxMLxfpau7d5gASB90DmhbgXKp0de5anUEQzB3iM3VVCkYAzB3H29kwV7w3SzrB8J6EXpCVbtVNnJi8xzJFO1UAkwPaxfo5ujFoKAfVWxXTXyEe0slwKaul3mWXJq7N0mtoOq34e40QGEXNTdRBwwBvzTBOAJhavV/hleNYYfhF3U6gK0hKo2nlllqxpwm2ua4AVVGEVpKtJ8oph4s19nHAH9IiB2GGuJNmqR2U9wJmdWs2d33PzEap7KTJUG40AKNVcTN8gPtmItXIU7MpCQDx3DR/AWvKCLYCVXl0Hwb/JiWUdrbpcEABV6QAs5i4Wx6gvIKvg7mjTTqjp9QZYo4jBEcXgJN3/ok63t7p7g6v6lY9iN1L4ZopylajNKVrtABbD8tMQdCLiX2C4BQBlt4W3vGVHHHo9VQCmzZeaeMVDdp4BbXxShuv6NDGKwW08YoRnjFeqXJk2njiVxBPNO2k1uev9vkLpz872RqNEg0IfMcaYfPoT6biWjA0N7OymuKUOB2TBS0FAUe0I4r3EFqJCg13jCXAdgWnmOpyeo5AvIExjWvlvVU87SX5xlUGhEPWmcgOSlENz2UmsqHSi7W6oR+HWlEchyYRGwfvyI3DgWEGQO3ggSB5RnQc3IPV0SM8Dn6RHof6ER+HI0Z+HOpFgBwadSZB9I0IOZjdBwCrLwfgFgRHxCjKdWqexdX2K/7QiNKvFIBGESaH54o0OTiaXGOnQeTJwT8C5XDkSJRDdeedNDLlcJQIlYNdWU+pTgdGsjIf9ojWjxWAA/dKWWroCHU5uFrfL9UzEJD2+rFtlIXnMza+or6V7OPDVsQeSjPYPDxNcVttYb8jFui5kgw7GwVJtt0xf8QZ6HZHIpn0K9kEOUuW65+l/Y8yIzQMyNfTLc4UE8Eo2IbkRbpc0iTKLk+T2Faqqo4fxiMnamMRZmybDiN1z+GkFAyUBU/hxn72ay8bOLVHbFW48a8Cd5sjbW9nnQpQGhU1UI+rIXckWi7vkIi0KBOHiWiM4ltBDP8qB4zluE+Wc3HdgkYfN37cHWKSkVJApBdgbkyAQjN8wuKovGuRQ6FWXnSMYXVRdRaoFiRN0Spnu260KhE1h6yCsF/Iako92kyiLgUOc245kWhmZ2/yYLwnR4rJMZ1CZBZUelWNbbLCxHEtaYpNu2nlsquE6RRydKgIsdb0nqo2H22NfBscbMk8I7ZqTs5JzTOTDXHyS083ZtACtIcaOmfquQWjBMyth8eslYP5unl8qx2KmJdscT1eFX7trDJJndtm+XSomKsrSpTf9d1SK0PVvJ1E30eC1eaqiI2KKioem9u2KXgLiT8qIX00RHfYDazmjnLokwtA8w89urfrsES2yhQNLko6QZdzMBd3bCng4N/WpDV0kXCsEelgj2TUXN4y9kJj59jCBWUow/upWtUYyJATQJoSzWPQJA/rJEMpHiLX2QTGQsPbQAlAwvArS8ZXesaaXJnr3J+U2W1QXTXW86svxfGpMM95zBpbo1Mf4NfcmYSIXXxXix6CWxvNB4GVTu8bQm21kfrluoXoblKXGyQrQVzDugE41qxsYF3Lqk2Jhd8k/isroiUOrIIGNeK8zLCPNbu9Hs+alEvLboIFwKYYzEtrs6qZkufhEcARpvmA3zBXxmqEVnUGUPZ9bK+rT//VpeJx7k/DMR768wG7OGEmxLnp+t25b67sWKvRrWkc+ljqfvPrUHfe97PKWcXn4RCgVfaPo+xN6m+TJTuzs9obRWalTSJ1uWzQuWyaGBHDMRHOTn/Y3GTUxQA4WBwe/I6iR6FL9j5S88MSiWj5ePyM7f4Jn+Sv2xQNuq/RRisbHLIBywa1N2bZ4Ei7g0zQeO+PkVjNDV42OECbTrEhzAb1NorZoPkGMhucYGOZDZptOLPBUYWREKy7Qc0G9f0954Y2GzQTfI8NcDZoYHY9dvjYoFn1jrXB7rhcARy0Ic8Gz71RzwYNg5XjbOyzQf0NfzY40UZAGzQXsmfZOGiDo24otEF94/rfYLaOtJHRBn4bHG3QXByPd+SvCvz2SdqgiVCdJrfv+udhOU65X1QysdxsStsOHYe6Kg+ZmdEADt3ix5kt6NTZbxNPxIzAaIziO7jfuN+vu+um1g6+yh0K9XZeVWxnOdVOPoBT7OZzN/RJzpVUTBH7qhUAbBCMu7YF/OLvxVlmwx3HmderPF3tLM7U3npKlv3FQK/F3tLSLu7DW3lhNqZ/DyImhqB2Dfp9O/OmdNpYpVtcq0uqfU6Rb7wbk2139l137mI5z9U75TzXQyrF0lmhZtPN7ur9N00fVzZPrelgjxOKv63pXUfztudirUg1p03bc7HtuVgC7blYAu25WB3ac7EqtOdiZT4+zrnYKoof/1is9jf0/P7wRCkgd1yNCeB3PWa5HM6V13SKGV0qvno6pVE8WvOkm4k5wgq0xo3x+hwjbVtoV5H34NtnHPuJSgjWqOTQO2dq+9VNfepa/vSBjtuxLqesO2F3Ct/Z329u5jMf2V+u7ysfM+jxNR4ATe7/c/vElgG8YvB2H7s81Ad2j8WNfd/n9HsdftHh/m49X/cEfq67g07u3x7Nt7U5UMdViSP4sdU+rLtLjuu7VvutR/FMZde0vS9DTwFo78to78tg0N6X8cndl/GivTCjqFx7YYaA9sIML2gvzGgvzGgvzHBDe2FGe2FGe2FGLWgvzHCU3QQLoL0ww4nVCO1TOkPfqAHaCzOc3LQXZlRAq+wfR9mb1L+9MMMb2gszakB7YUYlrfbCjAOgvTCjvTCjGtoLMwpoL8w4SA7bCzOeOdRpL8xwst9emCGgvTDDDu2FGQ2gvTDDDe2FGe43B+zXe4btejJ66QYL2KgHtpjs39OvsTBfvVFj95SOrh4xMf81bMC0bFnqD80HP4ydIl9HQv+OW1f/q2h38jwRuWXD+ieOrRJRf5lLXs5ia6piCfg20Dlii6kiy6tylupD+pU7h2CWG8GqFqqc5642eMdfpvIzsp4z0U21H+ATnmdy1vvgRSLXYpCy6KNJN/Ykf11a4rUW1ERHDlvbeVYN+a2qiKvav66lFUcf/Qb7R1U04XiI9i68j27XuXe1vavEilRzxrq9q6S9q4RAe1cJgfauEh3au0pUaO8qkflo7yox/VJnmAx3sqrRhNpEz3spq05CuZMVNvGoEZ1p6sfUVnWu/KDzYYOxdHR1bD0r5YgPa8ygVA83x5s5qVYAj3iwrqwCfMIhhs9MYP0ZEovNbW9wIQg1Iov2BhcXtDe4lKC9waW9waW9wUWB9gYXqUInv8FFPFlpw3Fn34kfoy26RI/JcsM4RpPO2SLuk9ZF9+sN1BLr0WwNHuEiXSZvVmedM/L4fiEloxS0YL0FYdokcbpIkzkuKsJOOG6C1Ry8tHS12eUC/+t3UbqMljOM/L+0nFckvf+Iuez3gSmpMn00T7PNMnpP7lkhLKMsxh7QiiKlBCnNk21/vctxQToSZhG/jKAgkOhZskWYLyosmDWUvEu272kH4txY8HEpRD6TOSnB1YMw9xttNss0jqA669XyPbmzhrdkf57Mdm9RSFnNCKukJMFrH0XLbI3Yb2CXsvKcnJHH6/TtCrPyCgXVeBTt9fd//ufrvw9xFf4Pi1CeEe5ZE68XiNlIwvnPyTbhvGMtQgssf/kaZ5kn2+1LidoICar/wPKaSb3H2mi9+v16sTAhOZAvMtaQBiLwANOP64BHxXQVwJdo+zbuIaYo+Me7+4ewQ60DSdxlCTNB98PB6PqBDZp/+v6HP2IEUA2WwsdHaTAi9MVXrJksLyuY/SILl9u3k+EYP2+BIfjCwz9hqUhY9wLrcfy0CQir+PHQQ1ijzsIQffiAzG+Jqp3JdxGo1m8DvboIzj7LznqyrdDMWtmMCQMEjpaDv9TNn6TVDjaJRE4h75R1rnLrgTczmZsZWW/9uKE9X82ThZIWPXNbziQFqoF5A6cQJMPBecGsIE8sN4xa83Q1lsaIgptS1sV6k6wUutuzUEZdgNEPhFYUvomkKIOH0JAc/t6SE4pmZSzi5TpLApZSzEJRlZ5gvUnzNFpOBQU40hnLhTCd0mNe5aXJJZY9Yqvn+0QdXwP+peahhWVSuLLcg2AvDTyM+RhucIFYew84bdXLkewENTvqFjF6rgpK1Jwb9XyVNj0FUxBB8G6dzi9D3SmKHkKTpDtQQs6UXQoB2RwyUCuFgrPvUbzeLeeri5y2EHUY3kZPCZj5Qlg7CtJnKX5HHes8fZJYEVZt3/l/SfRivg=='), {to: 'string'}));
<script src="https://cdn.rawgit.com/nodeca/pako/master/dist/pako.min.js"></script>
<script src="https://ajax.googleapis.com/ajax/libs/jquery/2.1.1/jquery.min.js"></script>
<pre id="a">
  
</pre>

Download the original source here. Use GCC and run make then using the guideline in the readme.

My formatting is bad (all the different files are in one code block) and this could be golfed more (12k bytes tho). Any help would be loved!

Some of the code is not mine. I used it from a un-copyrighted source. I however fixed the input/output method to be within the challenge (a long task since I am horrible at C (5ish hours)). I also had to re-write much of the code and debug everything. Many thanks to my Dad for helping out and being a rubber duck (and pointing out my memory management errors) and for everyone on TNB who dealt with my angry rants about segfaults and C.

\$\endgroup\$
5
  • \$\begingroup\$ You may be able to use this to get around the answer length restriction and have all of your code within the answer, rather than needing an external download. \$\endgroup\$
    – user45941
    Jan 2, 2018 at 22:38
  • \$\begingroup\$ @Mego i mean yeah but it is in several files \$\endgroup\$ Jan 2, 2018 at 23:15
  • \$\begingroup\$ It's easy to combine multiple C files into a single one. \$\endgroup\$
    – user45941
    Jan 2, 2018 at 23:34
  • \$\begingroup\$ Here is a stack snippet that shows the code combined into a single file. \$\endgroup\$
    – user45941
    Jan 2, 2018 at 23:56
  • \$\begingroup\$ @mego can you edit that in? On mobile \$\endgroup\$ Jan 3, 2018 at 14:51
3
\$\begingroup\$

Haskell, Score: 4.98M, 7564 Bytes

{-# LANGUAGE BangPatterns #-}

import Control.Concurrent.Async (race)
import Control.Concurrent.Async.Extra (sequenceConcurrently)
import qualified Data.Vector as V
import qualified Data.List   as L
import qualified Data.IntSet as S

type Deck     = String           -- a line of the input, s.th. like
                                 -- JD 2D 9H JC 5D 7H 7C...
type Card     = (Int , Int)      -- (Suit, Rank)
type Cascade  = [Card]           -- bottom up, i.e. head is the accessible card
type Board    = V.Vector Cascade -- the whole Board: 16 lots of cascades
                                 -- 0..7:tableau, 8..11:cells, 12..15:foundation
type Move     = (Int , Int)      -- 'from' and 'to' board index
type Game     = (Board, [Move])  -- a Board and the Moves to get there
type Strategy = Int

idxTbl, idxFnd, idxTblR, idxFrom :: [Int]
idxTbl  = [ 0.. 7]               -- indices of tableau cascades
idxTblR = [7,6..0]               -- indices of tableau in reverse order
idxFnd  = [12..15]               -- indices of foundations
idxFrom = [ 0..11]               -- all indices where a card can be moved from

(@@) :: Board -> Int -> Cascade  -- return cascade at index i
(@@) = (V.!)

(@!) :: Board -> Int -> Int      -- return the rank of the top card at index i
brd @! i = snd $ head $ brd@@i

(//) :: Board -> [(Int, Cascade)] -> Board
(//) = (V.//)                    -- update from Data.Vector

solved :: Board -> Bool
solved brd = all ((==13).(brd@!)) idxFnd

--
--
--

main :: IO ()
main = print . sum =<< mapM solveDeck . lines =<< getContents

-- applies different strategies and hash functions to a given deck
-- does all the concurreny stuff
solveDeck :: Deck -> IO Int
solveDeck deck = do
  putStrLn $ "Playing Deck: " ++ deck

  mvs <- sequenceConcurrently            -- try fast hash funtions concurrently
         [dfs hsh S.empty s startGame | hsh<-[hashCLS, hashCL], s<-[1..4]]
  let scores = [(length m, reverse m) | m <- mvs, not $ null m]

  if null scores
  then do   -- unsolvable by fast hash functions, retry with slow hash function
    mvs2 <- race' (race' (dfs hashC S.empty 1 startGame)
                         (dfs hashC S.empty 4 startGame))
                  (race' (dfs hashC S.empty 2 startGame)
                         (dfs hashC S.empty 3 startGame))
    let score2 = length mvs2
    putStrLn $ "Solution: " ++ show (score2, reverse mvs2)
    return score2
  else do   -- at least one slow hash function succeeded, return best result
    let winner = minimum scores
    putStrLn $ "Solution: " ++ show winner
    return $ fst winner

  where
  !startGame = [(deal deck, [])]
  race' one two = race one two >>= either return return

-- depth first search with a given strategy and hash function
dfs :: (Board -> Int) -> S.IntSet -> Strategy -> [Game] -> IO [Move]
dfs _ _ _ [] = return []
dfs hashFn seen strat ((brd,mvs):games)
  | S.member hBrd seen = dfs hashFn seen strat games --skip board if seen before
  | solved brd = return mvs                          --solution found
  | otherwise = dfs hashFn (S.insert hBrd seen) strat (newGames++games)
                                                     --descend the search space 
  where
  hBrd = hashFn brd
  newGames = nextGames mvs brd strat

-- one step in search
nextGames :: [Move] -> Board -> Strategy -> [Game]
nextGames moves brd strategy
  | mv:_ <- autoMoves = doAuto mv
  | otherwise         = checkMoves $ allMoves strategy 

  where

  -- all possible from/to combinations except between freecells and only to
  -- first empty freecell. Based on strategy.
  allMoves 1 = [(f,t) | f<-fList, t<-tList idxTbl,  f<8||f>11||t<8||t>11]
  allMoves 2 = [(f,t) | f<-fList, t<-tList idxTblR, f<8||f>11||t<8||t>11]
  allMoves 3 = [(f,t) | t<-tList idxTbl, f<-fList,  f<8||f>11||t<8||t>11]
  allMoves 4 = [(f,t) | t<-tList idxTblR, f<-fList, f<8||f>11||t<8||t>11]
  allMoves _ = error "allMoves: strategy out of range"

  -- "from" indices are always ordered by minimum rank in respective cascade 
  fList = L.sortOn (minimum.map snd.(brd@@)) $ filter (not.null.(brd@@)) idxFrom

  -- order of "to" indices is foundation before freecell before tableau
  -- * only tableau is subject to strategy
  -- * only first empty freecell (if any)
  -- * foundation is "12" for all suits, we'll unravel that later
  tList idxs
    | null $ brd@@ 8 = 12: 8:idxs
    | null $ brd@@ 9 = 12: 9:idxs
    | null $ brd@@10 = 12:10:idxs
    | null $ brd@@11 = 12:11:idxs
    | otherwise      = 12:   idxs

  -- checks which moves from 'allMoves' are actually legal and executes
  -- them returning a list of games
  checkMoves [] = []
  checkMoves (mv@(f,t):mvs)
    | t == 12   = if fitsFnd then doFnd else checkRest  -- to foundation
    | t  <  8   = if fitsTbl then doTbl else checkRest  -- to tableau
    | otherwise = doCell                                -- to cell (alway empty)

    where
    !cscdT = brd@@t
    !cscdF = brd@@f
    !cardF@(suitF,rankF) = head cscdF
    (suitT,rankT) = head cscdT

    fitsTbl = null cscdT || rankT==rankF+1 && odd (suitF+suitT)
    fitsFnd = rankF-1 == brd@!(12+suitF)

    doTbl  = (brd // [(t, cardF:cscdT),  (f, tail cscdF)], mv:moves) : checkRest
    doCell = (brd // [(t, [cardF]),      (f, tail cscdF)], mv:moves) : checkRest
    doFnd  = (brd // [(t+suitF, [cardF]),(f, tail cscdF)], (f,t+suitF):moves)
                                                                     : checkRest
    checkRest = checkMoves mvs

  -- a list of all greedy automoves
  autoMoves =
    [(f,12+s) | f <- idxFrom,                -- keep all 'from' indices
                let cascade = brd@@f,
                not $ null cascade,          -- if there's a card in the cascade
                let (s,r) = head cascade,
                r-1 == brd@!(12+s),          -- and it fits on its foundation
                let (j,k) = if even s then (13,15) else (12,14),
                r-4 <= min(brd@!j)(brd@!k) ] -- and it's not too greedy

  doAuto mv@(f,t)
    | fCrd:fCrds <- brd@@f = [(brd // [(t,[fCrd]),(f,fCrds)], mv:moves)]
    | otherwise            = error "nextGames: automove from empty cascade"
  
--
-- parsing and dealing decks
--

deal :: Deck -> Board
deal = foldl putCard emptyBoard . zip (cycle idxTbl) . parse

emptyBoard :: Board            -- foundation is initialised with dummy cards
emptyBoard =                   -- of rank 0, so that aces fit on them nicely 
  foldl (\b i -> putCard b (i+12, (i,0))) (V.replicate 16 []) [0..3]

putCard :: Board -> (Int,Card) -> Board
putCard brd (i,crd) = brd // [(i, crd : brd@@i)]

parse :: Deck -> [Card]
parse [] = []
parse (' ':cs)       = parse cs
parse ('1':'0':s:cs) = (chrToSuit s , 10) : parse cs
parse (r:s:cs) | Just i <- L.elemIndex r " A23456789 JQK"
                     = (chrToSuit s, i) : parse cs
parse _              = error "parse: invalid deck"

chrToSuit :: Char -> Int       -- parity important: reds are even, blacks odd
chrToSuit c | Just i <- L.elemIndex c "DSHC" = i
chrToSuit _ = error "chrToSuit: invalid char"

--
-- hash functions
--

hashCLS, hashCL, hashC :: Board -> Int

hashCLS brd = foldl (\h r -> h*16+r)  c $ map (brd@!) idxFnd
  where c   = foldl (\h l -> h*32+l)  0 $ L.sort $ map (length.(brd@@)) idxTbl

hashCL  brd = foldl (\h r -> h*16+r)  c $ map (brd@!) idxFnd
  where c   = foldl (\h l -> h*32+l)  0 $          map (length.(brd@@)) idxTbl

hashC   brd = foldl (\h r -> h*16+r)  c $ map (brd@!) idxFnd
  where c   = foldl (\h s->h*26633+s) 0 $ L.sort $ map (hCscd.(brd@@)) idxTbl
        hCscd cList = foldl (\v (s,r) -> (v*26633+s)*94291+r) 0 cList

The list of games is read via stdin. For each game the output is a pair of the number of moves and a list of moves as (from,to) pairs, where both 'from' and 'to' are indices of board positions. 0 to 7 are the eight cascades, 8 to 11 the four free cells and 12 to 15 the four foundations. E.g.

Playing Deck: KS 8S 3C 9D QS 4D JD QH 5C 10H 5D 10C 4H 3D 7H AD KC 6S 2S 8D AH 7C QD 6C 7S KH 8C 6H 2C 9C JH KD 4S 5S AC 10S JS 3S 9S 5H AS 4C 8H QC 6D 2H JC 10D 7D 2D 3H 9H
Solution: (85,[(0,8),(0,13),(2,9),(2,10),(2,15),(4,11),(7,6),(2,3),(2,13),(9,0),(4,9),(4,15),(4,14),(5,14),(0,14),(4,14),(5,13),(0,13),(7,14),(5,6),(11,5),(1,11),(5,0),(1,2),(0,5),(1,13),(5,0),(8,3),(7,8),(7,3),(7,12),(11,12),(2,11),(2,3),(2,15),(11,15),(5,11),(5,12),(5,12),(3,12),(0,12),(0,5),(0,2),(0,15),(3,15),(3,12),(11,15),(3,15),(6,15),(1,11),(1,13),(5,13),(3,5),(9,7),(3,9),(6,7),(1,6),(1,13),(3,1),(3,14),(3,12),(3,15),(3,12),(7,12),(6,7),(6,15),(6,13),(1,13),(6,4),(6,3),(6,14),(6,12),(3,12),(8,12),(10,14),(5,14),(7,14),(4,14),(7,13),(4,13),(0,13),(7,14),(9,15),(2,15),(11,14)])

At the end the total number of moves is printed.

How it works: The basic approach is a depth first search. As the quality of the search (both number of moves and search time) heavily depends on the search order, I try several orders concurrently and pick the result that finishes first:

  • two different nested loops

    • for each available card look where it can be placed
    • for each position look if a card from elsewhere fits on it
  • when looping over the destination try in order

    • foundation before free cell before tableau from left to right
    • foundation before free cell before tableau from right to left

That's four different orders (or strategies as I call them) in combination. Source order is the same for all strategies: sorted by minimum rank of all cards in the respective cascade/freecell. There's also autoplay, i.e. if a card can safely be placed in the foundation it's the only move in this situation. It turns out that a greedy autoplay leads to slightly better results, so I autoplay up to two additional ranks (e.g. autoplay 8s even if 5s of opposite color are still around).

However, all this is not good enough (5 games do not finish within reasonable time; about 14.7M moves for the rest), but I had a lucky find: somehow you have to keep track of the boards visited so far to prevent infinite loops during the search. The above method uses a hash which is calculated by rolling through the cascades and including suit and rank of all the cards along the way. Now we are just hashing the length of each cascade plus the top foundation cards (i.e. two boards result in the same hash if (and only if) the foundations are equal and all cascades in order have pairwise the same length). Yes, we do get a lot of collisions but they restrict the search space at pretty good spots and lead to far fewer moves in far less time. In fact, the search is so fast that we can afford to finish all four strategies and pick the best result. A similar hash function where for collision the matching length of a cascade can be anywhere in the tableau and not necessarily at the same index produces even better results - at least on average. Now we can try 8 variants (2 fast hash function with 4 strategies each) and pick the best result. Note: not all variants can solve every game but just one success is enough to get a result. There are 11 games (including the unsolvable #11982) which none of the variants can solve. In these cases I switch back to the slow hash function and pick the fastest result.

Using 4 cores on my laptop this solves all games in about 1.5h and a total of 4.98M moves.

Remarks

  • The total number of moves can vary by a few hundred, because the result of the games with the slow hash function depends on how the OS assigns CPU time to the strategies and in different a run a different strategy might finish first. But that's just for 10 games.
  • If I let all 12 variants (3 hash functions with 4 strategies each) race agains each other and pick the fastest result I get 7.25M moves in 250 sec.
  • The source code is not golfed at all. Removing unnecessary things like comments, types, type annotations, whitespace, error handling and switching to single letter names easily brings the byte count to a third and then we can still apply the usual golfing tricks.
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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