Perl's quicksort implemented in Perl

perl_quicksort_in_perl.pl

#!/Users/brian/bin/perls/perl5.20.0
use strict;
use warnings;

use List::Util qw(shuffle);
use Term::ANSIColor;
my @colors = qw(red blue green);

my $QSORT_ORDER_GUESS = 2;
my $QSORT_MAX_STACK   = 32;
my $QSORT_BREAK_EVEN  = 6;
my $QSORT_PLAY_SAFE   = 255;

my $array    = [ shuffle( 0 .. 9 ) ];
my $num_elts = @$array;
my $compare  = sub { $_[0] <=> $_[1] };
my $partition_stack_entry = [];
my $swapped;

my $qsort_cmp = sub {
	my( $elt1, $elt2 ) = @_;

	print "compare:    ";
	
	while( my( $index, $value ) = each $array ) {
		if( $index != $elt1 and $index != $elt2 ) {
			print "$value ";
			}
		elsif( $index == $elt1 ) {
			print colored( $value, $colors[0] ), ' ';
			}
		elsif( $index == $elt2 ) {
			print colored( $value, $colors[1] ), ' ';
			}
		}
	print "\n";

	$compare->( $array->[$elt1], $array->[$elt2] );
	};

my $qsort_swap = sub{
	my( $elt1, $elt2 ) = @_;

	$swapped++;
	print "   swap:    ";
	
	while( my( $index, $value ) = each $array ) {
		if( $index != $elt1 and $index != $elt2 ) {
			print "$value ";
			}
		elsif( $index == $elt1 ) {
			print colored( $value, $colors[0] ), ' ';
			}
		elsif( $index == $elt2 ) {
			print colored( $value, $colors[1] ), ' ';
			}
		}
	print "\n";

	my $temp = $array->[$elt1];
	$array->[$elt1] = $array->[$elt2];
	$array->[$elt2] = $temp;
	print "swapped:    ";

	while( my( $index, $value ) = each $array ) {
		if( $index != $elt1 and $index != $elt2 ) {
			print "$value ";
			}
		elsif( $index == $elt1 ) {
			print colored( $value, $colors[1] ), ' ';
			}
		elsif( $index == $elt2 ) {
			print colored( $value, $colors[0] ), ' ';
			}
		}
	print "\n";
	};

my $qsort_rotate = sub {
	my( $elt1, $elt2, $elt3 ) = @_;
	my $temp = $array->[$elt1];
	print " rotate:    ";
	while( my( $index, $value ) = each $array ) {
		if( $index != $elt1 and $index != $elt2 and $index != $elt3 ) {
			print "$value ";
			}
		elsif( $index == $elt1 ) {
			print colored( $value, $colors[0] ), ' ';
			}
		elsif( $index == $elt2 ) {
			print colored( $value, $colors[1] ), ' ';
			}
		elsif( $index == $elt3 ) {
			print colored( $value, $colors[2] ), ' ';
			}
		}
	print "\n";

	$array->[$elt1] = $array->[$elt2];
	$array->[$elt2] = $array->[$elt3];
	$array->[$elt3] = $temp;

	print "rotated:    ";
	while( my( $index, $value ) = each $array ) {
		if( $index != $elt1 and $index != $elt2 and $index != $elt3 ) {
			print "$value ";
			}
		elsif( $index == $elt1 ) {
			print colored( $value, $colors[2] ), ' ';
			}
		elsif( $index == $elt2 ) {
			print colored( $value, $colors[0] ), ' ';
			}
		elsif( $index == $elt3 ) {
			print colored( $value, $colors[1] ), ' ';
			}
		}
	print "\n";
	};

my $quicksort = sub {
	my( $array, $num_elts, $compare ) = @_;
	
	return if $num_elts == 1;

	my $partition_stack = [];
	my $next_stack_entry = 0;

	my $last_index = $#$array;
	my $part_left  = 0;
	my $part_right = $last_index;
	
	my $qsort_break_even = $QSORT_BREAK_EVEN;

	OUTER: for( ;; ) {
		if( ($part_right - $part_left) >= $qsort_break_even ) {
			my $pc_left    = int( ($part_left + $part_right ) / 2 );
			my $pc_right   = $pc_left;
	
			my $u_right    = $pc_left  - 1;
			my $u_left     = $pc_right + 1;
	
			$swapped = 0;

			my $s = $qsort_cmp->( $u_right, $pc_left );
			if( $s < 0 ) { # l < c
				$s = $qsort_cmp->( $pc_left, $u_left ); # if l < c, c < r - already in order - nothing to do
				if( $s == 0 ) { # l < c, c == r - already in order, pc grows
					++$pc_right;
					} 
				elsif( $s > 0) { # l < c, c > r - need to know more
					$s = $qsort_cmp->( $u_right, $u_left );
					if( $s < 0 ) { #l < c, c > r, l < r - swap c & r to get ordered
						$qsort_swap->( $pc_left, $u_left );
						} 
					elsif( $s == 0) { # l < c, c > r, l == r - swap c &r , grow pc
						$qsort_swap->( $pc_left, $u_left );
						--$pc_left;
						} 
					else { # l < c, c > r, l > r - make lcr into rlc to get ordered
						$qsort_rotate->( $pc_left, $u_right, $u_left );
						}
					}	
				}
			elsif( $s == 0 ) { # l == c
				$s = $qsort_cmp->( $pc_left, $u_left );
				if( $s < 0 ) { # l == c, c < r - already in order, grow pc
					--$pc_left;
					} 
				elsif( $s == 0 ) { # l == c, c == r - already in order, grow pc both ways
					--$pc_left;
					++$pc_right;
					} 
				else { # l == c, c > r - swap l & r, grow pc
				$qsort_swap->(  $u_right, $u_left );
					++$pc_right;
					}
				}
			else { #  l > c 
				$s = $qsort_cmp->( $pc_left, $u_left );
				if( $s < 0) { # l > c, c < r - need to know more
				   $s = $qsort_cmp->( $u_right, $u_left );
				   if( $s < 0) { # l > c, c < r, l < r - swap l & c to get ordered
						$qsort_swap->( $u_right, $pc_left );
						} 
					elsif( $s == 0) { # l > c, c < r, l == r - swap l & c, grow pc
						$qsort_swap->( $u_right, $pc_left );
						++$pc_right;
						} 
					else { # l > c, c < r, l > r - rotate lcr into crl to order
						$qsort_rotate->( $u_right, $pc_left, $u_left );
						}
					} 
				elsif( $s == 0 ) { # l > c, c == r - swap ends, grow pc
					$qsort_swap->( $u_right, $u_left );
					--$pc_left;
					} 
				else { # l > c, c > r - swap ends to get in order
					$qsort_swap->( $u_right, $u_left );
					}
				}

			--$u_right;
			++$u_left;

			INNER: for( ;; ) {
				my $still_work_on_left;
				my $still_work_on_right;

				LEFT: while( $still_work_on_left = $u_right >= $part_left ) {
					$s = $qsort_cmp->( $u_right, $pc_left );
					if( $s < 0 ) {
						--$u_right;
						} 
					elsif( $s == 0 ) {
						--$pc_left;
						if( $pc_left != $u_right ) {
							$qsort_swap->( $u_right, $pc_left );
							}
						--$u_right;
						} 
					else {
						last LEFT;
						}
					}

				RIGHT: while( $still_work_on_right = $u_left <= $part_right ) {
				   $s = $qsort_cmp->( $pc_right, $u_left );
				   if( $s < 0 ) {
						++$u_left;
						} 
					elsif( $s == 0 ) {
						++$pc_right;
						if( $pc_right != $u_left ) {
							$qsort_swap->( $pc_right, $u_left );
							}
						++$u_left;
						} 
					else {
						last RIGHT;
						}
					}

				if( $still_work_on_left ) {
					if( $still_work_on_right ) {
						$qsort_swap->( $u_right, $u_left );
						--$u_right;
						++$u_left;
						} 
					else {
						--$pc_left;
						if( $pc_left == $u_right ) {
							$qsort_swap->( $u_right, $pc_right );
							} 
						else {
							$qsort_rotate->( $u_right, $pc_left, $pc_right );
							}
						--$pc_right;
						--$u_right;
					   }
					} 
				elsif( $still_work_on_right ) {
					++$pc_right;
					if( $pc_right == $u_left ) {
						$qsort_swap->( $u_left, $pc_left );
						} 
					else {
						$qsort_rotate->( $pc_right, $pc_left, $u_left );
						}
					++$pc_left;
					++$u_left;
					} 
				else {
					last INNER;
					}
				}

			if( $swapped < 3 ) {
				$qsort_break_even *= 2;
				} 
			else {
				$qsort_break_even = $QSORT_BREAK_EVEN;
				}

			if( $part_left < $pc_left ) {
				if( $pc_right < $part_right ) {
					if( ($part_right - $pc_right ) > ($pc_left - $part_left )) {
						$partition_stack->[$next_stack_entry]{left} = $pc_right + 1;
						$partition_stack->[$next_stack_entry]{right} = $part_right;
						$partition_stack->[$next_stack_entry]{qsort_break_even} = $qsort_break_even;
						$part_right = $pc_left - 1;
						} 
					else {
						$partition_stack->[$next_stack_entry]{left} = $part_left;
						$partition_stack->[$next_stack_entry]{right} = $pc_left - 1;
						$partition_stack->[$next_stack_entry]{qsort_break_even} = $qsort_break_even;
						$part_left = $pc_right + 1;
						}
				   ++$next_stack_entry;
					} 
				else {
					$part_right = $pc_left - 1;
					}
				} 
			elsif( $pc_right < $part_right ) {
				$part_left = $pc_right + 1;
				} 
			else {
				if( $next_stack_entry == 0) {
					last;
					}
				--$next_stack_entry;
				$part_left = $partition_stack->[$next_stack_entry]{left};
				$part_right = $partition_stack->[$next_stack_entry]{right};
				$qsort_break_even = $partition_stack->[$next_stack_entry]{qsort_break_even};
				}
			} 
		else {
			my $i;
			for( $i = $part_left + 1; $i <= $part_right; ++$i ) {
				my $j;
				for( $j = $i - 1; $j >= $part_left; --$j ) {
					if( $qsort_cmp->( $i, $j ) >= 0 ) {
						last;
						}
					}
				++$j;
				if( $j != $i) {
					my $k;
					print "  shift:    ";

					while( my( $index, $value ) = each $array ) {
						if( $index > $i or $index < $j ) {
							print "$value ";
							}
						elsif( $index == $i ) {
							print colored( $value, $colors[0] ), ' ';
							}
						else {
							print colored( $value, $colors[1] ), ' ';
							}
						}
					print "\n";

					my $temp = $array->[$i];
					for( $k = $i - 1; $k >= $j; --$k ) {
						$array->[ $k + 1 ] = $array->[$k];
						}
					$array->[$j] = $temp;

					print "shifted:    ";
					while( my( $index, $value ) = each $array ) {
						if( $index > $i or $index < $j ) {
							print "$value ";
							}
						elsif( $index == $j ) {
							print colored( $value, $colors[0] ), ' ';
							}
						else {
							print colored( $value, $colors[1] ), ' ';
							}
						}
					print "\n";
					}
				}

			if( $next_stack_entry == 0) {
				last;
				}

			 --$next_stack_entry;
			 $part_left = $partition_stack->[$next_stack_entry]{left};
			 $part_right = $partition_stack->[$next_stack_entry]{right};
			 $qsort_break_even = $partition_stack->[$next_stack_entry]{qsort_break_even};
			}
		}
	};

print "@$array\n";
$quicksort->( $array, scalar @$array, $compare );
print "@$array\n";