PFDS Chapter #10 Examples in Oz
% 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]}

PAIRINGHEAP =
   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 {Merge Heap1 Heap2}
         case Heap1#Heap2
         of _#nil then Heap1
         [] nil#_ then Heap2
         [] tree(X Hs1)#tree(Y Hs2) then
            if {Element.leq X Y} then
               tree(X Heap2|Hs1)
            else
               tree(Y Heap1|Hs2)
            end
         end
      end
      fun {Insert X Heap}
         {Merge tree(X nil) Heap}
      end
      fun {MergePairs HeapList}
         case HeapList
         of nil then nil
         [] [X] then X
         [] Heap1|Heap2|Hs then {Merge {Merge Heap1 Heap2} {MergePairs Hs}}
         end
      end
      fun {FindMin Heap}
         case Heap
         of tree(X Hs) then X
         else raise empty end
         end
      end
      fun {DeleteMin Heap}
         case Heap
         of tree(X Hs) then {MergePairs Hs}
         else raise empty end
         end
      end
   end

% 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 {QueueTest F}
   A = F.empty
   B = {F.snoc A 1}
   C = {F.snoc B 2}
   D = {F.snoc C 3}
in
   {Browse D}
   {Browse {F.head D}}
   {Browse {F.head {F.tail D}}}
   {Browse {F.head {F.tail {F.tail D}}}}
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

proc {CatenableListTest F}
   A = F.empty
   B = {F.cons 2 A}
   C = {F.snoc B 1}
   D = {F.cons 3 C}
   E = {F.append D {F.cons 4 F.empty}}
in
   {Browse D}
   {Browse {F.head D}}
   {Browse {F.head {F.tail D}}}
   {Browse {F.head {F.tail {F.tail D}}}}
   {Browse {F.head E}}
   {Browse {F.head {F.tail E}}}
   {Browse {F.head {F.tail {F.tail E}}}}
   {Browse {F.head {F.tail {F.tail {F.tail E}}}}}
end

% 10.1 AltBinaryRandomAccessList
ALTBINARYRANDOMACCESSLIST =
   functor
   export
      empty   : Empty
      isEmpty : IsEmpty
      cons    : Cons
      head    : Head
      tail    : Tail
      lookup  : Lookup
      update  : Update
   define
      Empty = nil
      fun {IsEmpty Xs} Xs == Empty end
      fun {ConsEP X Xs}
         case Xs
         of nil then one(X nil)
         [] zero(Ps) then one(X Ps)
         [] one(Y Ps) then zero({ConsEP pair(X Y) Ps})
         end
      end
      fun {Cons X Xs}
         {ConsEP elem(X) Xs}
      end
      fun {UnconsEP Xs}
         case Xs
         of nil then raise empty end
         [] one(X nil) then X#nil
         [] one(X Ps) then X#zero(Ps)
         [] zero(Ps) then
            local
               pair(X Y)#Psp = {UnconsEP Ps}
            in
               X#one(Y Psp)
            end
         end
      end
      fun {Head Xs}
         elem(X)#_ = {UnconsEP Xs}
      in
         X
      end
      fun {Tail Xs}
         _#Xsp = {UnconsEP Xs}
      in
         Xsp
      end
      fun {LookupEP I Xs}
         case I#Xs
         of _#nil then raise subscript end
         [] 0#one(X Ps) then X
         [] _#one(X Ps) then {LookupEP I-1 zero(Ps)}
         [] _#zero(Ps) then
            local
               pair(X Y) = {LookupEP (I div 2) Ps}
            in
               if I mod 2 == 0 then
                  X
               else
                  Y
               end
            end
         end
      end
      fun {Lookup I Xs}
         elem(X) = {LookupEP I Xs}
      in
         X
      end
      fun {Fupdate F I Xs}
         case I#Xs
         of _#nil then raise subscript end
         [] 0#one(X Ps) then one({F X} Ps)
         [] _#one(X Ps) then {ConsEP X {Fupdate F I-1 zero(Ps)}}
         [] _#zero(Ps) then
            local
               fun {Fp pair(X Y)}
                  if I mod 2 == 0 then
                     pair({F X} Y)
                  else
                     pair(X {F Y})
                  end
               end
            in
               zero({Fupdate Fp (I div 2) Ps})
            end
         end
      end
      fun {Update I Y Xs}
         {Fupdate fun {$ X} elem(Y) end I Xs}
      end
   end

[AltBinaryRandomAccessList] = {Module.apply [ALTBINARYRANDOMACCESSLIST]}

{RandomAccessListTest AltBinaryRandomAccessList}

% 10.1 BootstrappedQueue
fun lazy {LazyReverse L}
   fun {Iter L1 L2}
      case L1
      of H|T then {Iter T H|L2}
      [] nil then L2
      end
   end
in
   {Iter L nil}
end

BOOTSTRAPPEDQUEUE =
   functor
   export
      empty   : Empty
      isEmpty : IsEmpty
      snoc    : Snoc
      head    : Head
      tail    : Tail
   define
      Empty = nil
      fun {IsEmpty Q} Q == Empty end
      fun {CheckQ Q=LenFM#F#M#LenR#R}
         if LenR =< LenFM then
            {CheckF Q}
         else
            {CheckF (LenFM+LenR)#F#{SnocEL M {LazyReverse R}}#0#nil}
         end
      end
      fun {CheckF Q}
         case Q
         of LenFM#nil#nil#LenR#R then nil
         [] LenFM#nil#M#LenR#R then
            local
               F = {HeadEL M}
            in
               q(LenFM#F#{Tail M}#LenR#R)
            end
         else q(Q)
         end
      end
      fun {SnocEL Q X}
         case Q
         of nil then q(1#[X]#nil#0#nil)
         [] q(LenFM#F#M#LenR#R) then {CheckQ LenFM#F#M#LenR+1#(X|R)}
         end
      end
      fun {HeadEL Q}
         case Q
         of nil then raise empty end
         [] q(LenFM#(X|Fp)#M#LenR#R) then X
         end
      end
      fun {Tail Q}
         case Q
         of nil then raise empty end
         [] q(LenFM#(X|Fp)#M#LenR#R) then {CheckQ (LenFM-1)#Fp#M#LenR#R}
         end
      end
      fun {Snoc Q X}
         {SnocEL Q elem(X)}
      end
      fun {Head Q}
         elem(X) = {HeadEL Q}
      in
         X
      end
   end

[BootstrappedQueue] = {Module.apply [BOOTSTRAPPEDQUEUE]}

{QueueTest BootstrappedQueue}

% 10.2 CatenableList
CATENABLELIST =
   functor
   export
      initialize : Initialize
      empty      : Empty
      isEmpty    : IsEmpty
      cons       : Cons
      snoc       : Snoc
      append     : Append
      head       : Head
      tail       : Tail
   define
      Queue
      proc {Initialize Q} Queue = Q end
      Empty = nil
      fun {IsEmpty L} L == Empty end
      fun {Link c(X Q) S}
         c(X {Queue.snoc Q S})
      end
      fun {LinkAll Q}
         T = {Queue.head Q}
         Qp = {Queue.tail Q}
      in
         if {Queue.isEmpty Qp} then
            T
         else
            {Link T {fun lazy {$} {LinkAll Qp} end}}
         end
      end
      fun {Append Xs Ys}
         case Xs#Ys
         of _#nil then Xs
         [] nil#_ then Ys
         else {Link Xs Ys}
         end
      end
      fun {Cons X Xs}
         {Append c(X Queue.empty) Xs}
      end
      fun {Snoc Xs X}
         {Append Xs c(X Queue.empty)}
      end
      fun {Head L}
         case L
         of nil then raise empty end
         [] c(X _) then X
         end
      end
      fun {Tail L}
         case L
         of nil then raise empty end
         [] c(X Q) then
            if {Queue.isEmpty Q} then
               nil
            else
               {LinkAll Q}
            end
         end
      end
   end

[CatenableList] = {Module.apply [CATENABLELIST]}
{CatenableList.initialize BootstrappedQueue}

{CatenableListTest CatenableList}

% 10.2 BootstrapHeap
BOOTSTRAPHEAP =
   functor
   export
      initialize : Initialize
      empty      : Empty
      isEmpty    : IsEmpty
      insert     : Insert
      merge      : Merge
      findMin    : FindMin
      deleteMin  : DeleteMin
   define
      Element
      PrimH
      BOOTSTRAPPEDELEM =
         functor
         export
            eq : EQ
            lt : LT
            leq : LEQ
         define
            fun {EQ heap(X _) heap(Y _)} {Element.eq X Y} end
            fun {LT heap(X _) heap(Y _)} {Element.lt X Y} end
            fun {LEQ heap(X _) heap(Y _)} {Element.leq X Y} end
         end
      proc {Initialize HEAP OrderedSet}
         [BootstrappedElem] = {Module.apply [BOOTSTRAPPEDELEM]}
         [Heap] = {Module.apply [HEAP]}
      in
         {Heap.initialize BootstrappedElem}
         PrimH = Heap
         Element = OrderedSet
      end
      Empty = nil
      fun {IsEmpty Heap} Heap == Empty end
      fun {Merge Heap1 Heap2}
         case Heap1#Heap2
         of nil#_ then Heap2
         [] _#nil then Heap1
         [] heap(X P1)#heap(Y P2) then
            if {Element.leq X Y} then
               heap(X {PrimH.insert Heap2 P1})
            else
               heap(Y {PrimH.insert Heap1 P2})
            end
         end
      end
      fun {Insert X Heap}
         {Merge heap(X PrimH.empty) Heap}
      end
      fun {FindMin Heap}
         case Heap
         of nil then raise empty end
         [] heap(X _) then X
         end
      end
      fun {DeleteMin Heap}
         case Heap
         of nil then raise empty end
         [] heap(X P) then
            if {PrimH.isEmpty P} then
               nil
            else
               local
                  heap(Y P1) = {PrimH.findMin P}
                  P2 = {PrimH.deleteMin P}
               in
                  heap(Y {PrimH.merge P1 P2})
               end
            end
         end
      end
   end

[BootstrapHeap] = {Module.apply [BOOTSTRAPHEAP]}
{BootstrapHeap.initialize PAIRINGHEAP OrderedValue}

{HeapTest BootstrapHeap}

% 10.2 Trie
TRIE =
   functor
   export
      initialize : Initialize
      empty      : Empty
      bind       : Bind
      lookup     : Lookup
   define
      Map
      Empty
      proc {Initialize FiniteMap}
         Map = FiniteMap
         Empty = trie(nil Map.empty)
      end
      fun {Lookup L Trie}
         case L#Trie
         of nil#trie(nil M) then raise notFound end
         [] nil#trie(X M) then X
         [] (H|T)#trie(X M) then {Lookup T {Map.lxookup H M}}
         end
      end
      fun {Bind L X Trie}
         case L#Trie
         of nil#trie(_ M) then trie(X M)
         [] (H|T)#trie(V M) then
            local
               Tr = try {M.lookup H M} catch notFound then nil end
               Tp = {Bind T X Tr}
            in
               trie(V {M.bind H Tp M})
            end
         end
      end
   end

[Trie] = {Module.apply [TRIE]}
%{Trie.initialize ???}

%{FiniteMapTest Trie}

% 10.3 TrieOfTrees
TRIEOFTREES =
   functor
   export
      initialize : Initialize
      empty      : Empty
      bind       : Bind
      lookup     : Lookup
   define
      Map
      Empty
      proc {Initialize FiniteMap}
         Map = FiniteMap
         Empty = trie(nil Map.empty)
      end

      fun {LookupEM T Trie}
         case T#Trie
         of nil#trie(nil M) then raise notFound end
         [] nil#trie(X M) then X
         [] t(K A B)#trie(V M) then
            local
               map(Mp) = {LookupEM A {Map.lookup K M}}
            in
               {LookupEM B Mp}
            end
         end
      end
      fun {Lookup T Trie}
         elem(X) = {LookupEM T Trie}
      in
         X
      end
      fun {BindEM T X Trie}
         case T#Trie
         of nil#trie(_ M) then trie(X M)
         [] t(K A B)#trie(V M) then
            local
               Tt = try {Map.lookup K M} catch notFound then nil end
               Tx = try {LookupEM A Tt} catch notFound then map(nil) end
               Tp = {BindEM B X Tx}
               Ttp = {BindEM A map(Tp) Tt}
            in
               trie(V {Map.bind K Ttp M})
            end
         end
      end
      fun {Bind T X Trie}
         {BindEM T elem(X) Trie}
      end
   end

[TrieOfTrees] = {Module.apply [TRIEOFTREES]}
%{TrieOfTrees.initialize ???}

%{FiniteMapTest TrieOfTrees}