#!/usr/bin/perl -w # # solve.pl # # # My first perl project! # As input, give it a magiccube4d log file, # or just the colors (from near the beginning of the file). # # The output is a full log file that produces that color configuration; # load it and hit "Solve" to see the solution. # # To see more of what it's thinking, give it "-v 2" on the command line. # It only works on the 3x3x3x3 puzzle. # # # Author: Don Hatch (hatch@hadron.org) # Revision history: # Mon Apr 17 17:38:00 PDT 2000 # Initial version (just before I started doing my taxes) # Wed Apr 19 03:06:00 PDT 2000 # Modified to work around bizarre ActivePerl 5.6 bug # that was causing an assertion failure # use strict; use Carp; # $verbose=0: just the output file (and prompt for input if from a tty). # $verbose=1: minimal progress diagnostics to stderr # $verbose=2: more detailed diagnostics to stderr # $verbose=3: not-very-interesting debugging stuff to stderr my $verbose = 1; #------------------------------------------------------------------------------ # General perl utilities... # # # Simple perl function to recursively expand a reference into a string. # Doesn't expand GLOB or CODE references, or class objects. # Cyclic references will produce endless recursion. # sub Stringify($) { my ($ref) = @_; my $result = ''; if (ref $ref eq 'ARRAY') { $result .= '['; $result .= join(',', map {Stringify($_)} @$ref); $result .= ']'; } elsif (ref $ref eq 'HASH') { $result .= '{'; $result .= join(',', map {Stringify($_) . '=>' . Stringify($$ref{$_})} sort(keys(%$ref))); $result .= '}'; } #elsif (ref $ref eq 'GLOB' or $ref eq 'CODE') #{ # ... for now, just printing as string such as GLOB(0x7845323) ... #} elsif (ref $ref eq 'SCALAR' or ref $ref eq 'REF') { $result .= '\\' . Stringify($$ref); # XXX probably wrong sometimes } else { local $_ = $ref; my $tick = ref $ref ? '' : /[\000-\037\177-\377]/ ? '"' : # must come first in case "5\n" /^-?(\d+(\.\d*)?|\.\d+)$/ ? '' : "'"; s/([$tick\\])/\\$1/g; if ($tick eq '"') { s/([\$\@])/\\$1/g; # From camel book p. 40... s/\n/\\n/g; s/\r/\\r/g; s/\t/\\t/g; s/\f/\\f/g; s/\010/\\b/g; # \b means something else when on LHS of s/// s/\a/\\a/g; s/\e/\\e/g; s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg; s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg; } $result .= $tick . $_ . $tick; } return $result; } # Stringify # # End of general perl utilities. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Rot utilities... # # # A rotation in the hypercube's symmetry group # can be represented by an even "signed" permutation of the four axes, # representing where +X,+Y,+Z,+W are rotated to. # (This is really just a compressed form of the integer-valued # rotation matrix.) # For example: # (+X,+Y,+Z,+W) = identity rotation # (+Y,-X,+Z,+W) = 90 degree rotation taking +X to +Y # We will represent the axes numerically as 0,1,2,3 for X,Y,Z,W, # so we can't use actual negation to represent the opposite of an axis # (since -0 = 0); so instead we use the bitwise complement of the number. # So the above examples are represented by: # (0,1,2,3) and # (1,~0,2,3) # respectively. # Evenness means that the parity (number of swaps) of the permutation # plus the number of negations must be even. # This gives (4! * 2^4) / 2 = 192 possible rotations. # # # Apply rot to coords. # We always put the rotation on the right, # so that we can compose from left to right # (I get hopelessly confused otherwise). # sub RotateCoords($$) { my ($coords,$rot) = @_; my @result; for my $fromAxis (0..4-1) { my $toAxis = $rot->[$fromAxis]; if (($toAxis>>31) != 0) # can't test $toAxis<0 since ~ makes result unsigned { $result[~$toAxis] = -$coords->[$fromAxis]; } else { $result[$toAxis] = $coords->[$fromAxis]; } } return @result; } # # Apply the inverse of a rot to coords. # InverseRotateCoords(\@coords,\@rot) # is the same as # RotateCoords(\@coords,\&InversRotation(\@rot)) # but is a bit faster since it is calculated directly. # sub InverseRotateCoords($$) { my ($coords,$rot) = @_; my @result; for my $fromAxis (0..4-1) { my $toAxis = $rot->[$fromAxis]; $result[$fromAxis] = ($toAxis>>31)!=0 ? -$coords->[~$toAxis] : $coords->[ $toAxis]; } return @result; } # # Compose rotations, such that # RotateCoords(coords,ComposeRotations(A,B)) # = RotateCoords(RotateCoords(coords,A),B)) # sub ComposeRotations($$) { my ($A,$B) = @_; my @result; for my $i (0..4-1) { my $Aaxis = $A->[$i]; $result[$i] = ($Aaxis>>31)!=0 ? ~$B->[~$Aaxis] : $B->[ $Aaxis]; } return @result; } # XXX should take any number of rotations! sub Compose3Rotations($$$) { my ($A,$B,$C) = @_; my @AB = ComposeRotations($A,$B); return ComposeRotations(\@AB,$C); } # # Compute the inverse of a rotation. # sub InverseRotation($) { my ($rot) = @_; my @invRot; for my $i (0..4-1) { my $axis = $rot->[$i]; if (($axis>>31)!=0) { $invRot[~$axis] = ~$i; } else { $invRot[$axis] = $i; } } return @invRot; } # # Compute a rotation that takes one coords to another. # This is sort of a symbolic Gaussian elimination or something. # Aborts the program on failure. # sub CalcRotThatTakesTheseToThoseCoords($$$) { my ($these,$those,$allowInsideOut) = @_; my @absThese = map {abs} @$these; my @absThose = map {abs} @$those; my @rot = (0,1,2,3); # incrementally becomes the desired rotation my @temp = @$these; # incrementally goes from these to those my $indexWhoseSignWeCanMessWith = 3; # until we find a zero entry #print "Trying to rot ", join(',',@$these), " to ", join(',',@$those), "\n"; for my $i (0..3) { #print "i = $i\n"; if ($temp[$i] != $those->[$i]) { #print " temp[$i]=$temp[$i] != those->[$i]=$those->[$i]\n"; if ($temp[$i] == -$those->[$i]) { #print " temp[$i] == -those->[$i]\n"; my $j = $indexWhoseSignWeCanMessWith; if ($j != $i) { my @incRot = (0,1,2,3); $incRot[$i] = ~$i; $incRot[$j] = ~$j; # XXX these are just sign changes, # XXX should execute them as such @rot = ComposeRotations(\@rot,\@incRot); @temp = RotateCoords(\@temp,\@incRot); } else { # $i is 3, and the sign is wrong-- this # will be fixed below. last; } } else { #print " temp[$i] != -those->[$i]\n"; for my $j ($i+1..3) { if ($temp[$j] == $those->[$i]) # magnitude and sign right { my @incRot = (0,1,2,3); $incRot[$j] = $i; $incRot[$i] = ~$j; # XXX these are just swaps and sign changes, # XXX should execute them as such @rot = ComposeRotations(\@rot,\@incRot); #print " sign right: incRot = ", RotToString(\@incRot), "\n"; @temp = RotateCoords(\@temp,\@incRot); last; } elsif ($temp[$j] == -$those->[$i]) # sign wrong { my @incRot = (0,1,2,3); $incRot[$j] = ~$i; $incRot[$i] = $j; # XXX these are just swaps and sign changes, # XXX should execute them as such #print " sign wrong: incRot = ", RotToString(\@incRot), "\n"; @rot = ComposeRotations(\@rot,\@incRot); @temp = RotateCoords(\@temp,\@incRot); last; } } } } $temp[$i] == $those->[$i] or die "No rotation taking ", join(',',@$these), " to ", join(',',@$those), "\n"; if ($those->[$i] == 0) { $indexWhoseSignWeCanMessWith = $i; } } if ($temp[3] != $those->[3] && $temp[3] == -$those->[3]) { #print " last sign wrong!\n"; my @incRot = (0,1,2,~3); @rot = ComposeRotations(\@rot,\@incRot); @temp = RotateCoords(\@temp,\@incRot); # # We just did an odd operation, # so we need to do one more to make the total even. # There are no zeros we can sign-flip, # so we need to find two entries of the same # magnitude that we can swap. # If there is no such pair, then we are inside out. # my $fixedIt = 0; OUTER: for my $i (0..3) { for my $j ($i+1..3) { if (abs($temp[$i]) == abs($temp[$j])) { my @incRot = (0,1,2,3); if ($temp[$i] == $temp[$j]) { $incRot[$i] = $j; $incRot[$j] = $i; } else { $incRot[$i] = ~$j; $incRot[$j] = ~$i; } @rot = ComposeRotations(\@rot,\@incRot); @temp = RotateCoords(\@temp,\@incRot); $fixedIt = 1; last OUTER; } } } $fixedIt or $allowInsideOut or die "Rotation taking ", join(',',@$these), " to ", join(',',@$those), " is inside out!\n"; } # # Assert that it worked... # my @thoseIHope = RotateCoords($these,\@rot); $thoseIHope[0] == $those->[0] && $thoseIHope[1] == $those->[1] && $thoseIHope[2] == $those->[2] && $thoseIHope[3] == $those->[3] or die; return @rot; } # CalcRotThatTakesTheseToThoseCoords # This is for human-readableness (for hashing, just use join(",", @rot)); sub RotToString($) { my ($rot) = @_; return join(",", map {(($_>>31)==0) ? $_ : "~".~$_} @$rot); } sub TestRotUtils($$) { my ($verbose,$allRots) = @_; my @coords = (10,100,200,300); my @someRots = ( [0,1,2,3], [1,2,0,3], [0,2,3,1], [1,~0,2,3], [0,2,~1,3], [0,1,3,~2], [~0,~1,2,3], [~0,~1,~2,~3], ); # # Composition test... # for my $i (0..@someRots-1) { for my $j (0..@someRots-1) { my @A = @{$someRots[$i]}; my @B = @{$someRots[$j]}; my @coordsA = RotateCoords(\@coords,\@A); my @AB = ComposeRotations(\@A,\@B); my @coords_AB = RotateCoords(\@coords, \@AB); my @coordsA_B = RotateCoords(\@coordsA, \@B); # Convert each array to a string... my $coords = "[" . join(",",@coords) . "]"; my $A = "[" . RotToString(\@A) . "]"; my $B = "[" . RotToString(\@B) . "]"; my $coordsA = "[" . join(",",@coordsA) . "]"; my $AB = "[" . RotToString(\@AB) . "]"; my $coords_AB = "[" . join(",",@coords_AB) . "]"; my $coordsA_B = "[" . join(",",@coordsA_B) . "]"; if ($verbose >= 3) { print "$coords * $A = $coordsA\n"; print "$A * $B = $AB\n"; print "($coords * $A) * $B = $coordsA_B\n"; print "$coords * ($A * $B) = $coords_AB\n"; print "\n"; } # Make sure the composition behaves correctly... $coords_AB eq $coordsA_B or die; }} # # Inverse test... # for my $i (0..@someRots-1) { my @rot = @{$someRots[$i]}; my @invRot = InverseRotation(\@rot); my @foo = ComposeRotations(\@rot,\@invRot); my @bar = ComposeRotations(\@invRot,\@rot); RotToString(\@foo) eq "0,1,2,3" or die; RotToString(\@bar) eq "0,1,2,3" or die; @foo = RotateCoords(\@coords,\@invRot); @bar = InverseRotateCoords(\@coords,\@rot); RotToString(\@foo) eq RotToString(\@bar) or die; @foo = RotateCoords(\@coords,\@rot); @bar = InverseRotateCoords(\@coords,\@invRot); RotToString(\@foo) eq RotToString(\@bar) or die; } # # CalcRotThatTakesTheseToThoseCoords test... # Do all rotations, not just some of them. # XXX should do lots of combinations of coords with zeros, too # $verbose >= 1 && print STDERR "Testing CalcRotThatTakesTheseToThoseCoords... "; my @moreCoords = ( [100,-200,300,-400], [0,-100,200,-300], [100,0,-200,300], [-100,200,0,-300], [100,-200,300,0], [0,0,-100,200], [0,-100,0,200], [0,-100,200,0], [-100,0,0,200], [-100,0,200,0], [-100,200,0,0], [0,0,0,-100], [0,0,100,0], [0,-100,0,0], [100,0,0,0], [0,0,0,0], [100,100,200,300], [100,100,100,300], [100,100,100,100], ); for my $coords (@moreCoords) { my @coords = @$coords; for my $rot (@$allRots) { $verbose >= 2 && print STDERR " ", RotToString($rot), ":\n"; my @those = RotateCoords(\@coords,$rot); my @rotIHope = CalcRotThatTakesTheseToThoseCoords(\@coords,\@those,0); # XXX can only do this if no zeros or dups in coords # $rot->[0] == $rotIHope[0] && # $rot->[1] == $rotIHope[1] && # $rot->[2] == $rotIHope[2] && # $rot->[3] == $rotIHope[3] or die; } } $verbose >= 1 && print STDERR "done.\n"; } # TestRotUtils # # End of rot utilities. #----------------------------------------------------------------------------- #----------------------------------------------------------------------------- # Magiccube4d cubie/sticker index/coord utilities... # # # Faces are numbered as follows: # 0: In -W # 1: Back (right) -Z # 2: Down -Y # 3: Left (back) -X # 4: Right (front) +X # 5: Up +Y # 6: Front (left) +Z # 7: Out +W sub AxisAndSignToFaceIndex($$) { my ($axis,$sign) = @_; return $sign==1 ? 4 + $axis : $sign==-1 ? 3 - $axis : die; } sub FaceIndexToAxisAndSign($) { my ($face) = @_; return $face>=4 ? ($face-4,1) : (3-$face,-1); } # # canonicalFaceRots[$face] is the canonical rotation # mapping stickers on face 0 to the stickers with same relative # indices on $face. # my @canonicalFaceRots = ( [0,1,2,3], # takes face 0 (-W) to face 0 (-W) [0,1,~3,2], # takes face 0 (-W) to face 1 (-Z) [0,~3,2,1], # takes face 0 (-W) to face 2 (-Y) [~3,1,2,0], # takes face 0 (-W) to face 3 (-X) [3,1,2,~0], # takes face 0 (-W) to face 4 (+X) [0,3,2,~1], # takes face 0 (-W) to face 5 (+Y) [0,1,3,~2], # takes face 0 (-W) to face 6 (+Z) [0,1,~2,~3], # takes face 0 (-W) to face 7 (+W), by moving it through Z ); # # Decompose a sticker index or cubie index # into ($face,$i,$j,$k) or ($i,$j,$k,$l) respectively. # sub DecomposeIndex($$) { my ($puzzlesize,$index) = @_; use integer; # use integer division in this function my $l = $index % $puzzlesize; my $k = ($index /= $puzzlesize) % $puzzlesize; my $j = ($index /= $puzzlesize) % $puzzlesize; my $i = $index / $puzzlesize; # note, may be >= 3 if it's a face index return ($i,$j,$k,$l); } # # Reverse the above operation. # sub ComposeIndex($$$$$) { my ($puzzlesize,$face,$i,$j,$k) = @_; return ((($face * $puzzlesize + $i) * $puzzlesize + $j) * $puzzlesize + $k); } # # The puzzle is centered at the origin and has a physical width # of 2*$puzzlesize; e.g. the width of the 3x3x3x3 puzzle is 6. # (This allows all cubie centers and sticker centers to be # expressed in integer coords.) # sub StickerToCoords($$) { my ($puzzlesize,$sticker) = @_; my ($face,$i,$j,$k) = DecomposeIndex($puzzlesize,$sticker); # Find coords of analogous sticker on face 0... my @face0coords = ($k*2 - ($puzzlesize-1), $j*2 - ($puzzlesize-1), $i*2 - ($puzzlesize-1), -$puzzlesize); # Canonically rotate face 0 to $face... return RotateCoords(\@face0coords,$canonicalFaceRots[$face]); } sub CoordsToSticker($$) { my ($puzzlesize,$coords) = @_; my ($x,$y,$z,$w) = @$coords; my ($ax,$sign) = (abs($x)==$puzzlesize ? (0,$x<=>0) : abs($y)==$puzzlesize ? (1,$y<=>0) : abs($z)==$puzzlesize ? (2,$z<=>0) : abs($w)==$puzzlesize ? (3,$w<=>0) : die "bad sticker coords $x,$y,$z,$w for puzzle size $puzzlesize"); my $face = AxisAndSignToFaceIndex($ax,$sign); # Canonically rotate $face to face 0... ($x,$y,$z,$w) = InverseRotateCoords($coords, $canonicalFaceRots[$face]); $w == -$puzzlesize or die; use integer; # integer divide my ($i,$j,$k) = map {($_+($puzzlesize-1))/2} ($z,$y,$x); # reversed! return ComposeIndex($puzzlesize,$face,$i,$j,$k); } sub CubieToCoords($$) { my ($puzzlesize,$cubie) = @_; my ($i,$j,$k,$l) = DecomposeIndex($puzzlesize,$cubie); my ($x,$y,$z,$w) = map {$_*2-($puzzlesize-1)} ($l,$k,$j,$i); # reversed return [$x,$y,$z,$w]; } sub CoordsToCubie($$) { my ($puzzlesize,$coords) = @_; my ($x,$y,$z,$w) = @$coords; use integer; # integer divide my ($i,$j,$k,$l) = map {($_+($puzzlesize-1))/2} ($w,$z,$y,$x); # reversed return ComposeIndex($puzzlesize,$i,$j,$k,$l); } sub Clamp($$$) { my ($x,$a,$b) = @_; return $x < $a ? $a : $x > $b ? $b : $x; } sub Dot($$) { my ($A,$B) = @_; my $sum = 0; for my $i (0..@$A-1) # A and B must be same size { $sum += $A->[$i]*$B->[$i]; } return $sum; } sub StickerCoordsToCubieCoords($$) { my ($puzzlesize,$stickerCoords) = @_; return map {Clamp($_,-($puzzlesize-1),$puzzlesize-1)} @$stickerCoords; } # XXX slow, should not exist (should be an array!) sub CalcStickerToCubie($$) { my ($puzzlesize,$sticker) = @_; my @stickerCoords = StickerToCoords($puzzlesize,$sticker); my @cubieCoords = StickerCoordsToCubieCoords($puzzlesize,\@stickerCoords); return CoordsToCubie($puzzlesize,\@cubieCoords); } # # For the 3x3x3x3 puzzle, a rotation "handle" is the same as a sticker; # it signifies a twist of 90, 120, or 180 degrees CCW about the axis # through the sticker and the hyperface center. # For other size puzzles, a handle is a sticker of an imaginary 3x3x3x3 # puzzle superimposed on the puzzle. So handles are always in the # range 0..8*3*3*3-1 regardless of the puzzle size. # sub CalcHandleToRot($) { my ($handle) = @_; my @handleCoords = StickerToCoords(3,$handle); my @absHandleCoords = map {abs} @handleCoords; my @canonicalHandleCoords = ( [2,2,2,-3], # corner handle Ofru [0,2,2,-3], # edge handle Ofu [0,0,2,-3], # face handle Of ); my @canonicalHandleRots = ( [1,2,0,3], # 120 degree rotation +X -> +Y -> +Z [~0,2,1,3], # 180 degree rotation +Y <-> +Z, +X <-> -X [1,~0,2,3], # 90 degree rotation +X -> +Y -> -X -> -Y ); my $handleType = (abs($handleCoords[0])==0) + (abs($handleCoords[1])==0) + (abs($handleCoords[2])==0) + (abs($handleCoords[3])==0); my @rot = CalcRotThatTakesTheseToThoseCoords(\@handleCoords, $canonicalHandleCoords[$handleType],0); my @invRot = InverseRotation(\@rot); return Compose3Rotations(\@rot, $canonicalHandleRots[$handleType], \@invRot); } # XXX this is slow and should only be used for calculating tables # XXX at initialization time. sub CalcRotToStickerPerm($$) { my ($puzzlesize,$rot) = @_; my $nStickers = 8*$puzzlesize*$puzzlesize*$puzzlesize; my @result; for my $fromSticker (0..$nStickers-1) { my @fromCoords = StickerToCoords($puzzlesize,$fromSticker); my @toCoords = RotateCoords(\@fromCoords,$rot); my $toSticker = CoordsToSticker($puzzlesize,\@toCoords); $result[$toSticker] = $fromSticker; } return \@result; } # XXX really need to work out how much of this should be cached # XXX in a table... sub CalcMoveToStickerPerm($$$) { my ($puzzlesize,$handle,$slicesmask) = @_; my @rot = CalcHandleToRot($handle); if ((((1<<$puzzlesize)-1) & ~$slicesmask) == 0) { return CalcRotToStickerPerm($puzzlesize,\@rot); # all slices } my $nStickers = 8*$puzzlesize*$puzzlesize*$puzzlesize; if ((((1<<$puzzlesize)-1) & $slicesmask) == 0) { return (0..$nStickers-1); # no slices } my $face = int $handle/27; my ($faceAxis,$faceSign) = FaceIndexToAxisAndSign($face); my @towardsFaceUnitVector = ($faceSign * ($faceAxis==0), $faceSign * ($faceAxis==1), $faceSign * ($faceAxis==2), $faceSign * ($faceAxis==3)); my @result; # XXX would it be faster to initialize to size $nStickers? for my $fromSticker (0..$nStickers-1) { my @fromCoords = StickerToCoords($puzzlesize,$fromSticker); my @cubieCoords = StickerCoordsToCubieCoords($puzzlesize, \@fromCoords); my $cubieCoordAlongAxisOfFace = Dot(\@cubieCoords, \@towardsFaceUnitVector); my $sliceContainingSticker = int ($puzzlesize-1 - $cubieCoordAlongAxisOfFace) / 2; if ($slicesmask & (1 << $sliceContainingSticker)) { # XXX should look up the full rot sticker perm in a table # XXX instead of doing this over and over my @toCoords = RotateCoords(\@fromCoords,\@rot); my $toSticker = CoordsToSticker($puzzlesize,\@toCoords); $result[$toSticker] = $fromSticker; } else # this sticker doesn't move { $result[$fromSticker] = $fromSticker; } } return \@result; } # CalcMoveToStickerPerm sub CalcSequenceToStickerPerm($$) { my ($puzzlesize,$seq) = @_; my $nStickers = 8*$puzzlesize*$puzzlesize*$puzzlesize; my @perm = (0..$nStickers-1); # identity permutation for my $move (@$seq) { my ($handle,$slicesmask) = @$move; my $incPerm = CalcMoveToStickerPerm($puzzlesize,$handle,$slicesmask); @perm = Permute(\@perm,$incPerm); } return \@perm; } sub CalcStickerPermToCubiePerm($$) { my ($puzzlesize,$stickerPerm) = @_; #print STDERR "CalcStickerPermToCubiePerm called on @$stickerPerm\n"; my $nStickers = 8*$puzzlesize*$puzzlesize*$puzzlesize; my $nCubies = $puzzlesize*$puzzlesize*$puzzlesize*$puzzlesize; my @cubiePerm = (0..$nCubies-1); # must at least init center # XXX should iterate over cubies instead of stickers, it would be faster for my $dstSticker (0..$nStickers-1) { my $srcSticker = $stickerPerm->[$dstSticker]; # XXX should look these up in arrays! my $srcCubie = CalcStickerToCubie($puzzlesize,$srcSticker); my $dstCubie = CalcStickerToCubie($puzzlesize,$dstSticker); $cubiePerm[$dstCubie] = $srcCubie; } #print STDERR "CalcStickerPermToCubiePerm returning @cubiePerm\n"; return @cubiePerm; } # # End of magiccube4d cubie/sticker index/coord utilities. #----------------------------------------------------------------------------- #----------------------------------------------------------------------------- # Utilities for i/o of stickers, moves, and stuff. # # # Print a sequence of moves (each move is a pair [handle, slicesmask]) # in the format that the magiccube4d log file reader expects. # sub PrintSequenceForLogFile($@) { my ($puzzlesize,@seq) = @_; my $i = 0; for my $move (@seq) { my $handle = $move->[0]; my $slicesmask = $move->[1]; print int $handle/27, $handle%27; print ":$slicesmask" if $slicesmask != 1; $i++; print $i == @seq ? "" : $i % 10 == 0 ? "\n" : " "; } print ".\n"; } sub HandleToString($) { my ($handle) = @_; my @coords = StickerToCoords(3,$handle); my $string = ""; for my $i (0..4-1) { if (abs($coords[$i]) == 3) { $string .= substr(($coords[$i]<0 ? "LDBO" : "RUFX"), $i, 1); } } for my $i (0..4-1) { if (abs($coords[$i]) == 2) { $string .= substr(($coords[$i]<0 ? "ldbo" : "rufx"), $i, 1); } } return $string; } sub StringToHandle($) { my ($string) = @_; my $rest = $string; my @coords = (0,0,0,0); for my $letter (split('', $string)) { my ($face,$amount); if (($face = index("OBDLRUFX", $letter)) >= 0) { # A face specification (upper case letter) # pulls the coordinate 3 units in that direction. $amount = 3; } elsif (($face = index("obdlrufx", $letter)) >= 0) { # A subface specifier (lower case letter) # pulls the coordinate 2 units in that direction. $amount = 2; } else { die "Unknown letter '$letter' in handle string '$string'"; } my ($axis,$sign) = FaceIndexToAxisAndSign($face); $coords[$axis] == 0 or die "Dup letter or direction '$letter' in handle string '$string'"; $coords[$axis] = $sign * $amount; } return CoordsToSticker(3,\@coords); } sub StringToMove($) { my ($string) = @_; my @splitString = split(':',$string); @splitString == 1 || @splitString == 2 or die "Bad move string '$string'\n"; my $handleString = $splitString[0]; my $slicesmask = (@splitString==2 ? 0+$splitString[1] # force numeric : 1); my $handle = StringToHandle($handleString); return ($handle,$slicesmask); } sub StringToMoveSequence($) { my ($string) = @_; my @moveStrings = split(/[\s,;!]+/, $string); # ",;!" treated as space return map {[StringToMove($_)]} @moveStrings; } sub MoveSequenceToString($) { my ($seq) = @_; my $string = ""; for my $move (@$seq) { my ($handle,$slicesmask) = @$move; $string .= " " . HandleToString($handle); if ($slicesmask != 1) { $string .= ":$slicesmask"; } } return $string; } # # End utilities for i/o of stickers, moves, and stuff. #----------------------------------------------------------------------------- #----------------------------------------------------------------------------- # Rot-related constant arrays, and utilities that make use of them # my $nRots; my @allRots; my %allRotsStringToIndex; # reverse lookup from join(' ',\@rot) to index my @allRotsFactored; # how each was obtained from 2 previous rots my @allRotsInvTable; # XXX not sure I need this my @allRotsMultTable; # XXX hmm, not sure I need this, and it's really slow my @rotHandleToIndex; # rot of sticker on 3x3x3x3 puzzle XXX init or remove! my @allRotsMoveSequences; # 0,1,or 2 moves accomplishing each rot sub InitConstantRotArrays() { $verbose >= 1 && print STDERR "Calculating all rots... "; { my @gens = ([1,~0,2,3], [0,2,~1,3], [0,1,3,~2]); @allRots = ([0,1,2,3]); # start with just identity %allRotsStringToIndex = ("0 1 2 3" => 0); @allRotsFactored = ([0,0]); $nRots = 1; for (my $i = 0; $i < $nRots; $i++) # while $nRots is increasing { for my $iGen (0..@gens-1) { my $gen = $gens[$iGen]; my @newRot = ComposeRotations($allRots[$i],$gen); my $newRotString = join(' ',@newRot); if (! exists $allRotsStringToIndex{$newRotString}) { $allRots[$nRots] = \@newRot; $allRotsStringToIndex{$newRotString} = $nRots; $allRotsFactored[$nRots] = [$i,$iGen+1]; $nRots++; } } } $nRots == 192 or die; } $verbose >= 1 && print STDERR "$nRots rots.\n"; $verbose >= 1 && print STDERR "Making rot inv table... "; my @table = (); for my $i (0..$nRots-1) { my $rot = $allRots[$i]; my @invRot = InverseRotation($rot); $allRotsInvTable[$i] = $allRotsStringToIndex{join(' ',@invRot)}; } $verbose >= 1 && print STDERR "done.\n"; if (0) { $verbose >= 1 && print STDERR "Making rot multiplication table... "; for my $i (0..$nRots-1) { my $iRot = $allRots[$i]; for my $j (0..$nRots-1) { my $jRot = $allRots[$j]; my @rot = ComposeRotations($iRot,$jRot); $allRotsMultTable[$i][$j] = $allRotsStringToIndex{join(' ',@rot)}; } $verbose >= 1 && print STDERR "."; } $verbose >= 1 && print STDERR "done.\n"; } $verbose >= 1 && print STDERR "Finding move sequences accomplishing each rot... "; { # XXX for now, get easy sequences consisting of # XXX just the three generator rotations. # XXX This is bad and time-wasting because it # XXX produces sequences of length up to 10-- # XXX using more general moves, it's possible # XXX to express every rotation in at most 2 moves. # XXX Note, this is just a waste of time but it doesn't # XXX affect the final solution length, # XXX since we squeeze out all rotations at the end anyway. @allRotsMoveSequences = ( [], # empty sequence gives identity [[StringToHandle("Of"),-1]], # move corresponding to first gen [[StringToHandle("Or"),-1]], # move corresponding to 2nd gen [[StringToHandle("Ru"),-1]], # move corresponding to 3rd gen ); for my $i (4..$nRots-1) { my ($LHS,$RHS) = @{$allRotsFactored[$i]}; my @seq = @{$allRotsMoveSequences[$LHS]}; push @seq, @{$allRotsMoveSequences[$RHS]}; $allRotsMoveSequences[$i] = \@seq; } if ($verbose >= 3) { for my $i (0..$nRots-1) { print "$i: ", RotToString($allRots[$i]), " = ", MoveSequenceToString($allRotsMoveSequences[$i]), "\n"; } } } $verbose >= 1 && print STDERR "done.\n"; $verbose >= 1 && print STDERR "Calculating rotation for each handle... "; { for my $handle (0..8*3*3*3-1) { $handle % (3*3*3) == 13 and next; # don't do center sticker my @rot = CalcHandleToRot($handle); $rotHandleToIndex[$handle] = $allRotsStringToIndex{join(' ',@rot)}; } } $verbose >= 1 && print STDERR "done.\n"; } # InitConstantRotArrays # Returns an index into @allRots, and the number of matches. # These and those should be equal-sized arrays of coords. sub FindRotThatTakesAsManyOfTheseToThoseCoordsAsPossibleInOrder($$) { my ($these,$those) = @_; my $nThese = @$these; my $nThose = @$those; $nThese == $nThose or croak; my $bestRotIndex = -1; my $bestNumMatches = -1; for my $iRot (0..$nRots-1) { my $rot = $allRots[$iRot]; my $numMatches = 0; for my $i (0..$nThese-1) { my @rotatedThesei = RotateCoords($these->[$i],$rot); my $thosei = $those->[$i]; if ($rotatedThesei[0] == $thosei->[0] && $rotatedThesei[1] == $thosei->[1] && $rotatedThesei[2] == $thosei->[2] && $rotatedThesei[3] == $thosei->[3]) { $numMatches++; } else { last; } } if ($numMatches > $bestNumMatches) { ($bestRotIndex,$bestNumMatches) = ($iRot,$numMatches); last if $bestNumMatches == $nThese; } } return ($bestRotIndex,$bestNumMatches); } # FindRotThatTakesAsManyOfTheseToThoseCoordsAsPossibleInOrder # # End of rot-related constant arrays and utilities that make use of them. #----------------------------------------------------------------------------- #----------------------------------------------------------------------------- # Abstract permutation stuff... # # XXX clever perlism to do this in one line? sub IsIdentityPerm($$) { my ($n,$perm) = @_; for my $i (0..$n-1) { $perm->[$i] == $i or return 0; } return 1; } # Returns the inverse of a lookup table (for instance a permutation) # as an array. # The input should be 1-to-1 (but not necessarily onto); # if it is not onto, the resulting array will be sparse (some elements # undefined), so if you print the resulting array # you'll get "use of uninitialized value" # errors. sub InverseLUT($) { my ($perm) = @_; #print "Inverting this perm: @$perm\n"; my @invPerm; for my $i (0..@$perm-1) { $invPerm[$perm->[$i]] = $i; } #print "Result is: @invPerm\n"; return @invPerm; } # Apply a position swap to a permutation and the inverse permutation array. sub _ApplySwapToPermAndInversePerm($$$$) { my ($i,$j,$perm,$invPerm) = @_; ($perm->[$i],$perm->[$j]) = ($perm->[$j],$perm->[$i]); $invPerm->[$perm->[$i]] = $i; $invPerm->[$perm->[$j]] = $j; } # # Return an array of position swaps # that undoes a given permutation. # $nSwapsPerStep must be 1 or 2. # If it's 2, the swaps are done in non-intersecting pairs, # i.e. (i0<->i1),(i2<->i3) # such that {i0,i1} intersect {i2,i3} is empty. # sub SolvePermInTermsOfSwaps($@) { my ($nSwapsPerStep,@perm) = @_; my $n = @perm; $verbose >= 2 && print STDERR "SolvePermInTermsOfSwaps(nSwapsPerStep=$nSwapsPerStep) called on @perm\n"; $nSwapsPerStep == 1 or $nSwapsPerStep == 2 or die; # can only handle 1 or 2 $n >= 6 or die; # helper logic uses item 5 my @invPerm = InverseLUT(\@perm); my @solution = (); for my $i0 (0..$n-1) { my $i1 = $invPerm[$i0]; # current position of item that's supposed to go in slot $i0 $i1 != $i0 or next; $i1 > $i0 or die; if ($nSwapsPerStep == 1) { push @solution, [$i0, $i1]; #print "Before swapping $i0,$i1:\n\t perm=@perm\n\tinvPerm=@invPerm\n"; _ApplySwapToPermAndInversePerm($i0,$i1,\@perm,\@invPerm); #print "After swapping $i0,$i1:\n\t perm=@perm\n\tinvPerm=@invPerm\n"; } else # $nSwapsPerStep == 2 { # # Find a "helper" pair $i2,$i3 to swap... # my ($i2,$i3); # First choice is a pair that wants to be swapped anyway... my $foundAGoodPair = 0; for my $i2maybe ($i0+1..$n-1) { $i2 = $i2maybe; # strange, $i2 doesn't persist if used as loop var $i2 != $i1 or next; $i3 = $invPerm[$i2]; # current positon of item that's supposed to go in slot $i2 $i3 != $i1 or die; # logical impossibility $i3 != $i0 or next; $i3 != $i2 or next; $foundAGoodPair = 1; last; } # If there was no such pair, then just use # a semi-arbitrary pair: # If $i0 >= 2 (which is most of the time), # we just use (0,1); they will get swapped back # during some later iteration (assuming the original # permutation was even). # Otherwise pick any pair of items > $i0 that doesn't include $i1. if (!$foundAGoodPair) { if ($i0 >= 2) { ($i2,$i3) = (0,1); # this helper pair gets used a lot } elsif ($i1 >= 4) { ($i2,$i3) = (2,3); } else # $i0 < $i1 < 4 { ($i2,$i3) = (4,5); } } #print "Before swapping $i0,$i1;$i2,$i3:\n\t perm=@perm\n\tinvPerm=@invPerm\n"; push @solution, [$i0, $i1]; _ApplySwapToPermAndInversePerm($i0,$i1,\@perm,\@invPerm); push @solution, [$i2, $i3]; _ApplySwapToPermAndInversePerm($i2,$i3,\@perm,\@invPerm); #print "After swapping $i0,$i1;$i2,$i3:\n\t perm=@perm\n\tinvPerm=@invPerm\n"; } } $verbose >= 2 && print STDERR " returning ".Stringify(\@solution)."\n"; IsIdentityPerm($n,\@perm) or die; IsIdentityPerm($n,\@invPerm) or die; return @solution; } # SolvePermInTermsOfSwaps sub Permute($$) { my ($things,$perm) = @_; my @result = map {$things->[$perm->[$_]]} 0..@$perm-1; return @result; } # # End of abstract permutation stuff. #----------------------------------------------------------------------------- #----------------------------------------------------------------------------- # Solve-related functions... # # # Moves all rotations to the end of the sequence. # XXX should also combine multiple moves of a single face # sub CompressMoveSequence(@) { my (@inSeq) = @_; my @rot = (0,1,2,3); # cumulative rotation as we progress my @invRot = (0,1,2,3); # inverse of @rot my @outSeq = (); $verbose >= 1 && print STDERR "Compressing move sequence... "; for my $move (@inSeq) { my ($handle,$slicesmask) = @$move; if ($slicesmask == -1) { # # It's a rotation; compose it onto the cumulative rotation. # my $incRot = $allRots[$rotHandleToIndex[$handle]]; @rot = ComposeRotations(\@rot, $incRot); @invRot = InverseRotation(\@rot); $verbose >= 2 && print STDERR ","; } else { # # It's a twist; transform it by current rot. # We want rot * move == transformedMove * rot # i.e. transformedMove = rot * move * invRot # = move with handle transformed by invRot # my @handleCoords = StickerToCoords(3,$handle); my @rotatedHandleCoords = RotateCoords(\@handleCoords,\@invRot); my $rotatedHandle = CoordsToSticker(3,\@rotatedHandleCoords); push @outSeq, [$rotatedHandle,$slicesmask]; $verbose >= 2 && print STDERR "."; } } $verbose >= 1 && print STDERR "done.\n"; # XXX the following has never been tested since the cumulative # XXX rotation is always the identity. It probably works but... my $rotIndex = $allRotsStringToIndex{join(' ',@invRot)}; $rotIndex == 0 or warn "surprise, cumulative rotation not identity"; push @outSeq, @{$allRotsMoveSequences[$rotIndex]}; if ($verbose >= 2) { print STDERR "Before compression: ".MoveSequenceToString(\@inSeq)."\n"; print STDERR "After compression: ".MoveSequenceToString(\@outSeq)."\n"; } return @outSeq; } sub InvertMoveSequence(@) { my (@seq) = @_; my @invSeq = (); for (my $i = @seq-1; $i >= 0; $i--) { my $globalSticker = $seq[$i][0]; my $slicesMask = $seq[$i][1]; my $face = int $globalSticker/27; my $localSticker = $globalSticker%27; my $oppositeLocalSticker = 27-1 - $localSticker; push @invSeq, ([$face*27 + $oppositeLocalSticker, $slicesMask]); } return @invSeq; } # XXX should be table calculated once sub CalcCubieType($$) { my ($puzzlesize,$cubie) = @_; my ($i,$j,$k,$l) = DecomposeIndex($puzzlesize,$cubie); my $cubieType = ($i > 0 && $i < $puzzlesize-1) + ($j > 0 && $j < $puzzlesize-1) + ($k > 0 && $k < $puzzlesize-1) + ($l > 0 && $l < $puzzlesize-1); #print STDERR "$cubie: $i $j $k $l -> type = $cubieType\n"; return $cubieType; } # Type = 0 for corners, 1 for edges, 2 for faces, 3 for cells sub FindCubiesOfType($$) { my ($puzzlesize,$desiredCubieType) = @_; #print STDERR "Looking for cubies of type $desiredCubieType\n"; my @cubiesOfType = (); for my $cubie (0..$puzzlesize*$puzzlesize*$puzzlesize*$puzzlesize-1) { my $thisCubieType = CalcCubieType($puzzlesize,$cubie); push(@cubiesOfType, $cubie) if ($thisCubieType == $desiredCubieType); } my $n = @cubiesOfType; $verbose >= 2 && print STDERR "$n cubies of type $desiredCubieType: ", join(" ", @cubiesOfType), "\n"; return @cubiesOfType; } # # Finds a sequence of moves that takes these cubies to those cubies. # Returns the sticker permutation (by reference) and sequence of moves. # sub FindSeqTakingTheseToThoseCubies($$$$) { my ($puzzlesize,$theseCubies,$thoseCubies,$skipInitialRot) = @_; my $nStickers = 8*$puzzlesize*$puzzlesize*$puzzlesize; my $nCubies = $puzzlesize*$puzzlesize*$puzzlesize*$puzzlesize; my $nToMatch = @$theseCubies; $nToMatch > 0 or die; my $cubieType = CalcCubieType($puzzlesize,$theseCubies->[0]); my @seq = (); my @stickerPerm = (0..$nStickers-1); # identity permutation my (@theseCoords, @thoseCoords); for my $i (0..$nToMatch-1) { $theseCoords[$i] = CubieToCoords($puzzlesize,$theseCubies->[$i]); $thoseCoords[$i] = CubieToCoords($puzzlesize,$thoseCubies->[$i]); } if ($verbose >= 2) { print STDERR " FindSeqTakingTheseToThoseCubies called to do these coords:\n"; for my $i (0..$nToMatch-1) { print STDERR " @{$theseCoords[$i]} -> @{$thoseCoords[$i]}\n"; } } # # Start by trying to match as many as possible with # just a single rotation, # (but matches must be in order from the beginnning of the these and # those lists). # my $nMatches = 0; if (!$skipInitialRot) { my $rotIndex; ($rotIndex,$nMatches) = FindRotThatTakesAsManyOfTheseToThoseCoordsAsPossibleInOrder(\@theseCoords,\@thoseCoords); my $rot = $allRots[$rotIndex]; if ($verbose >= 2) { print STDERR " Best rotation matched $nMatches of ", 0+@theseCoords, " cubies\n"; print STDERR " rotIndex = $rotIndex\n"; print STDERR " rot = ", RotToString($rot), "\n"; print STDERR " seq = ", MoveSequenceToString($allRotsMoveSequences[$rotIndex]), "\n"; } $nMatches >= 1 or die; # can always rotate at least one into place push @seq, @{$allRotsMoveSequences[$rotIndex]}; @stickerPerm = Permute(\@stickerPerm, CalcRotToStickerPerm($puzzlesize,$rot)); # XXX don't keep calling Calc! for my $i (0..$nToMatch-1) { @{$theseCoords[$i]} = RotateCoords($theseCoords[$i], $rot); } } # # Now put the rest of them in place, # using very special-case logic. # for my $i ($nMatches..$nToMatch-1) { $verbose >= 2 && print STDERR " doing $i\n"; if (! grep {$theseCoords[$i][$_] != $thoseCoords[$i][$_]} (0..3)) { $verbose >= 2 && print STDERR " it's already there\n"; next; # it's already there } # # If it's not on outer hyperface, put it there # using a single or double twist of an appropriate face, # being careful not to mess up what we've already placed. # if ($theseCoords[$i][3] != 2) { $verbose >= 2 && print STDERR " needs to go to outer face\n"; my $face = -1; # OBDLRUFX (to remind myself which faces are which) my @facesToTry = $cubieType==0 ? (2,4,6) # D,R,F : (2,5,4,3); # D,U,R,L for my $faceToTry (@facesToTry) { my ($axis,$sign) = FaceIndexToAxisAndSign($faceToTry); if ($theseCoords[$i][$axis] == ($puzzlesize-1)*$sign) { $face = $faceToTry; last; } } $face >= 0 or die; my $incSeq = CalcTwistsOfFaceThatTakesCoordsToPlane($face,$theseCoords[$i],3,2); $verbose >= 2 && print STDERR " seq to take ".Stringify($theseCoords[$i])." to value 2 on axis 3: ".MoveSequenceToString($incSeq)."\n"; # XXX VERY inefficient, and duplicated 3 times { push @seq, @$incSeq; my $incStickerPerm = CalcSequenceToStickerPerm($puzzlesize,$incSeq); @stickerPerm = Permute(\@stickerPerm, $incStickerPerm); my @incCubiePerm = CalcStickerPermToCubiePerm($puzzlesize,$incStickerPerm); my @invIncCubiePerm = InverseLUT(\@incCubiePerm); for my $j (0..$nToMatch-1) { my $cubie = CoordsToCubie($puzzlesize, $theseCoords[$j]); my $toCubie = $invIncCubiePerm[$cubie]; if ($j < $i) { $toCubie == $cubie or die; # doesn't mess up previous } else { $theseCoords[$j] = CubieToCoords($puzzlesize,$toCubie); } } } } else { $verbose >= 2 && print STDERR " it's already on outer face\n"; } # # Twist outer hyperface to put it as close as possible # to where it's supposed to go... # { my @outsideThoseCoords = ($thoseCoords[$i][0], $thoseCoords[$i][1], $thoseCoords[$i][2], -$thoseCoords[$i][3]); my ($rotIndex,$nMatches) = FindRotThatTakesAsManyOfTheseToThoseCoordsAsPossibleInOrder( [[0,0,0,1],$theseCoords[$i]], [[0,0,0,1],\@outsideThoseCoords]); $nMatches == 2 or die; # matched both of them my $incSeq = CalcTwistsOfFaceThatAccomplishesRotIndex(7,$rotIndex); $verbose >= 2 && print STDERR " seq to take ".Stringify($theseCoords[$i])." to ".Stringify(\@outsideThoseCoords).": ".MoveSequenceToString($incSeq)."\n"; # XXX VERY inefficient, and duplicated 3 times { push @seq, @$incSeq; my $incStickerPerm = CalcSequenceToStickerPerm($puzzlesize,$incSeq); @stickerPerm = Permute(\@stickerPerm, $incStickerPerm); my @incCubiePerm = CalcStickerPermToCubiePerm($puzzlesize,$incStickerPerm); my @invIncCubiePerm = InverseLUT(\@incCubiePerm); for my $j (0..$nToMatch-1) { my $cubie = CoordsToCubie($puzzlesize, $theseCoords[$j]); my $toCubie = $invIncCubiePerm[$cubie]; if ($j < $i) { $toCubie == $cubie or die; # doesn't mess up previous } else { $theseCoords[$j] = CubieToCoords($puzzlesize,$toCubie); } } } } # # Twist it from the outer hyperface to the inner one. # There are only 7 possible values (10 canonical cubies, # but we never see the first of each type here since # the initial rotation always succeeds in matching at least one). # { my $thatCubie = CoordsToCubie($puzzlesize, $thoseCoords[$i]); my $incSeq; if ($thatCubie == 22) # OF { # OBDLRUFX (to remind myself which faces are which) # Fru $incSeq = [[6*27+17,1]]; } elsif ($thatCubie == 21 || $thatCubie == 24) # OFL or OFLU { # Fd $incSeq = [[6*27+10,1]]; } elsif ($thatCubie == 5 || $thatCubie == 8) # OBR or OBRD { # Ru $incSeq = [[4*27+16,1]]; } elsif ($thatCubie == 23 || $thatCubie == 26) # OFR or OFRU { # Lx Fu Lo $incSeq = [[3*27+12,1],[6*27+16,1],[3*27+14,1]]; } else { die "unexpected cubie $thatCubie"; } $verbose >= 2 && print STDERR " seq to take ".Stringify($theseCoords[$i])." straight in to ".Stringify($thoseCoords[$i]).": ".MoveSequenceToString($incSeq)."\n"; # XXX VERY inefficient, and duplicated 3 times { push @seq, @$incSeq; my $incStickerPerm = CalcSequenceToStickerPerm($puzzlesize,$incSeq); @stickerPerm = Permute(\@stickerPerm, $incStickerPerm); my @incCubiePerm = CalcStickerPermToCubiePerm($puzzlesize,$incStickerPerm); my @invIncCubiePerm = InverseLUT(\@incCubiePerm); for my $j (0..$nToMatch-1) { my $cubie = CoordsToCubie($puzzlesize, $theseCoords[$j]); my $toCubie = $invIncCubiePerm[$cubie]; if ($j < $i) { $toCubie == $cubie or die; # doesn't mess up previous } else { $theseCoords[$j] = CubieToCoords($puzzlesize,$toCubie); } } } } $verbose >= 2 && print STDERR " done with $i, theseCoords are now ".Stringify(\@theseCoords)."\n"; } # for my $i ($nMatches+1..@theseCoords-1) return (\@stickerPerm,@seq); } # FindSeqTakingTheseToThoseCubies sub CalcTwistsOfFaceThatAccomplishesRotIndex($$) { my ($face,$rotIndex) = @_; return [] if $rotIndex == 0; for my $i (0..27-1) { $i == 13 and next; # no handle in center of hyperface my $handle = $face*27+$i; if ($rotHandleToIndex[$handle] == $rotIndex) { return [[$handle,1]]; } if ($i==4 || $i==10 || $i==12) { my $rot = $allRots[$rotHandleToIndex[$handle]]; my @doubleHandleRot = ComposeRotations($rot,$rot); # work around bizarre perl5.6 bug... @doubleHandleRot = map {~~$_} @doubleHandleRot; if (! grep {$doubleHandleRot[$_] != $allRots[$rotIndex][$_]} (0..3)) { return [[$handle,1],[$handle,1]]; } } } die "Can't find twists of face $face accomplishing rot $rotIndex: ", RotToString($allRots[$rotIndex]), "\n"; } # CalcTwistsOfFaceThatAccomplishesRotIndex sub CalcTwistsOfFaceThatTakesCoordsToPlane($$$$) { my ($face,$coords,$axis,$amount) = @_; for my $i (0..27-1) { $i == 13 and next; # no handle in center of hyperface my $handle = $face*27+$i; my @result = RotateCoords($coords, $allRots[$rotHandleToIndex[$handle]]); if ($result[$axis] == $amount) { return [[$handle,1]]; } } # XXX I *think* this can always be done in one move if at all, # XXX but I'm not sure! die 'Please page Don Hatch at 5609041@skytel.com'; } # CalcTwistsOfFaceThatAccomplishesRotIndex sub SolvePositionsOfCubiesOfOneType($$$$$) { my ($puzzlesize,$perm,$cubieType,$macroString,$canonicalStickersString) =@_; my $nStickers = 8*$puzzlesize*$puzzlesize*$puzzlesize; my @macro = StringToMoveSequence($macroString); my $macroPerm = CalcSequenceToStickerPerm($puzzlesize,\@macro); my @canonStickers = map {$_->[0]} StringToMoveSequence($canonicalStickersString); my @canonCubies = map {CalcStickerToCubie($puzzlesize,$_)} @canonStickers; # canonical string has two stickers on each cubie, so remove odd elements... @canonCubies = map {$canonCubies[2*$_]} (0..@canonCubies/2-1); # # Find a list of cubie swaps # (or pairs of cubie swaps, if number of canonical cubies is 4 rather # than 2) that does what we want. # my @cubiePairSwaps; { my @cubiePerm = CalcStickerPermToCubiePerm($puzzlesize,$perm); $verbose >= 2 && print STDERR "cubiePerm is @cubiePerm\n"; my @cubiesOfType = FindCubiesOfType($puzzlesize, $cubieType); $verbose >= 2 && print STDERR "cubies of type = @cubiesOfType\n"; my @invCubiesOfType = InverseLUT(\@cubiesOfType); my @cubiesOfTypePerm = map {$invCubiesOfType[$cubiePerm[$_]]} @cubiesOfType; @cubiePairSwaps = SolvePermInTermsOfSwaps( @canonCubies/2, # number of swaps per step @cubiesOfTypePerm); # convert back to indices in the full list of cubies... $verbose >= 1 && print STDERR " ",@cubiePairSwaps/@canonCubies*2,@canonCubies==4?" pairs of swaps ":" swaps "; $verbose >= 2 && print STDERR ":\n"; for my $i (0..@cubiePairSwaps-1) { $cubiePairSwaps[$i][0] = $cubiesOfType[$cubiePairSwaps[$i][0]]; $cubiePairSwaps[$i][1] = $cubiesOfType[$cubiePairSwaps[$i][1]]; $verbose >= 2 && print STDERR " $cubiePairSwaps[$i][0] $cubiePairSwaps[$i][1]\n"; } } my @seq = (); while (@cubiePairSwaps) { my @cubies; # @cubies[0..1] = (shift @cubiePairSwaps)->[0..1]; # XXX doesn't work? my $temp = shift @cubiePairSwaps; @cubies[0..1] = ($temp->[0],$temp->[1]); if (@canonCubies == 4) { # @cubies[2..3] = (shift @cubiePairSwaps)->[0..1]; # XXX doesn't work? my $temp = shift @cubiePairSwaps; @cubies[2..3] = ($temp->[0],$temp->[1]); } my ($incPerm, @incSeq) = FindSeqTakingTheseToThoseCubies($puzzlesize,\@cubies, \@canonCubies, 0); my @invIncPerm = InverseLUT($incPerm); push @seq, @incSeq; push @seq, @macro; push @seq, InvertMoveSequence(@incSeq); # Modify caller's @perm... @$perm = Permute($perm, $incPerm); @$perm = Permute($perm, $macroPerm); @$perm = Permute($perm, \@invIncPerm); $verbose == 1 && print STDERR '.'; } if ($verbose >= 1) { my $nRots = 0 + grep {$_->[1] == -1} @seq; my $nTwists = @seq - $nRots; print STDERR " done ($nTwists twists + $nRots rotations).\n"; } $verbose >= 2 && print STDERR " SolvePositionsOfCubiesOfOneType($cubieType) returning:", MoveSequenceToString(\@seq), "\n"; return @seq; } # SolvePositionsOfCubiesOfOneType # # XXX this function is a huge evil special-case mess # XXX with lots of duplicated code # sub SolveOrientationsOfCubiesOfOneType($$$$$) { my ($puzzlesize,$perm,$cubieType,$macroString,$canonicalStickersString) = @_; my $nStickers = 8*$puzzlesize*$puzzlesize*$puzzlesize; my @macro = StringToMoveSequence($macroString); my $macroPerm = CalcSequenceToStickerPerm($puzzlesize,\@macro); my @canonStickers = map {$_->[0]} StringToMoveSequence($canonicalStickersString); my @canonCubies = map {CalcStickerToCubie($puzzlesize,$_)} @canonStickers; @canonCubies = map {$canonCubies[2*$_]} (0..@canonCubies/2-1); my @seq = (); if ($cubieType == 2) { # # This case is easy, there's only one way to flip a face-cubie. # Make a list of face-cubies that need to be flipped... # my @list = grep {$perm->[$_] > $_} (0..$nStickers-1); @list = map {CalcStickerToCubie($puzzlesize,$_)} @list; @list = grep {CalcCubieType($puzzlesize,$_) == $cubieType} @list; $verbose >= 1 && print STDERR " ",@list/2," pairs of flips "; $verbose >= 2 && print STDERR ": @list\n"; # # There must be an even number of them... # @list % 2 == 0 or die "odd number of face-cubie flips needed!??"; @canonCubies == 2 or die; while (@list) { my @cubies = (shift @list, shift @list); # extract first two my ($incPerm, @incSeq) = FindSeqTakingTheseToThoseCubies($puzzlesize,\@cubies, \@canonCubies, 0); my @invIncPerm = InverseLUT($incPerm); push @seq, @incSeq; push @seq, @macro; push @seq, InvertMoveSequence(@incSeq); # Modify caller's @perm... @$perm = Permute($perm, $incPerm); @$perm = Permute($perm, $macroPerm); @$perm = Permute($perm, \@invIncPerm); $verbose == 1 && print STDERR '.'; } #$verbose >= 1 && print STDERR " done.\n"; } elsif ($cubieType == 0) { if (@canonCubies == 2) { # # Twirling pairs of corners in opposite directions. # No idea how many will be needed beforehand. # We use cubie 0 as a "helper" cubie-- # whatever direction we twist a given corner cubie, # we twist the helper cubie in the opposite direction, # paying no attention to what we're doing to its # particular stickers. # At the end the helper cubie will not need to be twisted # (but it might need to have its two pairs of stickers # swapped, which will be done later). # $verbose >= 1 && print STDERR " some pairs of twirls "; $verbose >= 2 && print STDERR "\n"; my $helperCubie = 0; # (lame, incoming canon stickers didn't have # enough stickers, but we know what they are...) my @canonStickerCoords = ( [-2,2,-2,-3], # Oblu [-2,3,-2,-2], # Uobl [-3,2,-2,-2], # Lobu #[-2,2,-3,-2], # Bolu ); my @invMacro = InvertMoveSequence(@macro); my @invMacroPerm = InverseLUT($macroPerm); for my $sticker0 (0..$nStickers-1) { # # See whether it's the lowest-indexed sticker # in a cycle of 3... # my $sticker1 = $perm->[$sticker0]; $sticker1 > $sticker0 or next; my $sticker2 = $perm->[$sticker1]; $sticker2 > $sticker0 or next; $perm->[$sticker2] == $sticker0 or next; # # Okay, we know it's a 3-cycle of stickers, # now we have to make sure they are on a corner cubie. # If one of them is, # then since corners have been positioned already, # that means they are all on the same corner. # my $cubie = CalcStickerToCubie($puzzlesize,$sticker0); $cubie != $helperCubie or next; CalcCubieType($puzzlesize,$cubie) == $cubieType or next; my @stickerCoords = map {[StickerToCoords($puzzlesize,$_)]} ($sticker0,$sticker1,$sticker2); my ($rotIndex,$nMatches) = FindRotThatTakesAsManyOfTheseToThoseCoordsAsPossibleInOrder(\@stickerCoords,\@canonStickerCoords); $nMatches == 2 || $nMatches == 3 or die; my $doItBackwards = 0; if ($nMatches == 2) { # # These three stickers don't rotate to the canonical # three stickers; they must be mirror-reversed # (i.e. the cycle goes in the other direction). # Make a note of this fact, # swap $sticker0 with $sticker1 and try again. # $doItBackwards = 1; ($sticker0,$sticker1) = ($sticker1,$sticker0); ($stickerCoords[0],$stickerCoords[1]) = ($stickerCoords[1],$stickerCoords[0]); ($rotIndex,$nMatches) = FindRotThatTakesAsManyOfTheseToThoseCoordsAsPossibleInOrder(\@stickerCoords,\@canonStickerCoords); } $nMatches == 3 or die; my $rot = $allRots[$rotIndex]; my @incSeq = @{$allRotsMoveSequences[$rotIndex]}; my $incPerm = CalcRotToStickerPerm($puzzlesize,$rot); my $helperCoords = CubieToCoords($puzzlesize,$helperCubie); $helperCoords = [RotateCoords($helperCoords,$rot)]; my $rotatedHelperCubie = CoordsToCubie($puzzlesize,$helperCoords); # # Move the helper cubie into place (without # perturbing the first cubie which we just placed in # canonCubies[0]). # my @theseCubies = ($canonCubies[0],$rotatedHelperCubie); my ($incIncPerm,@incIncSeq) = FindSeqTakingTheseToThoseCubies($puzzlesize,\@theseCubies,\@canonCubies,1); push @incSeq, @incIncSeq; $incPerm = [Permute($incPerm,$incIncPerm)]; my @invIncPerm = InverseLUT($incPerm); push @seq, @incSeq; push @seq, $doItBackwards ? @invMacro : @macro; push @seq, InvertMoveSequence(@incSeq); # Modify caller's @perm... @$perm = Permute($perm, $incPerm); @$perm = Permute($perm, $doItBackwards ? \@invMacroPerm : $macroPerm); @$perm = Permute($perm, \@invIncPerm); $verbose == 1 && print STDERR '.'; } } elsif (@canonCubies == 1) { # # Swapping two-pairs on corners in place. # Make a list of all corner-cubies that need to # be twiddled like this... # my $temp; my @stickerList = grep {($temp = $perm->[$_]) > $_ && $perm->[$temp] == $_} (0..$nStickers-1); @stickerList = grep {CalcCubieType($puzzlesize,CalcStickerToCubie($puzzlesize,$_)) == $cubieType} @stickerList; # (@stickerList now contains a sticker from each pair # that needs to be swapped; we really want only one # on each cubie, but we'll leave it for now # and just skip them if they are done already. # but all numbers must be divided by 2.) $verbose >= 1 && print STDERR " ",@stickerList/2," double-pair corner twiddles "; $verbose >= 2 && print STDERR "(but this list is redundant): @stickerList\n"; while (@stickerList) { my $sticker0 = shift @stickerList; my $sticker1 = $perm->[$sticker0]; $sticker1 == $sticker0 && next; # twiddled this cubie already my @stickerCoords = map {[StickerToCoords($puzzlesize,$_)]} ($sticker0,$sticker1); my @canonCoords = map {[StickerToCoords($puzzlesize,$_)]} @canonStickers; $verbose >= 2 && print STDERR " Rotating ".Stringify(\@stickerCoords)." to ".Stringify(\@canonCoords)."\n"; my ($rotIndex, $nMatches) = FindRotThatTakesAsManyOfTheseToThoseCoordsAsPossibleInOrder(\@stickerCoords,\@canonCoords); $nMatches == 2 or die; # matched both of them my $incSeq = $allRotsMoveSequences[$rotIndex]; my $incPerm = CalcRotToStickerPerm($puzzlesize,$allRots[$rotIndex]); my @invIncPerm = InverseLUT($incPerm); push @seq, @$incSeq; push @seq, @macro; push @seq, InvertMoveSequence(@$incSeq); # Modify caller's @perm... @$perm = Permute($perm, $incPerm); @$perm = Permute($perm, $macroPerm); @$perm = Permute($perm, \@invIncPerm); $verbose == 1 && print STDERR '.'; } #$verbose >= 1 && print STDERR " done.\n"; } } elsif ($cubieType == 1) { if (@canonCubies == 2) { # # Flipping pairs of edges. # if (0)# XXX this is a better way to do it but I'm going to just to do it like the corners because the code is already written. { # # Make a list of all edge-cubies that need flipping... # (one out-of-place sticker for each). # my $temp; my @stickerList = grep {($temp = $perm->[$_]) > $_ && $perm->[$temp] == $_} (0..$nStickers-1); @stickerList = grep {CalcCubieType($puzzlesize,CalcStickerToCubie($puzzlesize,$_)) == $cubieType} @stickerList; $verbose >= 1 && print STDERR " ",@stickerList/2," pairs of flips "; $verbose >= 2 && print STDERR ": @stickerList\n"; # # There must be an even number of them... # @stickerList % 2 == 0 or die "odd number of edge-cubie flips needed!??"; @canonCubies == 2 or die; while (@stickerList) { # ... take two cubies that need flipping and flip them. } } # # Lame way based on what was done for # twirl-two-corners-in-opposite-directions above. # No idea how many will be needed beforehand. # We use cubie 1 as the "helper" cubie-- # whenever we flip an edge, we flip the helper too # (without paying attention to its particular stickers). # At the end the helper cubie will not need to be flipped # (but it may need to be twirled, which will be done later). # $verbose >= 1 && print STDERR " some pairs of flips "; $verbose >= 2 && print STDERR "\n"; my $helperCubie = 1; my @canonStickerCoords = map {[StickerToCoords($puzzlesize,$_)]} @canonStickers[0..1]; for my $sticker0 (0..$nStickers-1) { # # See whether it's the lowest-indexed sticker # in a cycle of 2... # my $sticker1 = $perm->[$sticker0]; $sticker1 > $sticker0 or next; $perm->[$sticker1] == $sticker0 or next; # # Okay, we know it's a 2-cycle of stickers, # now we have to make sure they are on an edge cubie. # If one of them is, # then since edges have been positioned already, # that means they are both on the same edge. # my $cubie = CalcStickerToCubie($puzzlesize,$sticker0); $cubie != $helperCubie or next; CalcCubieType($puzzlesize,$cubie) == $cubieType or next; my @stickerCoords = map {[StickerToCoords($puzzlesize,$_)]} ($sticker0,$sticker1); my ($rotIndex,$nMatches) = FindRotThatTakesAsManyOfTheseToThoseCoordsAsPossibleInOrder(\@stickerCoords,\@canonStickerCoords); $nMatches == 2 or die; # matched both stickers my $rot = $allRots[$rotIndex]; my @incSeq = @{$allRotsMoveSequences[$rotIndex]}; my $incPerm = CalcRotToStickerPerm($puzzlesize,$rot); my $helperCoords = CubieToCoords($puzzlesize,$helperCubie); $helperCoords = [RotateCoords($helperCoords,$rot)]; my $rotatedHelperCubie = CoordsToCubie($puzzlesize,$helperCoords); # # Move the helper cubie into place (without # perturbing the first cubie which we just placed in # canonCubies[0]). # my @theseCubies = ($canonCubies[0],$rotatedHelperCubie); my ($incIncPerm,@incIncSeq) = FindSeqTakingTheseToThoseCubies($puzzlesize,\@theseCubies,\@canonCubies,1); push @incSeq, @incIncSeq; $incPerm = [Permute($incPerm,$incIncPerm)]; my @invIncPerm = InverseLUT($incPerm); push @seq, @incSeq; push @seq, @macro; push @seq, InvertMoveSequence(@incSeq); # Modify caller's @perm... @$perm = Permute($perm, $incPerm); @$perm = Permute($perm, $macroPerm); @$perm = Permute($perm, \@invIncPerm); $verbose == 1 && print STDERR '.'; } } elsif (@canonCubies == 1) { # # Twirling edges in place. # Make a list of all edge-cubies that need twirling... # my $temp; my @stickerList = grep {($temp = $perm->[$_]) > $_ && ($temp = $perm->[$temp]) > $_ && $perm->[$temp] == $_} (0..$nStickers-1); @stickerList = grep {CalcCubieType($puzzlesize,CalcStickerToCubie($puzzlesize,$_)) == $cubieType} @stickerList; $verbose >= 1 && print STDERR " ",0+@stickerList," twirls "; $verbose >= 2 && print STDERR ": @stickerList\n"; while (@stickerList) { my $sticker0 = shift @stickerList; my @stickers = ($sticker0, $perm->[$sticker0]); # where the sticker that's in position sticker0 should go my @stickerCoords = map {[StickerToCoords($puzzlesize,$_)]} @stickers; my @canonCoords = map {[StickerToCoords($puzzlesize,$_)]} @canonStickers; $verbose >= 2 && print STDERR " Rotating ".Stringify(\@stickerCoords)." to ".Stringify(\@canonCoords)."\n"; my ($rotIndex, $nMatches) = FindRotThatTakesAsManyOfTheseToThoseCoordsAsPossibleInOrder(\@stickerCoords,\@canonCoords); $nMatches == 2 or die; # matched both of them my $incSeq = $allRotsMoveSequences[$rotIndex]; my $incPerm = CalcRotToStickerPerm($puzzlesize,$allRots[$rotIndex]); my @invIncPerm = InverseLUT($incPerm); push @seq, @$incSeq; push @seq, @macro; push @seq, InvertMoveSequence(@$incSeq); # Modify caller's @perm... @$perm = Permute($perm, $incPerm); @$perm = Permute($perm, $macroPerm); @$perm = Permute($perm, \@invIncPerm); $verbose == 1 && print STDERR '.'; } #$verbose >= 1 && print STDERR " done.\n"; } else { die; } } else { die; } if ($verbose >= 1) { my $nRots = 0 + grep {$_->[1] == -1} @seq; my $nTwists = @seq - $nRots; print STDERR " done ($nTwists twists + $nRots rotations).\n"; } return @seq; } # SolveOrientationsOfCubiesOfOneType sub CubiesOfOneTypeAreSolved($$$$) { my ($puzzlesize, $perm, $cubieType, $checkOrientations) = @_; my $nStickers = 8*$puzzlesize*$puzzlesize*$puzzlesize; for my $dstSticker (0..$nStickers-1) { my $dstCubie = CalcStickerToCubie($puzzlesize,$dstSticker); my $dstCubieType = CalcCubieType($puzzlesize,$dstCubie); next if $dstCubieType != $cubieType; if ($checkOrientations) { return 0 if $perm->[$dstSticker] != $dstSticker; } else { next if $perm->[$dstSticker] == $dstSticker; my $srcSticker = $perm->[$dstSticker]; my $srcCubie = CalcStickerToCubie($puzzlesize,$srcSticker); return 0 if $srcCubie != $dstCubie; } } return 1; # nothing we checked is out of order } # CubiesOfOneTypeAreSolved # # Function to solve the puzzle from a given permutation of the stickers. # Returns a sequence of moves that solve the puzzle; # each move is a pair [handleIndex, slicesmask]. # (handleIndex corresponds to a sticker index on the 3x3x3x3 puzzle, # regardless of the actual size of the puzzle). # sub Solve($@) { my ($puzzlesize, @perm) = @_; # # Can unset some of these to facilitate debugging. # Undefined disaster will occur if doOrient is set but doPosition # is not (for any of the three cubie types). # my $doPositionFaceCubies = 1; my $doOrientFaceCubies = 1; my $doPositionCornerCubies = 1; my $doOrientCornerCubies = 1; my $doPositionEdgeCubies = 1; my $doOrientEdgeCubies = 1; if ($doPositionEdgeCubies && !$doPositionFaceCubies) { warn "Positioning edge cubies without positioning face cubies-- expect disaster if permutation is odd\n"; } my @currentPerm = @perm; # progresses from original perm to identity my @solutionSequence = (); # grows to form the solution # # 1. Position face cubies (screwing up edges and vertices), using a # swap-one-pair-of-faces macro. # Note, this macro is an odd permutation and will fix # the total parity of the puzzle if it was wrong; # all subsequent operations will be even permutations. # if ($doPositionFaceCubies) { $verbose >= 1 && print STDERR "Step 1: Position face cubies\n"; my $swapOnePairOfFacesMacroString = "Dofr:-1 Rx Fo Ro Fx Rx Dx Fx Do Ro Dxbl:-1"; my $canonicalFaceStickersString = "Ob,Bo; Of,Fo"; my @incSeq = SolvePositionsOfCubiesOfOneType($puzzlesize, \@currentPerm, 2, $swapOnePairOfFacesMacroString, $canonicalFaceStickersString); push @solutionSequence, @incSeq; # append @incSeq } # # 2. Orient face cubies (screwing up edges and vertices), # using a flip-two-faces macro. # if ($doOrientFaceCubies) { $verbose >= 1 && print STDERR "Step 2: Orient face cubies\n"; my $flipTwoFacesMacroString = "Bl Ur Ol:4 Ul Bur Our Bur Ur Or:4 Ul Br Our"; my $canonicalFaceStickersString = "Ob,Bo; Of,Fo"; my @incSeq = SolveOrientationsOfCubiesOfOneType($puzzlesize, \@currentPerm, 2, $flipTwoFacesMacroString, $canonicalFaceStickersString); push @solutionSequence, @incSeq; # append @incSeq } if ($doPositionFaceCubies) { CubiesOfOneTypeAreSolved($puzzlesize, \@currentPerm, 2, $doOrientFaceCubies) or die; } # # 3. Position corner cubies without perturbing faces # (but screwing up edges) using a swap-two-pairs-of-corners macro. # if ($doPositionCornerCubies) { $verbose >= 1 && print STDERR "Step 3: Position vertex cubies\n"; my $swapTwoPairsOfVerticesMacroString = "Rf Dor Rb Uf Rf Dor Rb Ub"; my $canonicalVertexStickersString = "Oblu,Bolu; Oflu,Folu! Obru,Boru; Ofru,Foru!"; # silly punctuation is ignored my @incSeq = SolvePositionsOfCubiesOfOneType($puzzlesize, \@currentPerm, 0, $swapTwoPairsOfVerticesMacroString, $canonicalVertexStickersString); push @solutionSequence, @incSeq; # append @incSeq } # # 4. Orient vertex cubies # (without perturbing faces, but screwing up edges) # using a twist-two-corners-in-opposite-directions macro # and a swap-two-pairs-of-stickers-on-a-single-vertex macro. # (The latter is not really necessary but it makes less to think about.) if ($doOrientCornerCubies) { $verbose >= 1 && print STDERR "Step 4a: Orient vertex cubies using twist-two-corners-in-opposite-directions\n"; my $twistTwoVerticesInOppositeDirectionsMacroString = "Ob:-1 " . "Rf Dor Rb Uf Rf Dor Rb Ub Rou " . "Rf Dor Rb Uf Rf Dor Rb Ub Rou " . "Of:-1 " . ""; #return StringToMoveSequence($twistTwoVerticesInOppositeDirectionsMacroString); my $canonicalVertexStickersString = "Oblu,Bolu; Oflu,Folu"; my @incSeq = SolveOrientationsOfCubiesOfOneType($puzzlesize, \@currentPerm, 0, $twistTwoVerticesInOppositeDirectionsMacroString, $canonicalVertexStickersString); push @solutionSequence, @incSeq; # append @incSeq } if ($doOrientCornerCubies) { $verbose >= 1 && print STDERR "Step 4b: Orient remaining vertex cubies using swap-two-pairs-of-stickers\n"; my $swapTwoPairsOfStickersOnSingleVertexMacroString = "Ob " . "Rf Dor Rb Uf Rf Dor Rb Ub Rou " . "Rf Dor Rb Uf Rf Dor Rb Ub Rou " . "Fx Rubo Fo " . "Rxd Uf Rf Dxl Rb Ub Rf Dxl Rb " . "Rxd Uf Rf Dxl Rb Ub Rf Dxl Rb " . "Fx Rdfx Fo " . "Of " . ""; #return StringToMoveSequence($swapTwoPairsOfStickersOnSingleVertexMacroString); my $canonicalVertexStickersString = "Oblu,Bolu"; my @incSeq = SolveOrientationsOfCubiesOfOneType($puzzlesize, \@currentPerm, 0, $swapTwoPairsOfStickersOnSingleVertexMacroString, $canonicalVertexStickersString); push @solutionSequence, @incSeq; # append @incSeq } if ($doPositionFaceCubies) { CubiesOfOneTypeAreSolved($puzzlesize, \@currentPerm, 2, $doOrientFaceCubies) or die; } if ($doPositionCornerCubies) { CubiesOfOneTypeAreSolved($puzzlesize, \@currentPerm, 0, $doOrientCornerCubies) or die; } # # 5. Position edge cubies (without perturbing faces or vertices) # using a swap-two-pairs-of-edges macro. # if ($doPositionEdgeCubies) { $verbose >= 1 && print STDERR "Step 5: Position edge cubies\n"; my $swapTwoPairsOfEdgesMacroString = "Rb Ob Rf " . "Uf:2 Xr Xr Ub:2 Our Uf:2 Xr Xr Ub:2 Our " . "Rb Of Rf "; my $canonicalEdgeStickersString = "Obl,Bol; Ofl,Fol! Obr,Bor; Ofr,For!"; my @incSeq = SolvePositionsOfCubiesOfOneType($puzzlesize, \@currentPerm, 1, $swapTwoPairsOfEdgesMacroString, $canonicalEdgeStickersString); push @solutionSequence, @incSeq; # append @incSeq } # # 6. Orient edges using a flip-two-edges macro # and a twirl-one-edge macro. # (The latter is not really necessary but it makes less to think about.) if ($doOrientEdgeCubies) { $verbose >= 1 && print STDERR "Step 6a: Orient edge cubies using flip-two-edges\n"; my $flipTwoEdgesMacroString = "Ob:-1 Ob:-1 " . "Rx " . "Rf Dor Rb Uf Rf Dor Rb Ub " . "Ro " . "Do:2 " . "Rx " . "Rf Dor Rb Uf Rf Dor Rb Ub " . "Ro " . "Dx:2 " . "Of:-1 Of:-1 " . ""; my $canonicalEdgeStickersString = "Obl,Bol; Ofl,Fol"; my @incSeq = SolveOrientationsOfCubiesOfOneType($puzzlesize, \@currentPerm, 1, $flipTwoEdgesMacroString, $canonicalEdgeStickersString); push @solutionSequence, @incSeq; # append @incSeq } if ($doOrientEdgeCubies) { $verbose >= 1 && print STDERR "Step 6b: Orient remaining edge cubies using twirl-one-edge\n"; my $twirlOneEdgeMacroString = "Odf:-1 " . "Rf Dor Rb Uf Rf Dor Rb Ub Rou " . "Rf Dor Rb Uf Rf Dor Rb Ub Rou " . "Fu:2 Rou Fd:2 " . "Rf Dor Rb Uf Rf Dor Rb Ub Rou " . "Rf Dor Rb Uf Rf Dor Rb Ub Rou " . "Fu:2 Rou Fd:2 " . "Oub:-1 " . ""; #return StringToMoveSequence($twirlOneEdgeMacroString); my $canonicalEdgeStickersString = "Obl,Bol"; my @incSeq = SolveOrientationsOfCubiesOfOneType($puzzlesize, \@currentPerm, 1, $twirlOneEdgeMacroString, $canonicalEdgeStickersString); push @solutionSequence, @incSeq; # append @incSeq } if ($doPositionFaceCubies) { CubiesOfOneTypeAreSolved($puzzlesize, \@currentPerm, 2, $doOrientFaceCubies) or die; } if ($doPositionCornerCubies) { CubiesOfOneTypeAreSolved($puzzlesize, \@currentPerm, 0, $doOrientCornerCubies) or die; } if ($doPositionEdgeCubies) { CubiesOfOneTypeAreSolved($puzzlesize, \@currentPerm, 1, $doOrientEdgeCubies) or die; } #SequenceSolves(\@solutionSequence, \@perm) or die; XXXimplement! return @solutionSequence; } # Solve # # End of solve-related functions #----------------------------------------------------------------------------- # # Given scrambled sticker colors and solved sticker colors, # find the permutation, i.e. lookup table mapping each scrambled sticker # index to the index where it needs to be moved to. # sub StickerColorsToPermutation($$$) { my ($puzzlesize,$scrambledColors,$solvedColors) = @_; $puzzlesize <= 3 or die; # XXX otherwise can't recognize a cubie by its stickers my $nStickers = 8*$puzzlesize*$puzzlesize*$puzzlesize; my $nCubies = $puzzlesize*$puzzlesize*$puzzlesize*$puzzlesize; my (@scrambledCubieColorLists, @solvedCubieColorLists); my (%colorListToScrambledCubie, %colorListToSolvedCubie); my (@cubieAndSolvedColorToStickerIndex); for my $cubie (0..$nCubies-1) { $scrambledCubieColorLists[$cubie] = ""; $solvedCubieColorLists[$cubie] = ""; } # # Make lists of colors on each scrambled and solved cubie... # for my $sticker (0..$nStickers-1) { my $cubie = CalcStickerToCubie($puzzlesize,$sticker); $scrambledCubieColorLists[$cubie] .= ' ' . $scrambledColors->[$sticker]; $solvedCubieColorLists[$cubie] .= ' ' . $solvedColors->[$sticker]; $cubieAndSolvedColorToStickerIndex[$cubie][$solvedColors->[$sticker]] = $sticker; } # # Canonicalize (sort) the color list for each scrambled and solved cubie... # for my $cubie (0..$nCubies-1) { { my $s = $scrambledCubieColorLists[$cubie]; my @cubieColorList = split(' ', $s); @cubieColorList = sort @cubieColorList; $s = join(' ', @cubieColorList); $scrambledCubieColorLists[$cubie] = $s; $colorListToScrambledCubie{$s} = $cubie; } { my $s = $solvedCubieColorLists[$cubie]; my @cubieColorList = split(' ', $s); @cubieColorList = sort @cubieColorList; $s = join(' ', @cubieColorList); $solvedCubieColorLists[$cubie] = $s; $colorListToSolvedCubie{$s} = $cubie; } } # # To find where a sticker goes: # find its color # find which cubie it's on # find destination where cubie is supposed to go # find the sticker of destination cubie that's the desired color # in solvedColors # my @perm = (); for my $scrambledStickerIndex (0..$nStickers-1) { my $stickerColor = $scrambledColors->[$scrambledStickerIndex]; my $scrambledCubie = CalcStickerToCubie($puzzlesize,$scrambledStickerIndex); my $cubieColors = $scrambledCubieColorLists[$scrambledCubie]; my $solvedCubie = $colorListToSolvedCubie{$cubieColors}; my $solvedStickerIndex = $cubieAndSolvedColorToStickerIndex[$solvedCubie][$stickerColor]; $perm[$scrambledStickerIndex] = $solvedStickerIndex; } return @perm; } # StickerColorsToPermutation MAIN: { # very primitive arg parsing... # XXX should have better usage message than "Arg." if (@ARGV >= 1) { @ARGV >= 2 && $ARGV[0] eq "-v" && $ARGV[1] =~ /^[0123]$/ or die "Arg."; $verbose = $ARGV[1]; shift; shift; } InitConstantRotArrays(); #TestRotUtils(1,\@allRots); if (-t STDIN) # if it's a terminal { print STDERR "Enter magiccube4d log (or just the colors from the beginning):\n"; } # # Read input from magiccube4d log file (or part thereof) # my @inputLines = (); while (<>) { chomp; # remove trailing newline if any push @inputLines, $_ if s/^\s*([0-9]{4,})\s*$/$1/; } $verbose >= 3 && print "inputLines = @inputLines\n"; my $nInputLines = @inputLines; @inputLines == 8 or die "Got $nInputLines input color lines, expected 8"; # # Check lengths of input lines # my $puzzlesize = 3; # that's all we can do for now my $nStickersPerFace = $puzzlesize*$puzzlesize*$puzzlesize; my $nStickers = 8*$nStickersPerFace; for my $i (0..8-1) { my $thisLength = length($inputLines[$i]); $thisLength == $nStickersPerFace or die "Got line of length $thisLength, expected $nStickersPerFace"; } # # Parse input into array of scrambledColors and solvedColors. # my (@scrambledColors, @solvedColors); for my $sticker (0..$nStickers-1) { my $face = int $sticker / $nStickersPerFace; my $localSticker = $sticker % $nStickersPerFace; $scrambledColors[$sticker] = substr($inputLines[$face],$localSticker,1); } $puzzlesize % 2 == 1 or die; # must be odd to be able to naively determine face colors for my $sticker (0..$nStickers-1) { my $stickerInCenterOfFace = (int $sticker / $nStickersPerFace) * $nStickersPerFace + int ($nStickersPerFace-1)/2; $solvedColors[$sticker] = $scrambledColors[$stickerInCenterOfFace]; } # # Express it as a permutation (lookup table # from scrambled cube position to its destination) # my @perm = StickerColorsToPermutation($puzzlesize, \@scrambledColors, \@solvedColors); if ($verbose >= 2) { print "scrambledColors = @scrambledColors\n"; print "solvedColors = @solvedColors\n"; print "The permutation (scrambled sticker to dest lookup table): @perm\n"; } # # Solve it. # my @solution = Solve($puzzlesize,@perm); if ($verbose >= 1) { my $nLabels = 0; # maybe someday my $nMoves = @solution - $nLabels; my $nRots = 0 + grep {$_->[1] == -1} @solution; my $nTwists = $nMoves - $nRots; print STDERR "Solution length = $nTwists twists + $nRots rotations = $nMoves\n"; } my $doCompress = 1; # XXX should be command-line option maybe if ($doCompress) { # # Compress solution (squeeze out multiple twists of a face, # and compose rotations into a single one at the end (if any)). # XXX only does the latter currently # @solution = CompressMoveSequence(@solution); if ($verbose >= 1) { my $nLabels = 0; # maybe someday my $nMoves = @solution - $nLabels; my $nRots = 0 + grep {$_->[1] == -1} @solution; my $nTwists = $nMoves - $nRots; print STDERR "Solution length = $nTwists twists + $nRots rotations = $nMoves\n"; } } my @inverseSolution = InvertMoveSequence(@solution); my $solutionLength = @solution; # # Print the inverse of the solution as a log file. # print "MagicCube4D 1 0 $solutionLength\n"; print join("\n", @inputLines), "\n"; PrintSequenceForLogFile($puzzlesize,@inverseSolution); } # main