<?xml version="1.0" encoding="UTF-8"?>
<rss version="2.0"
	xmlns:content="http://purl.org/rss/1.0/modules/content/"
	xmlns:wfw="http://wellformedweb.org/CommentAPI/"
	xmlns:dc="http://purl.org/dc/elements/1.1/"
	xmlns:atom="http://www.w3.org/2005/Atom"
	xmlns:sy="http://purl.org/rss/1.0/modules/syndication/"
	xmlns:slash="http://purl.org/rss/1.0/modules/slash/"
	>

<channel>
	<title>LAMBDAPHONE &#187; sequences</title>
	<atom:link href="http://coder.bsimmons.name/blog/tag/sequences/feed/" rel="self" type="application/rss+xml" />
	<link>http://coder.bsimmons.name/blog</link>
	<description>fragmentary ideas  ䷿  intellectual what-nots  ䷷  and haskell programming  ䷴</description>
	<lastBuildDate>Tue, 27 Jul 2010 16:58:03 +0000</lastBuildDate>
	<generator>http://wordpress.org/?v=2.9.1</generator>
	<language>en</language>
	<sy:updatePeriod>hourly</sy:updatePeriod>
	<sy:updateFrequency>1</sy:updateFrequency>
			<item>
		<title>17&#215;17: More about symmetry and a new rotation</title>
		<link>http://coder.bsimmons.name/blog/2010/03/17x17-more-about-symmetry-and-a-new-rotation/</link>
		<comments>http://coder.bsimmons.name/blog/2010/03/17x17-more-about-symmetry-and-a-new-rotation/#comments</comments>
		<pubDate>Thu, 18 Mar 2010 19:17:55 +0000</pubDate>
		<dc:creator>jberryman</dc:creator>
				<category><![CDATA[haskell]]></category>
		<category><![CDATA[17x17]]></category>
		<category><![CDATA[algorithm]]></category>
		<category><![CDATA[sequences]]></category>

		<guid isPermaLink="false">http://coder.bsimmons.name/blog/?p=362</guid>
		<description><![CDATA[<blockquote><p><em>Note: this is part of a <a href="http://coder.bsimmons.name/blog/tag/17x17/">series of posts</a> is related to the &#8220;<a href="http://blog.computationalcomplexity.org/2009/11/17x17-challenge-worth-28900-this-is-not.html">17&#215;17 Challenge</a>&#8221; posted by Bill Gasarch. The goal is to color cells of a 17 by 17 grid, using only four colors, such that no</em></p></blockquote><p>&#8230; <a href="http://coder.bsimmons.name/blog/2010/03/17x17-more-about-symmetry-and-a-new-rotation/" class="read_more">   [ R E A D &#124; M O R E ]</a></p>]]></description>
			<content:encoded><![CDATA[<blockquote><p><em>Note: this is part of a <a href="http://coder.bsimmons.name/blog/tag/17x17/">series of posts</a> is related to the &#8220;<a href="http://blog.computationalcomplexity.org/2009/11/17x17-challenge-worth-28900-this-is-not.html">17&#215;17 Challenge</a>&#8221; posted by Bill Gasarch. The goal is to color cells of a 17 by 17 grid, using only four colors, such that no rectangle is formed from four cells of the same color.</em></p></blockquote>
<p>In my <a href="http://coder.bsimmons.name/blog/2010/03/17x17-symmetric-single-colorings-and-some-graph-theory/">last post</a>, I gave a symmetrical rotation of the known 74-cell single-coloring. I want to use a slight variation of that grid to show why I think treating the grids as symmetrical will help us in solving this problem.</p>
<p>Here is a new spreadsheet, with several panes you can click through on the bottom. Panes ONE through FIVE represent the first few rows of a single-coloring in which we avoid making any real choices, thanks to a few assumptions we make (I&#8217;ll come back to that).</p>
<p>Orange represents the row we&#8217;re coloring, gray cells are rectangle forming cells (in which marks are not allowed), and blue cells represent what I consider to be the real search-space:</p>
<blockquote><p>
<iframe width='425' height='400' frameborder='0' src='http://spreadsheets.google.com/pub?key=tmOFAqHDqtADZJqwWOeenIw&#038;output=html&#038;widget=true'></iframe></p></blockquote>
<p><em><br />
NOTE: We&#8217;re simply using another automorphism of the original 74-coloring, i.e. a series of rotations that preserve all the significant attributes of the graph. </em></p>
<p><span id="more-362"></span></p>
<h3>Making Coloring Decisions</h3>
<p>We can choose, arbitrarily, to start with a 5-cell row starting on the cell in the upper left. This is our first decision: if it were that in an optimal single-coloring of 17&#215;17 <em>no</em> row with five colored cells shared a cell with <em>any</em> column with five colored cells, then we would have made a poor decision.</p>
<p>But given that in the 74-coloring that we have, <em>all</em> 5-colored-cell rows share a cell with a 5-colored column, we can probably assume that at least one will in our optimal single-coloring. So our first row (in pane 1) is a non-decision.</p>
<p>We continue with the second row by dumping 3 cells as soon as we can (i.e. as far to the left as possible. The only decision made here is in whether to make row two a row of four or five. But as we can see very quickly (and as a shallow search algorithm would see very quickly), making row 2 a five-colored-cell row would force us into forming a 3-cell row out of row five.</p>
<p>So in row 2 we have an easy decision (seeing that we would soon regret creating a 5-cell row) based on our assumption that a good singly-colored grid will have its cells spread evenly over rows &#038; columns. </p>
<p>And we have the non-decision of the column placement of those three cells: because identical columns (in this case empty columns) can be freely swapped without changing anything, there is no need to try every combination of column placement for the row. We put off our decision making for later. </p>
<p>We continue on in the same way.</p>
<h3>Search Ideas</h3>
<p>I&#8217;m coding up a program to try to generate good grids based on some heuristics. I think that a <a href="http://en.wikipedia.org/wiki/Minimax">minimax</a> type solution might be good: in which the coloring of a cell is assigned a point-value based on how many future cells it makes unusable. I could then keep track of which previous cells were complicit in forming potential rectangles and back-track at apparently-bad decisions: i.e. <a href="http://en.wikipedia.org/wiki/Hill_climbing">hill climbing</a>.</p>
<p>I may try to formulate the algorithm like a game and see if I can use the <a href="http://hackage.haskell.org/package/game-tree-0.1.0.0">game-tree module</a> by Colin Adams.</p>
<h3>Conclusion</h3>
<p>It seems to me that the key to the problem of a single-coloring is shrinking the search-space by eliminating false-choices. Treating the graph as it&#8217;s symmetrical (by our definition of symmetrical) automorphism is one way: suddenly the search space becomes the shaded area in the graph above.</p>
<p>Thankfully, my next post will be haskell-related and have nothing to do with Grids.</p>
]]></content:encoded>
			<wfw:commentRss>http://coder.bsimmons.name/blog/2010/03/17x17-more-about-symmetry-and-a-new-rotation/feed/</wfw:commentRss>
		<slash:comments>0</slash:comments>
		</item>
		<item>
		<title>17&#215;17: Some Thoughts on the Problem</title>
		<link>http://coder.bsimmons.name/blog/2010/03/17x17-some-thoughts-on-the-problem/</link>
		<comments>http://coder.bsimmons.name/blog/2010/03/17x17-some-thoughts-on-the-problem/#comments</comments>
		<pubDate>Sun, 07 Mar 2010 02:32:54 +0000</pubDate>
		<dc:creator>jberryman</dc:creator>
				<category><![CDATA[haskell]]></category>
		<category><![CDATA[17x17]]></category>
		<category><![CDATA[algorithm]]></category>
		<category><![CDATA[sequences]]></category>

		<guid isPermaLink="false">http://coder.bsimmons.name/blog/?p=344</guid>
		<description><![CDATA[<p><em>I&#8217;ve been puzzling over some of the problems presented by the <a href="http://blog.computationalcomplexity.org/2009/11/17x17-challenge-worth-28900-this-is-not.html">17 x 17 Challenge</a>, and wanted to share some of what I&#8217;ve learned and have been wondering about. The problem and ultimate goal is to color a 17</em>&#8230; <a href="http://coder.bsimmons.name/blog/2010/03/17x17-some-thoughts-on-the-problem/" class="read_more">   [ R E A D &#124; M O R E ]</a></p>]]></description>
			<content:encoded><![CDATA[<p><em>I&#8217;ve been puzzling over some of the problems presented by the <a href="http://blog.computationalcomplexity.org/2009/11/17x17-challenge-worth-28900-this-is-not.html">17 x 17 Challenge</a>, and wanted to share some of what I&#8217;ve learned and have been wondering about. The problem and ultimate goal is to color a 17 x 17 grid with four colors such that every cell is colored and no rectangle is formed by any four cells of the same color. </em></p>
<h2>Single-Color Subsets</h2>
<p>I&#8217;ve started by trying to find an algorithm to find optimal single-color subsets, i.e. a way of coloring a grid with one color such that no rectangle is formed by the colored cells, and we have the greatest number of cells colored as possible. I started thinking of coloring cells one at a time, following a path based on the notion of an &#8220;extended rectangle&#8221; where the fourth side was longer or shorter than the first, to avoid forming rectangles.</p>
<p>I also noticed that we could traverse all the cells in the <a href="http://www.cs.umd.edu/~gasarch/BLOGPAPERS/17x17.pdf">largest known 17&#215;17 subset</a> by following a simple spiraling algorithm. It didn&#8217;t seem to matter which cell or direction we started in either:</p>
<p><div id="attachment_345" class="wp-caption aligncenter" style="width: 410px"><a href="http://coder.bsimmons.name/blog/wp-content/uploads/17x17.png"><img src="http://coder.bsimmons.name/blog/wp-content/uploads/17x17-300x235.png" alt="grid traversal algorithm" title="17x17" width="300" height="235" class="size-medium wp-image-345" /></a><p class="wp-caption-text">go until you hit a colored cell, then rotate 90 degrees</p></div><br />
<span id="more-344"></span><br />
This led to a <a href="http://coder.bsimmons.name/blog/2010/03/17x17-deterministic-algorithm-for-single-coloring-a-grid/">simple algorithm</a> that does well in finding pretty good subsets, but doesn&#8217;t find optimal subsets for the larger grids (at least it couldn&#8217;t find a grid of size 74, linked above). The algorithm is something like &#8220;wagging the dog&#8221;, and it&#8217;s surprising that it works as well as it does. I wonder whether the sub-problem of optimal single-colorings has applications to <a href="http://en.wikipedia.org/wiki/Knot_theory">knot theory</a>.</p>
<h3>Optimal Grids</h3>
<p>I generated some optimally-colored grids to see if they all followed this property of being traversable via this &#8220;rotation&#8221; algorithm above. It turns out that some directions and starting points loop before they touch every colored cell. I suspect that will also be the case for the 74-color grid above.</p>
<p>Here are the grids I was able to generate <a href="http://coder.bsimmons.name/blog/2010/02/17x17-brute-force-algorithm-for-an-optimal-rectangle-free-subset/">via brute force</a>:</p>
<p><a href="http://coder.bsimmons.name/blog/wp-content/uploads/grids.png"><img src="http://coder.bsimmons.name/blog/wp-content/uploads/grids-300x108.png" alt="" title="grids" width="300" height="108" class="aligncenter size-medium wp-image-348" /></a></p>
<p>Notice that, as you might guess, colored cells are spread out as evenly as possible among rows and columns (i.e. no two rows differ by more than one in their number of colored cells).</p>
<h4>&#8230;and Symmetry and Rotations</h4>
<p>Also notice the diagonal symmetry that all of the grids exhibit. The 5&#215;5 grid was not symmetrical when it came out of my brute force algorithm, but I was happy to see that I could turn it into the above symmetrical version with a few rotations (a fun puzzle by the way). The symmetry reminds me of creating/solving <a href="http://en.wikipedia.org/wiki/Algorithmics_of_sudoku">sudoku</a> and I wonder if this is a similar constraint-solving problem.</p>
<p>It would be interesting to see if the 17&#215;17 grid was symmetrical in one of its possible rotations. I would like to look into that as well as code up a symmetrical variation of the algorithm I described in my <a href="http://coder.bsimmons.name/blog/2010/03/17x17-deterministic-algorithm-for-single-coloring-a-grid/">last</a> post. If all optimal subsets were symmetrical, that could make the search-space considerably smaller.</p>
<p>I also wonder whether <em>all</em> subsets of the same size are not simply rotations of the others. This seems to be the case for the smaller optimal subsets in the image above.</p>
<h2>Four-Coloring the 17&#215;17 Grid</h2>
<p>The author suggests that a 17&#215;17 grid is an edge case, meaning that it may or may not be possible to four-color. A single-coloring of at least 73 must be possible in order for a four-coloring to be possible: <code>73 + 72 + 72 + 72 = 289 = 17 x 17</code>. The author of the challenge has found one of size 74.</p>
<p>Given the difficulty of finding a single-coloring (74 colors seems to be the largest known), we can perhaps assume that each of the four <em>single-color subsets</em> will be evenly distributed with 4 or 5 cells per row/column. </p>
<p>Thus <em>every</em> row of a successful four coloring will have <code>4 + 4 + 4 + 5 = 17</code> in each of the four colors respectively.</p>
<p>There are 2380 possible unique 17-length rows with four colored cells in the row. There are 6188 with 5 colored. Here&#8217;s the code I used for that fun fact:</p>
<p><blockquote class="vimblock"><br />
<span class="Comment">-- finding promising rows:</span><br />
allRowsSize&nbsp;sz&nbsp;n<br />
&nbsp;&nbsp;&nbsp;&nbsp;<span class="Statement">|</span>&nbsp;sz&nbsp;<span class="Statement">==</span>&nbsp;n&nbsp;<span class="Statement">=</span>&nbsp;[&nbsp;<span class="Identifier">replicate</span>&nbsp;n&nbsp;&nbsp;<span class="Constant">True</span>&nbsp;]<br />
&nbsp;&nbsp;&nbsp;&nbsp;<span class="Statement">|</span>&nbsp;n&nbsp;&nbsp;<span class="Statement">==</span>&nbsp;<span class="Constant">0</span>&nbsp;<span class="Statement">=</span>&nbsp;[&nbsp;<span class="Identifier">replicate</span>&nbsp;sz&nbsp;<span class="Constant">False</span>&nbsp;]<br />
&nbsp;&nbsp;&nbsp;&nbsp;<span class="Statement">|</span>&nbsp;<span class="Identifier">otherwise</span>&nbsp;<span class="Statement">=</span><br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; [&nbsp;<span class="Constant">True</span><span class="Statement">:</span>as&nbsp;&nbsp;<span class="Statement">|</span>&nbsp;as&nbsp;<span class="Statement">&lt;-</span>&nbsp;allRowsSize&nbsp;(sz<span class="Statement">-</span><span class="Constant">1</span>)&nbsp;(n<span class="Statement">-</span><span class="Constant">1</span>)&nbsp;]&nbsp;<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<span class="Statement">++</span>&nbsp;[&nbsp;<span class="Constant">False</span><span class="Statement">:</span>as&nbsp;<span class="Statement">|</span>&nbsp;as&nbsp;<span class="Statement">&lt;-</span>&nbsp;allRowsSize&nbsp;(sz<span class="Statement">-</span><span class="Constant">1</span>)&nbsp;n&nbsp;]<br />
<br /></blockquote></p>
<h3>Going Forward</h3>
<p>If the couple ideas I still have for an optimal single-coloring don&#8217;t work out, it may be interesting to try to &#8220;deconstruct&#8221; the known 74-coloring, treating it like the algorithm I developed in my last post, but in reverse, noticing the &#8220;choices&#8221; made. </p>
<p>After giving up on a deterministic single-coloring algorithm it might be interesting to investigate some kind of ladder climbing algorithm that looks at trying to consolidate rectangle-forming squares.</p>
<p>Finally, an approach that might have been the easiest all along, would be to take the author&#8217;s 74-coloring above and try to generate 4 different permutations of sizes 73 and 72 that could fit together. We don&#8217;t learn too much from that though.</p>
<p>I&#8217;m really interested to know your thoughts on the problem as well. So leave a comment if you like!</p>
]]></content:encoded>
			<wfw:commentRss>http://coder.bsimmons.name/blog/2010/03/17x17-some-thoughts-on-the-problem/feed/</wfw:commentRss>
		<slash:comments>2</slash:comments>
		</item>
		<item>
		<title>17&#215;17: Deterministic algorithm for single-coloring a grid</title>
		<link>http://coder.bsimmons.name/blog/2010/03/17x17-deterministic-algorithm-for-single-coloring-a-grid/</link>
		<comments>http://coder.bsimmons.name/blog/2010/03/17x17-deterministic-algorithm-for-single-coloring-a-grid/#comments</comments>
		<pubDate>Mon, 01 Mar 2010 08:17:55 +0000</pubDate>
		<dc:creator>jberryman</dc:creator>
				<category><![CDATA[haskell]]></category>
		<category><![CDATA[17x17]]></category>
		<category><![CDATA[algorithm]]></category>
		<category><![CDATA[sequences]]></category>

		<guid isPermaLink="false">http://coder.bsimmons.name/blog/?p=337</guid>
		<description><![CDATA[<p><em>I finally got some time to code up a messy script to test out a few variations of an algorithm to generate rectangle-free single colorings of a grid, as part of a <del datetime="2010-03-02T18:50:50+00:00">lazy</del> humble effort to solve the <a</em>&#8230; <a href="http://coder.bsimmons.name/blog/2010/03/17x17-deterministic-algorithm-for-single-coloring-a-grid/" class="read_more">   [ R E A D &#124; M O R E ]</a></p>]]></description>
			<content:encoded><![CDATA[<p><em>I finally got some time to code up a messy script to test out a few variations of an algorithm to generate rectangle-free single colorings of a grid, as part of a <del datetime="2010-03-02T18:50:50+00:00">lazy</del> humble effort to solve the <a href="http://blog.computationalcomplexity.org/2009/11/17x17-challenge-worth-28900-this-is-not.html">17 x 17 challenge</a>. </em></p>
<p>This post is going to be a bit of a code-dump. The algorithm is essentially: </p>
<ol>
<li>color cell, </li>
<li>turn to the right, </li>
<li>stop on first non-rectangle forming cell, </li>
<li>
if the cell is uncolored, color it and turn to the right, else if the cell was already colored and has been entered from this direction already, then skip it, else turn to the right</li>
</ol>
<p><span id="more-337"></span><br />
I&#8217;m not sure if an algorithm exists yet to find rectangle free colorings. The authors of the challenge seem to know of no optimal deterministic algorithm.</p>
<p>The code below produces a rectangle-free subset of 68 colored cells on a 17&#215;17 grid. Apparently the <a href="http://www.cs.umd.edu/~gasarch/BLOGPAPERS/17x17.pdf">largest known subset</a> is <del datetime="2010-03-02T18:50:50+00:00">73</del> 74 (important because <del datetime="2010-03-03T15:11:51+00:00">4 subsets of length 73 or 72</del> one subset of size 73 and three of size 72 would fill a 17&#215;17 grid if they could be made to fit together). So hopefully one of the variations of the algorithm above that I have in mind will be able to match or beat that. </p>
<p>We don&#8217;t yet have logic for stopping once a row or column is exhausted, so it will just hang:</p>
<p><blockquote class="vimblock"><br />
<span class="Type">module</span>&nbsp;Main<br />
&nbsp;&nbsp;&nbsp;&nbsp;<span class="Type">where</span><br />
<br />
<span class="PreProc">import</span>&nbsp;Data.List<br />
<span class="PreProc">import</span>&nbsp;<span class="PreProc">qualified</span>&nbsp;Data.Map <span class="PreProc">as</span>&nbsp;M<br />
<span class="PreProc">import</span>&nbsp;Data.Maybe<br />
<br />
<br />
<br />
<span class="Comment">-- we move clockwise:</span><br />
<span class="Type">data</span>&nbsp;Direction&nbsp;<span class="Statement">=</span>&nbsp;W&nbsp;<span class="Statement">|</span>&nbsp;N&nbsp;<span class="Statement">|</span>&nbsp;E&nbsp;<span class="Statement">|</span>&nbsp;S&nbsp;&nbsp; <span class="Type">deriving</span>&nbsp;(<span class="Type">Show</span>,&nbsp;<span class="Type">Ord</span>,&nbsp;<span class="Type">Eq</span>,&nbsp;<span class="Type">Enum</span>)<br />
<br />
<span class="Type">data</span>&nbsp;Cell&nbsp;<span class="Statement">=</span>&nbsp;FormsRectangle<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<span class="Statement">|</span>&nbsp;Colored&nbsp;DirectionsEntered<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Type">deriving</span>&nbsp;<span class="Type">Show</span><br />
<br />
<span class="Comment">-- to avoid loops, keep track of which way we've entered a cell :</span><br />
<span class="Type">type</span>&nbsp;DirectionsEntered&nbsp;<span class="Statement">=</span>&nbsp;[&nbsp;Direction&nbsp;]&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<br />
<br />
<span class="Type">type</span>&nbsp;Grid&nbsp;<span class="Statement">=</span>&nbsp;M.Map&nbsp;(<span class="Type">Int</span>,<span class="Type">Int</span>)&nbsp;Cell<br />
<br />
singleColoring&nbsp;<span class="Statement">::</span>&nbsp;<span class="Type">Int</span>&nbsp;<span class="Statement">-&gt;</span>&nbsp;[(<span class="Type">Int</span>,<span class="Type">Int</span>)]<br />
singleColoring&nbsp;n&nbsp;<span class="Statement">=</span>&nbsp;colorCells&nbsp;M.empty&nbsp;dI&nbsp;turns&nbsp;posI&nbsp;<span class="Type">where</span><br />
&nbsp;&nbsp;&nbsp;&nbsp;<span class="Comment">-- start as we enter lower left corner cell...</span><br />
&nbsp;&nbsp;&nbsp;&nbsp;posI&nbsp;<span class="Statement">=</span>&nbsp;(<span class="Constant">1</span>,<span class="Constant">1</span>)<br />
&nbsp;&nbsp;&nbsp;&nbsp;<span class="Comment">-- ...moving to the left:</span><br />
&nbsp;&nbsp;&nbsp;&nbsp;(dI<span class="Statement">:</span>turns)&nbsp;<span class="Statement">=</span>&nbsp;<span class="Identifier">cycle</span>&nbsp;[W&nbsp;<span class="Statement">..</span>]<br />
<br />
&nbsp;&nbsp;&nbsp;&nbsp;<span class="Comment">-- we wrap when moving off the grid:</span><br />
&nbsp;&nbsp;&nbsp;&nbsp;mv&nbsp;d&nbsp;<span class="Statement">=</span>&nbsp;wrapped&nbsp;<span class="Statement">.</span>&nbsp;move&nbsp;d<br />
&nbsp;&nbsp;&nbsp;&nbsp;wrapped&nbsp;(x,y)&nbsp;<span class="Statement">=</span>&nbsp;(w&nbsp;x,&nbsp;w&nbsp;y)&nbsp;&nbsp;<span class="Type">where</span><br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;w&nbsp;<span class="Constant">0</span>&nbsp;<span class="Statement">=</span>&nbsp;n<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;w&nbsp;x&nbsp;<span class="Statement">=</span>&nbsp;<span class="Statement">if</span>&nbsp;x&nbsp;<span class="Statement">==</span>&nbsp;(n<span class="Statement">+</span><span class="Constant">1</span>)&nbsp;<span class="Statement">then</span>&nbsp;<span class="Constant">1</span>&nbsp;<span class="Statement">else</span>&nbsp;x<br />
<br />
&nbsp;&nbsp;&nbsp;&nbsp;<span class="Comment">-- our coloring algorithm:</span><br />
&nbsp;&nbsp;&nbsp;&nbsp;colorCells&nbsp;g&nbsp;d&nbsp;ts<span class="Statement">@</span>(d'<span class="Statement">:</span>ds)&nbsp;xy&nbsp;<span class="Statement">=</span><br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<span class="Statement">case</span>&nbsp;M.lookup&nbsp;xy&nbsp;g&nbsp;<span class="Statement">of</span><br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<span class="Comment">-- color this cell:</span><br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Constant">Nothing</span>&nbsp;<span class="Statement">-&gt;</span>&nbsp;xy&nbsp;<span class="Statement">:</span>&nbsp;turnUpdating&nbsp;(color&nbsp;xy&nbsp;d)<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<span class="Comment">-- NO LOGIC YET FOR STOPPING WHEN WE&quot;VE EXHAUSTED A ROW:</span><br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Constant">Just</span>&nbsp;FormsRectangle&nbsp;<span class="Statement">-&gt;</span>&nbsp;skip<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Constant">Just</span>&nbsp;(Colored&nbsp;es)&nbsp;<span class="Statement">-&gt;</span>&nbsp;<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<span class="Statement">if</span>&nbsp;d&nbsp;<span class="Statement">`elem`</span>&nbsp;es<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">--then []</span><br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Statement">then</span>&nbsp;skip<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<span class="Comment">-- cell colored and we haven't entered this way yet; turn:</span><br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Statement">else</span>&nbsp;turnUpdating&nbsp;(addEntered&nbsp;d&nbsp;es&nbsp;xy)<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<span class="Type">where</span>&nbsp;skip&nbsp;<span class="Statement">=</span>&nbsp;colorCells&nbsp;g&nbsp;d&nbsp;ts&nbsp;(mv&nbsp;d&nbsp;xy)<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;turnUpdating&nbsp;f&nbsp;<span class="Statement">=</span>&nbsp;colorCells&nbsp;(f&nbsp;g)&nbsp;d' ds&nbsp;(mv&nbsp;d' xy)<br />
<br />
<span class="Comment">-- insert colored cell, along with markers for the cells that would form</span><br />
<span class="Comment">-- a rectanlge with this newly-colored cell:</span><br />
color&nbsp;<span class="Statement">::</span>&nbsp;(<span class="Type">Int</span>,<span class="Type">Int</span>)&nbsp;<span class="Statement">-&gt;</span>&nbsp;Direction&nbsp;<span class="Statement">-&gt;</span>&nbsp;Grid&nbsp;<span class="Statement">-&gt;</span>&nbsp;Grid<br />
color&nbsp;(x,y)&nbsp;d&nbsp;g&nbsp;<span class="Statement">=</span>&nbsp;M.insert&nbsp;(x,y)&nbsp;(Colored&nbsp;[d])&nbsp;rectsFormed<br />
&nbsp;&nbsp;&nbsp;&nbsp;<span class="Type">where</span><br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;ccs&nbsp;<span class="Statement">=</span>&nbsp;M.keys&nbsp;<span class="Statement">$</span>&nbsp;M.filter&nbsp;isColored&nbsp;g<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- all x coords of colored cells in same row (i.e. with same y):</span><br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;row&nbsp;<span class="Statement">=</span>&nbsp;inRow&nbsp;y<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- all y coords of colored cells in same column:</span><br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;col&nbsp;<span class="Statement">=</span>&nbsp;inCol&nbsp;x<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- rectangles would be formed by these coordinates:</span><br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;xyRects&nbsp;<span class="Statement">=</span>&nbsp;[&nbsp;(x',&nbsp;y')&nbsp;<span class="Statement">|</span>&nbsp;x'<span class="Statement">&lt;-</span>&nbsp;row,&nbsp;y' <span class="Statement">&lt;-</span>&nbsp;col&nbsp;]<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;xxRects&nbsp;<span class="Statement">=</span>&nbsp;[&nbsp;(x,&nbsp;y')&nbsp;<span class="Statement">|</span>&nbsp;x'<span class="Statement">&lt;-</span>&nbsp;row,&nbsp;y' <span class="Statement">&lt;-</span>&nbsp;delete&nbsp;y&nbsp;(inCol&nbsp;x')&nbsp;]<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;yyRects&nbsp;<span class="Statement">=</span>&nbsp;[&nbsp;(x',&nbsp;y)&nbsp;<span class="Statement">|</span>&nbsp;y'<span class="Statement">&lt;-</span>&nbsp;col,&nbsp;x' <span class="Statement">&lt;-</span>&nbsp;delete&nbsp;x&nbsp;(inRow&nbsp;y')&nbsp;]<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;corners&nbsp;<span class="Statement">=</span>&nbsp;xyRects&nbsp;<span class="Statement">++</span>&nbsp;xxRects&nbsp;<span class="Statement">++</span>&nbsp;yyRects<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;rectsFormed&nbsp;<span class="Statement">=</span>&nbsp;<span class="Identifier">foldr</span>&nbsp;(<span class="Identifier">flip</span>&nbsp;M.insert&nbsp;FormsRectangle)&nbsp;g&nbsp;corners<br />
<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- some helpers for above:</span><br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;inRow&nbsp;r&nbsp;<span class="Statement">=</span>&nbsp;[&nbsp;x' <span class="Statement">|</span>&nbsp;(x',y')&nbsp;<span class="Statement">&lt;-</span>&nbsp;ccs,&nbsp;y' <span class="Statement">==</span>&nbsp;r&nbsp;]<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;inCol&nbsp;c&nbsp;<span class="Statement">=</span>&nbsp;[&nbsp;y' <span class="Statement">|</span>&nbsp;(x',y')&nbsp;<span class="Statement">&lt;-</span>&nbsp;ccs,&nbsp;x' <span class="Statement">==</span>&nbsp;c&nbsp;]<br />
<br />
isColored&nbsp;(Colored&nbsp;_)&nbsp;<span class="Statement">=</span>&nbsp;<span class="Constant">True</span><br />
isColored&nbsp;_&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Statement">=</span>&nbsp;<span class="Constant">False</span><br />
<br />
<span class="Comment">-- mark the cell as having been entered from the direction we're going:</span><br />
addEntered&nbsp;<span class="Statement">::</span>&nbsp;Direction&nbsp;<span class="Statement">-&gt;</span>&nbsp;[Direction]&nbsp;<span class="Statement">-&gt;</span>&nbsp;(<span class="Type">Int</span>,<span class="Type">Int</span>)&nbsp;<span class="Statement">-&gt;</span>&nbsp;Grid&nbsp;<span class="Statement">-&gt;</span>&nbsp;Grid<br />
addEntered&nbsp;d&nbsp;es&nbsp;<span class="Statement">=</span>&nbsp;M.adjust&nbsp;<span class="Statement">.</span>&nbsp;<span class="Identifier">const</span>&nbsp;<span class="Statement">$</span>&nbsp;Colored&nbsp;(d<span class="Statement">:</span>es)&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <br />
<br />
move&nbsp;S&nbsp;(x,y)&nbsp;<span class="Statement">=</span>&nbsp;(x,y<span class="Statement">-</span><span class="Constant">1</span>)<br />
move&nbsp;E&nbsp;(x,y)&nbsp;<span class="Statement">=</span>&nbsp;(x<span class="Statement">+</span><span class="Constant">1</span>,y)<br />
move&nbsp;N&nbsp;(x,y)&nbsp;<span class="Statement">=</span>&nbsp;(x,y<span class="Statement">+</span><span class="Constant">1</span>)<br />
move&nbsp;W&nbsp;(x,y)&nbsp;<span class="Statement">=</span>&nbsp;(x<span class="Statement">-</span><span class="Constant">1</span>,y)<br />
<br /></blockquote></p>
]]></content:encoded>
			<wfw:commentRss>http://coder.bsimmons.name/blog/2010/03/17x17-deterministic-algorithm-for-single-coloring-a-grid/feed/</wfw:commentRss>
		<slash:comments>1</slash:comments>
		</item>
		<item>
		<title>DeBruijn Sequences pt.3 &#8211; The &#8220;Prefer Opposite&#8221; algorithm</title>
		<link>http://coder.bsimmons.name/blog/2009/12/debruijn-sequences-pt3-the-prefer-opposite-algorithm/</link>
		<comments>http://coder.bsimmons.name/blog/2009/12/debruijn-sequences-pt3-the-prefer-opposite-algorithm/#comments</comments>
		<pubDate>Wed, 02 Dec 2009 02:29:29 +0000</pubDate>
		<dc:creator>jberryman</dc:creator>
				<category><![CDATA[haskell]]></category>
		<category><![CDATA[algorithm]]></category>
		<category><![CDATA[laziness]]></category>
		<category><![CDATA[monads]]></category>
		<category><![CDATA[sequences]]></category>

		<guid isPermaLink="false">http://coder.bsimmons.name/blog/?p=295</guid>
		<description><![CDATA[<p><em>This is the third post of mine on DeBruijn sequences, and is in preparation for another post to come which I hope should be an interesting investigation into a possible parallel algorithm. The first two posts are <a href="http://coder.bsimmons.name/blog/2009/09/cracking-a-lock-in-haskell-with-the-de-bruijn-sequence-pt-1/">here</a> and</em>&#8230; <a href="http://coder.bsimmons.name/blog/2009/12/debruijn-sequences-pt3-the-prefer-opposite-algorithm/" class="read_more">   [ R E A D &#124; M O R E ]</a></p>]]></description>
			<content:encoded><![CDATA[<p><em>This is the third post of mine on DeBruijn sequences, and is in preparation for another post to come which I hope should be an interesting investigation into a possible parallel algorithm. The first two posts are <a href="http://coder.bsimmons.name/blog/2009/09/cracking-a-lock-in-haskell-with-the-de-bruijn-sequence-pt-1/">here</a> and <a href="http://coder.bsimmons.name/blog/2009/09/cracking-a-lock-in-haskell-with-the-de-bruijn-sequence-pt-2/">here</a>.</em><br />
<span id="more-295"></span><br />
&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;</p>
<p><div class="vimblock"><br />
This algorithm works identically to the Prefer One algorithm, however<br />
rather than choose a 1-bit if possible, we instead choose the opposite<br />
bit from the previous bit, if possible.<br />
<br />
This has the effect of evening out the locations of the zeros and ones<br />
throughout the sequence. We will exploit this in a later post where I<br />
will explore a possible parallel algorithm, which should be interesting<br />
I hope!<br />
<br />
Here's the code...<br />
<br />
<span class="Comment">&gt;</span>&nbsp;<span class="Type">module</span>&nbsp;Main<br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp; <span class="Type">where</span><br />
<span class="Comment">&gt;</span><br />
<span class="Comment">&gt;</span>&nbsp;<span class="PreProc">import</span>&nbsp;Data.List(tails)<br />
<span class="Comment">&gt;</span>&nbsp;<span class="PreProc">import</span>&nbsp;Control.Monad.State<br />
<span class="Comment">&gt;</span>&nbsp;<span class="PreProc">import</span>&nbsp;Control.Arrow<br />
<br />
<br />
We use Bool for bits, where False ==&gt; 0, True ==&gt; 1:<br />
<br />
<span class="Comment">&gt;</span>&nbsp;<span class="Type">type</span>&nbsp;Bit&nbsp;<span class="Statement">=</span>&nbsp;<span class="Type">Bool</span><br />
<br />
<br />
We use a tree to search for the words already created in our bit stream:<br />
<br />
<span class="Comment">&gt;</span>&nbsp;<span class="Type">data</span>&nbsp;Tree&nbsp;<span class="Statement">=</span>&nbsp;Bs&nbsp;Tree&nbsp;Tree&nbsp;&nbsp;<span class="Comment">-- Bs (zero_bit) (one_bit)</span><br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Statement">|</span>&nbsp;X&nbsp;<span class="Comment">-- incomplete word</span><br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Statement">|</span>&nbsp;B&nbsp;<span class="Comment">-- final bit of word</span><br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Type">deriving</span>&nbsp;<span class="Type">Show</span><br />
<br />
<br />
We'll need to build a new tree from a list of bits, appending<br />
a final bit:<br />
<br />
<span class="Comment">&gt;</span>&nbsp;treeWithFinal&nbsp;<span class="Statement">::</span>&nbsp;Bit&nbsp;<span class="Statement">-&gt;</span>&nbsp;[Bit]&nbsp;<span class="Statement">-&gt;</span>&nbsp;Tree<br />
<span class="Comment">&gt;</span>&nbsp;treeWithFinal&nbsp;p&nbsp;<span class="Statement">=</span>&nbsp;<span class="Identifier">foldr</span>&nbsp;mkBranch&nbsp;(<span class="Statement">if</span>&nbsp;p&nbsp;<span class="Statement">then</span>&nbsp;Bs&nbsp;X&nbsp;B&nbsp;<span class="Statement">else</span>&nbsp;Bs&nbsp;B&nbsp;X)&nbsp;&nbsp; <br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp; <span class="Type">where</span>&nbsp;mkBranch&nbsp;b&nbsp;<span class="Statement">|</span>&nbsp;b&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Statement">=</span>&nbsp;Bs&nbsp;X&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<span class="Comment">--1</span><br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<span class="Statement">|</span>&nbsp;<span class="Identifier">otherwise</span>&nbsp;<span class="Statement">=</span>&nbsp;<span class="Identifier">flip</span>&nbsp;Bs&nbsp;X&nbsp;<span class="Comment">--0</span><br />
<br />
<br />
<br />
Finally, here is our new algorithm. The Tree which we use to search for<br />
previously-seen words is passed in the State monad, behind the scenes, <br />
with 'zipWithM', which in our case looks like:<br />
<br />
&nbsp;&nbsp;&nbsp;&nbsp;zipWithM :: (Bit -&gt; [Bit] -&gt; State Tree Bit) -&gt; <br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;[Bit]&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;-&gt; <br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;[[Bit]]&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;-&gt; <br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;State Tree [Bit]<br />
<br />
The state monad is a little tricky sometimes:<br />
<br />
<span class="Comment">&gt;</span>&nbsp;preferOpposite&nbsp;<span class="Statement">::</span>&nbsp;<span class="Type">Int</span>&nbsp;<span class="Statement">-&gt;</span>&nbsp;[&nbsp;Bit&nbsp;]<br />
<span class="Comment">&gt;</span>&nbsp;preferOpposite&nbsp;n&nbsp;<span class="Statement">=</span>&nbsp;<br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- the whole bit sequence, except for the final 1:</span><br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp; <span class="Statement">let</span>&nbsp;bs&nbsp;<span class="Statement">=</span>&nbsp;<span class="Identifier">take</span>&nbsp;(<span class="Constant">2</span><span class="Statement">^</span>n<span class="Statement">-</span><span class="Constant">1</span>)&nbsp;(<span class="Identifier">replicate</span>&nbsp;n&nbsp;<span class="Constant">False</span>&nbsp;<span class="Statement">++</span>&nbsp;bs')<br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- list of (n-1)-bit words:</span><br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; (wp0<span class="Statement">:</span>wordPrefixes)&nbsp;<span class="Statement">=</span>&nbsp;<span class="Identifier">map</span>&nbsp;(<span class="Identifier">take</span>&nbsp;(n<span class="Statement">-</span><span class="Constant">1</span>))&nbsp;(tails&nbsp;bs)<br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- we know the first word is n 0's so we create our initial</span><br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- tree from (n-1) 0's with a zero at the end:</span><br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; state0&nbsp;<span class="Statement">=</span>&nbsp;treeWithFinal&nbsp;<span class="Constant">False</span>&nbsp;wp0<br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- we zipWith a word with it's previous bit (so that we</span><br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- can know which bit is the opposite) passing along the</span><br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- Tree with help from the State monad:</span><br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; bsM' <span class="Statement">=</span>&nbsp;zipWithM&nbsp;thisBit&nbsp;(<span class="Constant">False</span><span class="Statement">:</span>bs')&nbsp;wordPrefixes<br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; bs' <span class="Statement">=</span>&nbsp;evalState&nbsp;bsM' state0<br />
<span class="Comment">&gt;</span><br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- we place a 1 for the final bit:</span><br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;<span class="Statement">in</span>&nbsp;bs&nbsp;<span class="Statement">++</span>&nbsp;[<span class="Constant">True</span>]<br />
<br />
If we wanted to be clever, we would have made the last line:<br />
<br />
&nbsp;&nbsp;&nbsp;&nbsp; in cycle (bs ++ [True])<br />
<br />
...as the sequence is actually cyclic.<br />
<br />
This helper function takes the previous bit and an n-1 bit word and returns <br />
a function :: Tree -&gt; (Bit,Tree), which takes the current search tree and<br />
checks the current word to see if the last bit of the word should be one<br />
or zero. The function :: Tree -&gt; (Bit,Tree) is wrapped in the State <br />
constructor, which is all you have to do to turn it into :: State Tree Bit<br />
<br />
<span class="Comment">&gt;</span>&nbsp;thisBit&nbsp;<span class="Statement">::</span>&nbsp;Bit&nbsp;<span class="Statement">-&gt;</span>&nbsp;[&nbsp;Bit&nbsp;]&nbsp;<span class="Statement">-&gt;</span>&nbsp;State&nbsp;Tree&nbsp;Bit<br />
<br />
The wrapper function splits up the input tuple and tuples up the returned<br />
bit to make a proper St so that we can pass the last bit through the state<br />
monad.<br />
<br />
<span class="Comment">&gt;</span>&nbsp;thisBit&nbsp;bP&nbsp;&nbsp; <span class="Statement">=</span>&nbsp;State&nbsp;<span class="Statement">.</span>&nbsp;thisBit'<br />
<span class="Comment">&gt;</span>&nbsp;&nbsp; <span class="Type">where</span>&nbsp;bOpp&nbsp;<span class="Statement">=</span>&nbsp;<span class="Identifier">not</span>&nbsp;bP&nbsp;<br />
<br />
We start checking a word, moving down the tree:<br />
<br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; thisBit' (<span class="Constant">False</span><span class="Statement">:</span>bs)&nbsp;(Bs&nbsp;z&nbsp;o)&nbsp;<span class="Statement">=</span>&nbsp;second&nbsp;(<span class="Identifier">flip</span>&nbsp;Bs&nbsp;o)&nbsp;(thisBit' bs&nbsp;z)<br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; thisBit' (<span class="Constant">True</span><span class="Statement">:</span>bs)&nbsp;&nbsp;(Bs&nbsp;z&nbsp;o)&nbsp;<span class="Statement">=</span>&nbsp;second&nbsp;(Bs&nbsp;z)&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;(thisBit' bs&nbsp;o)<br />
<br />
...or we walked off end of branch, so return opposite bit, and attach <br />
the rest of word to the tree:<br />
<br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; thisBit' bs&nbsp;X&nbsp;<span class="Statement">=</span>&nbsp;(bOpp,&nbsp;treeWithFinal&nbsp;bOpp&nbsp;bs)<br />
<br />
...or we reached the end of our word, so we prefer the opposite for the last <br />
bit, and check if it was seen:<br />
<br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; thisBit' []&nbsp;(Bs&nbsp;z&nbsp;o)&nbsp;<br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Statement">|</span>&nbsp;bOpp&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<span class="Statement">=</span>&nbsp;<span class="Statement">case</span>&nbsp;o&nbsp;<span class="Statement">of</span>&nbsp;<span class="Comment">-- opposite bit is 1 (True)</span><br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;X&nbsp;<span class="Statement">-&gt;</span>&nbsp;(bOpp,Bs&nbsp;z&nbsp;B)<br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;_&nbsp;<span class="Statement">-&gt;</span>&nbsp;(bP&nbsp;&nbsp;,Bs&nbsp;B&nbsp;B)<br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Statement">|</span>&nbsp;<span class="Identifier">otherwise</span>&nbsp;<span class="Statement">=</span>&nbsp;<span class="Statement">case</span>&nbsp;z&nbsp;<span class="Statement">of</span><br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;X&nbsp;<span class="Statement">-&gt;</span>&nbsp;(bOpp,Bs&nbsp;B&nbsp;o)<br />
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;_&nbsp;<span class="Statement">-&gt;</span>&nbsp;(bP&nbsp;&nbsp;,Bs&nbsp;B&nbsp;B)<br />
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <br />
Finally, here are some functions to generate the actual sequences <br />
in 0s and 1s:<br />
<br />
<span class="Comment">&gt;</span>&nbsp;test&nbsp;<span class="Statement">=</span>&nbsp;<span class="Identifier">map</span>&nbsp;(<span class="Statement">\</span>x<span class="Statement">-&gt;</span><span class="Statement">if</span>&nbsp;x&nbsp;<span class="Statement">then</span>&nbsp;<span class="Constant">'1'</span>&nbsp;<span class="Statement">else</span>&nbsp;<span class="Constant">'0'</span>)&nbsp;<span class="Statement">.</span>&nbsp;preferOpposite&nbsp;<br />
<span class="Comment">&gt;</span><br />
<span class="Comment">&gt;</span>&nbsp;main&nbsp;<span class="Statement">=</span>&nbsp;<span class="Identifier">print</span>&nbsp;<span class="Statement">$</span>&nbsp;test&nbsp;<span class="Constant">10</span><br />
<br />
<br /></div></p>
]]></content:encoded>
			<wfw:commentRss>http://coder.bsimmons.name/blog/2009/12/debruijn-sequences-pt3-the-prefer-opposite-algorithm/feed/</wfw:commentRss>
		<slash:comments>0</slash:comments>
		</item>
		<item>
		<title>Cracking a Lock in Haskell with the De Bruijn sequence, pt. 2</title>
		<link>http://coder.bsimmons.name/blog/2009/09/cracking-a-lock-in-haskell-with-the-de-bruijn-sequence-pt-2/</link>
		<comments>http://coder.bsimmons.name/blog/2009/09/cracking-a-lock-in-haskell-with-the-de-bruijn-sequence-pt-2/#comments</comments>
		<pubDate>Tue, 29 Sep 2009 22:10:58 +0000</pubDate>
		<dc:creator>jberryman</dc:creator>
				<category><![CDATA[haskell]]></category>
		<category><![CDATA[algorithm]]></category>
		<category><![CDATA[data]]></category>
		<category><![CDATA[library]]></category>
		<category><![CDATA[monads]]></category>
		<category><![CDATA[sequences]]></category>
		<category><![CDATA[Tree]]></category>

		<guid isPermaLink="false">http://coder.bsimmons.name/blog/?p=221</guid>
		<description><![CDATA[<p>For this post I will rework the <a href="http://coder.bsimmons.name/blog/2009/09/cracking-a-lock-in-haskell-with-the-de-bruijn-sequence-pt-1/">Prefer One algorithm from<br />
the previous post</a> so that it is much more efficient. We will<br />
add words to a <a href="http://en.wikipedia.org/wiki/Patricia_tree">Patricia Tree</a>-like dictionary as we see them,<br />
passing&#8230; <a href="http://coder.bsimmons.name/blog/2009/09/cracking-a-lock-in-haskell-with-the-de-bruijn-sequence-pt-2/" class="read_more">   [ R E A D &#124; M O R E ]</a></p>]]></description>
			<content:encoded><![CDATA[<p>For this post I will rework the <a href="http://coder.bsimmons.name/blog/2009/09/cracking-a-lock-in-haskell-with-the-de-bruijn-sequence-pt-1/">Prefer One algorithm from<br />
the previous post</a> so that it is much more efficient. We will<br />
add words to a <a href="http://en.wikipedia.org/wiki/Patricia_tree">Patricia Tree</a>-like dictionary as we see them,<br />
passing the tree along in the State monad; to check if a new<br />
word has been seen we simply check in the tree, rather than<br />
in the array.</p>
<p>First, a little boilerplate&#8230;</p>
<p><div class="vimblock"><br>
<span class="Comment">&gt;</span>&nbsp;<span class="Type">module</span>&nbsp;Main<br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp; <span class="Type">where</span><br>
<span class="Comment">&gt;</span><br>
<span class="Comment">&gt;</span>&nbsp;<span class="PreProc">import</span>&nbsp;Data.Array<br>
<span class="Comment">&gt;</span>&nbsp;<span class="PreProc">import</span>&nbsp;Data.List(isInfixOf, tails)<br>
<span class="Comment">&gt;</span><br>
<span class="Comment">&gt;</span>&nbsp;<span class="PreProc">import</span>&nbsp;Control.Monad.State<br>
<span class="Comment">&gt;</span>&nbsp;<span class="PreProc">import</span>&nbsp;Control.Arrow<br>
<br></div></p>
<h3>NEW IMPLEMENTATION:</h3>
<p>&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;-</p>
<p>In the previous implementation, to check if the word formed<br />
by adding a one has been seen, we had to iterate through each<br />
of the previous bits in the array, checking words.</p>
<p>For example for words of length 3, finding the 7th bit (?)<br />
by checking if 111 has already been seen:</p>
<pre>
        /-----\  ==>  111
0 0 0 1 1 1 (1)...
\----/         000 == 111  No
  \----/       001 == 111  No
    \----/     011 == 111  No
      \----/   111 == 111  Yes, so this bit must be (0)
</pre>
<p>This is extremely inefficient. What we want is to be able to<br />
store all the previous words that we&#8217;ve encountered in an easily-<br />
searchable data structure. </p>
<p>In the example above, we would like the three words that we&#8217;ve<br />
seen to be stored in what might be called a Trie, so that our<br />
search instead looks like the following:</p>
<pre>
       /\
      0  1         1 - in tree, go right
     / \  \
    0   1  1       1 - in tree, go right
   / \   \  \
  0   1   1  1     1 - in tree, we've already seen 111,
                       so the last bit must be 0
</pre>
<p>Our new data structure will look like this:</p>
<p><div class="vimblock"><br>
<span class="Comment">&gt;</span>&nbsp;<span class="Type">data</span>&nbsp;Tree&nbsp;<span class="Statement">=</span>&nbsp;Bs&nbsp;Tree&nbsp;Tree&nbsp;&nbsp;<span class="Comment">-- Bs (zero_bit) (one_bit)</span><br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Statement">|</span>&nbsp;X&nbsp;<span class="Comment">-- incomplete word</span><br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Statement">|</span>&nbsp;B&nbsp;<span class="Comment">-- final bit of word</span><br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Type">deriving</span>&nbsp;<span class="Type">Show</span><br>
<br></div></p>
<p>We&#8217;ll need to build a new tree from a list of bits, appending<br />
a final bit (1, except for the initial tree):</p>
<p><div class="vimblock"><br>
<span class="Comment">&gt;</span>&nbsp;treeWithFinal1&nbsp;<span class="Statement">=</span>&nbsp;mkTree&nbsp;<span class="Constant">True</span><br>
<span class="Comment">&gt;</span>&nbsp;treeWithFinal0&nbsp;<span class="Statement">=</span>&nbsp;mkTree&nbsp;<span class="Constant">False</span><br>
<span class="Comment">&gt;</span><br>
<span class="Comment">&gt;</span><br>
<span class="Comment">&gt;</span>&nbsp;mkTree&nbsp;<span class="Statement">::</span>&nbsp;Bit&nbsp;<span class="Statement">-&gt;</span>&nbsp;[Bit]&nbsp;<span class="Statement">-&gt;</span>&nbsp;Tree<br>
<span class="Comment">&gt;</span>&nbsp;mkTree&nbsp;p&nbsp;<span class="Statement">=</span>&nbsp;<span class="Identifier">foldr</span>&nbsp;mkBranch&nbsp;(<span class="Statement">if</span>&nbsp;p&nbsp;<span class="Statement">then</span>&nbsp;Bs&nbsp;X&nbsp;B&nbsp;<span class="Statement">else</span>&nbsp;Bs&nbsp;B&nbsp;X)&nbsp;&nbsp; <br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp; <span class="Type">where</span>&nbsp;mkBranch&nbsp;b&nbsp;<span class="Statement">|</span>&nbsp;b&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Statement">=</span>&nbsp;Bs&nbsp;X&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<span class="Comment">--1</span><br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<span class="Statement">|</span>&nbsp;<span class="Identifier">otherwise</span>&nbsp;<span class="Statement">=</span>&nbsp;<span class="Identifier">flip</span>&nbsp;Bs&nbsp;X&nbsp;<span class="Comment">--0</span><br>
<br>
<br></div></p>
<p>Finally, here is our new algorithm. The tree is passed in the<br />
State monad, through the use of mapM. The state monad is a little<br />
tricky sometimes:</p>
<p><div class="vimblock"><br>
<span class="Comment">&gt;</span>&nbsp;preferOneV2&nbsp;<span class="Statement">::</span>&nbsp;<span class="Type">Int</span>&nbsp;<span class="Statement">-&gt;</span>&nbsp;[&nbsp;Bit&nbsp;]<br>
<span class="Comment">&gt;</span>&nbsp;preferOneV2&nbsp;n&nbsp;<span class="Statement">=</span>&nbsp;<br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp; <span class="Statement">let</span>&nbsp;upB&nbsp;<span class="Statement">=</span>&nbsp;<span class="Constant">2</span><span class="Statement">^</span>n<br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- the whole bit sequence (one period):</span><br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; bs&nbsp;<span class="Statement">=</span>&nbsp;&nbsp;<span class="Identifier">take</span>&nbsp;upB&nbsp;(<span class="Identifier">replicate</span>&nbsp;n&nbsp;<span class="Constant">False</span>&nbsp;<span class="Statement">++</span>&nbsp;bs')<br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; (wp0<span class="Statement">:</span>wordPrefixes)&nbsp;<span class="Statement">=</span>&nbsp;[&nbsp;<span class="Identifier">take</span>&nbsp;(n<span class="Statement">-</span><span class="Constant">1</span>)&nbsp;w&nbsp;<span class="Statement">|</span>&nbsp;w&nbsp;<span class="Statement">&lt;-</span>&nbsp;tails&nbsp;bs&nbsp;]<br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- pass our Tree around in the State monad</span><br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; state0&nbsp;<span class="Statement">=</span>&nbsp;treeWithFinal0&nbsp;wp0<br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- thisBit is partially applied, after which we wrap the</span><br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- function in a State constructor to make our :: m a</span><br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; bsM'&nbsp;&nbsp;<span class="Statement">=</span>&nbsp;<span class="Identifier">mapM</span>&nbsp;(State&nbsp;<span class="Statement">.</span>&nbsp;thisBit)&nbsp;wordPrefixes<br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; (bs',tree)&nbsp;<span class="Statement">=</span>&nbsp;runState&nbsp;bsM' state0<br>
<span class="Comment">&gt;</span><br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- an infinite stream is returned... because I can:&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;</span><br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;<span class="Statement">in</span>&nbsp;<span class="Identifier">cycle</span>&nbsp;bs<br>
<br>
<br></div></p>
<p>With the following function, after we apply it to the word we&#8217;re searching<br />
for, it becomes a function :: state -> (val,state), suitable for the<br />
State monad:</p>
<p>Takes a list of the last n-1 Bits (Bools) and traverses a Tree which we&#8217;ve<br />
been using to keep track of the words we&#8217;ve already seen. We fold the Bit<br />
list into the tree. When we get to the endo of the list, we look for a One.<br />
We return the new bit as well as the new Tree:</p>
<p><div class="vimblock"><br>
<span class="Comment">&gt;</span>&nbsp;thisBit&nbsp;<span class="Statement">::</span>&nbsp;[&nbsp;Bit&nbsp;]&nbsp;<span class="Statement">-&gt;</span>&nbsp;Tree&nbsp;<span class="Statement">-&gt;</span>&nbsp;(Bit,&nbsp;Tree)<br>
<br></div></p>
<p>We&#8217;re at a Zero bit,</p>
<p><div class="vimblock"><br>
<span class="Comment">&gt;</span>&nbsp;thisBit&nbsp;(<span class="Constant">False</span><span class="Statement">:</span>bs)&nbsp;(Bs&nbsp;X&nbsp;o)&nbsp;<span class="Statement">=</span>&nbsp;(<span class="Constant">True</span>,&nbsp;Bs&nbsp;(treeWithFinal1&nbsp;bs)&nbsp;o)&nbsp;<span class="Comment">-- last bit must be 1</span><br>
<span class="Comment">&gt;</span>&nbsp;thisBit&nbsp;(<span class="Constant">False</span><span class="Statement">:</span>bs)&nbsp;(Bs&nbsp;z&nbsp;o)&nbsp;<span class="Statement">=</span>&nbsp;(<span class="Identifier">id</span>&nbsp;<span class="Statement">***</span>&nbsp;<span class="Identifier">flip</span>&nbsp;Bs&nbsp;o)&nbsp;(thisBit&nbsp;bs&nbsp;z)<br>
<br></div></p>
<p>&#8230;a One bit,</p>
<p><div class="vimblock"><br>
<span class="Comment">&gt;</span>&nbsp;thisBit&nbsp;(<span class="Constant">True</span><span class="Statement">:</span>bs)&nbsp;(Bs&nbsp;z&nbsp;X)&nbsp;<span class="Statement">=</span>&nbsp;(<span class="Constant">True</span>,&nbsp;Bs&nbsp;z&nbsp;(treeWithFinal1&nbsp;bs))&nbsp;<br>
<span class="Comment">&gt;</span>&nbsp;thisBit&nbsp;(<span class="Constant">True</span><span class="Statement">:</span>bs)&nbsp;(Bs&nbsp;z&nbsp;o)&nbsp;<span class="Statement">=</span>&nbsp;(<span class="Identifier">id</span>&nbsp;<span class="Statement">***</span>&nbsp;Bs&nbsp;z)&nbsp;(thisBit&nbsp;bs&nbsp;o)<br>
<br></div></p>
<p>&#8230;or else propose a One for the last bit:</p>
<p><div class="vimblock"><br>
<span class="Comment">&gt;</span>&nbsp;thisBit&nbsp;[]&nbsp;(Bs&nbsp;_&nbsp;o)&nbsp;<span class="Statement">=</span>&nbsp;(b&nbsp;,&nbsp;(Bs&nbsp;z&nbsp;B))&nbsp;<br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- we know that if the One bit has been seen (B) then we must</span><br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- place a zero. we assume then that the Zero bit is (X):</span><br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp; <span class="Type">where</span>&nbsp;(b,&nbsp;z)&nbsp;<span class="Statement">=</span>&nbsp;<span class="Statement">case</span>&nbsp;o&nbsp;<span class="Statement">of</span>&nbsp;<br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- this bit = 1, Zero branch = nil</span><br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; X&nbsp;<span class="Statement">-&gt;</span>&nbsp;(<span class="Constant">True</span>,&nbsp;&nbsp;X)&nbsp;<span class="Comment">-- 1</span><br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Comment">-- this bit = 0, Zero branch = last word bit</span><br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; _&nbsp;<span class="Statement">-&gt;</span>&nbsp;(<span class="Constant">False</span>,&nbsp;B)&nbsp;<span class="Comment">-- 0</span><br>
<br>
<br></div></p>
<h3>TEST FUNCTIONS:</h3>
<p>&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;&#8212;-</p>
<p>This code is copied from the previous post:</p>
<p>We use Bool for bits, where False ==> 0, True ==> 1:</p>
<p><div class="vimblock"><br>
<span class="Comment">&gt;</span>&nbsp;<span class="Type">type</span>&nbsp;Bit&nbsp;<span class="Statement">=</span>&nbsp;<span class="Type">Bool</span><br>
<br></div></p>
<p>Our garage-door lock model for testing the function:</p>
<p><div class="vimblock"><br>
<span class="Comment">&gt;</span>&nbsp;<span class="Type">type</span>&nbsp;Combo&nbsp;&nbsp;&nbsp;&nbsp;<span class="Statement">=</span>&nbsp;[&nbsp;Bit&nbsp;]<br>
<span class="Comment">&gt;</span>&nbsp;<span class="Type">type</span>&nbsp;Receiver&nbsp;<span class="Statement">=</span>&nbsp;Combo&nbsp;<span class="Statement">-&gt;</span>&nbsp;<span class="Type">Bool</span><br>
<br></div></p>
<p>True means access granted:</p>
<p><div class="vimblock"><br>
<span class="Comment">&gt;</span>&nbsp;programReceiver&nbsp;<span class="Statement">::</span>&nbsp;Combo&nbsp;<span class="Statement">-&gt;</span>&nbsp;Receiver<br>
<span class="Comment">&gt;</span>&nbsp;programReceiver&nbsp;<span class="Statement">=</span>&nbsp;isInfixOf&nbsp;<br>
<br></div></p>
<p>Test out our function:</p>
<p><div class="vimblock"><br>
<span class="Comment">&gt;</span>&nbsp;main&nbsp;<span class="Statement">=</span>&nbsp;&nbsp;<span class="Statement">let</span>&nbsp;secretCode&nbsp;<span class="Statement">=</span>&nbsp;[<span class="Constant">True</span>,<span class="Constant">True</span>,<span class="Constant">False</span>,<span class="Constant">False</span>,<span class="Constant">True</span>,<br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Constant">False</span>,<span class="Constant">True</span>,<span class="Constant">False</span>,<span class="Constant">True</span>,<span class="Constant">True</span>]<br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; receiver&nbsp;<span class="Statement">=</span>&nbsp;programReceiver&nbsp;secretCode<br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; crackingStream&nbsp;<span class="Statement">=</span>&nbsp;preferOneV2&nbsp;<span class="Constant">10</span><br>
<span class="Comment">&gt;</span><br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<span class="Statement">in</span>&nbsp;<span class="Statement">if</span>&nbsp;receiver&nbsp;crackingStream<br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Statement">then</span>&nbsp;<span class="Identifier">print</span>&nbsp;<span class="Constant">&quot;WE'RE IN!&quot;</span><br>
<span class="Comment">&gt;</span>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <span class="Statement">else</span>&nbsp;<span class="Identifier">print</span>&nbsp;<span class="Constant">&quot;...bugs&quot;</span><br>
<span class="Comment">&gt;</span><br>
<br></div></p>
<p>Stay tuned for one more post on these algorithms.</p>
]]></content:encoded>
			<wfw:commentRss>http://coder.bsimmons.name/blog/2009/09/cracking-a-lock-in-haskell-with-the-de-bruijn-sequence-pt-2/feed/</wfw:commentRss>
		<slash:comments>2</slash:comments>
		</item>
	</channel>
</rss>
