1// Koka language test module 2 3// This module implements the GarsiaWachs algorithm. 4// It is an adaptation of the algorithm in ML as described by JeanChristophe Filli�tre: 5// in ''A functional implementation of the GarsiaWachs algorithm. (functional pearl). ML workshop 2008, pages 91--96''. 6// See: http://www.lri.fr/~filliatr/publis/gwWml08.pdf 7// 8// The algorithm is interesting since it uses mutable references shared between a list and tree but the 9// side effects are not observable from outside. Koka automatically infers that the final algorithm is pure. 10// Note: due to a current limitation in the divergence analysis, koka cannot yet infer that mutually recursive 11// definitions in "insert" and "extract" are terminating and the final algorithm still has a divergence effect. 12// However, koka does infer that no other effect (i.e. an exception due to a partial match) can occur. 13module garcsiaWachs 14 15import test = qualified std/flags 16 17# pre processor test 18 19public function main() { 20 wlist = Cons1(('a',3), [('b',2),('c',1),('d',4),('e',5)]) 21 tree = wlist.garsiaWachs() 22 tree.show.println() 23} 24 25//---------------------------------------------------- 26// Trees 27//---------------------------------------------------- 28public type tree<a> { 29 con Leaf(value :a) 30 con Node(left :tree<a>, right :tree<a>) 31} 32 33function show( t : tree<char> ) : string { 34 match(t) { 35 Leaf(c) -> core/show(c) 36 Node(l,r) -> "Node(" + show(l) + "," + show(r) + ")" 37 } 38} 39 40 41//---------------------------------------------------- 42// Non empty lists 43//---------------------------------------------------- 44public type list1<a> { 45 Cons1( head : a, tail : list<a> ) 46} 47 48function map( xs, f ) { 49 val Cons1(y,ys) = xs 50 return Cons1(f(y), core/map(ys,f)) 51} 52 53function zip( xs :list1<a>, ys :list1<b> ) : list1<(a,b)> { 54 Cons1( (xs.head, ys.head), zip(xs.tail, ys.tail)) 55} 56 57 58//---------------------------------------------------- 59// Phase 1 60//---------------------------------------------------- 61 62function insert( after : list<(tree<a>,int)>, t : (tree<a>,int), before : list<(tree<a>,int)> ) : div tree<a> 63{ 64 match(before) { 65 Nil -> extract( [], Cons1(t,after) ) 66 Cons(x,xs) -> { 67 if (x.snd < t.snd) then return insert( Cons(x,after), t, xs ) 68 match(xs) { 69 Nil -> extract( [], Cons1(x,Cons(t,after)) ) 70 Cons(y,ys) -> extract( ys, Cons1(y,Cons(x,Cons(t,after))) ) 71 } 72 } 73 } 74} 75 76function extract( before : list<(tree<a>,int)>, after : list1<(tree<a>,int)> ) : div tree<a> 77{ 78 val Cons1((t1,w1) as x, xs ) = after 79 match(xs) { 80 Nil -> t1 81 Cons((t2,w2) as y, ys) -> match(ys) { 82 Nil -> insert( [], (Node(t1,t2), w1+w2), before ) 83 Cons((_,w3),_zs) -> 84 if (w1 <= w3) 85 then insert(ys, (Node(t1,t2), w1+w2), before) 86 else extract(Cons(x,before), Cons1(y,ys)) 87 } 88 } 89} 90 91function balance( xs : list1<(tree<a>,int)> ) : div tree<a> { 92 extract( [], xs ) 93} 94 95//---------------------------------------------------- 96// Phase 2 97//---------------------------------------------------- 98 99function mark( depth :int, t :tree<(a,ref<h,int>)> ) : <write<h>> () { 100 match(t) { 101 Leaf((_,d)) -> d := depth 102 Node(l,r) -> { mark(depth+1,l); mark(depth+1,r) } 103 } 104} 105 106function build( depth :int, xs :list1<(a,ref<h,int>)> ) : <read<h>,div> (tree<a>,list<(a,ref<h,int>)>) 107{ 108 if (!(xs.head.snd) == depth) return (Leaf(xs.head.fst), xs.tail) 109 110 l = build(depth+1, xs) 111 match(l.snd) { 112 Nil -> (l.fst, Nil) 113 Cons(y,ys) -> { 114 r = build(depth+1, Cons1(y,ys)) 115 (Node(l.fst,r.fst), r.snd) 116 } 117 } 118} 119 120//---------------------------------------------------- 121// Main 122//---------------------------------------------------- 123 124public function garsiaWachs( xs : list1<(a,int)> ) : div tree<a> 125{ 126 refs = xs.map(fst).map( fun(x) { (x, ref(0)) } ) 127 wleafs = zip( refs.map(Leaf), xs.map(snd) ) 128 129 tree = balance(wleafs) 130 mark(0,tree) 131 build(0,refs).fst 132} 133 134