diff --git a/examples/func_ds/BankersDeque.trp b/examples/func_ds/BankersDeque.trp new file mode 100644 index 00000000..f26f9fee --- /dev/null +++ b/examples/func_ds/BankersDeque.trp @@ -0,0 +1,74 @@ +import lazy +import lists +import streams + +datatype Atoms = NIL + +let + fun assertEq (got, exp, msg) = + if got = exp then print (msg ^ ": ok") + else print (msg ^ ": failed") + + val c = 2 + val empty = {F = fn () => NIL, LenF = 0, R = fn () => NIL, LenR = 0} + fun isEmpty {LenF = lenF, LenR = lenR, F = _, R = _} = (lenF + lenR = 0) + + fun queue {F = f, LenF = lenF, R = r, LenR = lenR} = + if lenF > c * lenR + 1 then + let val i = (lenF + lenR) div 2 + val j = lenF + lenR - i + val f' = take i f + val r' = streamAppend r (streamReverse (drop i f)) + in {F = f', LenF = i, R = r', LenR = lenR} end + else if lenR > c * lenF + 1 then + let val i = (lenF + lenR) div 2 + val j = lenF + lenR - i + val f' = streamAppend f (streamReverse (drop j r)) + val r' = take j r + in {F = f', LenF = i, R = r', LenR = lenR} end + else {F = f, LenF = lenF, R = r, LenR = lenR} + + fun cons {F = f, LenF = lenF, R = r, LenR = lenR} x = + queue {F = fn () => (x, f), LenF = lenF + 1, R = r, LenR = lenR} + fun head {F = f, R = r, LenF = _, LenR = _} = + case (force f) of + (x, _) => x + | _ => case (force r) of + NIL => print "EMPTY!" + | (x, _) => x + fun tail {F = f, R = r, LenF = lenF, LenR = lenR} = + case (force f) of + (x, f') => queue {F = f', LenF = lenF - 1, R = r, LenR = lenR} + | _ => case (force r) of + NIL => print "EMPTY!" + | (x, _) => empty + + fun snoc {F = f, LenF = lenF, R = r, LenR = lenR} x = + queue {F = f, LenF = lenF, R = fn () => (x, r), LenR = lenR + 1} + fun last {F = f, R = r, LenF = _, LenR = _} = + case (force r) of + (x, _) => x + | _ => case (force f) of + NIL => print "EMPTY!" + | (x, _) => x + fun init {F = f, R = r, LenF = lenF, LenR = lenR} = + case (force r) of + (x, r') => queue {F = f, LenF = lenF, R = r', LenR = lenR - 1} + | _ => case (force f) of + NIL => print "EMPTY!" + | (x, _) => empty + + fun dequeToList {F = f, R = r, LenF = _, LenR = lenR} = + append (streamToList f) (streamToList r) + + val q0 = empty + val q1 = snoc q0 1 + val q2 = snoc q1 2 + val q3 = cons q2 0 + val _ = assertEq (head q3 = 0, true, "check head") + val _ = assertEq (last q3 = 2, true, "check last") + val _ = assertEq (dequeToList (tail q3) = [1, 2], true, "check tail") + val _ = assertEq (dequeToList (init q3) = [0, 1], true, "check init") +in + print "success!" +end diff --git a/examples/func_ds/BinaryRAList.trp b/examples/func_ds/BinaryRAList.trp new file mode 100644 index 00000000..0d97a2b0 --- /dev/null +++ b/examples/func_ds/BinaryRAList.trp @@ -0,0 +1,59 @@ +import lists + +datatype Atoms = NONE + +let + fun assertEq (got, exp, msg) = + if got = exp then print (msg ^ ": ok") + else print (msg ^ ": failed") + + val empty = [] + fun isEmpty ts = null ts + + fun size {Size = sz, Left = _, Right = _, Tag = _, Val = _} = sz + fun link (t1, t2) = {Size = size t1 + size t2, Left = t1, Right = t2, Tag = "Node", Val = NONE} + fun insTree (t, []) = [{Tag = "One", Tree = t}] + | insTree (t, {Tag = "Zero", Tree = _}::ts) = {Tag = "One", Tree = t}::ts + | insTree (t1, {Tag = "One", Tree = t2}::ts) = {Tag = "Zero", Tree = NONE}::insTree(link(t1, t2), ts) + fun borrowTree [] = print "Empty!" + | borrowTree ({Tag = "One", Tree = t}::[]) = (t, []) + | borrowTree ({Tag = "One", Tree = t}::ts) = (t, {Tag = "Zero", Tree = NONE}::ts) + | borrowTree ({Tag = "Zero", Tree = 0}::ts) = let val ({Tag = "Node", Size = _, Left = t1, Right = t2, Val = _}, ts') = borrowTree ts + in (t1, {Tag = "One", Tree = t2}::ts') end + + fun cons(x, ts) = insTree ({Tag = "Leaf", Size = 1, Left = NONE, Right = NONE, Val = x}, ts) + fun head ts = let val ({Tag = "Leaf", Val = x, Size = _, Left = _, Right = _}, _) = borrowTree ts in x end + fun tail ts = let val (_, ts') = borrowTree ts in ts' end + + fun lookupTree ({Tag = "Leaf", Val = x, Left = _, Right = _, Size = _}, 0) = x + | lookupTree ({Tag = "Leaf", Val = x, Left = _, Right = _, Size = _}, i) = print "Invalid Index!" + | lookupTree ({Tag = "Node", Val = _, Left = t1, Right = t2, Size = w}, i) = + if i < w div 2 then lookupTree(t1, i) else lookupTree(t2, i - w div 2) + fun updateTree ({Tag = "Leaf", Val = x, Left = _, Right = _, Size = _}, 0, y) = {Tag = "Leaf", Val = y, Left = NONE, Right = NONE, Size = 1} + | updateTree ({Tag = "Leaf", Val = x, Left = _, Right = _, Size = _}, i, y) = print "Invalid Index!" + | updateTree ({Tag = "Node", Left = t1, Right = t2, Val = NONE, Size = w}, i, y) = + if i < w div 2 then {Tag = "Node", Size = w, Left = updateTree(t1, i, y), Right = t2, Val = NONE} + else {Tag = "Node", Size = w, Left = t1, Right = updateTree(t2, i - w div 2, y), Val = NONE} + fun lookup ([], i) = print "Invalid Index!" + | lookup ({Tag = "Zero", Tree = _}::ts, i) = lookup (ts, i) + | lookup ({Tag = "One", Tree = t}::ts, i) = + if i < size t then lookupTree(t, i) else lookup (ts, i - size t) + fun update ([], i, y) = print "Invalid Index!" + | update ({Tag = "Zero", Tree = _}::ts, i, y) = update (ts, i, y) + | update ({Tag = "One", Tree = t}::ts, i, y) = + if i < size t then {Tag = "One", Tree = updateTree(t, i, y)}::ts else {Tag = "One", Tree = t}::update(ts, i - size t, y) + + fun ofList xs = foldl (fn (x, acc) => cons(x, acc)) empty (reverse xs) + + val s0 = empty + val _ = assertEq (isEmpty s0, true, "check empty") + val s1 = cons(7, s0) + val _ = assertEq (head s1 = 7, true, "head singleton") + val _ = assertEq (tail s1 = [{Tag = "Zero", Tree = NONE}], true, "tail singleton") + val s = ofList [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] + val s' = update(s, 4, 42) + val _ = assertEq (lookup (s', 4) = 42, true, "check update") + val _ = assertEq (lookup (s', 3) = 3, true, "check false update") +in + print "success!" +end diff --git a/examples/func_ds/BottomUpMergeSort.trp b/examples/func_ds/BottomUpMergeSort.trp new file mode 100644 index 00000000..30fc7541 --- /dev/null +++ b/examples/func_ds/BottomUpMergeSort.trp @@ -0,0 +1,28 @@ +import lists +import lazy + +datatype Atoms = NIL + +let + fun less (a, b) = a < b + fun new {Less = less} = {Less = less, Size = 0, Segments = fn () => []} + + fun merge less (xs, ys) = + let fun mrg ([], ys) = ys + | mrg (xs, []) = xs + | mrg (x::xs, y::ys) = if less(x,y) then x::mrg(xs, y::ys) + else y::mrg(x::xs, ys) + in mrg(xs, ys) end + + fun add x {Less = less, Size = size, Segments = segs} = + let fun addSeg (seg, segs, size) = + if size mod 2 = 0 then seg::segs + else addSeg (merge less (seg, hd segs), tl segs, size div 2) + in {Less = less, Size = size + 1, Segments = fn () => addSeg([x], force segs, size)} end + + fun addList xs heap = foldl (fn (x, q) => add x q) heap xs + + fun sort {Less = less, Segments = segs, Size = _} = foldl (merge less) [] (force segs) +in + sort (addList [1, 7, 6, 1000, 999] (new {Less = less})) +end diff --git a/examples/func_ds/ScheduledBottomUpMergeSort.trp b/examples/func_ds/ScheduledBottomUpMergeSort.trp new file mode 100644 index 00000000..cdc3228d --- /dev/null +++ b/examples/func_ds/ScheduledBottomUpMergeSort.trp @@ -0,0 +1,58 @@ +import lazy +import lists +import streams + +datatype Atoms = NIL + +let + fun assertEq (got, exp, msg) = + if got = exp then print (msg ^ ": ok") + else print (msg ^ ": failed") + + fun new less = {Less = less, Size = 0, Segments = []} + + fun merge less (xs, ys) = + let fun mrg (xs, ys) = case (force xs) of + NIL => ys + | (x, xs') => case (force ys) of + NIL => xs + | (y, ys') => if less (x, y) then fn () => (x, mrg (xs', ys)) + else fn () => (y, mrg (xs, ys')) + in mrg (xs, ys) end + + fun exec1 [] = [] + | exec1 (fst::sched) = case (force fst) of + NIL => exec1 sched + | (x, xs) => xs::sched + + fun exec2PerSeg [] = [] + | exec2PerSeg ((xs, sched)::segs) = (xs, exec1 (exec1 sched))::exec2PerSeg segs + + fun add (x, {Less = less, Size = size, Segments = segs}) = + let fun addSeg (xs, segs, size, rsched) = + if size mod 2 = 0 then (xs, reverse (xs::rsched))::segs + else let val ((xs', [])::segs') = segs + in addSeg (merge less (xs, xs'), segs', size div 2, xs::rsched) end + val segs' = addSeg (fn () => (x, fn () => NIL), segs, size, []) + in {Less = less, Size = size + 1, Segments = exec2PerSeg segs'} end + + fun sort {Less = less, Size = _, Segments = segs} = + let fun mergeAll (xs, []) = xs + | mergeAll (xs, (xs', sched)::segs) = mergeAll(merge less (xs,xs'), segs) + fun streamToList stream = + case (force stream) of + NIL => [] + | (x, xs) => x :: streamToList xs + in streamToList (mergeAll (fn () => NIL, segs)) end + + val sorter = new (fn (a, b) => a < b) + val sorter1 = add (3, sorter) + val sorter2 = add (1, sorter1) + val sorter3 = add (4, sorter2) + val sorter4 = add (1, sorter3) + val sorter5 = add (5, sorter4) + + val _ = assertEq([1, 1, 3, 4, 5] = sort sorter5, true, "sorted list") +in + print "success" +end diff --git a/examples/func_ds/banker_q.trp b/examples/func_ds/banker_q.trp new file mode 100644 index 00000000..aba4eeec --- /dev/null +++ b/examples/func_ds/banker_q.trp @@ -0,0 +1,35 @@ +import lists +import lazy +import streams + +datatype Atoms = NIL + +let + val empty_queue = {F = fn () => NIL, Len_F = 0, R = fn () => NIL, Len_R = 0} + val test_stream = fn () => (1, fn () => (2, fn () => (3, fn () => NIL))) + + fun isEmpty q = (q.len_f = 0) + + fun queue {F = f, Len_F = lf, R = r, Len_R = lr} = + if lr <= lf then {F = f, Len_F = lf, R = r, Len_R = lr} + else {F = streamAppend f (streamReverse r), Len_F = lf + lr, R = fn () => NIL, Len_R = 0} + + fun snoc {F = f, Len_F = lf, R = r, Len_R = lr} x = + queue {F = f, Len_F = lf, R = fn () => (x, r), Len_R = lr + 1} + + fun head {F = f, Len_F = _, R = _, Len_R = _} = case force f of + NIL => print "Error: Empty Queue" + | (x, thunk) => x + + fun tail {F = f, Len_F = lf, R = r, Len_R = lr} = case force f of + NIL => print "Error: Empty Queue" + | (x, thunk) => queue {F = thunk, Len_F = lf - 1, R = r, Len_R = lr} + + fun printQueue {F = f, Len_F = lf, R = r, Len_R = lr} = print (append (streamToList f) (streamToList r)) + + val append1 = snoc empty_queue 1 + val {F = f, Len_F = _, R = _, Len_R = _} = append1 + val append2 = snoc append1 2 +in + printQueue append2 +end diff --git a/examples/func_ds/real_time_q.trp b/examples/func_ds/real_time_q.trp new file mode 100644 index 00000000..89aa01e4 --- /dev/null +++ b/examples/func_ds/real_time_q.trp @@ -0,0 +1,52 @@ +import lazy +import lists +import streams + +datatype Atoms = NIL + +let + fun assertEq (got, exp, msg) = + if got = exp then print (msg ^ "ok") + else print (msg ^ "failed") + + val new = {F = fn () => NIL, R = [], S = fn () => NIL} + fun isEmpty {F = f, R = r, S = s} = (force f = NIL) + + fun rotate (f, r, a) = fn () => ( + case (force f, r, a) of + (NIL, y::[], a) => (y, a) + | ((x, f'), y::r', a) => (x, rotate (f', r', fn () => (y, a))) + ) + + fun queue {F = f, R = r, S = s'} = ( + case (force s') of + (x, s) => {F = f, R = r, S = s} + | NIL => let val f' = rotate (f, r, fn () => NIL) + in {F = f', R = [], S = f'} end + ) + + fun snoc {F = f, R = r, S = s} x = queue {F = f, R = x::r, S = s} + + fun head {F = f', R = _, S = _} = ( + case (force f') of + NIL => NIL + | (x, f) => x + ) + + fun tail {F = f', R = r, S = s} = ( + case (force f') of + NIL => NIL + | (x, f) => {F = f, R = r, S = s} + ) + + val q0 = new + val _ = assertEq ("isEmpty new queue", isEmpty q0, true) + + val q1 = snoc q0 42 + val _ = assertEq ("isEmpty after one snoc", isEmpty q1, false) + val _ = assertEq ("head after one snoc", head q1, 42) + val q1' = tail q1 + val _ = assertEq ("tail returns empty after one snoc", isEmpty q1', true) +in + print "success!" +end diff --git a/lib/lazy.trp b/lib/lazy.trp new file mode 100644 index 00000000..eb35a3ad --- /dev/null +++ b/lib/lazy.trp @@ -0,0 +1,11 @@ +let + fun force thunk = thunk () + fun curry f x y = f (x, y) + fun uncurry f (x, y) = f x y +in + [ + ("force", force) + , ("curry", curry) + , ("uncurry", uncurry) + ] +end diff --git a/lib/lists.trp b/lib/lists.trp index 482f875e..2ba73576 100644 --- a/lib/lists.trp +++ b/lib/lists.trp @@ -10,8 +10,6 @@ let fun map f list = in mapj 0 list end - - fun foldl f y [] = y | foldl f y (x::xs) = foldl f (f (x,y)) xs @@ -36,7 +34,7 @@ let fun map f list = [] => l2 | x::l => x::(append l l2) - fun nth (x::l) 1 = x + fun nth (x::l) 0 = x | nth (x::l) n = nth l (n - 1) fun lookup list key default = @@ -54,10 +52,17 @@ let fun map f list = if f x then partition_aux (x::a, b) xs else partition_aux (a, x::b) xs - in partition_aux ([],[]) ls end + + fun hd [] = 0 + | hd (x::xs) = x + + fun tl [] = [] + | tl (x::xs) = xs + fun null [] = true + | null xs = false in [ ("map", map) , ("mapi", mapi) @@ -69,5 +74,9 @@ in , ("length", length) , ("append", append) , ("partition", partition) + , ("hd", hd) + , ("tl", tl) + , ("nth", nth) + , ("null", null) ] end diff --git a/lib/streams.trp b/lib/streams.trp new file mode 100644 index 00000000..ef19070c --- /dev/null +++ b/lib/streams.trp @@ -0,0 +1,71 @@ +import lazy + +datatype Atoms = NIL + +let + val empty_stream = fn () => NIL + val test_stream = fn () => (1, fn () => (2, fn () => (3, fn () => NIL))) + + fun take n s = fn () => ( + case n of + 0 => NIL + | _ => case force s of + NIL => NIL + | (x , s') => (x, take (n - 1) s') + ) + + fun streamAppend s1 s2 = fn () => ( + case force s1 of + NIL => force s2 + | (x, s') => (x, streamAppend s' s2) + ) + + fun drop n s = + let fun dropHelper n c = + case n of + 0 => force c + | _ => case force c of + NIL => NIL + | (x, s') => dropHelper (n - 1) s' + in fn () => (dropHelper n s) end + + fun streamReverse s = + let fun reverseHelper f r = + case force f of + NIL => r + | (x, thunk) => reverseHelper thunk (x, fn () => r) + in fn () => reverseHelper s NIL end + + fun streamRepeat x = + let fun repHelper x = (x, fn () => repHelper x) + in fn () => (repHelper x) end + + fun streamMap f s = + case force s of + NIL => fn () => NIL + | (x, thunk) => fn () => (f x, streamMap f thunk) + + fun streamFromSeed f seed = fn () => (seed, streamFromSeed f (f seed)) + + fun streamIndex s n = + case force s of + NIL => NIL + | (x, thunk) => if n = 0 then x else streamIndex thunk (n - 1) + + fun streamToList s = + case force s of + NIL => [] + | (x, thunk) => x :: streamToList thunk +in + [ + ("take", take), + ("streamAppend", streamAppend), + ("drop", drop), + ("streamReverse", streamReverse), + ("streamRepeat", streamRepeat), + ("streamMap", streamMap), + ("streamFromSeed", streamFromSeed), + ("streamIndex", streamIndex), + ("streamToList", streamToList) + ] +end