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