sub format_string {
my ($str) = @_;
return $str if ! $str;
my $new_str = '';
for my $chr (split '', $str) {
my $ord = ord($chr);
if ($ord < 255) {
$new_str .= $chr;
next;
}
$new_str .= '' . sprintf("%x", $ord) . ';';
}
return $new_str;
}
####
my $wid = WaitWindow('Notepad', 5);
# Paranoia - make sure we are affecting the desired window
SetActiveWindow($wid);
SetFocus($wid);
SetForegroundWindow($wid);
# Used to determine where to move the mouse later
my ($left, $top, $right, $bottom) = GetWindowRect($wid);
# Enable moving the mouse to move the window
# I *THINK* this will work
SendKeys("%{SPACE}M{DOWN}");
my ($x, $y) = calculate_position_from($left, $top, $right, $bottom);
MouseMoveAbsPix($x,$y);
SendKeys("{ENTER}");
##
##
## Shared the array of select ids
my @id :shared;
## Select them
while (my $rec = $sth->fetchrow_hashref) {
push @id, $rec->{unique_id} if desired_rec($rec);
}
## Set the number of threads--start with 1 per core
our $T //= 4;
## break up the array into non-overlapping ranges
my( $step, $s, @ranges ) = ( int @id / $T, 0 );
push( @ranges, [ $s, $s + $step -1 ] ), $s += $step for 1 ..$T;
$ranges[ -1][1] = scalar @id;
my @threads;
## Loop over those ranges
for my $range ( @ranges ) {
##starting a new thread for each
push @threads, async {
## Create a new handle in each thread
my $dbh = DBI->connect( ... ) or die ..;
my $del_sth = $dbh->prepare("DELETE FROM TBL WHERE unique_id = ?");
## process the subrange one at a time
for( @id[ @$range ] ) {
eval {
$del_sth->execute($_);
};
$logger->write("Failed to remove '$_'") if $@;
}
## till done
$dbh->disconnect;
};
}
## Wait for them
$_->join for @threads;
##
##
sub _insert {
my ($node, $cmp, $key, $val) = @_;
return [RED, $key, $val, undef, undef] if ! $node;
# Do foo with $node
my $result = $key cmp $node->[KEY];
if ($result == EQUAL) {
$node->[VALUE] = $val;
}
elsif ($result == MORE) {
$node->[RIGHT] = _insert($node->[RIGHT], $cmp, $key, $val);
}
else {
$node->[LEFT] = _insert($node->[LEFT], $cmp, $key, $val);
}
# Do bar with $node
# Do blah with $node
return $node;
}
##
##
sub _insert {
my ($node, $cmp, $key, $val) = @_;
my ($found, @stack);
while ($node) {
_colorFlip($node) if _isRed($node->[RIGHT]) && _isRed($node->[LEFT]);
push @stack, [$node, undef];
my $result = $cmp->($key, $node->[KEY]);
# Dup key, replace value
if ($result == EQUAL) {
($found, $node->[VALUE]) = (1, $val);
$node = undef;
}
# Descend right
elsif ($result == MORE) {
$stack[LAST][DIR] = RIGHT;
$node = $node->[RIGHT];
}
# Descend right
else {
$stack[LAST][DIR] = LEFT;
$node = $node->[LEFT];
}
}
push @stack, [[RED, $key, $val, undef, undef], undef] if ! $found;
my $assign;
while (@stack) {
my $unwind = pop @stack;
my ($item, $dir) = @{$unwind}[NODE, DIR];
if ($assign || $found) {
$item->[$dir] = $assign->[NODE] if $assign;
$item = _rotateLeft($item) if _isRed($item->[RIGHT]) && ! _isRed($item->[LEFT]);
$item = _rotateRight($item) if _isRed($item->[LEFT]) && _isRed($item->[LEFT][LEFT]);
}
$assign = [$item, undef];
}
return $assign->[NODE];
}
##
##
package Tree::Binary::RedBlack;
require Exporter;
@ISA = 'Exporter';
@EXPORT = qw/
deleteKey
deleteMax
deleteMin
insert
key_exists
lookup
max
min
new_rb
node_count
/;
our $VERSION = '0.01';
# Tree definition
use constant ROOT => 0;
use constant COUNT => 1;
use constant COMPARE => 2;
# Node definition
use constant COLOR => 0;
use constant KEY => 1;
use constant VALUE => 2;
use constant RIGHT => 3;
use constant LEFT => 4;
# Color definition
use constant BLACK => 0;
use constant RED => 1;
# Comparison definition
use constant LESS => -1;
use constant EQUAL => 0;
use constant MORE => 1;
# Truth definition
use constant TRUE => 1;
use constant FALSE => undef;
# Stack definition
use constant LAST => -1;
use constant NODE => 0;
use constant DIR => 1;
use strict;
use warnings;
use Carp;
use UNIVERSAL 'isa';
# Public
sub new_rb {
croak "Incorrect number of parameters" if @_ % 2;
my %opt = @_;
my $cmp = delete $opt{compare} || 'cmp';
if (isa($cmp, 'CODE')) {
*_insert = *_insert_custom;
}
elsif($cmp eq 'cmp') {
#*_insert = *_insert_ascii;
*_insert = *_insert_cmp;
}
else {
croak "The '$cmp' comparison is not supported";
}
carp "The '$_' parameter is not supported\n" for keys %opt;
return [undef, 0, $cmp];
}
# Public
sub insert {
my ($tree, $key, $val) = @_;
$tree->[ROOT] = _insert($tree->[ROOT], $tree->[COMPARE], $key, $val);
$tree->[COUNT]++;
$tree->[ROOT][COLOR] = BLACK;
}
# Private
sub _insert_custom {
my ($node, $cmp, $key, $val) = @_;
return [RED, $key, $val, undef, undef] if ! $node;
if ($node->[RIGHT] && $node->[RIGHT][COLOR] && $node->[LEFT] && $node->[LEFT][COLOR]) {
$node->[COLOR] = ! $node->[COLOR] || BLACK;
$node->[LEFT][COLOR] = ! $node->[LEFT][COLOR] || BLACK;
$node->[RIGHT][COLOR] = ! $node->[RIGHT][COLOR] || BLACK;
}
my $result = $cmp->($key, $node->[KEY]);
if ($result == EQUAL) {
$node->[VALUE] = $val;
}
elsif ($result == MORE) {
$node->[RIGHT] = _insert($node->[RIGHT], $cmp, $key, $val);
}
else {
$node->[LEFT] = _insert($node->[LEFT], $cmp, $key, $val);
}
if ($node->[RIGHT] && $node->[RIGHT][COLOR] && ! ($node->[LEFT] && $node->[LEFT][COLOR])) {
my $temp = $node->[RIGHT];
$node->[RIGHT] = $temp->[LEFT];
$temp->[LEFT] = $node;
$temp->[COLOR] = $node->[COLOR];
$node->[COLOR] = RED;
$node = $temp;
}
if ($node->[LEFT] && $node->[LEFT][COLOR] && $node->[LEFT][LEFT] && $node->[LEFT][LEFT][COLOR]) {
my $temp = $node->[LEFT];
$node->[LEFT] = $temp->[RIGHT];
$temp->[RIGHT] = $node;
$temp->[COLOR] = $node->[COLOR];
$node->[COLOR] = RED;
$node = $temp;
}
return $node;
}
sub _insert_cmp {
my ($node, $cmp, $key, $val) = @_;
return [RED, $key, $val, undef, undef] if ! $node;
if ($node->[RIGHT] && $node->[RIGHT][COLOR] && $node->[LEFT] && $node->[LEFT][COLOR]) {
$node->[COLOR] = ! $node->[COLOR] || BLACK;
$node->[LEFT][COLOR] = ! $node->[LEFT][COLOR] || BLACK;
$node->[RIGHT][COLOR] = ! $node->[RIGHT][COLOR] || BLACK;
}
my $result = $key cmp $node->[KEY];
if ($result == EQUAL) {
$node->[VALUE] = $val;
}
elsif ($result == MORE) {
$node->[RIGHT] = _insert($node->[RIGHT], $cmp, $key, $val);
}
else {
$node->[LEFT] = _insert($node->[LEFT], $cmp, $key, $val);
}
if ($node->[RIGHT] && $node->[RIGHT][COLOR] && ! ($node->[LEFT] && $node->[LEFT][COLOR])) {
my $temp = $node->[RIGHT];
$node->[RIGHT] = $temp->[LEFT];
$temp->[LEFT] = $node;
$temp->[COLOR] = $node->[COLOR];
$node->[COLOR] = RED;
$node = $temp;
}
if ($node->[LEFT] && $node->[LEFT][COLOR] && $node->[LEFT][LEFT] && $node->[LEFT][LEFT][COLOR]) {
my $temp = $node->[LEFT];
$node->[LEFT] = $temp->[RIGHT];
$temp->[RIGHT] = $node;
$temp->[COLOR] = $node->[COLOR];
$node->[COLOR] = RED;
$node = $temp;
}
return $node;
}
sub _insert_ascii {
my ($node, $cmp, $key, $val) = @_;
my ($found, @stack);
while ($node) {
if ($node->[RIGHT] && $node->[RIGHT][COLOR] && $node->[LEFT] && $node->[LEFT][COLOR]) {
$node->[COLOR] = ! $node->[COLOR] || BLACK;
$node->[LEFT][COLOR] = ! $node->[LEFT][COLOR] || BLACK;
$node->[RIGHT][COLOR] = ! $node->[RIGHT][COLOR] || BLACK;
}
my $result = $key cmp $node->[KEY];
# Descend right
if ($result == LESS) {
push @stack, [$node, LEFT];
$node = $node->[LEFT];
}
# Descend right
elsif ($result == MORE) {
push @stack, [$node, RIGHT];
$node = $node->[RIGHT];
}
# Dup key, replace value
else {
push @stack, [$node];
($found, $node->[VALUE]) = (1, $val);
$node = undef;
}
}
push @stack, [[RED, $key, $val, undef, undef]] if ! $found;
my $idx = @stack;
my $assign;
while ($idx--) {
my ($item, $dir) = @{$stack[$idx]}[NODE, DIR];
if ($assign || $found) {
$item->[$dir] = $assign->[NODE] if $assign;
if ($item->[RIGHT] && $item->[RIGHT][COLOR] && ! ($item->[LEFT] && $item->[LEFT][COLOR])) {
my $temp = $item->[RIGHT];
$item->[RIGHT] = $temp->[LEFT];
$temp->[LEFT] = $item;
$temp->[COLOR] = $item->[COLOR];
$item->[COLOR] = RED;
$item = $temp;
}
if ($node->[LEFT] && $node->[LEFT][COLOR] && $node->[LEFT][LEFT] && $node->[LEFT][LEFT][COLOR]) {
my $temp = $node->[LEFT];
$node->[LEFT] = $temp->[RIGHT];
$temp->[RIGHT] = $node;
$temp->[COLOR] = $node->[COLOR];
$node->[COLOR] = RED;
$node = $temp;
}
}
$assign = [$item];
}
return $assign->[NODE];
}
sub lookup {
my ($tree, $key) = @_;
return FALSE if ! defined $key;
my ($root, $cmp) = ($tree->[ROOT], $tree->[COMPARE]);
while ($root) {
my $result = $cmp->($key, $root->[KEY]);
return $root->[VALUE] if $result == EQUAL;
$root = $result == LESS ? $root->[LEFT] : $root->[RIGHT];
}
return FALSE;
}
sub key_exists {
my ($tree, $key) = @_;
return FALSE if ! defined $key;
my ($root, $cmp) = ($tree->[ROOT], $tree->[COMPARE]);
while ($root) {
my $result = $cmp->($key, $root->[KEY]);
return TRUE if $result == EQUAL;
$root = $result == LESS ? $root->[LEFT] : $root->[RIGHT];
}
return FALSE;
}
sub node_count {
my ($tree) = @_;
return $tree->[COUNT];
}
sub deleteMin {
my ($tree) = @_;
$tree->[ROOT] = _deleteMin($tree->[ROOT]);
$tree->[COUNT]-- if $tree->[COUNT];
$tree->[ROOT][COLOR] = BLACK;
}
sub deleteKey {
my ($tree, $key) = @_;
$tree->[ROOT] = _deleteKey($tree->[ROOT], $tree->[COMPARE], $key);
$tree->[COUNT]-- if $tree->[COUNT];
$tree->[ROOT][COLOR] = BLACK;
}
sub max {
my ($tree, $key) = @_;
return FALSE if ! $tree->[ROOT];
return _max($tree->[ROOT]);
}
sub min {
my ($tree, $key) = @_;
return FALSE if ! $tree->[ROOT];
return _min($tree->[ROOT]);
}
sub deleteMax {
my ($tree) = @_;
$tree->[ROOT] = _deleteMax($tree->[ROOT]);
$tree->[COUNT]-- if $tree->[COUNT];
$tree->[ROOT][COLOR] = BLACK;
}
# Private
sub _deleteMax {
my ($node) = @_;
$node = _rotateRight($node) if _isRed($node->[LEFT]);
return FALSE if ! $node->[RIGHT];
$node = _moveRedRight($node) if ! _isRed($node->[RIGHT]) && ! _isRed($node->[RIGHT][LEFT]);
$node->[RIGHT] = _deleteMax($node->[RIGHT]);
return _fixUp($node);
}
sub _deleteKey {
my ($node, $cmp, $key) = @_;
if ($cmp->($key, $node->[KEY]) == LESS) {
$node = _moveRedLeft($node) if ! _isRed($node->[LEFT]) && ! _isRed($node->[LEFT][LEFT]);
$node->[LEFT] = _deleteKey($node->[LEFT], $cmp, $key);
}
else {
$node = _rotateRight($node) if _isRed($node->[LEFT]);
return FALSE if $cmp->($key, $node->[KEY]) == EQUAL && ! $node->[RIGHT];
$node = _moveRedRight($node) if ! _isRed($node->[RIGHT]) && ! _isRed($node->[RIGHT][LEFT]);
if ($cmp->($key, $node->[KEY]) == EQUAL) {
# Opportunity to return key/val together
$node->[VALUE] = _get($node->[RIGHT], $cmp, _min($node->[RIGHT]));
$node->[KEY] = _min($node->[RIGHT]);
$node->[RIGHT] = _deleteMin($node->[RIGHT]);
}
else {
$node->[RIGHT] = _deleteKey($node->[RIGHT], $key);
}
}
return _fixUp($node);
}
sub _get {
my ($node, $cmp, $key) = @_;
return FALSE if ! $node;
my $result = $cmp->($key, $node->[KEY]);
return $node->[VALUE] if $result == EQUAL;
return _get($node->[LEFT], $cmp, $key) if $result == LESS;
return _get($node->[RIGHT], $cmp, $key);
}
sub _min {
my ($node) = @_;
return $node->[KEY] if ! $node->[LEFT];
return _min($node->[LEFT]);
}
sub _max {
my ($node) = @_;
return $node->[KEY] if ! $node->[RIGHT];
return _max($node->[RIGHT]);
}
sub _deleteMin {
my ($node) = @_;
return FALSE if ! $node->[LEFT];
$node = _moveRedLeft($node) if ! _isRed($node->[LEFT]) && ! _isRed($node->[LEFT][LEFT]);
$node->[LEFT] = _deleteMin($node->[LEFT]);
return _fixUp($node);
}
sub _moveRedLeft {
my ($node) = @_;
_colorFlip($node);
if (_isRed($node->[RIGHT][LEFT])) {
$node->[RIGHT] = _rotateRight($node->[RIGHT]);
$node = _rotateLeft($node);
_colorFlip($node);
}
return $node;
}
sub _moveRedRight {
my ($node) = @_;
_colorFlip($node);
if (_isRed($node->[LEFT][LEFT])) {
$node = _rotateRight($node);
_colorFlip($node);
}
return $node;
}
sub _rotateLeft {
my ($node) = @_;
my $temp = $node->[RIGHT];
$node->[RIGHT] = $temp->[LEFT];
$temp->[LEFT] = $node;
$temp->[COLOR] = $node->[COLOR];
$node->[COLOR] = RED;
return $temp;
}
sub _rotateRight {
my ($node) = @_;
my $temp = $node->[LEFT];
$node->[LEFT] = $temp->[RIGHT];
$temp->[RIGHT] = $node;
$temp->[COLOR] = $node->[COLOR];
$node->[COLOR] = RED;
return $temp;
}
sub _isRed {
my ($node) = @_;
return FALSE if ! $node;
return $node->[COLOR] == RED;
}
sub _colorFlip {
my ($node) = @_;
$node->[COLOR] = ! $node->[COLOR] || BLACK;
$node->[LEFT][COLOR] = ! $node->[LEFT][COLOR] || BLACK;
$node->[RIGHT][COLOR] = ! $node->[RIGHT][COLOR] || BLACK;
}
sub _fixUp {
my ($node) = @_;
$node = _rotateLeft($node) if _isRed($node->[RIGHT]);
$node = _rotateRight($node) if _isRed($node->[LEFT]) && _isRed($node->[LEFT][LEFT]);
_colorFlip($node) if _isRed($node->[LEFT]) && _isRed($node->[RIGHT]);
return $node;
}
'This statement is false.';
__END__
OPTIMIZATIONS
1. Inline some subs
2. Turn recursion into a stack
3. Allow predefined comparison subs and then *foo = in order to not pay penalty
- ascii, numerical, coderef sub {$_[0] cmp $_[1]}
4. Add get_min_kv and get_max_kv (see _deleteKey)
5. Turn the things that make sense from recursion to iteration (but frustratingly, not insert)
6. Consider XS
7. As a configurable option, allow not storing values to reduce memory
FEATURES
1. Add val_defined
2. Iterator for going over the tree
GENERAL
1. Consistency in sub names
REFERENCE
1. http://www.cs.princeton.edu/~rs/talks/LLRB/08Dagstuhl/RedBlack.pdf
2. http://www.cs.princeton.edu/~rs/talks/LLRB/RedBlack.pdf
3. http://www.cs.princeton.edu/~rs/talks/LLRB/08Penn.pdf
##
##
UPDATE
table t
SET
race_id = (
SELECT
pkey_id
FROM
race r,
(SELECT * from race where pkey_id = t.race_id) x
WHERE
r.track_id = 41 AND
r.raceday = x.race_day AND
r.race = x.race
)
WHERE
race_id in (select pkey_id from race where track_id = 37)
##
##
table event
pkey_id = serial
event_id = integer
event_date = date(YYYY-MM-DD)
event_num = integer
UPDATE
event e
SET
event_id = 41
WHERE
event_id = 37 AND
NOT EXISTS (
SELECT
1
FROM
event
WHERE
event_id = 41 AND
event_date = e.event_date AND
event_num = e.event_num
)
##
##
print solve(
holes => 33,
empty => 17,
towin => 17,
valid => [
[1, 2, 3], [1, 4, 9], [2, 5, 10], [3, 6, 11],
[4, 5, 6], [4, 9, 16], [5, 10, 17], [6, 11, 18],
[7, 8, 9], [7, 14, 21], [8, 9, 10], [8, 15, 22],
[9, 10, 11], [9, 16, 23], [10, 11, 12], [10, 17, 24],
[11, 12, 13], [11, 18, 25], [12, 19, 26], [13, 20, 27],
[14, 15, 16], [15, 16, 17], [16, 17, 18], [16, 23, 28],
[17, 18, 19], [17, 24, 29], [18, 19, 20], [18, 25, 30],
[21, 22, 23], [22, 23, 24], [23, 24, 25], [23, 28, 21],
[24, 25, 26], [24, 29, 32], [25, 26, 27], [25, 30, 33],
[28, 29, 30], [31, 32, 33],
],
);
##
##
#!/usr/bin/perl
use strict;
use warnings;
for my $base (3 .. 9) {
print "\tBASE $base\n";
my $next = count_base($base);
my $n = 0;
while (my @dig = $next->()) {
my $num = join '', @dig;
if (restricted(@dig)) {
print "$n\n" if $n;
$n = 0;
#print "\t$num\n";
}
else {
++$n;
#print "$num\n";
}
}
print "\n\n";
}
sub restricted {
my @dig = @_;
my $i = 0;
while (! $dig[$i]) {
shift @dig;
}
for (1 .. $#dig) {
return 0 if $dig[$_] <= $dig[$_ - 1];
}
return 1;
}
sub count_base {
my $base = shift @_;
my @dig = (0) x $base;
my @end = 0 .. $base - 1;
return sub {
return () if "@dig" eq "@end";
my $pos = @dig;
while ($pos--) {
if (++$dig[$pos] < $base) {
@dig[$pos + 1 .. $#dig] = (0) x ($#dig - $pos);
return @dig;
}
}
};
}
##
##
#! /usr/bin/perl
use strict;
use warnings;
use Quantum::Superpositions;
my @array_1 = (1 .. 4);
my @array_2 = qw{1 2 2 3 3 3 4 4 4 4 7 6 5};
my @array_3 = eigenstates( any(@array_2) != all(@array_1) );
my @array_4 = Quantum::Superpositions::eigenstates( any(@array_2) != all(@array_1) );
print "Ordered:\n";
print "$_\n" for @array_3;
print "Hash:\n";
print "$_\n" for @array_4;
{
no warnings 'redefine';
*eigenstates = *main::eigenstates;
sub eigenstates ($) {
my @uniq;
my %seen;
for ( Quantum::Superpositions::collapse( $_[0] ) ) {
push @uniq , $_ if ! $seen{$_};
$seen{$_}++;
}
return @uniq;
}
}
##
##
package Some::Object;
use strict;
use warnings;
use Carp;
our $VERSION = '0.01';
sub new {
my $class = shift;
my $self = bless {}, $class;
croak "Incorrect number of parameters" if @_ % 2;
$self->_init(@_);
return $self;
}
sub _init {
my $self = shift;
my %default = (
foo => 'bar',
blah => 'asdf',
);
my %user = @_;
for ( keys %user ) {
delete $user{$_} if ! exists $default{$_};
}
for ( keys %default ) {
$user{$_} = $default{$_} if ! exists $user{$_};
}
$self->{OPT} = \%user;
}
##
##
#!/usr/bin/perl
use strict;
use warnings;
use Parallel::ForkManager;
use constant MAX_PROCS => 1;
use constant MAX_TIME => 10;
my ($pid, $ident, $start);
my $pm = new Parallel::ForkManager( MAX_PROCS );
@SIG{ qw(ABRT STOP TERM INT) } = (sub { kill 9, $pid; exit }) x 4;
$pm->run_on_start (
sub {
($pid, $ident)= @_;
$start = time;
print "$ident started at ", scalar localtime($start), " with pid: $pid\n";
}
);
$pm->run_on_wait (
sub {
if ( time - $start > MAX_TIME ) {
print "Killing $pid - taking too long to run\n";
kill 9, $pid;
}
},
1
);
$pm->run_on_finish (
sub {
($pid, my $exit_code, $ident) = @_;
print "$ident ($pid) just completed with : $exit_code\n";
}
);
while ( 1 ) {
$pid = $pm->start( 'health check' ) and next;
# We are in child process
for ( 1 .. rand 15 ) {
print "I am the child doing work\n";
sleep 1;
}
$pm->finish;
# We are in parent process
}