PFDS Chapter #09 Examples in Oz
% Utility functions for tests
proc {HeapTest F}
   A = {F.insert 1 F.empty}
   B = {F.insert 3 A}
   C = {F.insert 7 B}
   D = {F.insert 5 C}
   X = {F.insert 2 F.empty}
   Y = {F.insert 6 X}
   Z = {F.insert 4 Y}
   H = {F.merge D Z}
in
   {Browse D}
   {Browse Z}
   {Browse H}
   {Browse {F.findMin H}}
   {Browse {F.findMin {F.deleteMin H}}}
   {Browse {F.findMin {F.deleteMin {F.deleteMin H}}}}
   {Browse {F.findMin {F.deleteMin {F.deleteMin {F.deleteMin H}}}}}
   {Browse {F.findMin {F.deleteMin {F.deleteMin {F.deleteMin {F.deleteMin H}}}}}}
   {Browse {F.findMin {F.deleteMin {F.deleteMin {F.deleteMin {F.deleteMin {F.deleteMin H}}}}}}}
   {Browse {F.findMin {F.deleteMin {F.deleteMin {F.deleteMin {F.deleteMin {F.deleteMin {F.deleteMin H}}}}}}}}
end

proc {BinaryTest F}
   A = nil
   B = {F.inc A}
   C = {F.inc B}
   D = {F.inc C}
in
   {Browse D}
   {Browse {F.dec D}}
   {Browse {F.dec {F.dec D}}}
   {Browse {F.dec {F.dec {F.dec D}}}}
   {Browse {F.add D C}}
end

proc {RandomAccessListTest F}
   A = F.empty
   B = {F.cons 1 A}
   C = {F.cons 3 B}
   D = {F.cons 5 C}
   X = {F.update 0 7 D}
   Y = {F.update 2 9 X}
in
   {Browse D}
   {Browse {F.head D}}
   {Browse {F.head {F.tail D}}}
   {Browse {F.head {F.tail {F.tail D}}}}
   {Browse {F.lookup 0 Y}}
   {Browse {F.lookup 1 Y}}
   {Browse {F.lookup 2 Y}}
end

% Functions defined in previous chapters
ORDEREDVALUE =
   functor
   export
      eq : EQ
      lt : LT
      leq : LEQ
   define
      fun {EQ X Y} X == Y end
      fun {LT X Y} X < Y end
      fun {LEQ X Y} X =< Y end
   end
[OrderedValue] = {Module.apply [ORDEREDVALUE]}

% 9.2 Dense
DENSE =
   functor
   export
      inc : Inc
      dec : Dec
      add : Add
   define
      fun {Inc X}
         case X
         of nil then [one]
         [] zero|T then one|T
         [] one|T then zero|{Inc T}
         end
      end
      fun {Dec X}
         case X
         of [one] then nil
         [] one|T then zero|T
         [] zero|T then one|{Dec T}
         end
      end
      fun {Add X Y}
         case X#Y
         of _#nil then X
         [] nil#_ then Y
         [] (H1|T1)#(zero|T2) then H1|{Add T1 T2}
         [] (zero|T1)#(H2|T2) then H2|{Add T1 T2}
         [] (one|T1)#(one|T2) then zero|{Inc {Add T1 T2}}
         end
      end
   end

[Dense] = {Module.apply [DENSE]}

{BinaryTest Dense}

% 9.2 SparseByWeight
SPARSEBYWEIGHT =
   functor
   export
      inc : Inc
      dec : Dec
      add : Add
   define
      fun {Carry X Y}
         case X#Y
         of _#nil then [X]
         [] _#(H|T) then
            if X < H then
               X|Y
            else
               {Carry 2*X T}
            end
         end
      end
      fun {Borrow X Y=H|T}
         if X == H then
            T
         else
            X|{Borrow 2*X Y}
         end
      end
      fun {Inc X}
         {Carry 1 X}
      end
      fun {Dec X}
         {Borrow 1 X}
      end
      fun {Add X Y}
         case X#Y
         of _#nil then X
         [] nil#_ then Y
         [] (H1|T1)#(H2|T2) then
            if H1 < H2 then
               H1|{Add T1 Y}
            elseif H2 < H1 then
               H2|{Add X T2}
            else
               {Carry 2*H1 {Add T1 T2}}
            end
         end
      end
   end

[SparseByWeight] = {Module.apply [SPARSEBYWEIGHT]}

{BinaryTest SparseByWeight}

% 9.2 BinaryRandomAccessList
BINARYRANDOMACCESSLIST =
   functor
   export
      empty   : Empty
      isEmpty : IsEmpty
      cons    : Cons
      head    : Head
      tail    : Tail
      lookup  : Lookup
      update  : Update
   define
      Empty = nil
      fun {IsEmpty Tree} Tree == Empty end
      fun {Size Tree}
         case Tree
         of leaf(X) then 1
         [] node(W Tree1 Tree2) then W
         end
      end
      fun {Link Tree1 Tree2}
         node({Size Tree1}+{Size Tree2} Tree1 Tree2)
      end
      fun {ConsTree Tree1 N}
         case N
         of nil then [one(Tree1)]
         [] zero|T then one(Tree1)|T
         [] one(Tree2)|T then  zero|{ConsTree {Link Tree1 Tree2} T}
         end
      end
      fun {UnconsTree Tree}
         case Tree
         of nil then raise empty end
         [] [one(X)] then X#nil
         [] one(X)|T then X#(zero|T)
         [] zero|T then
            local
               node(_ Left Right)#Ts = {UnconsTree T}
            in
               Left#(one(Right)|Ts)
            end
         end
      end
      fun {Cons X Tree}
         {ConsTree leaf(X) Tree}
      end
      fun {Head Tree}
         leaf(X)#_ = {UnconsTree Tree}
      in
         X
      end
      fun {Tail Tree}
         _#T = {UnconsTree Tree}
      in
         T
      end
      fun {LookupTree I Tree}
         case I#Tree
         of 0#leaf(X) then X
         [] _#leaf(X) then raise subscript end
         [] _#node(W Left Right) then
            if I < W div 2 then
               {LookupTree I Left}
            else
               {LookupTree (I - W div 2) Right}
            end
         end
      end
      fun {UpdateTree I Y Tree}
         case I#Tree
         of 0#leaf(X) then leaf(Y)
         [] _#leaf(X) then raise subscript end
         [] _#node(W Left Right) then
            if I < W div 2 then
               node(W {UpdateTree I Y Left} Right)
            else
               node(W Left {UpdateTree (I - W div 2) Y Right})
            end
         end
      end
      fun {Lookup I Tree}
         case Tree
         of nil then raise subscript end
         [] zero|T then {Lookup I T}
         [] one(X)|T then
            if I < {Size X} then
               {LookupTree I X}
            else
               {Lookup I-{Size X} T}
            end
         end
      end
      fun {Update I Y Tree}
         case Tree
         of nil then raise subscript end
         [] zero|T then zero|{Update I Y T}
         [] one(X)|T then
            if I < {Size X} then
               one({UpdateTree I Y X})|T
            else
               one(X)|{Update I-{Size X} Y T}
            end
         end
      end
   end

[BinaryRandomAccessList] = {Module.apply [BINARYRANDOMACCESSLIST]}

{RandomAccessListTest BinaryRandomAccessList}

% 9.2 SkewBinaryRandomAccessList
SKEWBINARYRANDOMACCESSLIST =
   functor
   export
      empty   : Empty
      isEmpty : IsEmpty
      cons    : Cons
      head    : Head
      tail    : Tail
      lookup  : Lookup
      update  : Update
   define
      Empty = nil
      fun {IsEmpty Tree} Tree == Empty end
      fun {Cons X Tree}
         case Tree
         of (W1#T1)|(W2#T2)|T then
            if W1 == W2 then
               ((1+W1+W2)#node(X T1 T2))|T
            else
               (1#leaf(X))|Tree
            end
         else (1#leaf(X))|Tree
         end
      end
      fun {Head Tree}
         case Tree
         of nil then raise empty end
         [] (1#leaf(X))|T then X
         [] (W#node(X T1 T2))|T then X
         end
      end
      fun {Tail Tree}
         case Tree
         of nil then raise empty end
         [] (1#leaf(X))|T then T
         [] (W#node(X T1 T2))|T then ((W div 2)#T1)|((W div 2)#T2)|T
         end
      end
      fun {LookupTree W I Tree}
         case W#I#Tree
         of 1#0#leaf(X) then X
         [] 1#_#leaf(X) then raise subscript end
         [] _#0#node(X T1 T2) then X
         [] _#_#node(X T1 T2) then
            if I =< W div 2 then
               {LookupTree (W div 2) I-1 T1}
            else
               {LookupTree (W div 2) (I - 1 - W div 2) T2}
            end
         end
      end
      fun {UpdateTree W I Y Tree}
         case W#I#Tree
         of 1#0#leaf(X) then leaf(Y)
         [] 1#_#leaf(X) then raise subscript end
         [] _#0#node(X T1 T2) then node(Y T1 T2)
         [] _#_#node(X T1 T2) then
            if I =< W div 2 then
               node(X {UpdateTree (W div 2) I-1 Y T1} T2)
            else
               node(X T1 {UpdateTree (W div 2) (I - 1 - W div 2) Y T2})
            end
         end
      end
      fun {Lookup I Tree}
         case Tree
         of nil then raise subscript end
         [] (W#X)|T then
            if I < W then
               {LookupTree W I X}
            else
               {Lookup I-W T}
            end
         end
      end
      fun {Update I Y Tree}
         case Tree
         of nil then raise subscript end
         [] (W#X)|T then
            if I < W then
               (W#{UpdateTree W I Y X})|T
            else
               (W#X)|{Update I-W Y T}
            end
         end
      end
   end

[SkewBinaryRandomAccessList] = {Module.apply [SKEWBINARYRANDOMACCESSLIST]}

{RandomAccessListTest SkewBinaryRandomAccessList}

% 9.3 SkewBinomialHeap
SKEWBINOMIALHEAP =
   functor
   export
      initialize : Initialize
      empty      : Empty
      isEmpty    : IsEmpty
      insert     : Insert
      merge      : Merge
      findMin    : FindMin
      deleteMin  : DeleteMin
   define
      Element
      proc {Initialize OrderedSet} Element = OrderedSet end
      Empty = nil
      fun {IsEmpty Heap} Heap == Empty end
      fun {Rank Heap=node(R X Xs C)} R end
      fun {Root Heap=node(R X Xs C)} X end
      fun {Link Heap1=node(R X1 Xs1 C1) Heap2=node(_ X2 Xs2 C2)}
         if {Element.leq X1 X2} then
            node(R+1 X1 Xs1 Heap2|C1)
         else
            node(R+1 X2 Xs2 Heap1|C2)
         end
      end
      fun {SkewLink X T1 T2}
         node(R Y Ys C) = {Link T1 T2}
      in
         if {Element.leq X Y} then
            node(R X Y|Ys C)
         else
            node(R Y X|Ys C)
         end
      end
      fun {InsTree T1 T2}
         case T2
         of nil then [T1]
         [] H|T then
            if {Rank T1} < {Rank H} then
               T1|H|T
            else
               {InsTree {Link T1 H} T}
            end
         end
      end
      fun {MergeTrees Ts1 Ts2}
         case Ts1#Ts2
         of _#nil then Ts1
         [] nil#_ then Ts2
         [] (T1|Tsp1)#(T2|Tsp2) then
            if {Rank T1} < {Rank T2} then
               T1|{MergeTrees Tsp1 Ts2}
            elseif {Rank T2} < {Rank T1} then
               T2|{MergeTrees Ts1 Tsp2}
            else
               {InsTree {Link T1 T2} {MergeTrees Tsp1 Tsp2}}
            end
         end
      end
      fun {Normalize Tree}
         case Tree
         of nil then nil
         [] H|T then {InsTree H T}
         end
      end
      fun {Insert X Heap}
         case Heap
         of T1|T2|Rest then
            if {Rank T1} == {Rank T2} then
               {SkewLink X T1 T2}|Rest
            else
               node(0 X nil nil)|Heap
            end
         else node(0 X nil nil)|Heap
         end
      end
      fun {Merge Tree1 Tree2}
         {MergeTrees {Normalize Tree1} {Normalize Tree2}}
      end
      fun {RemoveMinTree Heap}
         case Heap
         of nil then raise empty end
         [] [X] then X#nil
         [] H|T then
            local
               Tree1#Tree2 = {RemoveMinTree T}
            in
               if {Element.leq {Root H} {Root Tree1}} then
                  H#T
               else
                  Tree1#(H|Tree2)
               end
            end
         end
      end
      fun {FindMin Heap}
         Tree#_ = {RemoveMinTree Heap}
      in
         {Root Tree}
      end
      fun {DeleteMin Heap}
         node(_ X Xs Ts1)#Ts2 = {RemoveMinTree Heap}
         fun {InsertAll Xs Heap}
            case Xs
            of nil then Heap
            [] H|T then {InsertAll T {Insert H Heap}}
            end
         end
      in
         {InsertAll Xs {Merge {List.reverse Ts1} Ts2}}
      end
   end

[SkewBinomialHeap] = {Module.apply [SKEWBINOMIALHEAP]}
{SkewBinomialHeap.initialize OrderedValue}

{HeapTest SkewBinomialHeap}