tasks a-s

Task/Pattern-matching/0DESCRIPTION

@@ -0,0 +1,5 @@
+{{omit from|BBC BASIC}}
+
+Some languages offer direct support for [[wp:Algebraic_data_type|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.
+
+As an example, implement insertion in a [[wp:Red_Black_Tree|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.

Task/Pattern-matching/1META.yaml

@@ -0,0 +1,2 @@
+---
+note: Data Structures

Task/Pattern-matching/Bracmat/pattern-matching-1.bracmat

@@ -0,0 +1,47 @@
+  ( 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
+  =   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
+  )
+;

Task/Pattern-matching/Bracmat/pattern-matching-2.bracmat

@@ -0,0 +1,8 @@
+    (   it allows for terse code which is easy to read
+      , and can represent the algorithm directly
+    .
+    )
+  : ?values
+& insertMany$(!values.):?tree
+& out$!tree
+& done;

Task/Pattern-matching/Bracmat/pattern-matching-3.bracmat

@@ -0,0 +1,20 @@
+  B
+.   ( 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,))
+        )
+    )

Task/Pattern-matching/Common-Lisp/pattern-matching.lisp

@@ -0,0 +1,39 @@
+(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))))

Task/Pattern-matching/Haskell/pattern-matching.hs

@@ -0,0 +1,18 @@
+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

Task/Pattern-matching/J/pattern-matching-1.j

@@ -0,0 +1,196 @@
+help=: noun define
+red-black tree
+Store dictionary in red-black tree.  The keys can be any noun.
+
+Reference:
+Left-leaning Red-Black Trees
+Robert Sedgewick
+Department of Computer Science
+Princeton University
+
+verbs:
+insert key;value  Inserts item into tree
+delete key        Deletes item with key from tree
+                  Deletion via the Sedgewick method is fairly simple.
+                  However, I elected to remove the KEY;VALUE pair
+                  rather than change the tree.
+find key          Returns the associated definition or EMPTY
+items any_noun    Returns all the items as a rank 1 array of KEY;VALUE pairs
+keys any_noun     Returns all the keys as a rank 1 array of boxes
+values any_noun   Returns all the values as a rank 1 array of boxes
+
+J stores all data as arrays.
+I chose to use array indexes to implement pointers.
+An "index" is a rank 0 length 1 array.
+
+Internal data structure:
+
+T This rank 2 array stores indexes of left and right at each branch point.
+C rank 1 array of node color.
+H rank 1 array of the hash value of each key.
+R rank 0 array stores the root index.
+D rank 1 array of boxes.  In each box is a rank 2 array of key value
+  pairs associated with the hash value.  Hash collision invokes direct
+  lookup by key among the keys having same hash.
+
+Additional test idea (done):
+  Changing the hash to 0: or 2&| rapidly tests
+  hash collision code for integer keys.
+)
+
+bitand=: (#. 1  0 0 0 1)b.
+bitxor=: (#. 1  0 1 1 0)b.
+hash=: [: ((4294967295) bitand (bitxor 1201&*))/ 846661 ,~ ,@:(a.&i.)@:":
+NB. hash=: ] [ 1&bitand NB. can choose simple hash functions for tests
+
+setup=: 3 : 0
+T=: i. 0 2                              NB. Tree
+H=: D=: C=: i. 0                        NB. Hashes, Data, Color
+R=: _                                   NB. Root
+'BLACK RED'=: i. 2
+EMPTY
+)
+
+setup''
+
+flipColors=: monad def 'C=: -.@:{`[`]}&C (, {&T) y'
+
+3 : 0 'test flipColors'
+DD=.D=: ,/<@:(;3j1&":)"0 i.3
+TT=.T=: _ _,0 2,:_ _
+CC=.C=: 1 0 1
+RR=.R=: 1
+HH=.H=: i.3
+flipColors R
+assert C -: -. CC
+assert HH -: H
+assert TT -: T
+assert DD -: D
+assert RR -: R
+)
+
+getColor=: monad def 'C ({~ :: (BLACK"_))"_ 0 y' NB. y the node
+
+rotateTree=: dyad define                NB. x left or right, y node
+I=. x <@:(, -.)~ y
+X=. I { T                               NB. x = root.otherside
+J=. X <@:, x
+T=: (J { T) I} T
+T=: y J} T
+C=: y (RED ,~ {)`(X , [)`]} C
+X
+)
+
+3 : 0 'test rotateTree'
+DD=.D=:,/<@:(;3j1&":)"0 i.5
+TT=.T=:_ _,0 2,_ _,1 4,:_ _
+CC=.C=:0 1 0 0 0
+R=:3
+HH=.H=:i.5
+assert R = rotateTree/0 1 , R
+assert DD -: D
+assert CC -: C
+assert HH -: H
+assert TT -: T
+)
+
+setup''
+
+insert_privately=: adverb define
+:
+ROOT=. m
+HASH=. x
+ITEM=. y
+if. _ -: ROOT do.                       NB. new key
+ ROOT=. # H
+ H=: H , HASH
+ T=: T , _ _
+ D=: D , < ,: , ITEM
+ C=: C , RED
+elseif. HASH = ROOT { H do.       NB. change a value or hash collision
+ STACK=. ROOT >@:{ D
+ I=. STACK i.&:({."1) ITEM
+ STACK=. ITEM <@:(I}`,@.(I = #@])) STACK
+ D=: STACK ROOT } D
+elseif. do.          NB. Follow tree
+ NB. if both children are red then flipColors ROOT
+ flipColors^:((,~ RED) -: getColor@:({&T)) ROOT
+ I=. <@:(, HASH > {&H) ROOT
+ TEMP=. HASH (I { T) insert_privately y
+ T=:  TEMP I } T
+ NB.if (isRed(h.right) && !isRed(h.left)) h = rotateLeft(h)
+ ROOT=. 0&rotateTree^:((BLACK,RED) -: getColor@:({&T)) ROOT
+ NB.if (isRed(h.left) && isRed(h.left.left)) h = rotateRight(h)
+ if. RED -: getColor {. ROOT { T do.
+  if. (RED -: (getColor@:(([: {&T <@:,&0)^:2) :: (BLACK"_))) ROOT do.
+   ROOT=. 1 rotateTree ROOT
+  end.
+ end.
+end.
+ROOT
+)
+
+insert=: monad define"1
+assert 'boxed' -: datatype y
+R=: (R insert_privately~ hash@:(0&{::)) y
+C=: BLACK R } C
+y
+)
+
+find_hash_index=: monad define          NB. y is the hash
+if. 0 = # T do. '' return. end.         NB. follow the tree
+I=. R                                   NB. instead of
+while. y ~: I { H do.                   NB. direct search
+ J=. <@:(, y > {&H) I
+ if. _ > II=. J { T do. I=. II else. '' return. end.
+end.
+)
+
+find=: monad define
+if. '' -: I=. find_hash_index hash y do. EMPTY return. end.
+LIST=. I {:: D
+K=. {. |: LIST
+LIST {::~ ::empty 1 ,~ K i. < y
+)
+
+delete=: 3 : 0
+if. '' -: I=. find_hash_index hash y do. EMPTY return. end.
+LIST=. I {:: D
+K=. {. |: LIST
+J=. K i. < y
+RESULT=. J ({::~ ,&1)~ LIST
+STACK=. J <@:({. , (}.~ >:)~) LIST
+D=. LIST I } D
+RESULT
+)
+
+getPathsToLeaves=: a:&$: : (4 : 0) NB. PATH getPathsToLeaves ROOT  use: getPathsToLeaves R
+if. 0 = # y do. getPathsToLeaves R return. end.
+PATH=. x ,&.> y
+if. _ -: y do. return. end.
+PATH getPathsToLeaves"0 y { T
+)
+
+check=: 3 : 0
+COLORS=. getColor"0&.> a: -.~ ~. , getPathsToLeaves ''
+result=. EMPTY
+if. 0&e.@:(= {.) +/@:(BLACK&=)@>COLORS do. result=. result,<'mismatched black count' end.
+if. 1 e. 1&e.@:(*. (= 1&|.))@:(RED&=)@>COLORS do. result=. result,<'successive reds' end.
+>result
+)
+
+getPath=: 3 : 0                        NB. get path to y, the key
+if. 0 = # H do. EMPTY return. end.
+HASH=. hash y
+PATH=. , I=. R
+while. HASH ~: I { H do.
+ J=. <@:(, HASH > {&H) I
+ PATH=. PATH , II=. J { T
+ if. _ > II do. I=. II else. EMPTY return. end.
+end.
+PATH
+)
+
+items=: 3 :';D'
+keys=: 3 :'0{"1 items y'
+values=: 3 :'1{"1 items y'

Task/Pattern-matching/J/pattern-matching-2.j

@@ -0,0 +1,11 @@
+   load'rb.ijs'
+   NB. populate dictionary in random order with 999 key value pairs
+   insert@:(; 6j1&":)"0@:?~ 999
+   find 'the' NB. 'the' has no entry.
+   find 239   NB. entry 239 has the anticipated formatted string value.
+ 239.0
+   find 823823 NB. also no such entry
+   NB.
+   NB. tree passes the "no consecutive red" and "same number of black"
+   NB. nodes to and including NULL leaves.
+   check''

Task/Pattern-matching/OCaml/pattern-matching.ocaml

@@ -0,0 +1,24 @@
+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
+  | B, T (R, T (R,a,x,b), y, c), z, d
+  | B, T (R, a, x, T (R,b,y,c)), z, d
+  | B, a, x, T (R, T (R,b,y,c), z, d)
+  | 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))
+  | col, a, x, b                      -> T (col, a, x, b)
+
+(** 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)

Task/Pattern-matching/Oz/pattern-matching.oz

@@ -0,0 +1,24 @@
+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

Task/Pattern-matching/Perl-6/pattern-matching.pl6

@@ -0,0 +1,25 @@
+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.perl;
+}

Task/Pattern-matching/PicoLisp/pattern-matching-1.l

@@ -0,0 +1,35 @@
+(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)
+   (@ < (-> @X) (-> @Y))
+   (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)) )

Task/Pattern-matching/PicoLisp/pattern-matching-2.l

@@ -0,0 +1,3 @@
+: (? (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

Task/Pattern-matching/Racket/pattern-matching.rkt

@@ -0,0 +1,28 @@
+#lang racket
+
+(struct t-node (color t-left value t-right))
+
+(define (balance t)
+  (match t
+    [(t-node 'black (t-node 'red (t-node 'red a x b) y c) z d)
+     (t-node 'red (t-node 'black a x b) y (t-node 'black c z d))]
+    [(t-node 'black (t-node 'red a x (t-node 'red b y c)) z d)
+     (t-node 'red (t-node 'black a x b) y (t-node 'black c z d))]
+    [(t-node 'black a x (t-node 'red (t-node 'red b y c) z d))
+     (t-node 'red (t-node 'black a x b) y (t-node 'black c z d))]
+    [(t-node 'black a x (t-node 'red b y (t-node 'red c z d)))
+     (t-node 'red (t-node 'black a x b) y (t-node 'black c z d))]
+    [else t]))
+
+(define (insert x s)
+  (define (ins t)
+    (match t
+      ['empty (t-node 'red 'empty x 'empty)]
+      [(t-node c a y b)
+       (cond [(< x y)
+              (balance (t-node c (ins a) y b))]
+             [(> x y)
+              (balance (t-node c a y (ins b)))]
+             [else t])]))
+  (match (ins s)
+    [(t-node _ a y b) (t-node 'black a y b)]))

Task/Pattern-matching/Rascal/pattern-matching-1.rascal

@@ -0,0 +1,65 @@
+// Literal
+rascal>123 := 123
+bool: true
+
+// VariableDeclaration
+rascal>if(str S := "abc")
+>>>>>>>   println("Match succeeds, S == \"<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 = <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]: []

Task/Pattern-matching/Rascal/pattern-matching-2.rascal

@@ -0,0 +1,8 @@
+// Quoted pattern
+` Token1 Token2 ... Tokenn `
+// A typed quoted pattern
+(Symbol) ` Token1 Token2 ... TokenN `
+// A typed variable pattern
+<Type Var>
+// A variable pattern
+<Var>

Task/Pattern-matching/Rascal/pattern-matching-3.rascal

@@ -0,0 +1,40 @@
+// 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)
+   };
+}

Task/Pattern-matching/Rascal/pattern-matching-4.rascal

@@ -0,0 +1,4 @@
+rascal>/XX/i := "some xx";
+bool: true
+rascal>/a.c/ := "abc";
+bool: true

Task/Pattern-matching/Scala/pattern-matching.scala

@@ -0,0 +1,33 @@
+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
+    }
+  }
+}

Task/Pattern-matching/Standard-ML/pattern-matching.ml

@@ -0,0 +1,24 @@
+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

Task/Pattern-matching/Tcl/pattern-matching-1.tcl

@@ -0,0 +1,70 @@
+# 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] }
+}

Task/Pattern-matching/Tcl/pattern-matching-2.tcl

@@ -0,0 +1,30 @@
+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
+        }
+    }
+}