Paths in a rectangular 
integer lattice

by Jaime Rangel-Mondragón

Facultad de Informática 
(Faculty of Computer Science)
Universidad Autónoma de Querétaro
(Autonomous University of Querétaro)
Division of Postgraduate Studies  

jrangel@sunserver.uaq.mx

Copyright ©1999, UAQ, Facultad de Informática

Off[General::spell];

\(\(path[w_] := 
      Module[{p = Join[{0}, w], i}, 
		
        Do[
			
          p[[i + 1]] = 
            p[[i]] + 
              p[[i + 1]], {i, 
            Length[w]}]; 
		p]		\)\)

For example:

path[{h, h, v, -h}]

manhattan[a_, b_] := Abs[b - a]  /.  {h -> 1, v -> 1}

For example:

manhattan[h + 2  v, 4  h + 7  v]

previousEdge[{___, a_, b_, a_}] := TruepreviousEdge[{___, a_ , b_, ___, a_, b_}] := True previousEdge[{___, a_ , b_, ___, b_, a_}] := True

For example:

previousEdge[path[{h, h, v, v, -h, -h, -v, -v, h}]]

previousEdge[path[{h, h, v, v, h, -h}]]

previousEdge[path[{h, v, h, v, -h, -v}]]

\(numIntersections[p_] := 
      Module[{u = p}, 
	\ \ \ 
        u = u //. \ {a___, b_, c__, b_, d___} -> {a, c, d}; 
	\ 
        \((Length[p] - Length[u])\)/2]\)

Examples:

numIntersections[
      path[{h, h, h, v, v, v, -h, -h, -v, -v, h, h, h, v, 
          -h, -h, -h, -h, v, v, h, h, -v, -v, -v, 
          -v, -v}]]

numIntersections[path[{h, v, h, v, -h, -v, -v}]]

\(candidates[start_, {}, _, n_, m_, _, _] := 
      Module[{ans = {}, a, b}, 

        		{a, b} = {Coefficient[start, h], Coefficient[start, v]}; 
		
        If[a > 0, \ AppendTo[ans, \(-h\)]]; 
		
        If[a < n, \ AppendTo[ans, h]]; 
		
        If[b > 0, \ AppendTo[ans, \(-v\)]]; 
		
        If[b < m, \ AppendTo[ans, v]]; 
		ans]
\)\(candidates[start_, w_, goal_, _, _, _, maxLen_] := {}\  /; \ 
        Length[w] + \ manhattan[start + Plus@@w, \ goal] > maxLen
\)\(candidates[start_, w_, goal_, n_, m_, nI_, _] := 
      Module[{s, vP, hP, p = path[w], path1, path2, path3, path4, 
          exclude = {}}, 
	
		s = start + Plus@@w; 
		
        If[s == goal, \ Return[{}]]; 
		
		vP = Coefficient[s, v]; \ 

        		hP = Coefficient[s, h]; 

		path1 = Join[p, {Last[p] + v}]; 

        		path2 = Join[p, {Last[p] - v}]; 
		
        path3 = Join[p, {Last[p] + h}]; 
		path4 = Join[p, {Last[p] - h}]; 
        

		If[
          vP == m\  || \ previousEdge[path1]\  || \ 
			
            numIntersections[path1] > nI, AppendTo[exclude, v]]\ ; 
		

        		If[vP == 0\  || \ previousEdge[path2]\  || \ 
			
            numIntersections[path2] > nI, AppendTo[exclude, \(-v\)]]\ ; 

        			
		
        If[hP == n\  || \ previousEdge[path3]\  || \ 
			
            numIntersections[path3] > nI, AppendTo[exclude, h]]\ ; 
			

        		If[hP == 0\  || \ previousEdge[path4]\  || \ 
			
            numIntersections[path4] > nI, AppendTo[exclude, \(-h\)]]\ ; 

	
        Complement[{v, \(-v\), h, \(-h\)}, exclude]]\)

For example:

candidates[0, {h, h, v}, 2  h + 2  v, 2, 2, 0, 4]

candidates[0, {h, h, v, -h}, 3  h + 3  v, 3, 3, 1, 8]

candidates[h + v, {h, h, v, -h}, 2  h + 2  v, 3, 3, 1, 5]

candidates[0, {h, h, v, -h}, 3  h + 3  v, 3, 3, 1, 6]

\(traverse[start_, goal_, n_, m_, nI_, maxLen_] := 
      traverse[start, {}, goal, n, m, nI, maxLen]
\)\(traverse[start_, w_, goal_, _, _, _, _] := {w}\  /; \ 
        start + Plus@@w == goal
\)\(traverse[start_, w_, goal_, n_, m_, nI_, maxLen_] := 
      Module[{c = candidates[start, w, goal, n, m, nI, maxLen], ans = {}, 
          sol}, 
		
        If[c ≠ {}, 
			sol = Map[Append[w, #]&, c]; 
			
          Map[AppendTo[ans, traverse[start, #, goal, n, m, nI, maxLen]]&, 
            sol]]; 
		\ Flatten[ans, 1]]\)

For example:

traverse[0, 2  h + 2  v, 2, 2, 0, 8]

traverse[0, 2  h + 2  v, 2, 2, 0, 4]

Length[traverse[0, 3  h + 3  v, 3, 3, 0, 20]]

\(grid[n_, m_] := 
      Module[{i}, 

        		{Dashing[{0.01}], RGBColor[0, 0.5, 0.5], 
          Join[Table[Line[{{i, 0}, {i, m}}], {i, 0, n}], 
            Table[Line[{{0, i}, {n, i}}], {i, 0, m}]]}]
\)\(showPath[p_, n_, m_] := 
      Module[{g = grid[n, m]}, 
		{g, {Thickness[0.1], Line[p]}}]\)

For example:

Show[Graphics[grid[3, 2]]];

\(x = showPath[{{0, 0}, {1, 0}, {2, 0}, {2, 1}}, 3, 2]; 

    Show[Graphics[x]]; \)

\(computePaths[start_, goal_, n_, m_, nI_, maxLen_] := 
      Module[{p, ans = {}, s, 
          p0 = {Coefficient[start, h], Coefficient[start, v]}}, 
		
        Map[
			
          \((p = p0; 
			s = {p}; 
			
              Map[
				
                \((p = p + 
                        Switch[#, 
									v, {0, 1}, 

                          									\(-v\), {0, \(-1\)}, 

                          									h, {1, 0}, 
									
                          \(-h\), {\(-1\), 0}]; 
				AppendTo[s, p])
                    \)&, #]; 
			AppendTo[ans, s])\)&, 
          traverse[start, goal, n, m, nI, maxLen]]; 
		ans]

\)\(showAllPaths[start_, goal_, n_, m_, nI_, maxLen_] := 
      Module[{g, l, i, sP = computePaths[start, goal, n, m, nI, maxLen]}, 

        		l = Mod[Length[sP], 10]; 
		
        g = Map[Show[Graphics[showPath[#, n, m]], AspectRatio -> 1, 
                DisplayFunction -> Identity]&, sP]; \ 
		
        If[l > 0, 
			
          Do[AppendTo[g, 
              Show[Graphics[Point[{0, 0}]], 
                DisplayFunction -> Identity]], {i, 10 - l}]]; 
		
        Show[GraphicsArray[Partition[g, 10]]]]\)

showAllPaths[0, 2  h + 2  v, 2, 2, 0, 8];

showAllPaths[0, 2  h + 2  v, 2, 2, 2, 8];

showAllPaths[0, 2  h, 2, 2, 2, 8];

showAllPaths[0, 2  v, 2, 2, 2, 8];

showAllPaths[0, h, 2, 2, 2, 8];

showAllPaths[0, h + v, 2, 2, 0, 8];

showAllPaths[h + v, 0, 2, 2, 0, 8];

showAllPaths[0, h + v, 3, 3, 1, 20];

showAllPaths[h + v, 2  h + 2  v, 3, 2, 1, 20];

showAllPaths[0, 3  h + 3  v, 3, 3, 20, 6];

Table[Length[traverse[0, n h  +  n v, n, n, 0, 2 n]], {n, 5}]

Table[
      Length[traverse[0, (n - 1) h  +  n v, n, n, 0, 2 n]], {n, 5}]

\(candidates2[{}, n_, _] := {h, v}
\)\(candidates2[w_, n_, maxLen_] := {}\  /; \ 
        Length[w] + \ manhattan[Plus@@w, n\ h] > maxLen
\)\(candidates2[w_, n_, _] := 
      Module[{s, vP, hP, p = path[w], path1, path2, path3, path4, 
          exclude = {}}, 
	
		s = Plus@@w; 
		
        If[s == n\ h, \ Return[{}]]; 
				
		vP = Coefficient[s, v]; 
        \ 
		hP = Coefficient[s, h]; 

		
        path1 = Join[p, {Last[p] + v}]; 
		path2 = Join[p, {Last[p] - v}]; 
        
		path3 = Join[p, {Last[p] + h}]; 
		
        path4 = Join[p, {Last[p] - h}]; 

		
        If[vP == n\  || \ previousEdge[path1]\  || \ 
			
            numIntersections[path1] > 0, AppendTo[exclude, v]]\ ; 
		
		
        If[vP == 0\  || \ previousEdge[path2]\  || \ 
			
            numIntersections[path2] > 0, AppendTo[exclude, \(-v\)]]\ ; 
		
        
		If[
          hP == n\  || \ previousEdge[path3]\  || \ 
			
            numIntersections[path3] > 0, AppendTo[exclude, h]]\ ; 
			

        		If[hP == 0\  || \ previousEdge[path4]\  || \ 
			
            numIntersections[path4] > 0, AppendTo[exclude, \(-h\)]]\ ; 
	

        	Complement[{v, \(-v\), h, \(-h\)}, exclude]]

\)\(traverse2[n_, maxLen_] := traverse2[{}, n, maxLen]
\)\(traverse2[w_, n_, _] := {w}\  /; Plus@@w == n\ h
\)\(traverse2[w_, n_, maxLen_] := 
      Module[{c = candidates2[w, n, maxLen], ans = {}, sol}, 
		
        If[c ≠ {}, 
			sol = Map[Append[w, #]&, c]; 
			
          Map[AppendTo[ans, traverse2[#, n, maxLen]]&, sol]]; 
		\ 
        Flatten[ans, 1]]

\)\(computePaths2[n_, maxLen_] := 
      Module[{p, ans = {}, s}, 
		
        Map[
			
          \((p = {0, 0}; 
			s = {p}; 
			
              Map[
				
                \((p = p + 
                        Switch[#, 
									v, {0, 1}, 

                          									\(-v\), {0, \(-1\)}, 

                          									h, {1, 0}, 
									
                          \(-h\), {\(-1\), 0}]; 
				AppendTo[s, p])
                    \)&, #]; 
			AppendTo[ans, s])\)&, 
          traverse2[n, maxLen]]; 
		ans]
\)\(showAllPaths2[n_, maxLen_] := 
      Module[{g, l, i, sP = computePaths2[n, maxLen]}, 
		
        l = Mod[Length[sP], 10]; 
		
        g = Map[Show[Graphics[showPath[#, n, n]], AspectRatio -> 1, 
                DisplayFunction -> Identity]&, sP]; \ 
		
        If[l > 0, 
			
          Do[AppendTo[g, 
              Show[Graphics[Point[{0, 0}]], 
                DisplayFunction -> Identity]], {i, 10 - l}]]; 
		
        Show[GraphicsArray[Partition[g, 10]]]]\)

\(canonical[a_] := 
      Module[{i, j, b = a, c = Reverse[a]\  /. \ v -> \(-v\)}, 
		
        i = FromDigits[b /. \ {h -> 0, v -> 1}, 2]; 
		
        j = FromDigits[c /. \ {h -> 0, v -> 1}, 2]; 
		
        If[i ≤ j, b, c]]\)

For example:

canonical[{v, v, h, -v, h, h, -v}]

filter[setOfPaths_, n_]:=Module[{p, s1 = {}, s2},
		\(Map[\((p = path[#]; 
				
                    If[Cases[p, _ + n\ v] != {}, AppendTo[s1, #]])\)&, 
                setOfPaths]\);
		  
	s2 = Complement[s1, Cases[s1, {v, ___, h}]];
	Union[Map[canonical[#]&, s2]]]
\(computePaths3[n_, maxLen_] := 
        Module[{p, ans = {}, s}, 
		
          Map[
			
            \((p = {0, 0}; 
			s = {p}; 
			
                Map[
				
                  \((p = p + 
                          Switch[#, 
									v, {0, 1}, 

                            									\(-v\), {0, \(-1\)}, 

                            									h, {1, 0}, 
									
                            \(-h\), {\(-1\), 0}]; 
				AppendTo[s, p])
                      \)&, #]; 
			AppendTo[ans, s])\)&, 
            filter[traverse2[n, maxLen], n]]; 
		ans]\)
\(showAllPaths3[n_, maxLen_] := 
      Module[{g, l, i, sP = computePaths3[n, maxLen]}, 
		
        l = Mod[Length[sP], 10]; 
		
        g = Map[Show[Graphics[showPath[#, n, n]], AspectRatio -> 1, 
                DisplayFunction -> Identity]&, sP]; \ 
		
        If[l > 0, 
			
          Do[AppendTo[g, 
              Show[Graphics[Point[{0, 0}]], 
                DisplayFunction -> Identity]], {i, 10 - l}]]; 
		
        Show[GraphicsArray[Partition[g, 10]]]]\)

Examples:

showAllPaths3[2, 20];

showAllPaths3[3, 20];

spansAllQ[p_, n_]:=Module[{i, j, q = p  /.  {h -> {1, 0}, v -> {0, 1}}, sq = {}, 
            allSq},
		allSq = Table[{i, j}, {i, (1/2), n, 1}, {j, (1/2), n, 1}];
		Do[
			AppendTo[sq,((q[[i + 1]]+q[[i
                            ]]+(({{0, -1}, {1, 0}})).(q[[i + 1
                                    ]] - 
                                q[[i]])
                              )/2)];
			AppendTo[sq,((q[[i + 1]]+q[[i
                            ]]-(({{0, -1}, {1, 0}})).(q[[i + 1
                                    ]] - 
                                q[[i]])
                              )/2)],{i, Length[p] - 1}];
		Complement[Flatten[allSq, 1], sq] == {}]

For example:

\(u = 
      path[{h, v, \(-h\), v, h, v, h, \(-v\), h, \(-v\), \(-h\), \(-v\), h}]; 
    
spansAllQ[u, 3]\)

\(u = 
      path[{v, v, v, h, \(-v\), \(-v\), h, v, v, h, \(-v\), \(-v\), \(-v\)}]; 
    
spansAllQ[u, 3]\)

\(filter2[setOfPaths_, n_] := 
      Module[{p, s1 = {}, s2, s3}, 
		
        Map[\((p = path[#]; 
				
              If[Cases[p, _ + n\ v] != {}, AppendTo[s1, #]])\)&, setOfPaths]; 
        
	s2 = Complement[s1, Cases[s1, {v, ___, h}]]; 
		
        s3 = Select[s2, spansAllQ[path[#], n]&]; 
	
        Union[Map[canonical[#]&, s3]]]
\)\(computePaths4[n_, maxLen_] := 
      Module[{p, ans = {}, s}, 
		
        Map[
			
          \((p = {0, 0}; 
			s = {p}; 
			
              Map[
				
                \((p = p + 
                        Switch[#, 
									v, {0, 1}, 

                          									\(-v\), {0, \(-1\)}, 

                          									h, {1, 0}, 
									
                          \(-h\), {\(-1\), 0}]; 
				AppendTo[s, p])
                    \)&, #]; 
			AppendTo[ans, s])\)&, 
          filter2[traverse2[n, maxLen], n]]; 
		ans]

\)\(showAllPaths4[n_, maxLen_] := 
      Module[{g, l, i, sP = computePaths4[n, maxLen]}, 
		
        l = Mod[Length[sP], 10]; 
		
        g = Map[Show[Graphics[showPath[#, n, n]], AspectRatio -> 1, 
                DisplayFunction -> Identity]&, sP]; \ 
		
        If[l > 0, 
			
          Do[AppendTo[g, 
              Show[Graphics[Point[{0, 0}]], 
                DisplayFunction -> Identity]], {i, 10 - l}]]; 
		
        Show[GraphicsArray[Partition[g, 10]]]]\)

Examples:

showAllPaths4[2, 20];

showAllPaths4[3, 20];

showAllPaths4[4, 20];

Warning: the above computation took about 40 minutes on a 200MHz Pentium PC.

For example, the complete set of squares in a 4x4 grid is:

\(n = 4; 

    allSq = Flatten[Table[{i, j}, {i, 1\/2, n, 1}, {j, 1\/2, n, 1}], 1]\)

sqChoice[{a_, b_}]:={a+b+(({{0, -1}, {1, 0}})).(a - b),a+b-(({{0, -1}, {1, 0}})).(a - b)}/2;

Examples:

sqChoice[{{1, 0}, {1, 1}}]

sqChoice[{{1, 1}, {2, 1}}]

manhattan[a_, b_] := Plus @@ Abs[b - a]

Example:

manhattan[{5, 5}, {3, 1}]

traverseSquares[n_] := 
        Module[{allSq, i, j}, 
          allSq = Flatten[Table[{i, j}, {i, (1/2), n, 1}, {j, (1/2), n, 1}], 
              1]; traverseSquares[{{{0, 0}, {{0, 0}}}}, n, allSq]]
traverseSquares[{a___, {{n_, 0}, s_}}, n_, {}] := {a, {{n, 0}, s}} traverseSquares[{___, {x_, _}, ___, {x_, _}}, _, _] := {}traverseSquares[_, _, {}] := {} traverseSquares[{__, {p_, _}}, n_, sq_] := {}  /;  
          Length[sq] < manhattan[p, {n, 0}]
		traverseSquares[w : {a___, {{i_, j_}, s_}}, n_, sq_]:=Module[{c, ch, ans = {}, u, t},
	c = Map[{i, j} + #&, {{1, 0}, {0, 1}, {-1, 0}, {0, -1}}]
                ;
				If[{a} != {}, 
              c = Select[
                  c, # != {a}[[-1, 1
                        ]]&]];   
				ch = Map[{#, sqChoice[{{i, j}, #}]}&, c];
		     ch = Map[{First[#], Select[Last[#], MemberQ[sq, #]&]}&, ch];
		     ch = Map[
                (u = sqChoice[{{i, j}, #}]; {{#, {
                          u[[1]]}}, {#, {
                          u[[2]]}}})&, 
                c];
				ch = Map[{First[#], Select[Last[#], MemberQ[sq, #]&]}&, 
                Flatten[ch, 1]];
				c = Select[ch, Last[#] != {}&];
				
			\(If[c ≠ {}, 
						
              Map[\((u = #; 
					
                    t = traverseSquares[Append[w, u], n, 
                        Select[
                          sq, # != 
                              u[[2, 1
                                ]]&]]; 
					
                    If[t != {}, AppendTo[ans, t]])\)&, c]; 
              Flatten[ans, 1], {}]\)]

Timing[traverseSquares[2]]

Timing[traverseSquares[3]]

Timing[Length[traverseSquares[4]]]

\(showAllPaths5[n_] := 
      Module[{g, l, i, 
          sP = Partition[First\ /@\ traverseSquares[n], n\^2 + 1]}, 
		
        l = Mod[Length[sP], 10]; 
		
        g = Map[Show[Graphics[showPath[#, n, n]], AspectRatio -> 1, 
                DisplayFunction -> Identity]&, sP]; \ 
		
        If[l > 0, 
			
          Do[AppendTo[g, 
              Show[Graphics[Point[{0, 0}]], 
                DisplayFunction -> Identity]], {i, 10 - l}]]; 
		
        Show[GraphicsArray[Partition[g, 10]]]]\)

The first four cases are:

showAllPaths5[2];

showAllPaths5[3];

showAllPaths5[4];

\(t = 
      Table[
Partition[
          Partition[Partition[Flatten[traverseSquares[n]], 2], 2], 
          n\^2 + 1], {n, 2, 4}]; 
	t\  >> \ fractals\)

Clear[t]t = <<  fractals;

\(similarity[n_, A : {Ax_, Ay_}, B : {Bx_, By_}, {Cx_, Cy_}] := 
      Module[{d, t, t1, t2}, 
		
        d\  = Det[{{Ax - Bx, Ay - By}, {Cx - Bx, Cy - By}}]; 
		
        If[d < 0, t = A; {t1, t2} = \((B - A)\)/n, 
			
          t = B; {t1, t2} = \((A - B)\)/n]; 
		
        \(({{t1, \(-t2\)}, {t2, t1}}.{#1, #2} + t)\)&]\)

For example:

\(s = similarity[3, {1, 3}, {1, 1}, {2, 2}]; 
s[0, 3]\)

\(create[n_, squeleton_, skin_, depth_] := 
      Module[{i, j, s, ans = {{{0, 0}, {0, 0}}}, sq = squeleton, u, h}, 
		
        Do[
			ans = {{{0, 0}, {0, 0}}}; 
			
          Do[
			\ \ \ 
            s = similarity[n, 
                sq[[i - 1, 1]], 
                sq[[i, 1]], 
                sq[[i, 2]]]; 
				
            u = Map[Apply[s, #, 1]&, skin]; 
				
            If[u[[1, 1]] != 
                ans[[\(-1\), 1]], 

              								u = Reverse[u]; 
								
              Do[u[[h, 2]] = 
                  u[[h - 1, 2]], {h, 
                  Length[u], 2, \(-1\)}]]; 
		\ \ \ \ \ 
            ans = Join[ans, Rest[u]], 
			{i, 2, Length[sq]}]; 
				
          sq = ans, {j, depth}]; 
		sq]\)

u = t[[1, 1]] create[2, u, u, 1]

\(showFractal[n_, squeleton_, skin_, depth_] := 
      Module[{c = \ First\ /@\ create[n, squeleton, skin, depth]}, 
		
        Show[Graphics[Line[c]], AspectRatio -> 1]]\)

Example: the first four generations for the case n=1 are:

\(r = t[\([1, 1]\)]; 
Do[
	\(showFractal[2, r, r, i]; \), {i, 4}]; \)

Example: the first three generations for the case n=2 (the other case is isomorphic to this one) are:

\(r = t[\([2, 1]\)]; 
Do[
	\(showFractal[3, r, r, i]; \), {i, 3}]; \)

Example: the first two generations for each of the first seven paths corresponding to the case n=3 (the other seven cases are isomorphic to them) are:

\(\(Do[
		Print["j=", j]; 
	
      Do[
			r = t[\([3, j]\)]; 
			
        showFractal[4, r, r, i], {i, 2}], {j, 7}]; \)\)