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

--
-- 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()
