#!/usr/bin/env perl6
# This is perl6 version 2011.12-18-ga7fd89e built on parrot 3.11.0 revision RELEASE_3_11_0

=begin comment
 - The list of all moves in a groove is generated before solving the puzzle.
 - Moves are sorted from the shortest to the longest (so that a solution with the shortest moves is found first).
 - Each field on the board is assigned one character (convenient for serialization).
 - The board is analyzed with a regular BFS.
 - Convertions between different notation types make the code appear more difficult than it really is.
 - The script dies if the input is illegal.
=end comment



my @BOARDS =
[
	<
	   e1  d1  c1  b1  a1
	 f1  e2  d2  c2  b2  a2
	   f2  e3  d3  c3  b3
	 g1  f3  e4  d4  c4  b4
	   g2  f4  e5  d5  c5
	 h1  g3  f5  e6  d6  c6
	   h2  g4  f6  e7  d7
	>
],
[
	<
	   i1  i2  i3  i4  i5
	 j1  j2  j3  j4  j5  j6
	   k1  k2  k3  k4  k5
	 l1  l2  l3  l4  l5  l6
	   m1  m2  m3  m4  m5
	 n1  n2  n3  n4  n5  n6
	   o1  o2  o3  o4  o5
	>
],
[
	<
	   p2  q4  r6  s7  t7
	 p1  q3  r5  s6  t6  u6
	   q2  r4  s5  t5  u5
	 q1  r3  s4  t4  u4  v4
	   r2  s3  t3  u3  v3
	 r1  s2  t2  u2  v2  w2
	   s1  t1  u1  v1  w1
	>
];



# Auxilliary routines

sub fill-dictionary ( %dict is rw, @board ) {
	my $num = ord( ' ' );
	for @board -> $f {
		%dict{ $f } = chr( ++$num ); # Encode each field into a single char.
	}
}

sub encode-piece ( $piece, %field-dict ) { # Changes g123 to g1g2g3 and encodes.
	my $groove = $piece.substr( 0, 1 );
	my $result;
	for $piece.substr( 1 ).split('') -> $num {
		my $field = $groove ~ $num;
		die "Field $field not on board." unless %field-dict.exists( $field );
		$result ~= %field-dict{ $field };
	}
	return $result;
}



# Reading the board and initializing data structures

sub read-board () {
	my %layout;

	for lines() -> $piece {
		$piece.chomp;
		%layout{ $piece } = 1;
	}

	return %layout;
}

sub assert-board ( %initial-layout, %layout ) {
	if not %initial-layout.exists( 'l12' ) {
		die "Piece l12 missing.";
	}

	my %board = layout-to-board( %layout );
	my $fields-in-layout = 0;
	for %layout.keys -> $k {
		$fields-in-layout += $k.chars;
	}
	if $fields-in-layout != %board.keys.elems {
		die "Overlapping pieces.";
	}

}

sub moves-in-groove ( $length, @fields ) {
	my @result;

	for 0 .. @fields.elems - $length -> $start-pos {
		for 0  .. @fields.elems - $length -> $end-pos {
			next if $start-pos == $end-pos;

			my $from = @fields[ $start-pos .. $start-pos + $length - 1 ].join( '' );
			my $to   = @fields[ $end-pos   .. $end-pos   + $length - 1 ].join( '' );

			my @must-be-empty-fields;
			if $start-pos < $end-pos > 0  {
				@must-be-empty-fields = @fields[ $start-pos + $length .. $end-pos + $length - 1 ];
			}
			else {
				@must-be-empty-fields = @fields[ $end-pos .. $start-pos - 1 ];
			}
			
			@result.push( [ $from, $to, @must-be-empty-fields.join(',') ] );
		}
	}

	return @result;
}

sub generate-all-moves ( %initial-layout, %field-to-id ) {
	my @moves;

	my %grooves-seen;
	for %initial-layout.keys -> $piece {
		my $groove = $piece.substr( 0, 1 );
		my $length = $piece.chars - 1;
		next if %grooves-seen.exists( { $groove ~ $length } );

		my @fields = %field-to-id.keys.grep( { .substr( 0, 1 ) eq $groove } ).sort.map( { %field-to-id{$_} } );
		my @arr = moves-in-groove( $length, @fields );
		@moves.push( moves-in-groove( $length, @fields ) );
		%grooves-seen{ $groove ~ $length } = 1;
	}

	return @moves;
}



# Board analysis

sub check-l-groove ( %initial-layout ) { # Return false if there is more than one piece on groove L.
	for %initial-layout.keys -> $k {
		return if $k.substr( 0, 1 ) eq 'l' && $k ne 'l12';
	}
	return 1;
}
	

sub transform-layout( %layout, $transformation ) {
	my %new-layout = %layout;
	return %new-layout unless $transformation.chars;

	for $transformation.split( ' ' ) -> $from, $to {
		%new-layout.delete( $from );
		%new-layout{ $to } = 1;
	}

	return %new-layout;
}

sub layout-to-board( %layout ) {
	my @fields = %layout.keys.map( { $_.split( '' ) } );
	my %board;
	%board{ @fields } = ( 1 ) xx %board.elems;
	return %board;
}

sub solve ( %initial-layout, @moves, $success ) {
	my @queue;
	my @next-queue = "";
	my %positions_seen;
	loop {
		if @next-queue.elems == 0 {
			return;
		}

		( @queue, @next-queue ) .= reverse();
		@next-queue = ();

		for @queue -> $history {
			my %layout = transform-layout( %initial-layout, $history );
			my %board = layout-to-board( %layout );

			for @moves -> $from, $to, $fields {
				# Check if a piece is placed in the $from position.
				next unless %layout.exists( $from );

				# Check if fields required for move are empty.
				next if grep { %board.exists( $_  )  }, $fields.split( '' );

				# Transform and serialize board
				for $from.split( '' ) -> $f { %board.delete( $f ); }
				for $to.split( '' )   -> $f { %board{ $f } = 1; }

				my $key = %board.keys.sort.join( '' );

				for $to.split( '' )   -> $f { %board.delete( $f ); }
				for $from.split( '' ) -> $f { %board{ $f } = 1; }	

				next if %positions_seen.exists( $key );

				%positions_seen{$key} = 1;
				my $new-move = ( $history.chars ?? "$history " !! '' ) ~ "$from $to";
				if $to eq $success {
					return $new-move;
				}
				@next-queue.push( $new-move );
			}
		}
	}
}



# Arghhh, have the solution but have to print it in the desired format

sub decode-piece ( $piece, @boards ) {
	my @pos = $piece.split( '' ).map( { ord( $_ ) - ord( ' ' ) -  1 } );

	for 0 .. @boards.end -> $i {
		my @alpha-fields = @pos.map( { @boards[$i][$_] } );
		if @alpha-fields[0].substr( 0, 1 ) eq @alpha-fields[1].substr( 0, 1 ) {
			my $result = @alpha-fields.shift ~ @alpha-fields.map( { $_.substr( 1 ) } ).join( '' );
			return $result;
		}
	}
	die "Corrupted input.";
}

sub decode-result ( $moves, @boards ) {
	return "No solution.\n" unless $moves.chars;

	my $result;
	for $moves.split( ' ' ) -> $from, $to {
		my $f = decode-piece( $from, @boards );
		my $t = decode-piece( $to, @boards );
		
		$result ~= $f.substr( 0, 1 ) ~ '[' ~ $f.substr( 1 );
		$result ~= ' -> ' ~ $t.substr( 1 ) ~ "]\n";
	}

	return $result;
}

sub MAIN {
	my %field-to-id;
	for 0 .. @BOARDS.end -> $i {
		fill-dictionary( %field-to-id, @BOARDS[ $i ] );	
	}

	my %initial-layout = read-board( );
	my %layout = %initial-layout.keys.map( { encode-piece( $_, %field-to-id ), 1 } );
	assert-board( %initial-layout, %layout );

	my $result = '';
	if check-l-groove( %initial-layout ) {
		my @moves = generate-all-moves( %initial-layout, %field-to-id );

		# Sort the moves (shortest first) and then flatten the array of arrays.
		@moves = @moves.sort( { $^a[2].chars <=> $^b[2].chars } ).map( { @($_) } );

		$result = solve( %layout, @moves, encode-piece( 'l56', %field-to-id ) );
	};

	print decode-result( $result, @BOARDS );
}