RedBlack tree mockup in Corinna

RedBlack.pm

# RedBlack tree mockup for Corinna, modeled after https://metacpan.org/pod/Tree::RedBlack
# It is not guaranteed to work

use feature 'class';

# we really want this to be a private class, but we can't yet
class RedBlack::Node {
    field $key    :reader :writer :param { undef };
    field $value  :reader :writer :param { undef };
    field $parent :reader :writer :param { undef };
    field $color  :reader :writer;    # 1 is red, 0 is black
    field $right  :reader :writer;
    field $left   :reader :writer;

    method successor() {
        if ($right) {
            return $right->min;
        }
        my $parent = $parent;
        my $right  = $self;
        
        # the == relies on the fact that it should use the address of
        # the nodes. Sloppy.
        while ( $parent && $right == $parent->right ) {
            $right  = $parent;
            $parent = $right->parent;
        }
        $parent;
    }

    method minimum() {
        while ( $self->left ) {
            $self = $self->left;
        }
        return $self;
    }

    method maximum() {
        while ( $self->right ) {
            $self = $self->right;
        }
        return $self;
    }

    method replace_with( $new_node //= RedBlack::Node->new ) {
        $key   = $new_node->key;
        $key   = $new_node->key;
        $value = $new_node->value;
        $left  = $new_node->left;
        $right = $new_node->right;
        $color = $new_node->color;
    }
}

class RedBlack {
    use RedBlack::Node;
    use Scalar::Util 'blessed';

    field $cmp  :param { sub ( $key1, $key2 ) { return $key1 eq $key2 } };
    field $root :param { undef }; # contains a RedBlack::Node guaranteed to be black

    method insert( $key, $value=undef ) {
        my $node = $root;
        my $parent;
        while ($node) {
            $parent = $node;
            if ( !$cmp->( $key, $node->key ) ) {
                $node = $node->left;
            }
            else {
                $node = $node->right;
            }
        }
        if ($parent) {

            # Handle case of inserting node with duplicate key.
            if ( $cmp->( $parent->key, $key ) ) {
                my $val = $parent->value;
                $parent->set_value($value);
                return $val;
            }
            $node = ( ref $parent )->new(
                key    => $key,
                value  => $value,
                parent => $parent,
            );
            if ( !$cmp->( $key, $parent->key ) ) {
                $parent->set_left($node);
            }
            else {
                $parent->set_right($node);
            }
        }
        else {
            $root = $node = RedBlack::Node->new( key => $key, value => $value );
        }
        $node->set_color(1);
        while ( $node != $root && $node->parent->color ) {
            if ( defined $node->parent->parent->left
                && $node->parent == $node->parent->parent->left )
            {
                my $uncle = $node->parent->parent->right;
                if ( $uncle && $uncle->color ) {
                    $node->parent->set_color(0);
                    $uncle->set_color(0);
                    $node->parent->parent->set_color(1);
                    $node = $node->parent->parent;
                }
                else {
                    if ( $node == $node->parent->right ) {
                        $node = $node->parent;
                        $self->left_rotate($node);
                    }
                    $node->parent->set_color(0);
                    $node->parent->parent->set_color(1);
                    $self->right_rotate( $node->parent->parent );
                }
            }
            else {
                my $uncle = $node->parent->parent->left;
                if ( $uncle && $uncle->color ) {
                    $node->parent->set_color(0);
                    $uncle->set_color(0);
                    $node->parent->parent->set_color(1);
                    $node = $node->parent->parent;
                }
                else {
                    if ( defined $node->parent->left
                        && $node == $node->parent->left )
                    {
                        $node = $node->parent;
                        $self->right_rotate($node);
                    }
                    $node->parent->set_color(0);
                    $node->parent->parent->set_color(1);
                    $self->left_rotate( $node->parent->parent );
                }
            }
        }
        $root->set_color(0);
        return;
    }

    method minimum() {
        if ($root) {
            if ( $root->left ) {
                return $root->left->minimum;
            }
            else {
                return $root;
            }
        }
        return;
    }

    method maximum() {
        if ($root) {
            if ( $root->right ) {
                return $root->right->maximum;
            }
            else {
                return $root;
            }
        }
        return;
    }

    method find($key) {
        my $node = $root;
        while ($node) {
            if ( $cmp->( $key, $node->key ) ) {
                return $node->value;
            }
            elsif ( $cmp->( $key, $node->key ) < 0 ) {
                $node = $node->left;
            }
            else {
                $node = $node->right;
            }
        }

        # Got to the end without finding the node.
        return;
    }

    # this has a bug, faithfully copied from the original, but
    # since it's only a mockup, I'm not too concerned for now.
    method delete ($key) {
        my $node = $self->find_node($key) or return;

        my ( $successor, $successor_child );
        if ( !( $node->left && $node->right ) ) {
            $successor = $node;
        }
        else {
            $successor = $node->successor;
        }
        if ( $successor->left ) {
            $successor_child = $successor->left;
        }
        else {
            $successor_child = $successor->right || RedBlack::Node->new;
        }
        $successor_child->set_parent( $successor->parent );
        if ( !$successor_child || !$successor_child->parent ) {
            $root = $successor_child;
        }
        elsif ( $successor == $successor->parent->left ) {
            $successor->parent->set_left($successor_child);
        }
        else {
            $successor->parent->set_right($successor_child);
        }
        if ( $successor != $node ) {
            $node->set_key( $successor->key );
            $node->set_value( $successor->value );
        }
        if ( !$successor->color ) {
            $self->delete_fixup($successor_child);
        }
        if ( !$successor_child->parent ) {
            $root = undef;
        }
        $successor;
    }

    # private methods start here
    method delete_fixup ($x) :private {
        while ( $x != $root && !$x->color ) {
            if ( $x == $x->parent->left ) {
                my $w = $x->parent->right;
                if ( $w->color ) {
                    $w->set_color(0);
                    $x->parent->set_color(1);
                    $self->left_rotate( $x->parent );
                }
                if ( !$w->left->color && !$w->right->color ) {
                    $w->set_color(1);
                    $x = $x->parent;
                }
                else {
                    if ( !$w->right->color ) {
                        $w->left->set_color(0);
                        $w->set_color(1);
                        $self->right_rotate($w);
                        $w = $x->parent->right;
                    }
                    $w->set_color( $x->parent->color );
                    $x->parent->set_color(0);
                    $w->right->set_color(0);
                    $self->left_rotate( $x->parent );
                    $x = $root;
                }
            }
            else {
                my $w = $x->parent->left;
                if ( $w->color ) {
                    $w->set_color(0);
                    $x->parent->set_color(1);
                    $self->right_rotate( $x->parent );
                }
                if ( !$w->left->color && !$w->right->color ) {
                    $w->set_color(1);
                    $x = $x->parent;
                }
                else {
                    if ( !$w->left->color ) {
                        $w->right->set_color(0);
                        $w->set_color(1);
                        $self->left_rotate($w);
                        $w = $x->parent->left;
                    }
                    $w->color( $x->parent->color );
                    $x->parent->set_color(0);
                    $w->left->set_color(0);
                    $self->right_rotate( $x->parent );
                    $x = $root;
                }
            }
        }
        $x->set_color(0);
    }

    method find_node($key) :private {
        my $node = $root;
        while ($node) {
            if ( $cmp->( $key, $node->key ) ) {
                return $node;
            }
            elsif ( $cmp->( $key, $node->key ) < 0 ) {
                $node = $node->left;
            }
            else {
                $node = $node->right;
            }
        }

        # Got to the end without finding the node.
        return;
    }

    method left_rotate($node) :private {
        my $child = $node->right;
        $node->set_right( $child->left );
        if ( $child->left ) {
            $child->left->set_parent($node);
        }
        $child->set_parent( $node->parent );
        if ( $node->parent ) {
            if ( $node == $node->parent->left ) {
                $node->parent->set_left($child);
            }
            else {
                $node->parent->set_right($child);
            }
        }
        else {
            $root = $child;
        }
        $child->set_left($node);
        $node->set_parent($child);
    }

    method right_rotate($node) :private {
        my $child = $node->left;
        $node->set_left( $child->right );
        if ( $child->right ) {
            $child->right->set_parent($node);
        }
        $child->set_parent( $node->parent );
        if ( $node->parent ) {
            if ( $node == $node->parent->right ) {
                $node->parent->set_right($child);
            }
            else {
                $node->parent->set_left($child);
            }
        }
        else {
            $root = $child;
        }
        $child->set_right($node);
        $node->set_parent($child);
    }
}

I agree with all the points up to 5th. Regarding that one, there are many designs in software development where adding an extra layer of abstraction is useful or might theoretically be useful in the future, but another whole class of problems where the internal data structures have no reason at all to ever be subclassed outside the knowledge of the containing class, and having the containing class use the method abstraction does nothing except waste performance. Red/Black trees are a prime example of that second group of problems, which is the point I was going for above.

"First make it right, then make it fast." ... and perl 6 did exactly that, and is arguably the prime reason it failed.

I would argue for the approach used by Git. "Make it right and fast (and ugly), then make it pretty and convenient". Perl blessed arrays are already right and fast, and just need syntactic sugar and helpful tooling so that they are less of a pain to use. It sure would be nice if Corinna had a provision for that, including protected access of named fields that compiles into array access (or pad access).