Algebraic data types

Some languages offer direct support for algebraic data types and pattern matching on them. While this of course can always be simulated with manual tagging and conditionals, it allows for terse code which is easy to read, and can represent the algorithm directly.

Task

As an example, implement insertion in a red-black-tree.

A red-black-tree is a binary tree where each internal node has a color attribute red or black. Moreover, no red node can have a red child, and every path from the root to an empty node must contain the same number of black nodes. As a consequence, the tree is balanced, and must be re-balanced after an insertion.

Reference

Red-Black Trees in a Functional Setting

Bracmat

<lang bracmat>( ( balance

 =   a x b y c zd
   .       !arg
         : ( B
           .   ( ( R
                 .   ((R.?a,?x,?b),?y,?c)
                   | (?a,?x,(R.?b,?y,?c))
                 )
               , ?zd
               )
             | ( ?a
               , ?x
               , ( R
                 .   ((R.?b,?y,?c),?zd)
                   | (?b,?y,(R.?c,?zd))
                 )
               )
           )
       & (R.(B.!a,!x,!b),!y,(B.!c,!zd))
     | !arg
 )

& ( ins

 =   C X tree a m z
   .     !arg:(?X.?tree)
       & !tree:(?C.?a,?m,?z)
       & (   !X:<!m
           & balance$(!C.ins$(!X.!a),!m,!z)
         |   !X:>!m
           & balance$(!C.!a,!m,ins$(!X.!z))
         | !tree
         )
     | (R.,!X,)
 )

& ( insert

 =   X tree
   .   !arg:(?X.?tree)
     & ins$(!X.!tree):(?.?X)
     & (B.!X)
 )

& ( insertMany

 =   L R tree
   .     !arg:(%?L_%?R.?tree)
       & insertMany$(!L.!tree):?tree
       & insertMany$(!R.!tree)
     | insert$!arg
 )

);</lang>

Test: <lang bracmat>( ( it allows for terse code which is easy to read

     , and can represent the algorithm directly
   .
   )
 : ?values

& insertMany$(!values.):?tree & lst$tree & done );</lang>

Output: <lang bracmat>(tree=

. ( B

   .   (R.(B.,,),algorithm,(B.,allows,))
     , and
     , (B.,can,)
   )
 , code
 , ( R
   .   ( B
       .   (B.(R.,directly,),easy,)
         , for
         , (B.(R.,is,),it,)
       )
     , read
     , ( B
       .   (B.,represent,)
         , terse
         , (R.(B.,the,),to,(B.,which,))
       )
   )

);</lang>

C++

Translation of: Haskell

Compile time

C++ templates have a robust pattern matching facility, with some warts - for example, nested templates cannot be fully specialized, so we must use a dummy template parameter. This implementation uses C++17 deduced template parameters for genericity.

<lang cpp>enum Color { R, B }; template<Color, class, auto, class> struct T; struct E;

template<Color col, class a, auto x, class b> struct balance {

   using type = T<col, a, x, b>;

}; template<class a, auto x, class b, auto y, class c, auto z, class d> struct balance<B, T<R, T<R, a, x, b>, y, c>, z, d> {

   using type = T<R, T<B, a, x, b>, y, T<B, c, z, d>>;

}; template<class a, auto x, class b, auto y, class c, auto z, class d> struct balance<B, T<R, a, x, T<R, b, y, c>>, z, d> {

   using type = T<R, T<B, a, x, b>, y, T<B, c, z, d>>;

}; template<class a, auto x, class b, auto y, class c, auto z, class d> struct balance<B, a, x, T<R, T<R, b, y, c>, z, d>> {

   using type = T<R, T<B, a, x, b>, y, T<B, c, z, d>>;

}; template<class a, auto x, class b, auto y, class c, auto z, class d> struct balance<B, a, x, T<R, b, y, T<R, c, z, d>>> {

   using type = T<R, T<B, a, x, b>, y, T<B, c, z, d>>;

};

template<auto x, class s> struct insert {

   template<class, class = void> struct ins;
   template<class _> struct ins<E, _> { using type = T<R, E, x, E>; };
   template<Color col, class a, auto y, class b> struct ins<T<col, a, y, b>> {
       template<int, class = void> struct cond;
       template<class _> struct cond<-1, _> : balance<col, typename ins<a>::type, y, b> {};
       template<class _> struct cond<1, _> : balance<col, a, y, typename ins::type> {};
       template<class _> struct cond<0, _> { using type = T<col, a, y, b>; };
       using type = typename cond<x < y ? -1 : y < x ? 1 : 0>::type;
   };
   template<class> struct repaint;
   template<Color col, class a, auto y, class b>
   struct repaint<T<col, a, y, b>> { using type = T<B, a, y, b>; };
   using type = typename repaint<typename ins::type>::type;

}; template<auto x, class s> using insert_t = typename insert<x, s>::type;

template<class> void print(); int main() {

~~print<insert_t<1, insert_t<2, insert_t<0, insert_t<4, E>>>>>();~~

}</lang>

~~Run time~~

Although C++ has structured bindings and pattern matching through function overloading, it is not yet possible to use them together so we must match the structure of the tree being rebalanced separately from decomposing it into its elements. A further issue is that function overloads are not ordered, so to avoid ambiguity we must explicitly reject any (ill-formed) trees that would match more than one case during rebalance.

<lang cpp>#include <memory>

~~include <variant>~~

template<class... Ts> struct overloaded : Ts... { using Ts::operator()...; }; template<class... Ts> overloaded(Ts...) -> overloaded<Ts...>;

enum Color { R, B }; using E = std::monostate; template<class, Color> struct Node; template<class T, Color C> using Ptr = std::unique_ptr<Node<T, C>>; template<class T> using Tree = std::variant<E, Ptr<T, R>, Ptr<T, B>>; template<class T, Color Col> struct Node {

~~static constexpr auto C = Col; Tree<T> left; T value; Tree<T> right;~~

}; template<Color C, class A, class T, class B> Tree<T> tree(A&& a, T& x, B&& b) {

~~return Tree<T>{Ptr<T, C>{new Node<T, C>{std::move(a), std::move(x), std::move(b)}}};~~

}

template<class T> Tree<T> balance(Tree<T> s) {

auto&& ll = [](Ptr<T, R>& s, Ptr<T, R>& t, auto&, Ptr<T, B>& u, auto&, auto&, auto&) { auto& [a, x, b] = *s; auto& [s_, y, c] = *t; auto& [t_, z, d] = *u; return tree<R>(tree(a, x, b), y, tree(c, z, d)); }; auto&& lr = [](auto&, Ptr<T, R>& s, Ptr<T, R>& t, Ptr<T, B>& u, auto&, auto&, auto&) { auto& [a, x, t_] = *s; auto& [b, y, c] = *t; auto& [s_, z, d] = *u; return tree<R>(tree(a, x, b), y, tree(c, z, d)); }; auto&& rl = [](auto&, auto&, auto&, Ptr<T, B>& s, Ptr<T, R>& t, Ptr<T, R>& u, auto&) { auto& [a, x, u_] = *s; auto& [b, y, c] = *t; auto& [t_, z, d] = *u; return tree<R>(tree(a, x, b), y, tree(c, z, d)); }; auto&& rr = [](auto&, auto&, auto&, Ptr<T, B>& s, auto&, Ptr<T, R>& t, Ptr<T, R>& u) { auto& [a, x, t_] = *s; auto& [b, y, u_] = *t; auto& [c, z, d] = *u; return tree<R>(tree(a, x, b), y, tree(c, z, d)); }; auto&& l = [](auto& s) -> Tree<T>& { return *std::visit(overloaded{[&](E) { return &s; }, [](auto& t) { return &t->left; }}, s); }; auto&& r = [](auto& s) -> Tree<T>& { return *std::visit(overloaded{[&](E) { return &s; }, [](auto& t) { return &t->right; }}, s); }; return std::visit([&](auto&... ss) -> Tree<T> { if constexpr (1 < std::is_invocable_v<decltype(ll), decltype(ss)...> + std::is_invocable_v<decltype(lr), decltype(ss)...> + std::is_invocable_v<decltype(rl), decltype(ss)...> + std::is_invocable_v<decltype(rr), decltype(ss)...>) throw std::logic_error{""}; else return overloaded{ll, lr, rl, rr, [&](auto&... ss) { return std::move(s); }}(ss...); }, l(l(s)), l(s), r(l(s)), s, l(r(s)), r(s), r(r(s)));

} template<class T> Tree<T> ins(T& x, Tree<T>& s) {

return std::visit(overloaded{ [&](E) -> Tree<T> { return tree<R>(s, x, s); }, [&](auto& t) { auto& [a, y, b] = *t; static constexpr auto Col = std::remove_reference_t<decltype(*t)>::C; return x < y ? balance(tree<Col>(ins(x, a), y, b)) : y < x ? balance(tree<Col>(a, y, ins(x, b))) : std::move(s); }, }, s);

} template<class T> Tree<T> insert(T x, Tree<T> s) {

return std::visit(overloaded{ [](E) -> Tree<T> { throw std::logic_error{""}; }, [](auto&& t) { auto& [a, y, b] = *t; return tree(a, y, b); } }, ins(x, s));

}

~~include <iostream>~~

template<class T> void print(Tree<T> const& s, int i = 0) {

std::visit(overloaded{ [](E) {}, [&](auto& t) { auto& [a, y, b] = *t; print(a, i + 1); std::cout << std::string(i, ' ') << "RB"[t->C] << " " << y << "\n"; print(b, i + 1); } }, s);

} int main(int argc, char* argv[]) {

~~auto t = Tree<std::string>{}; for (auto i = 1; i != argc; ++i) t = insert(std::string{argv[i]}, std::move(t)); print(t);~~

}</lang>

C#

Translation of several

Works with: C sharp version 8

<lang csharp>using System;

class Tree {

~~public static void Main() { Tree tree = Tree.E; for (int i = 1; i <= 16; i++) { tree = tree.Insert(i); } tree.Print(); }~~
~~private const bool B = false, R = true; public static readonly Tree E = new Tree(B, null, 0, null);~~
~~private Tree(bool c, Tree? l, int v, Tree? r) => (IsRed, Left, Value, Right) = (c, l ?? this, v, r ?? this);~~
~~public bool IsRed { get; private set; } public int Value { get; } public Tree Left { get; } public Tree Right { get; }~~
public static implicit operator Tree((bool c, Tree l, int v, Tree r) t) => new Tree(t.c, t.l, t.v, t.r); public void Deconstruct(out bool c, out Tree l, out int v, out Tree r) => (c, l, v, r) = (IsRed, Left, Value, Right); public override string ToString() => this == E ? "[]" : $"[{(IsRed ? 'R' : 'B')}{Value}]"; public Tree Insert(int x) => Ins(x).MakeBlack(); private Tree MakeBlack() { IsRed = false; return this; }
public void Print(int indent = 0) { if (this != E) Right.Print(indent + 1); Console.WriteLine(new string(' ', indent * 4) + ToString()); if (this != E) Left.Print(indent + 1); }
private Tree Ins(int x) => Math.Sign(x.CompareTo(Value)) switch { _ when this == E => (R, E, x, E), -1 => new Tree(IsRed, Left.Ins(x) , Value, Right).Balance(), 1 => new Tree(IsRed, Left , Value, Right.Ins(x)).Balance(), _ => this };
private Tree Balance() => this switch { (B, (R, (R, var a, var x, var b), var y, var c), var z, var d) => (R, (B, a, x, b), y, (B, c, z, d)), (B, (R, var a, var x, (R, var b, var y, var c)), var z, var d) => (R, (B, a, x, b), y, (B, c, z, d)), (B, var a, var x, (R, (R, var b, var y, var c), var z, var d)) => (R, (B, a, x, b), y, (B, c, z, d)), (B, var a, var x, (R, var b, var y, (R, var c, var z, var d))) => (R, (B, a, x, b), y, (B, c, z, d)), _ => this };

}</lang>

~~Output:~~
[] [R16] [] [B15] [] [B14] [] [B13] [] [B12] [] [B11] [] [B10] [] [B9] [] [B8] [] [B7] [] [B6] [] [B5] [] [B4] [] [B3] [] [B2] [] [B1] []
~~Clojure~~

Pattern matching library: core.match.

For code and a thorough write-up on the red-black tree implementation that uses core.match, please read: Clojure Cookbook - Data Structures: Red-Black Trees.

~~Common Lisp~~

Common Lisp doesn't come with any pattern-matching solutions on its own, but with the help of its macro facility, it can incorporate features from other languages such as pattern matching. Macros expand into efficient code during compilation time and there isn't much difference if it's included in the core language or not. As has been said, Lisp is a ball of mud and remains one no matter what one throws at it.

This is a straighforward translation of the TCL solution. I don't know red-black-trees myself but I tried mirroring the original program as closely as possible. It uses a pattern-matching library called toadstool.

Library: toadstool

<lang lisp>(mapc #'use-package '(#:toadstool #:toadstool-system)) (defstruct (red-black-tree (:constructor tree (color left val right)))

~~color left val right)~~

(defcomponent tree (operator macro-mixin)) (defexpand tree (color left val right)

`(class red-black-tree red-black-tree-color ,color red-black-tree-left ,left red-black-tree-val ,val red-black-tree-right ,right))

(pushnew 'tree *used-components*)

(defun balance (color left val right)

(toad-ecase (color left val right) (('black (tree 'red (tree 'red a x b) y c) z d) (tree 'red (tree 'black a x b) y (tree 'black c z d))) (('black (tree 'red a x (tree 'red b y c)) z d) (tree 'red (tree 'black a x b) y (tree 'black c z d))) (('black a x (tree 'red (tree 'red b y c) z d)) (tree 'red (tree 'black a x b) y (tree 'black c z d))) (('black a x (tree 'red b y (tree 'red c z d))) (tree 'red (tree 'black a x b) y (tree 'black c z d))) ((color a x b) (tree color a x b))))

(defun %insert (x s)

(toad-ecase1 s (nil (tree 'red nil x nil)) ((tree color a y b) (cond ((< x y) (balance color (%insert x a) y b)) ((> x y) (balance color a y (%insert x b))) (t s)))))

(defun insert (x s)

~~(toad-ecase1 (%insert x s) ((tree t a y b) (tree 'black a y b))))</lang>~~
E
Translation of: Haskell

In E, a pattern can be used almost anywhere a variable name can. Additionally, there are two operators used for pattern matching idioms: =~ (returns success as a boolean, somewhat like Perl's =~), and switch (matches multiple patterns, like Haskell's case).

Both of those operators are defined in terms of the basic bind/match operation: def pattern exit failure_handler := specimen

def balance(tree) { return if ( tree =~ term`tree(black, tree(red, tree(red, @a, @x, @b), @y, @c), @z, @d)` || tree =~ term`tree(black, tree(red, @a, @x, tree(red, @b, @y, @c)), @z, @d)` || tree =~ term`tree(black, @a, @x, tree(red, tree(red, @b, @y, @c), @z, @d))` || tree =~ term`tree(black, @a, @x, tree(red, @b, @y, tree(red, @c, @z, @d)))` ) { term`tree(red, tree(black, $a, $x, $b), $y, tree(black, $c, $z, $d))` } else { tree } } def insert(elem, tree) { def ins(tree) { return switch (tree) { match term`empty` { term`tree(red, empty, $elem, empty)` } match term`tree(@color, @a, @y, @b)` { if (elem < y) { balance(term`tree($color, ${ins(a)}, $y, $b)`) } else if (elem > y) { balance(term`tree($color, $a, $y, ${ins(b)})`) } else { tree } } } } def term`tree(@_, @a, @y, @b)` := ins(tree) return term`tree(black, $a, $y, $b)` }

This code was tested by filling a tree with random values; you can try this at the E REPL:

~~? var tree := term`empty` > for _ in 1..20 { > tree := insert(entropy.nextInt(100), tree) > } > tree~~
~~EchoLisp~~

code adapted from Racket and Common Lisp

Illustrates matching on structures

(require 'match) (require 'struct)

(define (N-tostring n) (format "%s %d" (N-color n) (N-value n))) (struct N (color left value right) #:tostring N-tostring)

(define (balance t)

(match t [(N '⚫️ (N '🔴 (N '🔴 a x b) y c) z d) (N '🔴 (N '⚫️ a x b) y (N '⚫️ c z d))] [(N '⚫️ (N '🔴 a x (N '🔴 b y c)) z d) (N '🔴 (N '⚫️ a x b) y (N '⚫️ c z d))] [(N '⚫️ a x (N '🔴 (N '🔴 b y c) z d)) (N '🔴 (N '⚫️ a x b) y (N '⚫️ c z d))] [(N '⚫️ a x (N '🔴 b y (N '🔴 c z d))) (N '🔴 (N '⚫️ a x b) y (N '⚫️ c z d))] [else t])) (define (ins value: x tree: t) (match t ['empty (N '🔴 'empty x 'empty)] [(N c l v r) (cond [(< x v) (balance (N c (ins x l) v r))] [(> x v) (balance (N c l v (ins x r)))] [else t])]))

(define (insert value: x tree: s)

~~(match (ins x s) [(N _ l v r) (N '⚫️ l v r)]))~~

</lang>

~~Output:~~

<lang scheme> (define (t-show n (depth 0)) (when (!eq? 'empty n) (t-show (N-left n) (+ 12 depth)) (writeln (string-pad-left (format "%s" n ) depth)) (t-show (N-right n) (+ 12 depth))))

(define T (for/fold [t 'empty] ([i 32]) (insert (random 100) t))) (t-show T) </lang>

🔴 1 ⚫️ 2 ⚫️ 7 ⚫️ 8 🔴 11 🔴 17 ⚫️ 25 ⚫️ 28 ⚫️ 31 ⚫️ 32 ⚫️ 36 ⚫️ 40 ⚫️ 43 ⚫️ 44 🔴 45 ⚫️ 53 ⚫️ 71 🔴 72 ⚫️ 73 ⚫️ 83 ⚫️ 89 🔴 91 ⚫️ 92 🔴 94 ⚫️ 99

~~Elixir~~
Translation of: Erlang

But, it changed an API into the Elixir style. <lang elixir>defmodule RBtree do

def find(nil, _), do: :not_found def find({ key, value, _, _, _ }, key), do: { :found, { key, value } } def find({ key1, _, _, left, _ }, key) when key < key1, do: find(left, key) def find({ key1, _, _, _, right }, key) when key > key1, do: find(right, key) def new(key, value), do: ins(nil, key, value) |> make_black def insert(tree, key, value), do: ins(tree, key, value) |> make_black defp ins(nil, key, value), do: { key, value, :r, nil, nil } defp ins({ key, _, color, left, right }, key, value), do: { key, value, color, left, right } defp ins({ ky, vy, cy, ly, ry }, key, value) when key < ky, do: balance({ ky, vy, cy, ins(ly, key, value), ry }) defp ins({ ky, vy, cy, ly, ry }, key, value) when key > ky, do: balance({ ky, vy, cy, ly, ins(ry, key, value) }) defp make_black({ key, value, _, left, right }), do: { key, value, :b, left, right } defp balance({ kx, vx, :b, lx, { ky, vy, :r, ly, { kz, vz, :r, lz, rz } } }), do: { ky, vy, :r, { kx, vx, :b, lx, ly }, { kz, vz, :b, lz, rz } } defp balance({ kx, vx, :b, lx, { ky, vy, :r, { kz, vz, :r, lz, rz }, ry } }), do: { kz, vz, :r, { kx, vx, :b, lx, lz }, { ky, vy, :b, rz, ry } } defp balance({ kx, vx, :b, { ky, vy, :r, { kz, vz, :r, lz, rz }, ry }, rx }), do: { ky, vy, :r, { kz, vz, :b, lz, rz }, { kx, vx, :b, ry, rx } } defp balance({ kx, vx, :b, { ky, vy, :r, ly, { kz, vz, :r, lz, rz } }, rx }), do: { kz, vz, :r, { ky, vy, :b, ly, lz }, { kx, vx, :b, rz, rx } } defp balance(t), do: t

end

~~Output:~~
{0, 3, :b, nil, nil} {0, 3, :b, nil, {1, 5, :r, nil, nil}} {1, 5, :b, {0, 3, :b, nil, nil}, {2, -1, :b, nil, nil}} {1, 5, :b, {0, 3, :b, nil, nil}, {2, -1, :b, nil, {3, 7, :r, nil, nil}}} {1, 5, :b, {0, 3, :b, nil, nil}, {3, 7, :r, {2, -1, :b, nil, nil}, {4, -3, :b, nil, nil}}} {1, 5, :b, {0, 3, :b, nil, nil}, {3, 7, :r, {2, -1, :b, nil, nil}, {4, -3, :b, nil, {5, 0, :r, nil, nil}}}} {3, 7, :b, {1, 5, :b, {0, 3, :b, nil, nil}, {2, -1, :b, nil, nil}}, {5, 0, :b, {4, -3, :b, nil, nil}, {6, -1, :b, nil, nil}}} {3, 7, :b, {1, 5, :b, {0, 3, :b, nil, nil}, {2, -1, :b, nil, nil}}, {5, 0, :b, {4, -3, :b, nil, nil}, {6, -1, :b, nil, {7, 0, :r, nil, nil}}}} {:found, {4, -3}}
~~Emacs Lisp~~

The pcase macro was added in Emacs 24.1. It's auto-loaded, so there's no need to add (require 'pcase) to your code.

<lang lisp>(defun rbt-balance (tree)

(pcase tree (`(B (R (R ,a ,x ,b) ,y ,c) ,z ,d) `(R (B ,a ,x ,b) ,y (B ,c ,z ,d))) (`(B (R ,a ,x (R ,b ,y ,c)) ,z ,d) `(R (B ,a ,x ,b) ,y (B ,c ,z ,d))) (`(B ,a ,x (R (R ,b ,y ,c) ,z ,d)) `(R (B ,a ,x ,b) ,y (B ,c ,z ,d))) (`(B ,a ,x (R ,b ,y (R ,c ,z ,d))) `(R (B ,a ,x ,b) ,y (B ,c ,z ,d))) (_ tree)))

(defun rbt-insert- (x s)

(pcase s (`nil `(R nil ,x nil)) (`(,color ,a ,y ,b) (cond ((< x y) (rbt-balance `(,color ,(rbt-insert- x a) ,y ,b))) ((> x y) (rbt-balance `(,color ,a ,y ,(rbt-insert- x b)))) (t s))) (_ (error "Expected tree: %S" s))))

(defun rbt-insert (x s)

~~(pcase (rbt-insert- x s) (`(,_ ,a ,y ,b) `(B ,a ,y ,b)) (_ (error "Internal error: %S" s))))~~

(let ((s nil))

~~(dotimes (i 16) (setq s (rbt-insert (1+ i) s))) (pp s))</lang>~~

Output:

(B (B (B (B nil 1 nil) 2 (B nil 3 nil)) 4 (B (B nil 5 nil) 6 (B nil 7 nil))) 8 (B (B (B nil 9 nil) 10 (B nil 11 nil)) 12 (B (B nil 13 nil) 14 (B nil 15 (R nil 16 nil)))))
~~Erlang~~

The code used here is extracted from Mark Northcott's GitHubGist. <lang erlang> -module(rbtree). -export([insert/3, find/2]).

% Node structure: { Key, Value, Color, Smaller, Bigger }

find(_, nil) ->

~~not_found;~~

find(Key, { Key, Value, _, _, _ }) ->

~~{ found, { Key, Value } };~~

find(Key, { Key1, _, _, Left, _ }) when Key < Key1 ->

~~find(Key, Left);~~

find(Key, { Key1, _, _, _, Right }) when Key > Key1 ->

~~find(Key, Right).~~

insert(Key, Value, Tree) ->

~~make_black(ins(Key, Value, Tree)).~~

ins(Key, Value, nil) ->

~~{ Key, Value, r, nil, nil };~~

ins(Key, Value, { Key, _, Color, Left, Right }) ->

~~{ Key, Value, Color, Left, Right };~~

ins(Key, Value, { Ky, Vy, Cy, Ly, Ry }) when Key < Ky ->

~~balance({ Ky, Vy, Cy, ins(Key, Value, Ly), Ry });~~

ins(Key, Value, { Ky, Vy, Cy, Ly, Ry }) when Key > Ky ->

~~balance({ Ky, Vy, Cy, Ly, ins(Key, Value, Ry) }).~~

make_black({ Key, Value, _, Left, Right }) ->

~~{ Key, Value, b, Left, Right }.~~

balance({ Kx, Vx, b, Lx, { Ky, Vy, r, Ly, { Kz, Vz, r, Lz, Rz } } }) ->

~~{ Ky, Vy, r, { Kx, Vx, b, Lx, Ly }, { Kz, Vz, b, Lz, Rz } };~~

balance({ Kx, Vx, b, Lx, { Ky, Vy, r, { Kz, Vz, r, Lz, Rz }, Ry } }) ->

~~{ Kz, Vz, r, { Kx, Vx, b, Lx, Lz }, { Ky, Vy, b, Rz, Ry } };~~

balance({ Kx, Vx, b, { Ky, Vy, r, { Kz, Vz, r, Lz, Rz }, Ry }, Rx }) ->

~~{ Ky, Vy, r, { Kz, Vz, b, Lz, Rz }, { Kx, Vx, b, Ry, Rx } };~~

balance({ Kx, Vx, b, { Ky, Vy, r, Ly, { Kz, Vz, r, Lz, Rz } }, Rx }) ->

~~{ Kz, Vz, r, { Ky, Vy, b, Ly, Lz }, { Kx, Vx, b, Rz, Rx } };~~

balance(T) ->

T.

</lang>

Output:

> rbtree:insert(0,3,nil). {0,3,b,nil,nil} > T1 = rbtree:insert(0,3,nil). {0,3,b,nil,nil} > T2 = rbtree:insert(1,5,T1). {0,3,b,nil,{1,5,r,nil,nil}} > T3 = rbtree:insert(2,-1,T2). {1,5,b,{0,3,b,nil,nil},{2,-1,b,nil,nil}} > T4 = rbtree:insert(3,7,T3). {1,5,b,{0,3,b,nil,nil},{2,-1,b,nil,{3,7,r,nil,nil}}} > T5 = rbtree:insert(4,-3,T4). {1,5,b, {0,3,b,nil,nil}, {3,7,r,{2,-1,b,nil,nil},{4,-3,b,nil,nil}}} > T6 = rbtree:insert(5,0,T5). {1,5,b, {0,3,b,nil,nil}, {3,7,r,{2,-1,b,nil,nil},{4,-3,b,nil,{5,0,r,nil,nil}}}} > T7 = rbtree:insert(6,-1,T6). {3,7,b, {1,5,b,{0,3,b,nil,nil},{2,-1,b,nil,nil}}, {5,0,b,{4,-3,b,nil,nil},{6,-1,b,nil,nil}}} > T8 = rbtree:insert(7,0,T7). {3,7,b, {1,5,b,{0,3,b,nil,nil},{2,-1,b,nil,nil}}, {5,0,b,{4,-3,b,nil,nil},{6,-1,b,nil,{7,0,r,nil,nil}}}} > rbtree:find(4,T8). {found,{4,-3}}
F#

|Black,N(Red,ll,N(Red,lr,rl,v),lv),rr,rv |Black,ll,N(Red,N(Red,lr,rl,v),rr,rv),lv |Black,ll,N(Red,lr,N(Red,rl,rr,rv),v),lv->N(Red,N(Black,ll,lr,lv),N(Black,rl,rr,rv),v) |i,g,e,l->N(i,g,e,l)

let insert item rbt = let rec insert=function

|Empty->N(Red,Empty,Empty,item) |N(i,g,e,l) as node->if item>l then repair(i,g,insert e,l) elif item<l then repair(i,insert g,e,l) else node match insert rbt with N(_,g,e,l)->N(Black,g,e,l) |_->Empty

</lang>

Go
Translation of: Kotlin

Go doesn't have algebraic data types as such though they can simulated (to a limited extent) by interfaces.

However, pattern matching on interfaces (via the type switch statement and type assertions) is limited to matching the implementing type and so the balance() method is not very pleasant. <lang go>package main

import "fmt"

type Color string

const (

~~R Color = "R" B = "B"~~

)

type Tree interface {

~~ins(x int) Tree~~

}

type E struct{}

func (_ E) ins(x int) Tree {

~~return T{R, E{}, x, E{}}~~

}

func (_ E) String() string {

~~return "E"~~

}

type T struct {

~~cl Color le Tree aa int ri Tree~~

}

func (t T) balance() Tree {

if t.cl != B { return t } le, leIsT := t.le.(T) ri, riIsT := t.ri.(T) var lele, leri, rile, riri T var leleIsT, leriIsT, rileIsT, ririIsT bool if leIsT { lele, leleIsT = le.le.(T) } if leIsT { leri, leriIsT = le.ri.(T) } if riIsT { rile, rileIsT = ri.le.(T) } if riIsT { riri, ririIsT = ri.ri.(T) } switch { case leIsT && leleIsT && le.cl == R && lele.cl == R: _, t2, z, d := t.destruct() _, t3, y, c := t2.(T).destruct() _, a, x, b := t3.(T).destruct() return T{R, T{B, a, x, b}, y, T{B, c, z, d}} case leIsT && leriIsT && le.cl == R && leri.cl == R: _, t2, z, d := t.destruct() _, a, x, t3 := t2.(T).destruct() _, b, y, c := t3.(T).destruct() return T{R, T{B, a, x, b}, y, T{B, c, z, d}} case riIsT && rileIsT && ri.cl == R && rile.cl == R: _, a, x, t2 := t.destruct() _, t3, z, d := t2.(T).destruct() _, b, y, c := t3.(T).destruct() return T{R, T{B, a, x, b}, y, T{B, c, z, d}} case riIsT && ririIsT && ri.cl == R && riri.cl == R: _, a, x, t2 := t.destruct() _, b, y, t3 := t2.(T).destruct() _, c, z, d := t3.(T).destruct() return T{R, T{B, a, x, b}, y, T{B, c, z, d}} default: return t }

}

func (t T) ins(x int) Tree {

~~switch { case x < t.aa: return T{t.cl, t.le.ins(x), t.aa, t.ri}.balance() case x > t.aa: return T{t.cl, t.le, t.aa, t.ri.ins(x)}.balance() default: return t }~~

}

func (t T) destruct() (Color, Tree, int, Tree) {

~~return t.cl, t.le, t.aa, t.ri~~

}

func (t T) String() string {

~~return fmt.Sprintf("T(%s, %v, %d, %v)", t.cl, t.le, t.aa, t.ri)~~

}

func insert(tr Tree, x int) Tree {

~~t := tr.ins(x) switch t.(type) { case T: tt := t.(T) _, a, y, b := tt.destruct() return T{B, a, y, b} case E: return E{} default: return nil }~~

}

func main() {

~~var tr Tree = E{} for i := 1; i <= 16; i++ { tr = insert(tr, i) } fmt.Println(tr)~~

}</lang>

~~Output:~~
T(B, T(B, T(B, T(B, E, 1, E), 2, T(B, E, 3, E)), 4, T(B, T(B, E, 5, E), 6, T(B, E, 7, E))), 8, T(B, T(B, T(B, E, 9, E), 10, T(B, E, 11, E)), 12, T(B, T(B, E, 13, E), 14, T(B, E, 15, T(R, E, 16, E)))))
~~Haskell~~

<lang haskell>data Color = R | B data Tree a = E | T Color (Tree a) a (Tree a)

balance :: Color -> Tree a -> a -> Tree a -> Tree a balance B (T R (T R a x b) y c ) z d = T R (T B a x b) y (T B c z d) balance B (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d) balance B a x (T R (T R b y c) z d ) = T R (T B a x b) y (T B c z d) balance B a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d) balance col a x b = T col a x b

insert :: Ord a => a -> Tree a -> Tree a insert x s = T B a y b where

~~ins E = T R E x E ins s@(T col a y b) | x < y = balance col (ins a) y b | x > y = balance col a y (ins b) | otherwise = s T _ a y b = ins s</lang>~~
J

J incorporates a symbol data type which, in versions 6.02 and 7.01, J implements directly as a red-black tree. The s: entry in the J dictionary begins Symbols are a data type and are created by the verb s:. Symbols provide a mechanism for searching, sorting, and comparisons more efficient than alternative mechanisms such as boxed strings. Structural, selection, and relational verbs work on symbols. Arithmetic verbs do not work on symbols. However, for this task we want to see an implementation and we want the implementation to represent an algebraic data type approach.

The following code represents a best effort translation of the current Haskell implementation of this task:

<lang J>insert=:{{

'R';;y;a:

if. 0=#y do. insert x elseif. 0=L.y do. x insert insert y else. 'C e K w'=. y select. *x - K case. _1 do. balance C;(x insert e);K;<w case. 0 do. y case. 1 do. balance C;e;K;<x insert w end. end.

}}

NB. C: color, e: east, K: key, w: west NB. two cascaded reds under a black become two black siblings under a red balance=: {{

'C e K w'=. y if. #e do. 'eC ee eK ew'=. e if. 'R'=eC do. if. #ee do. 'eeC eee eeK eew'=. ee NB. ((eee eeK eew) eK ew) K w => (eee eeK eew) eK (ew K w) if. 'R'=eeC do. 'R';('B';eee;eeK;<eew);eK;<'B';ew;K;<w return. end. end. if. #ew do. 'ewC ewe ewK eww'=. ew NB. (ee ek (ewe ewK eww)) K w => (ee ek ewe) ewK (eww K w) if. 'R'=ewC do. 'R';('B';ee;eK;<ewe);ewK;<'B';eww;K;<w return. end. end. end. end. if. #w do. 'wC we wK ww'=. w if. 'R'=wC do. if. #we do. 'weC wee weK wew'=. we NB. e K ((wee weK wew) wK ww) => (e K wee) weK (wew wK ww) if. 'R'=weC do. 'R';('B';e;K;<wee);weK;<'B';wew;wK;<ww return. end. end. if. #ww do. 'wwC wwe wwK www'=. ww NB. e K (we wK (wwe wwK www)) => (e K we) wK (wwe wwK www) if. 'R'=wwC do. 'R';('B';e;K;<we);wK;<'B';wwe;wwK;<www return. end. end. end. end. y

}}</lang>

Example use:

<lang J> 3 insert 2 insert 5 ┌─┬───────┬─┬───────┐ │R│┌─┬┬─┬┐│3│┌─┬┬─┬┐│ │ ││B││2│││ ││B││5│││ │ │└─┴┴─┴┘│ │└─┴┴─┴┘│ └─┴───────┴─┴───────┘</lang>

Note that by convention we treat the root node as black. This approach always labels it with 'R' which we ignore. However, if we wish to validate these trees, we must account for the discrepancy.

<lang J>NB. always treat root of tree as black validate=: Template:If. 0=

check=: Template:If. 0=</lang>

Here, validate returns the effective "black depth" of the tree (treating the root node as black and treating empty nodes as black), or 0 if the tree is not balanced properly.

For example:

<lang J> ?.~20 14 18 12 16 5 1 3 0 6 13 9 8 15 17 2 10 7 4 19 11

~~insert/?.~20~~

┌─┬──────────────────────────────────────────────────────────────────────┬──┬────────────────────────────────────────────────────────────────────────┐ │R│┌─┬───────────────────────────────────┬─┬────────────────────────────┐│10│┌─┬────────────────────────────────────────────────┬──┬────────────────┐│ │ ││R│┌─┬──────────────┬─┬──────────────┐│5│┌─┬───────┬─┬──────────────┐││ ││B│┌─┬────────────────┬──┬────────────────────────┐│17│┌─┬────────┬──┬┐││ │ ││ ││B│┌─┬┬─┬───────┐│2│┌─┬───────┬─┬┐││ ││B│┌─┬┬─┬┐│7│┌─┬┬─┬───────┐│││ ││ ││R│┌─┬┬──┬────────┐│13│┌─┬────────┬──┬────────┐││ ││B│┌─┬┬──┬┐│19││││ │ ││ ││ ││B││0│┌─┬┬─┬┐││ ││B│┌─┬┬─┬┐│4││││ ││ ││B││6│││ ││B││8│┌─┬┬─┬┐││││ ││ ││ ││B││11│┌─┬┬──┬┐││ ││B│┌─┬┬──┬┐│15│┌─┬┬──┬┐│││ ││ ││R││18│││ ││││ │ ││ ││ ││ ││ ││R││1││││ ││ ││R││3│││ ││││ ││ │└─┴┴─┴┘│ ││ ││ ││R││9││││││ ││ ││ ││ ││ ││R││12││││ ││ ││R││14│││ ││R││16│││││ ││ │└─┴┴──┴┘│ ││││ │ ││ ││ ││ ││ │└─┴┴─┴┘││ ││ │└─┴┴─┴┘│ ││││ ││ │ │ ││ ││ │└─┴┴─┴┘││││ ││ ││ ││ ││ │└─┴┴──┴┘││ ││ │└─┴┴──┴┘│ │└─┴┴──┴┘│││ │└─┴────────┴──┴┘││ │ ││ ││ │└─┴┴─┴───────┘│ │└─┴───────┴─┴┘││ ││ │ │ │└─┴┴─┴───────┘│││ ││ ││ │└─┴┴──┴────────┘│ │└─┴────────┴──┴────────┘││ │ ││ │ ││ │└─┴──────────────┴─┴──────────────┘│ │└─┴───────┴─┴──────────────┘││ ││ │└─┴────────────────┴──┴────────────────────────┘│ │ ││ │ │└─┴───────────────────────────────────┴─┴────────────────────────────┘│ │└─┴────────────────────────────────────────────────┴──┴────────────────┘│ └─┴──────────────────────────────────────────────────────────────────────┴──┴────────────────────────────────────────────────────────────────────────┘

~~validate insert/?.~20~~

4</lang>

Finally a caution: red black trees exhibit poor cache coherency. In many (perhaps most or all) cases an amortized hierarchical linear sort mechanism will perform better than a red black tree implementation. (And that characteristic is especially true of this particular implementation.)

jq

Adapted from Tcl

Works with: jq

Works with gojq, the Go implementation of jq

jq does not have built-in support for pattern matching in the sense of the present task description, but the following `bindings` function takes advantage of the way in which singleton-key JSON objects can be used as variables for pattern-matching. In effect, jq expressions such as `{a}` can be used as variables in the pattern definitions, and after matching, the corresponding values can be referenced by jq expressions such as `.a`.

Notice also how various features of jq come together to simplify the implementation of the `balance` function.

bindings.jq <lang jq># bindings($x) attempts to match . and $x structurally on the

assumption that . is free of JSON objects, and that any objects in

$x will have distinct, singleton keys that are to be interpreted as

variables. These variables will match the corresponding entities in

. if . and $x can be structurally matched.

If . and $x cannot be matched, then null is returned;

otherwise, if $x contains no objects, {} is returned;

finally, if . and $x can be structurally matched, a composite object containing the bindings

will be returned.

Output: null (failure to match) or a single JSON object giving the bindings if any.

def bindings($x):

if $x == . then {} # by assumption, no bindings are necessary elif ($x|type) == "object" then ($x|keys) as $keys | if ($keys|length) == 1 then {($keys[0]): .} else "objects should be singletons"|error end elif type != ($x|type) then null elif type == "array" then if length != ($x|length) then null else . as $in | reduce range(0;length) as $i ({}; if . == null then null else ($in[$i] | bindings($x[$i]) ) as $m | if $m == null then null else . + $m end end)

end

~~else null end ;</lang>~~

pattern-matching.jq <lang jq>include "bindings" {search: "."};

def E: []; # the empty node

Each nonempty node is an array: [Color, Left, Value, Right]

where Left and Right are nodes.

def B: "⚫"; def R: "🔴";

def b(x): bindings({} | x) // empty;

~~Input: [$color, $left, $value, $right]~~

def balance:

~~def node: [R, [B, .a, .x, .b], .y, [B, .c, .z, .d]];~~
( b([B, [R, [R, {a}, {x}, {x}], {y}, {c}], {z}, {d}]) // b([B, [R, {a}, {x}, [R, {b}, {y}, {c}]], {z}, {d}]) // b([B, {a},{x}, [R, [R, {b}, {y}, {c}], {z}, {d}]]) // b([B, {a},{x}, [R, {b}, {y}, [R, {c}, {z}, {d}]]]) | node) // . ;
~~Input: a node~~

def ins($x):

def insert($x):

~~ins($x) as [$col, $left, $y, $right] | [ B, $left, $y, $right] ;~~

def pp: walk( if type == "array" then map(select(length>0)) else . end);

def task($n):

~~reduce range(0; $n) as $i (E; insert($i));~~

task(16) | pp</lang>

~~Output:~~

For brevity and perhaps visual appeal, the output from jq has been trimmed as per the following invocation: <lang sh>jq -n -f pattern-matching.jq | grep -v '[][]' | tr -d ',"'</lang>

⚫ ⚫ ⚫ ⚫ 1 ⚫ 2 3 ⚫ ⚫ 4 5 ⚫ 6 7 ⚫ ⚫ ⚫ 8 9 ⚫ 10 11 ⚫ ⚫ 12 13 ⚫ 14 🔴 15
~~Julia~~

Julia's multiple dispatch model is based on the types of a function's arguments, but does not look deeper into the function's array arguments for the types of their contents. Therefore we do multi-dispatch on the balance function but then use an if statement within the multiply dispatched functions to further match based on argument vector contents. <lang julia>import Base.length

abstract type AbstractColoredNode end

struct RedNode <: AbstractColoredNode end; const R = RedNode() struct BlackNode <: AbstractColoredNode end; const B = BlackNode() struct Empty end; const E = Empty() length(e::Empty) = 1

function balance(b::BlackNode, v::Vector, z, d)

if v[1] == R if length(v[2]) == 4 && v[2][1] == R return [R, [B, v[2][2], v[2][3], v[2][4]], v[3], [B, v[4], z, d]] elseif length(v[4]) == 4 && v[4][1] == R return [R, [B, v[2], v[3], v[4][2]], v[4][3], [B, v[4][4], z, d]] end end [b, v, z, d]

end

function balance(b::BlackNode, a, x, v::Vector)

if v[1] == R if length(v[2]) == 4 && v[2][1] == R return [R, [B, a, x, v[2][2]], v[2][3], [B, v[2][4], v[3], v[4]]] elseif length(v[4]) == 4 && v[4][1] == R return [R, [B, a, x, v[2]], v[3], [B, v[4][2], v[4][3], v[4][4]]] end end [b, a, x, v]

end

function balance(b::BlackNode, a::Vector, x, v::Vector)

if v[1] == R if length(v[2]) == 4 && v[2][1] == R return [R, [B, a, x, v[2][2]], v[2][3], [B, v[2][4], v[3], v[4]]] elseif length(v[4]) == 4 && v[4][1] == R return [R, [B, a, x, v[2]], v[3], [B, v[4][2], v[4][3], v[4][4]]] end end [b, a, x, v]

end

balance(node, l, a, r) = [node, l, a, r]

function ins(v::Vector, x::Number)

if length(v) == 4 if x < v[3] return balance(v[1], ins(v[2], x), v[3], v[4]) elseif x > v[3] return balance(v[1], v[2], v[3], ins(v[4], x)) end end v

end

ins(t, a) = [R, E, a, E]

insert(v, a) = (t = ins(v, a); t[1] = B; t)

function testRB()

~~t = E for i in rand(collect(1:20), 10) t = insert(t, i) end println(replace(string(t), r"lackNode|edNode|Any|mpty" => ""))~~

end

testRB()

~~</lang>~~

~~Output:~~
~~[B, [R, [B, [R, E, 1, E], 2, [R, E, 3, E]], 4, [B, E, 6, E]], 14, [B, E, 18, E]]]~~
~~Kotlin~~
Translation of: Scala

Whilst Kotlin supports algebraic data types (via 'sealed classes') and destructuring of data classes, pattern matching on them (via the 'when' expression) is currently limited to matching the type. Consequently the balance() function is not very pretty!

<lang scala>// version 1.1.51

import Color.*

enum class Color { R, B }

sealed class Tree<A : Comparable<A>> {

~~fun insert(x: A): Tree<A> { val t = ins(x) return when (t) { is T -> { val (_, a, y, b) = t T(B, a, y, b) }~~
~~is E -> E() } }~~
~~abstract fun ins(x: A): Tree<A>~~

}

class E<A : Comparable<A>> : Tree<A>() {

~~override fun ins(x: A): Tree<A> = T(R, E(), x, E())~~
~~override fun toString() = "E"~~

}

data class T<A : Comparable<A>>(

~~val cl: Color, val le: Tree<A>, val aa: A, val ri: Tree<A>~~

) : Tree<A>() {

private fun balance(): Tree<A> { if (cl != B) return this val res = if (le is T && le.le is T && le.cl == R && le.le.cl == R) { val (_, t, z, d) = this val (_, t2, y, c) = t as T val (_, a, x, b) = t2 as T T(R, T(B, a, x, b), y, T(B, c, z, d)) } else if (le is T && le.ri is T && le.cl == R && le.ri.cl == R) { val (_, t, z, d) = this val (_, a, x, t2) = t as T val (_, b, y, c) = t2 as T T(R, T(B, a, x, b), y, T(B, c, z, d)) } else if (ri is T && ri.le is T && ri.cl == R && ri.le.cl == R) { val (_, a, x, t) = this val (_, t2, z, d) = t as T val (_, b, y, c) = t2 as T T(R, T(B, a, x, b), y, T(B, c, z, d)) } else if (ri is T && ri.ri is T && ri.cl == R && ri.ri.cl == R) { val (_, a, x, t) = this val (_, b, y, t2) = t as T val (_, c, z, d) = t2 as T T(R, T(B, a, x, b), y, T(B, c, z, d)) } else this return res }
~~override fun ins(x: A): Tree<A> = when (x.compareTo(aa)) { -1 -> T(cl, le.ins(x), aa, ri).balance() +1 -> T(cl, le, aa, ri.ins(x)).balance() else -> this }~~
~~override fun toString() = "T($cl, $le, $aa, $ri)"~~

}

fun main(args: Array<String>) {

~~var tree: Tree<Int> = E() for (i in 1..16) { tree = tree.insert(i) } println(tree)~~

}</lang>

~~Output:~~
T(B, T(B, T(B, T(B, E, 1, E), 2, T(B, E, 3, E)), 4, T(B, T(B, E, 5, E), 6, T(B, E, 7, E))), 8, T(B, T(B, T(B, E, 9, E), 10, T(B, E, 11, E)), 12, T(B, T(B, E, 13, E), 14, T(B, E, 15, T(R, E, 16, E)))))
~~Nim~~
Library: fusion/matching

<lang nim>import fusion/matching {.experimental: "caseStmtMacros".}

type

~~Colour = enum Empty, Red, Black RBTree[T] = ref object colour: Colour left, right: RBTree[T] value: T~~

proc `[]`[T](r: RBTree[T], idx: static[FieldIndex]): auto =

~~## enables tuple syntax for unpacking and matching when idx == 0: r.colour elif idx == 1: r.left elif idx == 2: r.value elif idx == 3: r.right~~

template B[T](l: untyped, v: T, r): RBTree[T] =

~~RBTree[T](colour: Black, left: l, value: v, right: r)~~

template R[T](l: untyped, v: T, r): RBTree[T] =

~~RBTree[T](colour: Red, left: l, value: v, right: r)~~

template balImpl[T](t: typed): untyped =

case t of (colour: Red | Empty): discard of (Black, (Red, (Red, @a, @x, @b), @y, @c), @z, @d) | (Black, (Red, @a, @x, (Red, @b, @y, @c)), @z, @d) | (Black, @a, @x, (Red, (Red, @b, @y, @c), @z, @d)) | (Black, @a, @x, (Red, @b, @y, (Red, @c, @z, @d))): t = R(B(a, x, b), y, B(c, z, d))

proc balance*[T](t: var RBTree[T]) = balImpl[T](t)

template insImpl[T](t, x: typed): untyped =

~~template E: RBTree[T] = RBTree[T]() case t of (colour: Empty): t = R(E, x, E) of (value: > x): t.left.ins(x); t.balance() of (value: < x): t.right.ins(x); t.balance()~~

proc insert*[T](tt: var RBTree[T], xx: T) =

~~proc ins(t: var RBTree[T], x: T) = insImpl[T](t, x) tt.ins(xx) tt.colour = Black</lang>~~
~~OCaml~~

<lang ocaml> type color = R | B type 'a tree = E | T of color * 'a tree * 'a * 'a tree

(** val balance : color * 'a tree * 'a * 'a tree -> 'a tree *) let balance = function

(** val insert : 'a -> 'a tree -> 'a tree *) let insert x s =

~~let rec ins = function | E -> T (R,E,x,E) | T (col,a,y,b) as s ->~~

if x < y then balance (col, ins a, y, b) else if x > y then balance (col, a, y, ins b) else s

~~in let T (_,a,y,b) = ins s in T (B,a,y,b)~~

</lang>

Oz
Translation of: Haskell

Unlike Haskell, Oz does not support multiple equations per function. So we use an explicit case-statement. To match multiple variables at once, we create temporary tuples with "#".

<lang oz>fun {Balance Col A X B}

case Col#A#X#B of b#t(r t(r A X B) Y C )#Z#D then t(r t(b A X B) Y t(b C Z D)) [] b#t(r A X t(r B Y C))#Z#D then t(r t(b A X B) Y t(b C Z D)) [] b#A #X#t(r t(r B Y C) Z D) then t(r t(b A X B) Y t(b C Z D)) [] b#A #X#t(r B Y t(r C Z D)) then t(r t(b A X B) Y t(b C Z D)) else t(Col A X B) end

end

fun {Insert X S}

~~fun {Ins S} case S of e then t(r e X e) [] t(Col A Y B) then~~

if X < Y then {Balance Col {Ins A} Y B} elseif X > Y then {Balance Col A Y {Ins B}} else S end

~~end end t(_ A Y B) = {Ins S}~~

in

~~t(b A Y B)~~

end</lang>

~~Perl~~
Works with: Perl version 5.010

Although Perl does not have algebraic data types, it does have a wonderfully flexible regular expression engine, which is powerfully enough to perform the task.

However, representing a tree as a string, and repeatedly parsing that string, is truly inefficient way to solve the problem. Someday, someone will write a perl multi-method-dispatch module which is as amazing as Raku's, and then we can copy the Raku solution here.

The $balanced variable matches against either some data, or the empty tree (_), or, using perl's amazing recursive regular expression feature, a non-empty tree.

Each of the single letter variables declared right after $balanced, match an instance of $balanced, and if they succeed, store the result into the %+ hash.

<lang perl>#!perl use 5.010; use strict; use warnings qw(FATAL all);

my $balanced = qr{([^<>,]++|<(?-1),(?-1),(?-1),(?-1)>)}; my ($a, $b, $c, $d, $x, $y, $z) = map +qr((?<$_>$balanced)), 'a'..'d', 'x'..'z'; my $col = qr{(?<col>[RB])};

sub balance { local $_ = shift; if( /^<B,<R,<R,$a,$x,$b>,$y,$c>,$z,$d>\z/ or /^<B,<R,$a,$x,<R,$b,$y,$c>>,$z,$d>\z/ or /^<B,$a,$x,<R,<R,$b,$y,$c>,$z,$d>>\z/ or /^<B,$a,$x,<R,$b,$y,<R,$c,$z,$d>>>\z/ ) { my ($aa, $bb, $cc, $dd) = @+{'a'..'d'}; my ($xx, $yy, $zz) = @+{'x'..'z'}; "<R,<B,$aa,$xx,$bb>,$yy,<B,$cc,$zz,$dd>>"; } else { $_; } }

sub ins { my ($xx, $tree) = @_; if($tree =~ m{^<$col,$a,$y,$b>\z} ) { my ($color, $aa, $bb, $yy) = @+{qw(col a b y)}; if( $xx < $yy ) { return balance "<$color,".ins($xx,$aa).",$yy,$bb>"; } elsif( $xx > $yy ) { return balance "<$color,$aa,$yy,".ins($xx,$bb).">"; } else { return $tree; } } elsif( $tree !~ /,/) { return "<R,_,$xx,_>"; } else { print "Unexpected failure!\n"; print "Tree parts are: \n"; print $_, "\n" for $tree =~ /$balanced/g; exit; } }

sub insert { my $tree = ins(@_); $tree =~ m{^<$col,$a,$y,$b>\z} or die; "<B,$+{a},$+{y},$+{b}>"; }

MAIN: { my @a = 1..10; for my $aa ( 1 .. $#a ) { my $bb = int rand( 1 + $aa ); @a[$aa, $bb] = @a[$bb, $aa]; } my $t = "!"; for( @a ) { $t = insert( $_, $t ); print "Tree: $t.\n"; } } print "Done\n"; </lang>

~~Output:~~
Tree: <B,_,9,_>. Tree: <B,<R,_,7,_>,9,_>. Tree: <B,<B,_,2,_>,7,<B,_,9,_>>. Tree: <B,<B,_,2,<R,_,6,_>>,7,<B,_,9,_>>. Tree: <B,<B,_,2,<R,_,6,_>>,7,<B,_,9,<R,_,10,_>>>. Tree: <B,<R,<B,_,2,_>,5,<B,_,6,_>>,7,<B,_,9,<R,_,10,_>>>. Tree: <B,<R,<B,_,2,<R,_,4,_>>,5,<B,_,6,_>>,7,<B,_,9,<R,_,10,_>>>. Tree: <B,<R,<B,_,2,<R,_,4,_>>,5,<B,_,6,_>>,7,<B,<R,_,8,_>,9,<R,_,10,_>>>. Tree: <B,<R,<B,<R,_,1,_>,2,<R,_,4,_>>,5,<B,_,6,_>>,7,<B,<R,_,8,_>,9,<R,_,10,_>>>. Tree: <B,<B,<B,<R,_,1,_>,2,_>,3,<B,_,4,_>>,5,<B,<B,_,6,_>,7,<B,<R,_,8,_>,9,<R,_,10,_>>>>. Done
~~Phix~~

There is no formal support for this sort of thing in Phix, but that's not to say that whipping something up is likely to be particularly difficult, so let's give it a whirl.

-- -- demo\rosetta\Pattern_matching.exw -- ================================= -- -- 1). Lightly modified copy of demo\rosetta\VisualiseTree.exw with javascript_semantics -- To the theme tune of the Milk Tray Ad iyrt, -- All because the Windows console hates utf8: constant TL = '\#DA', -- aka '┌' VT = '\#B3', -- aka '│' BL = '\#C0', -- aka '└' HZ = '\#C4', -- aka '─' HS = "\#C4" -- (string version of HZ) function w1252_to_utf8(string s) if platform()!=WINDOWS then s = substitute_all(s,{ TL, VT, BL, HZ}, {"┌","│","└","─"}) end if return s end function --</hates utf8> procedure visualise_tree(object tree, string root=HS) if atom(tree) then puts(1,"<empty>\n") else object {colour,left,v,right} = tree integer g = root[$] if sequence(left) then root[$] = iff(g=TL or g=HZ?' ':VT) visualise_tree(left,root&TL) end if root[$] = g printf(1,"%s%s%v\n",{w1252_to_utf8(root),colour,v}) if sequence(right) then root[$] = iff(g=TL?VT:' ') visualise_tree(right,root&BL) end if end if end procedure --</copy VisualiseTree> -- 2). Imagine the following is in a file, say algebraic_data_types.e - not quite generic enough -- for inclusion in builtins, but not exactly difficult to copy/maintain per-project either. function match_one(sequence key, object t) sequence res = {} if sequence(t) and length(key)==length(t) then for i=1 to length(key) do object ki = key[i], ti = t[i] if sequence(ki) and not string(ki) then sequence r2 = match_one(ki,ti) if r2={} then res = {} exit end if res &= r2 else if ki=0 then res = append(res,ti) else if ki!=ti then res = {} exit end if end if end if end for end if return res end function /*global*/ function match_algebraic(sequence set, t) sequence s for i=1 to length(set) do s = match_one(set[i],t) if length(s) then exit end if end for return s end function --</algebraic_data_types.e> -- 3). The actual task constant B = "B", R = "R" function balance(sequence t) sequence s = match_algebraic({{B,{R,{R,0,0,0},0,0},0,0}, {B,{R,0,0,{R,0,0,0}},0,0}, {B,0,0,{R,{R,0,0,0},0,0}}, {B,0,0,{R,0,0,{R,0,0,0}}}},t) if length(s) then object {a,x,b,y,c,z,d} = s t = {R,{B,a,x,b},y,{B,c,z,d}} end if return t end function function ins(object tree, object leaf) if tree=NULL then tree = {R,NULL,leaf,NULL} else object {c,l,k,r} = tree if leaf!=k then if leaf<k then l = ins(l,leaf) else r = ins(r,leaf) end if tree = balance({c,l,k,r}) end if end if return tree end function function tree_insert(object tree, object leaf) tree = ins(tree,leaf) tree[1] = B return tree end function sequence stuff = shuffle(tagset(10)) object tree = NULL for i=1 to length(stuff) do tree = tree_insert(tree,stuff[i]) end for visualise_tree(tree) ?"done" {} = wait_key()

~~Output:~~
~~┌R1 ┌B2 ┌B3 │└B4 ─B5 │┌B6 ││└R7 └B8 └B9 └R10~~
~~Picat~~
Translation of: Prolog

~~T = e, foreach (X in 1..10) insert(X,T,T1), T := T1 end, output(T,0).~~

insert(X,S,R) =>

~~ins(X,S,R1), R1 = $t(_,A,Y,B), R = $t(b,A,Y,B).~~

ins(X,e,R) => R = $t(r,e,X,e). ins(X,t(C,A,Y,B),R), X < Y => ins(X,A,Ao), balance(C,Ao,Y,B,R). ins(X,t(C,A,Y,B),R), X > Y => ins(X,B,Bo), balance(C,A,Y,Bo,R). ins(_X,T,R) => R = T.

balance(C,A,X,B,S) :- (bal(C,A,X,B,T) -> S = T ; S = $t(C,A,X,B)).

bal(b, t(r,t(r,A,X,B),Y,C), Z, D, R) => R = $t(r,t(b,A,X,B),Y,t(b,C,Z,D)). bal(b, t(r,A,X,t(r,B,Y,C)), Z, D, R) => R = $t(r,t(b,A,X,B),Y,t(b,C,Z,D)). bal(b, A, X, t(r,t(r,B,Y,C),Z,D), R) => R = $t(r,t(b,A,X,B),Y,t(b,C,Z,D)). bal(b, A, X, t(r,B,Y,t(r,C,Z,D)), R) => R = $t(r,t(b,A,X,B),Y,t(b,C,Z,D)).

output(e,Indent) => printf("%*w\n",Indent,e). output(t(C,A,Y,B),Indent) =>

~~output(A,Indent+6), printf("%*w[%w]\n",Indent,C,Y), output(B,Indent+6).~~

</lang>

~~Output:~~
e b[1] e b[2] e b[3] e b[4] e b[5] e b[6] e b[7] e r[8] e b[9] e r[10] e
~~PicoLisp~~
Translation of: Prolog

<lang PicoLisp>(be color (R)) (be color (B))

(be tree (@ E)) (be tree (@P (T @C @L @X @R))

~~(color @C) (tree @P @L) (call @P @X) (tree @P @R) )~~

(be bal (B (T R (T R @A @X @B) @Y @C) @Z @D (T R (T B @A @X @B) @Y (T B @C @Z @D)))) (be bal (B (T R @A @X (T R @B @Y @C)) @Z @D (T R (T B @A @X @B) @Y (T B @C @Z @D)))) (be bal (B @A @X (T R (T R @B @Y @C) @Z @D) (T R (T B @A @X @B) @Y (T B @C @Z @D)))) (be bal (B @A @X (T R @B @Y (T R @C @Z @D)) (T R (T B @A @X @B) @Y (T B @C @Z @D))))

(be balance (@C @A @X @B @S)

~~(bal @C @A @X @B @S) T )~~

(be balance (@C @A @X @B (T @C @A @X @B)))

(be ins (@X E (T R E @X E))) (be ins (@X (T @C @A @Y @B) @R)

~~(^ @ (> (-> @Y) (-> @X))) (ins @X @A @Ao) (balance @C @Ao @Y @B @R) T )~~

(be ins (@X (T @C @A @Y @B) @R)

~~(^ @ (> (-> @X) (-> @Y))) (ins @X @B @Bo) (balance @C @A @Y @Bo @R) T )~~

(be ins (@X (T @C @A @Y @B) (T @C @A @Y @B)))

(be insert (@X @S (T B @A @Y @B))

~~(ins @X @S (T @ @A @Y @B)) )</lang>~~

Test: <lang PicoLisp>: (? (insert 2 E @A) (insert 1 @A @B) (insert 3 @B @C))

~~@A=(T B E 2 E) @B=(T B (T R E 1 E) 2 E) @C=(T B (T R E 1 E) 2 (T R E 3 E))~~

-> NIL</lang>

~~Prolog~~
color(r). color(b). tree(_,e). tree(P,t(C,L,X,R)) :- color(C), tree(P,L), call(P,X), tree(P,R). bal(b, t(r,t(r,A,X,B),Y,C), Z, D, t(r,t(b,A,X,B),Y,t(b,C,Z,D))). bal(b, t(r,A,X,t(r,B,Y,C)), Z, D, t(r,t(b,A,X,B),Y,t(b,C,Z,D))). bal(b, A, X, t(r,t(r,B,Y,C),Z,D), t(r,t(b,A,X,B),Y,t(b,C,Z,D))). bal(b, A, X, t(r,B,Y,t(r,C,Z,D)), t(r,t(b,A,X,B),Y,t(b,C,Z,D))). balance(C,A,X,B,S) :- ( bal(C,A,X,B,T) -> S = T ; S = t(C,A,X,B) ). ins(X,e,t(r,e,X,e)). ins(X,t(C,A,Y,B),R) :- ( X < Y -> ins(X,A,Ao), balance(C,Ao,Y,B,R) ; X > Y -> ins(X,B,Bo), balance(C,A,Y,Bo,R) ; X = Y -> R = t(C,A,Y,B) ). insert(X,S,t(b,A,Y,B)) :- ins(X,S,t(_,A,Y,B)).
~~Python~~
Translation of: C#

Structural pattern matching was added to Python in version 3.10.

<lang python>from __future__ import annotations from enum import Enum from typing import NamedTuple from typing import Optional

class Color(Enum):

~~B = 0 R = 1~~

class Tree(NamedTuple):

~~color: Color left: Optional[Tree] value: int right: Optional[Tree]~~
~~def insert(self, val: int) -> Tree: return self._insert(val).make_black()~~
def _insert(self, val: int) -> Tree: match compare(val, self.value): case _ if self == EMPTY: return Tree(Color.R, EMPTY, val, EMPTY) case -1: assert self.left is not None return Tree( self.color, self.left._insert(val), self.value, self.right ).balance() case 1: assert self.right is not None return Tree( self.color, self.left, self.value, self.right._insert(val) ).balance() case _: return self
def balance(self) -> Tree: match self: case (Color.B, (Color.R, (Color.R, a, x, b), y, c), z, d): return Tree(Color.R, Tree(Color.B, a, x, b), y, Tree(Color.B, c, z, d)) case (Color.B, (Color.R, a, x, (Color.R, b, y, c)), z, d): return Tree(Color.R, Tree(Color.B, a, x, b), y, Tree(Color.B, c, z, d)) case (Color.B, a, x, (Color.R, (Color.R, b, y, c), z, d)): return Tree(Color.R, Tree(Color.B, a, x, b), y, Tree(Color.B, c, z, d)) case (Color.B, a, x, (Color.R, b, y, (Color.R, c, z, d))): return Tree(Color.R, Tree(Color.B, a, x, b), y, Tree(Color.B, c, z, d)) case _: return self
~~def make_black(self) -> Tree: return self._replace(color=Color.B)~~
~~def __str__(self) -> str: if self == EMPTY: return "[]" return f"[{'R' if self.color == Color.R else 'B'}{self.value}]"~~
~~def print(self, indent: int = 0) -> None: if self != EMPTY: assert self.right is not None self.right.print(indent + 1)~~
~~print(f"{' ' * indent * 4}{self}")~~
~~if self != EMPTY: assert self.left is not None self.left.print(indent + 1)~~

EMPTY = Tree(Color.B, None, 0, None)

def compare(x: int, y: int) -> int:

~~if x > y: return 1 if x < y: return -1 return 0~~

def main():

~~tree = EMPTY for i in range(1, 17): tree = tree.insert(i) tree.print()~~

if __name__ == "__main__":

~~main()~~

</lang>

~~Output:~~
[] [R16] [] [B15] [] [B14] [] [B13] [] [B12] [] [B11] [] [B10] [] [B9] [] [B8] [] [B7] [] [B6] [] [B5] [] [B4] [] [B3] [] [B2] [] [B1] []
~~Racket~~
Translation of: OCaml

~~lang racket~~

~~Using short names to make the code line up nicely~~

(struct N (color left value right) #:prefab)

(define (balance t)

(match t [(N 'B (N 'R (N 'R a x b) y c) z d) (N 'R (N 'B a x b) y (N 'B c z d))] [(N 'B (N 'R a x (N 'R b y c)) z d) (N 'R (N 'B a x b) y (N 'B c z d))] [(N 'B a x (N 'R (N 'R b y c) z d)) (N 'R (N 'B a x b) y (N 'B c z d))] [(N 'B a x (N 'R b y (N 'R c z d))) (N 'R (N 'B a x b) y (N 'B c z d))] [else t]))

(define (insert x s)

(define (ins t) (match t ['empty (N 'R 'empty x 'empty)] [(N c l v r) (cond [(< x v) (balance (N c (ins l) v r))] [(> x v) (balance (N c l v (ins r)))] [else t])])) (match (ins s) [(N _ l v r) (N 'B l v r)]))

(define (visualize t0)

(let loop ([t t0] [last? #t] [indent '()]) (define (I mid last) (cond [(eq? t t0) ""] [last? mid] [else last])) (for-each display (reverse indent)) (printf "~a~a[~a]\n" (I "\\-" "+-") (N-value t) (N-color t)) (define subs (filter N? (list (N-left t) (N-right t)))) (for ([s subs] [n (in-range (sub1 (length subs)) -1 -1)]) (loop s (zero? n) (cons (I " " "| ") indent)))))

(visualize (for/fold ([t 'empty]) ([i 16]) (insert i t))) </lang>

~~7[B] +-3[B] | +-1[B] | | +-0[B] | | \-2[B] | \-5[B] | +-4[B] | \-6[B] \-11[B] +-9[B] | +-8[B] | \-10[B] \-13[B] +-12[B] \-14[B] \-15[R]~~
~~Raku~~

(formerly Perl 6)

Works with: rakudo version 2016.11

Raku doesn't have algebraic data types (yet), but it does have pretty good pattern matching in multi signatures. <lang perl6>enum RedBlack <R B>;

multi balance(B,[R,[R,$a,$x,$b],$y,$c],$z,$d) { [R,[B,$a,$x,$b],$y,[B,$c,$z,$d]] } multi balance(B,[R,$a,$x,[R,$b,$y,$c]],$z,$d) { [R,[B,$a,$x,$b],$y,[B,$c,$z,$d]] } multi balance(B,$a,$x,[R,[R,$b,$y,$c],$z,$d]) { [R,[B,$a,$x,$b],$y,[B,$c,$z,$d]] } multi balance(B,$a,$x,[R,$b,$y,[R,$c,$z,$d]]) { [R,[B,$a,$x,$b],$y,[B,$c,$z,$d]] }

multi balance($col, $a, $x, $b) { [$col, $a, $x, $b] }

multi ins( $x, @s [$col, $a, $y, $b] ) {

~~when $x before $y { balance $col, ins($x, $a), $y, $b } when $x after $y { balance $col, $a, $y, ins($x, $b) } default { @s }~~

} multi ins( $x, Any:U ) { [R, Any, $x, Any] }

multi insert( $x, $s ) {

~~[B, |ins($x,$s)[1..3]];~~

}

sub MAIN {

~~my $t = Any; $t = insert($_, $t) for (1..10).pick(*); say $t.gist;~~

}</lang> This code uses generic comparison operators before and after, so it should work on any ordered type.

~~Output:~~
~~[B [B [B (Any) 1 [R (Any) 2 (Any)]] 3 [B (Any) 4 [R (Any) 5 (Any)]]] 6 [B [B (Any) 7 (Any)] 8 [B [R (Any) 9 (Any)] 10 (Any)]]]~~
~~Rascal~~

Rascal offers many options for pattern matching. In essence, there are four sorts of patterns: Abstract, Concrete, PatternWithAction and classic Regular Expressions. These patterns can be used in several cases, for example switch or visit statements, on the right of the Match operator (:=), or in TryCatch statements for thrown exceptions. Each pattern binds variables in a conditional scope.

~~Abstract~~

An abstract pattern is recursively defined and may contain, among others, the following elements: Literal, VariableDeclaration, MultiVariable, Variable, List, Set, Tuple, Node, Descendant, Labelled, TypedLabelled, TypeConstrained. More explanation can be found in the Documentation. Some examples: <lang rascal> // Literal rascal>123 := 123 bool: true

// VariableDeclaration rascal>if(str S := "abc") >>>>>>> println("Match succeeds, S == \"~~\""); Match succeeds, S == "abc" ok~~

~~// MultiVariable rascal>if([10, N*, 50] := [10, 20, 30, 40, 50]) >>>>>>> println("Match succeeds, N == <N>"); Match succeeds, N == [20,30,40] ok~~

~~// Variable rascal>N = 10; int: 10 rascal>N := 10; bool: true rascal>N := 20; bool: false~~

~~// Set and List rascal>if({10, set[int] S, 50} := {50, 40, 30, 20, 10}) >>>>>>> println("Match succeeded, S = ~~"); Match succeeded, S = {30,40,20} ok~~~~

rascal>for([L1*, L2*] := [10, 20, 30, 40, 50]) >>>>>>> println("<L1> and <L2>"); [] and [10,20,30,40,50] [10] and [20,30,40,50] [10,20] and [30,40,50] [10,20,30] and [40,50] [10,20,30,40] and [50] [10,20,30,40,50] and [] list[void]: []

// Descendant rascal>T = red(red(black(leaf(1), leaf(2)), black(leaf(3), leaf(4))), black(leaf(5), leaf(4))); rascal>for(/black(_,leaf(4)) := T) >>>>>>> println("Match!"); Match! Match! list[void]: []

~~rascal>for(/black(_,leaf(int N)) := T) >>>>>>> println("Match <N>"); Match 2 Match 4 Match 4 list[void]: []~~

~~rascal>for(/int N := T) >>>>>>> append N; list[int]: [1,2,3,4,5,4]~~

~~// Labelled rascal>for(/M:black(_,leaf(4)) := T) >>>>>>> println("Match <M>"); Match black(leaf(3),leaf(4)) Match black(leaf(5),leaf(4)) list[void]: []</lang>~~

~~~~Concrete~~~~

Suppose we want to manipulate text written in some hypothetical language LANG. Then first the concrete syntax of LANG has to be defined by importing a module that declares the non-terminals and syntax rules for LANG. Next LANG programs have to be parsed. LANG programs made come from text files or they may be included in the Rascal program as literals. In both cases the text is parsed according to the defined syntax and the result is a parse tree in the form of a value of type Tree. Concrete patterns operate on these trees.

A concrete pattern is a quoted concrete syntax fragment that may contain variables. The syntax that is used to parse the concrete pattern may come from any module that has been imported in the module in which the concrete pattern occurs. Some examples of concrete patterns: <lang rascal>// Quoted pattern ` Token1 Token2 ... Tokenn ` // A typed quoted pattern (Symbol) ` Token1 Token2 ... TokenN ` // A typed variable pattern <Type Var> // A variable pattern </lang>

A full example of concrete patterns can be found in the Rascal Recipes.

~~~~PatternWithAction~~~~

There are two variants of the PatternsWitchAction. When the subject matches Pattern, the expression Exp is evaluated and the subject is replaced with the result. Secondly, when the subject matches Pattern, the (block of) Statement(s) is executed. See below for some ColoredTree examples:

<lang rascal>// Define ColoredTrees with red and black nodes and integer leaves data ColoredTree = leaf(int N)

~~~~| red(ColoredTree left, ColoredTree right) | black(ColoredTree left, ColoredTree right);~~~~

// Count the number of black nodes public int cntBlack(ColoredTree t){

~~~~int c = 0; visit(t) { case black(_,_): c += 1; }; return c;~~~~

}

// Returns if a tree is balanced public bool balance(ColoredTree t){

~~~~visit(t){ case black(a,b): if (cntBlack(a) == cntBlack(b)) true; else return false; case red(a,b): if (cntBlack(a) == cntBlack(b)) true; else return false; } return true;~~~~

} // Compute the sum of all integer leaves public int addLeaves(ColoredTree t){

~~~~int c = 0; visit(t) { case leaf(int N): c += N; }; return c;~~~~

}

// Add green nodes to ColoredTree data ColoredTree = green(ColoredTree left, ColoredTree right);

// Transform red nodes into green nodes public ColoredTree makeGreen(ColoredTree t){

~~~~return visit(t) { case red(l, r) => green(l, r) };~~~~

}</lang>

~~~~Regular Expressions~~~~

Regular expressions are noated between two slashes. Most normal regular expressions patterns are available, such as ., \n, \d, etc. Additionally, flags can be used to create case intensiveness.

<lang rascal>rascal>/XX/i := "some xx"; bool: true rascal>/a.c/ := "abc"; bool: true</lang>

~~~~REXX~~~~

The nodes used for this example are taken from the Wikipedia example at: [red black tree, an example] <lang rexx>/*REXX pgm builds a red/black tree (with verification & validation), balanced as needed.*/ parse arg nodes '/' insert /*obtain optional arguments from the CL*/ if nodes= then nodes = 13.8.17 8.1.11 17.15.25 1.6 25.22.27 /*default nodes. */ if insert= then insert= 22.44 44.66 /* " inserts.*/ top= . /*define the default for the TOP var.*/ call Dnodes nodes /*define nodes, balance them as added. */ call Dnodes insert /*insert " " " " needed.*/ call Lnodes /*list the nodes (with indentations). */ exit /*stick a fork in it, we're all done. */ /*──────────────────────────────────────────────────────────────────────────────────────*/ err: say; say '***error***: ' arg(1); say; exit 13 /*──────────────────────────────────────────────────────────────────────────────────────*/ Dnodes: arg $d; do j=1 for words($d); t= word($d, j) /*color: encoded into L. */

parse var t p '.' a "." b '.' x 1 . . . xx call Vnodes p a b if x\== then call err "too many nodes specified: " xx if p\==top then if @.p==. then call err "node isn't defined: " p if p ==top then do; !.p=1; L.1=p; end /*assign the top node. */ @.p= a b; n= !.p + 1 /*assign node; bump level.*/ if a\== then do; !.a= n; @.a=; maxL= max(maxL, !.a); end if b\== then do; !.b= n; @.b=; maxL= max(maxL, !.b); end L.n= space(L.n a b) /*append to the level list*/ end /*j*/ return

/*──────────────────────────────────────────────────────────────────────────────────────*/ Lnodes: do L=1 for maxL; w= length(maxL); rb= word('(red) (black)', 1+L//2)

~~~~say "level:" right(L, w) left(, L+L) " ───► " rb ' ' L.L end /*lev*/ return~~~~

/*──────────────────────────────────────────────────────────────────────────────────────*/ Vnodes: arg $v; do v=1 for words($v); y= word($v, v)

if \datatype(y, 'W') then call err "node isn't a whole number: " y y= y / 1 /*normalize Y int.: no LZ, dot*/ if top==. then do; LO=y; top=y; HI=y; L.=; @.=; maxL=1; end LO= min(LO, y); HI= max(HI, y) if @.y\==. & @.y\== then call err "node is already defined: " y end /*v*/ return</lang>

~~~~output when using the default inputs:~~~~
level: 1 ───► (black) 13 level: 2 ───► (red) 8 17 level: 3 ───► (black) 1 11 15 25 level: 4 ───► (red) 6 22 27 level: 5 ───► (black) 44 level: 6 ───► (red) 66
~~~~Rust~~~~
Translation of: Haskell

This would be a horribly inefficient way to implement a Red-Black Tree in Rust as nodes are being allocated and deallocated constantly, but it does show off Rust's pattern matching. <lang rust>#![feature(box_patterns, box_syntax)] use self::Color::*; use std::cmp::Ordering::*;

enum Color {R,B}

type Link<T> = Option<Box<N<T>>>; struct N<T> {

~~~~c: Color, l: Link<T>, val: T, r: Link<T>,~~~~

}

impl<T: Ord> N<T> {

fn balance(col: Color, n1: Link<T>, z: T, n2: Link<T>) -> Link<T> { Some(box match (col,n1,n2) { (B, Some(box N {c: R, l: Some(box N {c: R, l: a, val: x, r: b}), val: y, r: c}), d) | (B, Some(box N {c: R, l: a, val: x, r: Some (box N {c: R, l: b, val: y, r: c})}), d) => N {c: R, l: Some(box N {c: B, l: a, val: x, r: b}), val: y, r: Some(box N {c: B, l: c, val: z, r: d})}, (B, a, Some(box N {c: R, l: Some(box N {c: R, l: b, val: y, r: c}), val: v, r: d})) | (B, a, Some(box N {c: R, l: b, val: y, r: Some(box N {c: R, l: c, val: v, r: d})})) => N {c: R, l: Some(box N {c: B, l: a, val: z, r: b}), val: y, r: Some(box N {c: B, l: c, val: v, r: d})}, (col, a, b) => N {c: col, l: a, val: z, r: b}, }) } fn insert(x: T, n: Link<T>) -> Link<T> { match n { None => Some(box N { c: R, l: None, val: x, r: None }), Some(n) => { let n = *n; let N {c: col, l: a, val: y, r: b} = n; match x.cmp(&y) { Greater => Self::balance(col, a,y,Self::insert(x,b)), Less => Self::balance(col, Self::insert(x,a),y,b), Equal => Some(box N {c: col, l: a, val: y, r: b}) } } } }

}</lang>

~~~~Scala~~~~
Translation of: Haskell

Algebraic data types are implemented in Scala through the combination of a number of different features, to ensure principles of Object Oriented Programming.

The main type is usually defined as a sealed abstract class, which ensures it can't be instantiated, and guarantees that it can't be expanded outside the file it was defined at. This last feature is used so the compiler can verify that the pattern matching is complete, or warn when there are missing cases. It can be ommitted if preferred.

Each subtype is defined either as a case object, for non-paremeterized types, or case class, for parameterized types, all extending the main type. The case keyword is not required, but, when used, it provides a number of default methods which ensure they can be used without any further definitions.

The most important of those default methods for the purpose of algebraic data types is the extractor, a method called either unapply or unapplySeq, and which returns an Option containing the deconstructed parameters, or None if the passed object can't be deconstructed by this method. Scala uses the extractors to implement pattern matching without exposing the internal representation of the data.

This specific task is made much harder than necessary because Scala doesn't have a variant ordering class. Given that limitation, one has to either give up on a singleton object representing the empty tree, or give up on parameterizing the tree itself.

The solution below, uses the latter approach. The algebraic data types are members of a RedBlackTree class, which, itself, receives a type parameter for the keys of the tree, and an implicit parameter for an Ordering for that type. To use the tree it is thus necessary to instantiate an object of type RedBlackTree, and then reference the members of that object.

<lang scala>class RedBlackTree[A](implicit ord: Ordering[A]) {

sealed abstract class Color case object R extends Color case object B extends Color sealed abstract class Tree { def insert(x: A): Tree = ins(x) match { case T(_, a, y, b) => T(B, a, y, b) case E => E } def ins(x: A): Tree } case object E extends Tree { override def ins(x: A): Tree = T(R, E, x, E) } case class T(c: Color, left: Tree, a: A, right: Tree) extends Tree { private def balance: Tree = (c, left, a, right) match { case (B, T(R, T(R, a, x, b), y, c), z, d ) => T(R, T(B, a, x, b), y, T(B, c, z, d)) case (B, T(R, a, x, T(R, b, y, c)), z, d ) => T(R, T(B, a, x, b), y, T(B, c, z, d)) case (B, a, x, T(R, T(R, b, y, c), z, d )) => T(R, T(B, a, x, b), y, T(B, c, z, d)) case (B, a, x, T(R, b, y, T(R, c, z, d))) => T(R, T(B, a, x, b), y, T(B, c, z, d)) case _ => this } override def ins(x: A): Tree = ord.compare(x, a) match { case -1 => T(c, left ins x, a, right ).balance case 1 => T(c, left, a, right ins x).balance case 0 => this } }

}</lang>

Usage example:

scala> val rbt = new RedBlackTree[Int] rbt: RedBlackTree[Int] = RedBlackTree@17dfcf1 scala> import rbt._ import rbt._ scala> List.range(1, 17).foldLeft(E: Tree)(_ insert _) res5: rbt.Tree = T(B,T(B,T(B,T(B,E,1,E),2,T(B,E,3,E)),4,T(B,T(B,E,5,E),6,T(B,E,7,E))),8,T(B,T(B,T(B,E,9,E),10,T(B,E,11,E )),12,T(B,T(B,E,13,E),14,T(B,E,15,T(R,E,16,E)))))
~~~~Standard ML~~~~

<lang sml> datatype color = R | B datatype 'a tree = E | T of color * 'a tree * 'a * 'a tree

(** val balance = fn : color * 'a tree * 'a * 'a tree -> 'a tree *) fun balance (B, T (R, T (R,a,x,b), y, c), z, d) = T (R, T (B,a,x,b), y, T (B,c,z,d))

| balance (B, T (R, a, x, T (R,b,y,c)), z, d) = T (R, T (B,a,x,b), y, T (B,c,z,d)) | balance (B, a, x, T (R, T (R,b,y,c), z, d)) = T (R, T (B,a,x,b), y, T (B,c,z,d)) | balance (B, a, x, T (R, b, y, T (R,c,z,d))) = T (R, T (B,a,x,b), y, T (B,c,z,d)) | balance (col, a, x, b) = T (col, a, x, b)

(** val insert = fn : int -> int tree -> int tree *) fun insert x s = let

~~~~fun ins E = T (R,E,x,E) | ins (s as T (col,a,y,b)) =~~~~

if x < y then balance (col, ins a, y, b) else if x > y then balance (col, a, y, ins b) else s

~~~~val T (_,a,y,b) = ins s~~~~

in

~~~~T (B,a,y,b)~~~~

end </lang>

~~~~Swift~~~~
Works with: Swift version 2+

<lang swift>enum Color { case R, B } enum Tree<A> {

~~~~case E indirect case T(Color, Tree<A>, A, Tree<A>)~~~~

}

func balance<A>(input: (Color, Tree<A>, A, Tree<A>)) -> Tree<A> {

switch input { case let (.B, .T(.R, .T(.R,a,x,b), y, c), z, d): return .T(.R, .T(.B,a,x,b), y, .T(.B,c,z,d)) case let (.B, .T(.R, a, x, .T(.R,b,y,c)), z, d): return .T(.R, .T(.B,a,x,b), y, .T(.B,c,z,d)) case let (.B, a, x, .T(.R, .T(.R,b,y,c), z, d)): return .T(.R, .T(.B,a,x,b), y, .T(.B,c,z,d)) case let (.B, a, x, .T(.R, b, y, .T(.R,c,z,d))): return .T(.R, .T(.B,a,x,b), y, .T(.B,c,z,d)) case let (col, a, x, b) : return .T(col, a, x, b) }

}

func insert<A : Comparable>(x: A, s: Tree<A>) -> Tree<A> {

func ins(s: Tree<A>) -> Tree<A> { switch s { case .E : return .T(.R,.E,x,.E) case let .T(col,a,y,b): if x < y { return balance((col, ins(a), y, b)) } else if x > y { return balance((col, a, y, ins(b))) } else { return s } } } switch ins(s) { case let .T(_,a,y,b): return .T(.B,a,y,b) case .E: assert(false) return .E }

}</lang>

~~~~Tailspin~~~~
Translation of: Haskell

Tailspin doesn't have type names, so here using a tag. Neither does it have destructuring (which seems to be posited in the problem statement). Arguably, pattern matching in Tailspin is more readable while still as concise. <lang tailspin> processor RedBlackTree

data node <{VOID}|{colour: <='black'|='red'>, left: <node>, right: <node>, value: <> VOID}> local @: {}; sink insert templates balance when <{colour: <='black'>, left: <{ colour: <='red'> left: <{colour: <='red'>}>}>}> do { colour: 'red', left: { $.left.left..., colour: 'black'}, value: $.left.value, right: { $..., left: $.left.right }} ! when <{colour: <='black'>, left: <{ colour: <='red'> right: <{colour: <='red'>}>}>}> do { colour: 'red', left: { $.left..., colour: 'black', right: $.left.right.left}, value: $.left.right.value, right: { $..., left: $.left.right.right }} ! when <{colour: <='black'>, right: <{ colour: <='red'> left: <{colour: <='red'>}>}>}> do { colour: 'red', left: { $..., right: $.right.left.left}, value: $.right.left.value, right: { $.right..., colour: 'black', left: $.right.left.right }} ! when <{colour: <='black'>, right: <{ colour: <='red'> right: <{colour: <='red'>}>}>}> do { colour: 'red', left: { $..., right: $.right.left}, value: $.right.value, right: { $.right.right..., colour: 'black' }} ! otherwise $ ! end balance templates ins&{into:} when <?($into <={}>)> do { colour: 'red', left: {}, value: $, right: {}} ! when <..$into.value::raw> do { $into..., left: $ -> ins&{into: $into.left}} -> balance ! otherwise { $into..., right: $ -> ins&{into: $into.right}} -> balance ! end ins @RedBlackTree: { $ -> ins&{into: $@RedBlackTree} ..., colour: 'black'}; end insert source toString '$@RedBlackTree;' ! end toString

end RedBlackTree

def tree: $RedBlackTree; 1..5 -> $'$tree::toString;$#10;' -> !OUT::write $ -> !tree::insert $ -> !VOID $tree::toString -> !OUT::write </lang>

~~~~Output:~~~~
{} {colour=black, left={}, right={}, value=1} {colour=black, left={}, right={colour=red, left={}, right={}, value=2}, value=1} {colour=black, left={colour=black, left={}, right={}, value=1}, right={colour=black, left={}, right={}, value=3}, value=2} {colour=black, left={colour=black, left={}, right={}, value=1}, right={colour=black, left={}, right={colour=red, left={}, right={}, value=4}, value=3}, value=2} {colour=black, left={colour=black, left={}, right={}, value=1}, right={colour=red, left={colour=black, left={}, right={}, value=3}, right={colour=black, left={}, right={}, value=5}, value=4}, value=2}
~~~~Tcl~~~~
Translation of: Haskell

Tcl doesn't have algebraic types built-in, but they can be simulated using tagged lists, and a custom pattern matching control structure can be built: <lang tcl># From http://wiki.tcl.tk/9547 package require Tcl 8.5 package provide datatype 0.1

namespace eval ::datatype {

~~~~namespace export define match matches namespace ensemble create~~~~
# Datatype definitions proc define {type = args} { set ns [uplevel 1 { namespace current }] foreach cons [split [join $args] |] { set name [lindex $cons 0] set args [lrange $cons 1 end] proc $ns\::$name $args [format { lreplace [info level 0] 0 0 %s } [list $name]] } return $type }
# Pattern matching # matches pattern value envVar -- # Returns 1 if value matches pattern, else 0 # Binds match variables in envVar proc matches {pattern value envVar} { upvar 1 $envVar env if {[var? $pattern]} { return [bind env $pattern $value] } if {[llength $pattern] != [llength $value]} { return 0 } if {[lindex $pattern 0] ne [lindex $value 0]} { return 0 } foreach pat [lrange $pattern 1 end] val [lrange $value 1 end] { if {![matches $pat $val env]} { return 0 } } return 1 } # A variable starts with lower-case letter or _. _ is a wildcard. proc var? term { string match {[a-z_]*} $term } proc bind {envVar var value} { upvar 1 $envVar env if {![info exists env]} { set env [dict create] } if {$var eq "_"} { return 1 } dict set env $var $value return 1 } proc match args { #puts "MATCH: $args" set values [lrange $args 0 end-1] set choices [lindex $args end] append choices \n [list return -code error -level 2 "no match for $values"] set f [list values $choices [namespace current]] lassign [apply $f $values] env body #puts "RESULT: $env -> $body" dict for {k v} $env { upvar 1 $k var; set var $v } catch { uplevel 1 $body } msg opts dict incr opts -level return -options $opts $msg } proc case args { upvar 1 values values set patterns [lrange $args 0 end-2] set body [lindex $args end] set env [dict create] if {[llength $patterns] != [llength $values]} { return } foreach pattern $patterns value $values { if {![matches $pattern $value env]} { return } } return -code return [list $env $body] } proc default body { return -code return [list {} $body] }

} </lang> We can then code our solution similar to Haskell:

<lang tcl>datatype define Color = R | B datatype define Tree = E | T color left val right

~~~~balance :: Color -> Tree a -> a -> Tree a -> Tree a~~~~

proc balance {color left val right} {

datatype match $color $left $val $right { case B [T R [T R a x b] y c] z d -> { T R [T B $a $x $b] $y [T B $c $z $d] } case B [T R a x [T R b y c]] z d -> { T R [T B $a $x $b] $y [T B $c $z $d] } case B a x [T R [T R b y c] z d] -> { T R [T B $a $x $b] $y [T B $c $z $d] } case B a x [T R b y [T R c z d]] -> { T R [T B $a $x $b] $y [T B $c $z $d] } case col a x b -> { T $col $a $x $b } }

}

~~~~insert :: Ord a => a -> Tree a -> Tree a~~~~

proc insert {x s} {

~~~~datatype match [ins $x $s] { case [T _ a y b] -> { T B $a $y $b } }~~~~

}

~~~~ins :: Ord a => a -> Tree a -> Tree a~~~~

proc ins {x s} {

datatype match $s { case E -> { T R E $x E } case [T col a y b] -> { if {$x < $y} { return [balance $col [ins $x $a] $y $b] } if {$x > $y} { return [balance $col $a $y [ins $x $b]] } return $s } }

}</lang>

~~~~Wren~~~~
Translation of: Go

Wren doesn't have either algebraic data types or pattern matching though, despite that, the T.balance() method looks better than I thought it would :) <lang ecmascript>var R = "R" var B = "B"

class Tree {

~~~~ins(x) {} // overridden by child classes~~~~
~~~~insert(x) { // inherited by child classes var t = ins(x) if (t.type == T) return T.new(B, t.le, t.aa, t.ri) if (t.type == E) return E.new() return null }~~~~

}

class T is Tree {

~~~~construct new(cl, le, aa, ri) { _cl = cl // color _le = le // Tree _aa = aa // integer _ri = ri // Tree }~~~~
~~~~cl { _cl } le { _le } aa { _aa } ri { _ri }~~~~
~~~~balance() { if (_cl != B) return this~~~~
var le2 = _le.type == T ? _le : null var lele var leri if (le2) { lele = _le.le.type == T ? _le.le : null leri = _le.ri.type == T ? _le.ri : null } var ri2 = _ri.type == T ? _ri : null var rile var riri if (ri2) { rile = _ri.le.type == T ? _ri.le : null riri = _ri.ri.type == T ? _ri.ri : null }
if (le2 && lele && le2.cl == R && lele.cl == R) { var t = le2.le return T.new(R, T.new(B, t.le, t.aa, t.ri), le2.aa, T.new(B, le2.ri, _aa, _ri)) } if (le2 && leri && le2.cl == R && leri.cl == R) { var t = le2.ri return T.new(R, T.new(B, le2.le, le2.aa, t.le), t.aa, T.new(B, t.ri, _aa, _ri)) } if (ri2 && rile && ri2.cl == R && rile.cl == R) { var t = ri2.ri return T.new(R, T.new(B, _le, _aa, t.le), t.aa, T.new(B, t.ri, ri2.aa, ri2.ri)) } if (ri2 && riri && ri2.cl == R && riri.cl == R) { var t = ri2.ri return T.new(R, T.new(B, _le, _aa, ri2.le), ri2.aa, T.new(B, t.le, t.aa, t.ri)) } return this }
~~~~ins(x) { if (x < _aa) return T.new(_cl, _le.ins(x), _aa, _ri).balance() if (x > _aa) return T.new(_cl, _le, _aa, _ri.ins(x)).balance() return this }~~~~
~~~~toString { "T(%(_cl), %(_le), %(_aa), %(_ri))" }~~~~

}

class E is Tree {

~~~~construct new() {}~~~~
~~~~ins(x) { T.new(R, E.new(), x, E.new()) }~~~~
~~~~toString { "E" }~~~~

}

var tr = E.new() for (i in 1..16) tr = tr.insert(i) System.print(tr)</lang>

~~~~Output:~~~~
~~T(B, T(B, T(B, T(B, E, 1, E), 2, T(B, E, 3, E)), 4, T(B, T(B, E, 5, E), 6, T(B, E, 7, E))), 8, T(B, T(B, T(B, E, 9, E), 10, T(B, E, 11, E)), 12, T(B, T(B, E, 13, E), 14, T(B, E, 15, T(R, E, 16, E)))))~~