1(* ========================================================================= *) 2(* FINITE MAPS WITH A FIXED KEY TYPE *) 3(* Copyright (c) 2004 Joe Hurd, distributed under the BSD License *) 4(* ========================================================================= *) 5 6functor KeyMap (Key : Ordered) :> KeyMap where type key = Key.t = 7struct 8 9(* ------------------------------------------------------------------------- *) 10(* Importing from the input signature. *) 11(* ------------------------------------------------------------------------- *) 12 13type key = Key.t; 14 15val compareKey = Key.compare; 16 17(* ------------------------------------------------------------------------- *) 18(* Importing useful functionality. *) 19(* ------------------------------------------------------------------------- *) 20 21exception Bug = Useful.Bug; 22 23exception Error = Useful.Error; 24 25val pointerEqual = Portable.pointerEqual; 26 27val K = Useful.K; 28 29val randomInt = Portable.randomInt; 30 31val randomWord = Portable.randomWord; 32 33(* ------------------------------------------------------------------------- *) 34(* Converting a comparison function to an equality function. *) 35(* ------------------------------------------------------------------------- *) 36 37fun equalKey key1 key2 = compareKey (key1,key2) = EQUAL; 38 39(* ------------------------------------------------------------------------- *) 40(* Priorities. *) 41(* ------------------------------------------------------------------------- *) 42 43type priority = Word.word; 44 45val randomPriority = randomWord; 46 47val comparePriority = Word.compare; 48 49(* ------------------------------------------------------------------------- *) 50(* Priority search trees. *) 51(* ------------------------------------------------------------------------- *) 52 53datatype 'value tree = 54 E 55 | T of 'value node 56 57and 'value node = 58 Node of 59 {size : int, 60 priority : priority, 61 left : 'value tree, 62 key : key, 63 value : 'value, 64 right : 'value tree}; 65 66fun lowerPriorityNode node1 node2 = 67 let 68 val Node {priority = p1, ...} = node1 69 and Node {priority = p2, ...} = node2 70 in 71 comparePriority (p1,p2) = LESS 72 end; 73 74(* ------------------------------------------------------------------------- *) 75(* Tree debugging functions. *) 76(* ------------------------------------------------------------------------- *) 77 78(*BasicDebug 79local 80 fun checkSizes tree = 81 case tree of 82 E => 0 83 | T (Node {size,left,right,...}) => 84 let 85 val l = checkSizes left 86 and r = checkSizes right 87 88 val () = if l + 1 + r = size then () else raise Bug "wrong size" 89 in 90 size 91 end; 92 93 fun checkSorted x tree = 94 case tree of 95 E => x 96 | T (Node {left,key,right,...}) => 97 let 98 val x = checkSorted x left 99 100 val () = 101 case x of 102 NONE => () 103 | SOME k => 104 case compareKey (k,key) of 105 LESS => () 106 | EQUAL => raise Bug "duplicate keys" 107 | GREATER => raise Bug "unsorted" 108 109 val x = SOME key 110 in 111 checkSorted x right 112 end; 113 114 fun checkPriorities tree = 115 case tree of 116 E => NONE 117 | T node => 118 let 119 val Node {left,right,...} = node 120 121 val () = 122 case checkPriorities left of 123 NONE => () 124 | SOME lnode => 125 if not (lowerPriorityNode node lnode) then () 126 else raise Bug "left child has greater priority" 127 128 val () = 129 case checkPriorities right of 130 NONE => () 131 | SOME rnode => 132 if not (lowerPriorityNode node rnode) then () 133 else raise Bug "right child has greater priority" 134 in 135 SOME node 136 end; 137in 138 fun treeCheckInvariants tree = 139 let 140 val _ = checkSizes tree 141 142 val _ = checkSorted NONE tree 143 144 val _ = checkPriorities tree 145 in 146 tree 147 end 148 handle Error err => raise Bug err; 149end; 150*) 151 152(* ------------------------------------------------------------------------- *) 153(* Tree operations. *) 154(* ------------------------------------------------------------------------- *) 155 156fun treeNew () = E; 157 158fun nodeSize (Node {size = x, ...}) = x; 159 160fun treeSize tree = 161 case tree of 162 E => 0 163 | T x => nodeSize x; 164 165fun mkNode priority left key value right = 166 let 167 val size = treeSize left + 1 + treeSize right 168 in 169 Node 170 {size = size, 171 priority = priority, 172 left = left, 173 key = key, 174 value = value, 175 right = right} 176 end; 177 178fun mkTree priority left key value right = 179 let 180 val node = mkNode priority left key value right 181 in 182 T node 183 end; 184 185(* ------------------------------------------------------------------------- *) 186(* Extracting the left and right spines of a tree. *) 187(* ------------------------------------------------------------------------- *) 188 189fun treeLeftSpine acc tree = 190 case tree of 191 E => acc 192 | T node => nodeLeftSpine acc node 193 194and nodeLeftSpine acc node = 195 let 196 val Node {left,...} = node 197 in 198 treeLeftSpine (node :: acc) left 199 end; 200 201fun treeRightSpine acc tree = 202 case tree of 203 E => acc 204 | T node => nodeRightSpine acc node 205 206and nodeRightSpine acc node = 207 let 208 val Node {right,...} = node 209 in 210 treeRightSpine (node :: acc) right 211 end; 212 213(* ------------------------------------------------------------------------- *) 214(* Singleton trees. *) 215(* ------------------------------------------------------------------------- *) 216 217fun mkNodeSingleton priority key value = 218 let 219 val size = 1 220 and left = E 221 and right = E 222 in 223 Node 224 {size = size, 225 priority = priority, 226 left = left, 227 key = key, 228 value = value, 229 right = right} 230 end; 231 232fun nodeSingleton (key,value) = 233 let 234 val priority = randomPriority () 235 in 236 mkNodeSingleton priority key value 237 end; 238 239fun treeSingleton key_value = 240 let 241 val node = nodeSingleton key_value 242 in 243 T node 244 end; 245 246(* ------------------------------------------------------------------------- *) 247(* Appending two trees, where every element of the first tree is less than *) 248(* every element of the second tree. *) 249(* ------------------------------------------------------------------------- *) 250 251fun treeAppend tree1 tree2 = 252 case tree1 of 253 E => tree2 254 | T node1 => 255 case tree2 of 256 E => tree1 257 | T node2 => 258 if lowerPriorityNode node1 node2 then 259 let 260 val Node {priority,left,key,value,right,...} = node2 261 262 val left = treeAppend tree1 left 263 in 264 mkTree priority left key value right 265 end 266 else 267 let 268 val Node {priority,left,key,value,right,...} = node1 269 270 val right = treeAppend right tree2 271 in 272 mkTree priority left key value right 273 end; 274 275(* ------------------------------------------------------------------------- *) 276(* Appending two trees and a node, where every element of the first tree is *) 277(* less than the node, which in turn is less than every element of the *) 278(* second tree. *) 279(* ------------------------------------------------------------------------- *) 280 281fun treeCombine left node right = 282 let 283 val left_node = treeAppend left (T node) 284 in 285 treeAppend left_node right 286 end; 287 288(* ------------------------------------------------------------------------- *) 289(* Searching a tree for a value. *) 290(* ------------------------------------------------------------------------- *) 291 292fun treePeek pkey tree = 293 case tree of 294 E => NONE 295 | T node => nodePeek pkey node 296 297and nodePeek pkey node = 298 let 299 val Node {left,key,value,right,...} = node 300 in 301 case compareKey (pkey,key) of 302 LESS => treePeek pkey left 303 | EQUAL => SOME value 304 | GREATER => treePeek pkey right 305 end; 306 307(* ------------------------------------------------------------------------- *) 308(* Tree paths. *) 309(* ------------------------------------------------------------------------- *) 310 311(* Generating a path by searching a tree for a key/value pair *) 312 313fun treePeekPath pkey path tree = 314 case tree of 315 E => (path,NONE) 316 | T node => nodePeekPath pkey path node 317 318and nodePeekPath pkey path node = 319 let 320 val Node {left,key,right,...} = node 321 in 322 case compareKey (pkey,key) of 323 LESS => treePeekPath pkey ((true,node) :: path) left 324 | EQUAL => (path, SOME node) 325 | GREATER => treePeekPath pkey ((false,node) :: path) right 326 end; 327 328(* A path splits a tree into left/right components *) 329 330fun addSidePath ((wentLeft,node),(leftTree,rightTree)) = 331 let 332 val Node {priority,left,key,value,right,...} = node 333 in 334 if wentLeft then (leftTree, mkTree priority rightTree key value right) 335 else (mkTree priority left key value leftTree, rightTree) 336 end; 337 338fun addSidesPath left_right = List.foldl addSidePath left_right; 339 340fun mkSidesPath path = addSidesPath (E,E) path; 341 342(* Updating the subtree at a path *) 343 344local 345 fun updateTree ((wentLeft,node),tree) = 346 let 347 val Node {priority,left,key,value,right,...} = node 348 in 349 if wentLeft then mkTree priority tree key value right 350 else mkTree priority left key value tree 351 end; 352in 353 fun updateTreePath tree = List.foldl updateTree tree; 354end; 355 356(* Inserting a new node at a path position *) 357 358fun insertNodePath node = 359 let 360 fun insert left_right path = 361 case path of 362 [] => 363 let 364 val (left,right) = left_right 365 in 366 treeCombine left node right 367 end 368 | (step as (_,snode)) :: rest => 369 if lowerPriorityNode snode node then 370 let 371 val left_right = addSidePath (step,left_right) 372 in 373 insert left_right rest 374 end 375 else 376 let 377 val (left,right) = left_right 378 379 val tree = treeCombine left node right 380 in 381 updateTreePath tree path 382 end 383 in 384 insert (E,E) 385 end; 386 387(* ------------------------------------------------------------------------- *) 388(* Using a key to split a node into three components: the keys comparing *) 389(* less than the supplied key, an optional equal key, and the keys comparing *) 390(* greater. *) 391(* ------------------------------------------------------------------------- *) 392 393fun nodePartition pkey node = 394 let 395 val (path,pnode) = nodePeekPath pkey [] node 396 in 397 case pnode of 398 NONE => 399 let 400 val (left,right) = mkSidesPath path 401 in 402 (left,NONE,right) 403 end 404 | SOME node => 405 let 406 val Node {left,key,value,right,...} = node 407 408 val (left,right) = addSidesPath (left,right) path 409 in 410 (left, SOME (key,value), right) 411 end 412 end; 413 414(* ------------------------------------------------------------------------- *) 415(* Searching a tree for a key/value pair. *) 416(* ------------------------------------------------------------------------- *) 417 418fun treePeekKey pkey tree = 419 case tree of 420 E => NONE 421 | T node => nodePeekKey pkey node 422 423and nodePeekKey pkey node = 424 let 425 val Node {left,key,value,right,...} = node 426 in 427 case compareKey (pkey,key) of 428 LESS => treePeekKey pkey left 429 | EQUAL => SOME (key,value) 430 | GREATER => treePeekKey pkey right 431 end; 432 433(* ------------------------------------------------------------------------- *) 434(* Inserting new key/values into the tree. *) 435(* ------------------------------------------------------------------------- *) 436 437fun treeInsert key_value tree = 438 let 439 val (key,value) = key_value 440 441 val (path,inode) = treePeekPath key [] tree 442 in 443 case inode of 444 NONE => 445 let 446 val node = nodeSingleton (key,value) 447 in 448 insertNodePath node path 449 end 450 | SOME node => 451 let 452 val Node {size,priority,left,right,...} = node 453 454 val node = 455 Node 456 {size = size, 457 priority = priority, 458 left = left, 459 key = key, 460 value = value, 461 right = right} 462 in 463 updateTreePath (T node) path 464 end 465 end; 466 467(* ------------------------------------------------------------------------- *) 468(* Deleting key/value pairs: it raises an exception if the supplied key is *) 469(* not present. *) 470(* ------------------------------------------------------------------------- *) 471 472fun treeDelete dkey tree = 473 case tree of 474 E => raise Bug "KeyMap.delete: element not found" 475 | T node => nodeDelete dkey node 476 477and nodeDelete dkey node = 478 let 479 val Node {size,priority,left,key,value,right} = node 480 in 481 case compareKey (dkey,key) of 482 LESS => 483 let 484 val size = size - 1 485 and left = treeDelete dkey left 486 487 val node = 488 Node 489 {size = size, 490 priority = priority, 491 left = left, 492 key = key, 493 value = value, 494 right = right} 495 in 496 T node 497 end 498 | EQUAL => treeAppend left right 499 | GREATER => 500 let 501 val size = size - 1 502 and right = treeDelete dkey right 503 504 val node = 505 Node 506 {size = size, 507 priority = priority, 508 left = left, 509 key = key, 510 value = value, 511 right = right} 512 in 513 T node 514 end 515 end; 516 517(* ------------------------------------------------------------------------- *) 518(* Partial map is the basic operation for preserving tree structure. *) 519(* It applies its argument function to the elements *in order*. *) 520(* ------------------------------------------------------------------------- *) 521 522fun treeMapPartial f tree = 523 case tree of 524 E => E 525 | T node => nodeMapPartial f node 526 527and nodeMapPartial f (Node {priority,left,key,value,right,...}) = 528 let 529 val left = treeMapPartial f left 530 and vo = f (key,value) 531 and right = treeMapPartial f right 532 in 533 case vo of 534 NONE => treeAppend left right 535 | SOME value => mkTree priority left key value right 536 end; 537 538(* ------------------------------------------------------------------------- *) 539(* Mapping tree values. *) 540(* ------------------------------------------------------------------------- *) 541 542fun treeMap f tree = 543 case tree of 544 E => E 545 | T node => T (nodeMap f node) 546 547and nodeMap f node = 548 let 549 val Node {size,priority,left,key,value,right} = node 550 551 val left = treeMap f left 552 and value = f (key,value) 553 and right = treeMap f right 554 in 555 Node 556 {size = size, 557 priority = priority, 558 left = left, 559 key = key, 560 value = value, 561 right = right} 562 end; 563 564(* ------------------------------------------------------------------------- *) 565(* Merge is the basic operation for joining two trees. Note that the merged *) 566(* key is always the one from the second map. *) 567(* ------------------------------------------------------------------------- *) 568 569fun treeMerge f1 f2 fb tree1 tree2 = 570 case tree1 of 571 E => treeMapPartial f2 tree2 572 | T node1 => 573 case tree2 of 574 E => treeMapPartial f1 tree1 575 | T node2 => nodeMerge f1 f2 fb node1 node2 576 577and nodeMerge f1 f2 fb node1 node2 = 578 let 579 val Node {priority,left,key,value,right,...} = node2 580 581 val (l,kvo,r) = nodePartition key node1 582 583 val left = treeMerge f1 f2 fb l left 584 and right = treeMerge f1 f2 fb r right 585 586 val vo = 587 case kvo of 588 NONE => f2 (key,value) 589 | SOME kv => fb (kv,(key,value)) 590 in 591 case vo of 592 NONE => treeAppend left right 593 | SOME value => 594 let 595 val node = mkNodeSingleton priority key value 596 in 597 treeCombine left node right 598 end 599 end; 600 601(* ------------------------------------------------------------------------- *) 602(* A union operation on trees. *) 603(* ------------------------------------------------------------------------- *) 604 605fun treeUnion f f2 tree1 tree2 = 606 case tree1 of 607 E => tree2 608 | T node1 => 609 case tree2 of 610 E => tree1 611 | T node2 => nodeUnion f f2 node1 node2 612 613and nodeUnion f f2 node1 node2 = 614 if pointerEqual (node1,node2) then nodeMapPartial f2 node1 615 else 616 let 617 val Node {priority,left,key,value,right,...} = node2 618 619 val (l,kvo,r) = nodePartition key node1 620 621 val left = treeUnion f f2 l left 622 and right = treeUnion f f2 r right 623 624 val vo = 625 case kvo of 626 NONE => SOME value 627 | SOME kv => f (kv,(key,value)) 628 in 629 case vo of 630 NONE => treeAppend left right 631 | SOME value => 632 let 633 val node = mkNodeSingleton priority key value 634 in 635 treeCombine left node right 636 end 637 end; 638 639(* ------------------------------------------------------------------------- *) 640(* An intersect operation on trees. *) 641(* ------------------------------------------------------------------------- *) 642 643fun treeIntersect f t1 t2 = 644 case t1 of 645 E => E 646 | T n1 => 647 case t2 of 648 E => E 649 | T n2 => nodeIntersect f n1 n2 650 651and nodeIntersect f n1 n2 = 652 let 653 val Node {priority,left,key,value,right,...} = n2 654 655 val (l,kvo,r) = nodePartition key n1 656 657 val left = treeIntersect f l left 658 and right = treeIntersect f r right 659 660 val vo = 661 case kvo of 662 NONE => NONE 663 | SOME kv => f (kv,(key,value)) 664 in 665 case vo of 666 NONE => treeAppend left right 667 | SOME value => mkTree priority left key value right 668 end; 669 670(* ------------------------------------------------------------------------- *) 671(* A union operation on trees which simply chooses the second value. *) 672(* ------------------------------------------------------------------------- *) 673 674fun treeUnionDomain tree1 tree2 = 675 case tree1 of 676 E => tree2 677 | T node1 => 678 case tree2 of 679 E => tree1 680 | T node2 => 681 if pointerEqual (node1,node2) then tree2 682 else nodeUnionDomain node1 node2 683 684and nodeUnionDomain node1 node2 = 685 let 686 val Node {priority,left,key,value,right,...} = node2 687 688 val (l,_,r) = nodePartition key node1 689 690 val left = treeUnionDomain l left 691 and right = treeUnionDomain r right 692 693 val node = mkNodeSingleton priority key value 694 in 695 treeCombine left node right 696 end; 697 698(* ------------------------------------------------------------------------- *) 699(* An intersect operation on trees which simply chooses the second value. *) 700(* ------------------------------------------------------------------------- *) 701 702fun treeIntersectDomain tree1 tree2 = 703 case tree1 of 704 E => E 705 | T node1 => 706 case tree2 of 707 E => E 708 | T node2 => 709 if pointerEqual (node1,node2) then tree2 710 else nodeIntersectDomain node1 node2 711 712and nodeIntersectDomain node1 node2 = 713 let 714 val Node {priority,left,key,value,right,...} = node2 715 716 val (l,kvo,r) = nodePartition key node1 717 718 val left = treeIntersectDomain l left 719 and right = treeIntersectDomain r right 720 in 721 if Option.isSome kvo then mkTree priority left key value right 722 else treeAppend left right 723 end; 724 725(* ------------------------------------------------------------------------- *) 726(* A difference operation on trees. *) 727(* ------------------------------------------------------------------------- *) 728 729fun treeDifferenceDomain t1 t2 = 730 case t1 of 731 E => E 732 | T n1 => 733 case t2 of 734 E => t1 735 | T n2 => nodeDifferenceDomain n1 n2 736 737and nodeDifferenceDomain n1 n2 = 738 if pointerEqual (n1,n2) then E 739 else 740 let 741 val Node {priority,left,key,value,right,...} = n1 742 743 val (l,kvo,r) = nodePartition key n2 744 745 val left = treeDifferenceDomain left l 746 and right = treeDifferenceDomain right r 747 in 748 if Option.isSome kvo then treeAppend left right 749 else mkTree priority left key value right 750 end; 751 752(* ------------------------------------------------------------------------- *) 753(* A subset operation on trees. *) 754(* ------------------------------------------------------------------------- *) 755 756fun treeSubsetDomain tree1 tree2 = 757 case tree1 of 758 E => true 759 | T node1 => 760 case tree2 of 761 E => false 762 | T node2 => nodeSubsetDomain node1 node2 763 764and nodeSubsetDomain node1 node2 = 765 pointerEqual (node1,node2) orelse 766 let 767 val Node {size,left,key,right,...} = node1 768 in 769 size <= nodeSize node2 andalso 770 let 771 val (l,kvo,r) = nodePartition key node2 772 in 773 Option.isSome kvo andalso 774 treeSubsetDomain left l andalso 775 treeSubsetDomain right r 776 end 777 end; 778 779(* ------------------------------------------------------------------------- *) 780(* Picking an arbitrary key/value pair from a tree. *) 781(* ------------------------------------------------------------------------- *) 782 783fun nodePick node = 784 let 785 val Node {key,value,...} = node 786 in 787 (key,value) 788 end; 789 790fun treePick tree = 791 case tree of 792 E => raise Bug "KeyMap.treePick" 793 | T node => nodePick node; 794 795(* ------------------------------------------------------------------------- *) 796(* Removing an arbitrary key/value pair from a tree. *) 797(* ------------------------------------------------------------------------- *) 798 799fun nodeDeletePick node = 800 let 801 val Node {left,key,value,right,...} = node 802 in 803 ((key,value), treeAppend left right) 804 end; 805 806fun treeDeletePick tree = 807 case tree of 808 E => raise Bug "KeyMap.treeDeletePick" 809 | T node => nodeDeletePick node; 810 811(* ------------------------------------------------------------------------- *) 812(* Finding the nth smallest key/value (counting from 0). *) 813(* ------------------------------------------------------------------------- *) 814 815fun treeNth n tree = 816 case tree of 817 E => raise Bug "KeyMap.treeNth" 818 | T node => nodeNth n node 819 820and nodeNth n node = 821 let 822 val Node {left,key,value,right,...} = node 823 824 val k = treeSize left 825 in 826 if n = k then (key,value) 827 else if n < k then treeNth n left 828 else treeNth (n - (k + 1)) right 829 end; 830 831(* ------------------------------------------------------------------------- *) 832(* Removing the nth smallest key/value (counting from 0). *) 833(* ------------------------------------------------------------------------- *) 834 835fun treeDeleteNth n tree = 836 case tree of 837 E => raise Bug "KeyMap.treeDeleteNth" 838 | T node => nodeDeleteNth n node 839 840and nodeDeleteNth n node = 841 let 842 val Node {size,priority,left,key,value,right} = node 843 844 val k = treeSize left 845 in 846 if n = k then ((key,value), treeAppend left right) 847 else if n < k then 848 let 849 val (key_value,left) = treeDeleteNth n left 850 851 val size = size - 1 852 853 val node = 854 Node 855 {size = size, 856 priority = priority, 857 left = left, 858 key = key, 859 value = value, 860 right = right} 861 in 862 (key_value, T node) 863 end 864 else 865 let 866 val n = n - (k + 1) 867 868 val (key_value,right) = treeDeleteNth n right 869 870 val size = size - 1 871 872 val node = 873 Node 874 {size = size, 875 priority = priority, 876 left = left, 877 key = key, 878 value = value, 879 right = right} 880 in 881 (key_value, T node) 882 end 883 end; 884 885(* ------------------------------------------------------------------------- *) 886(* Iterators. *) 887(* ------------------------------------------------------------------------- *) 888 889datatype 'value iterator = 890 LeftToRightIterator of 891 (key * 'value) * 'value tree * 'value node list 892 | RightToLeftIterator of 893 (key * 'value) * 'value tree * 'value node list; 894 895fun fromSpineLeftToRightIterator nodes = 896 case nodes of 897 [] => NONE 898 | Node {key,value,right,...} :: nodes => 899 SOME (LeftToRightIterator ((key,value),right,nodes)); 900 901fun fromSpineRightToLeftIterator nodes = 902 case nodes of 903 [] => NONE 904 | Node {key,value,left,...} :: nodes => 905 SOME (RightToLeftIterator ((key,value),left,nodes)); 906 907fun addLeftToRightIterator nodes tree = fromSpineLeftToRightIterator (treeLeftSpine nodes tree); 908 909fun addRightToLeftIterator nodes tree = fromSpineRightToLeftIterator (treeRightSpine nodes tree); 910 911fun treeMkIterator tree = addLeftToRightIterator [] tree; 912 913fun treeMkRevIterator tree = addRightToLeftIterator [] tree; 914 915fun readIterator iter = 916 case iter of 917 LeftToRightIterator (key_value,_,_) => key_value 918 | RightToLeftIterator (key_value,_,_) => key_value; 919 920fun advanceIterator iter = 921 case iter of 922 LeftToRightIterator (_,tree,nodes) => addLeftToRightIterator nodes tree 923 | RightToLeftIterator (_,tree,nodes) => addRightToLeftIterator nodes tree; 924 925fun foldIterator f acc io = 926 case io of 927 NONE => acc 928 | SOME iter => 929 let 930 val (key,value) = readIterator iter 931 in 932 foldIterator f (f (key,value,acc)) (advanceIterator iter) 933 end; 934 935fun findIterator pred io = 936 case io of 937 NONE => NONE 938 | SOME iter => 939 let 940 val key_value = readIterator iter 941 in 942 if pred key_value then SOME key_value 943 else findIterator pred (advanceIterator iter) 944 end; 945 946fun firstIterator f io = 947 case io of 948 NONE => NONE 949 | SOME iter => 950 let 951 val key_value = readIterator iter 952 in 953 case f key_value of 954 NONE => firstIterator f (advanceIterator iter) 955 | s => s 956 end; 957 958fun compareIterator compareValue io1 io2 = 959 case (io1,io2) of 960 (NONE,NONE) => EQUAL 961 | (NONE, SOME _) => LESS 962 | (SOME _, NONE) => GREATER 963 | (SOME i1, SOME i2) => 964 let 965 val (k1,v1) = readIterator i1 966 and (k2,v2) = readIterator i2 967 in 968 case compareKey (k1,k2) of 969 LESS => LESS 970 | EQUAL => 971 (case compareValue (v1,v2) of 972 LESS => LESS 973 | EQUAL => 974 let 975 val io1 = advanceIterator i1 976 and io2 = advanceIterator i2 977 in 978 compareIterator compareValue io1 io2 979 end 980 | GREATER => GREATER) 981 | GREATER => GREATER 982 end; 983 984fun equalIterator equalValue io1 io2 = 985 case (io1,io2) of 986 (NONE,NONE) => true 987 | (NONE, SOME _) => false 988 | (SOME _, NONE) => false 989 | (SOME i1, SOME i2) => 990 let 991 val (k1,v1) = readIterator i1 992 and (k2,v2) = readIterator i2 993 in 994 equalKey k1 k2 andalso 995 equalValue v1 v2 andalso 996 let 997 val io1 = advanceIterator i1 998 and io2 = advanceIterator i2 999 in 1000 equalIterator equalValue io1 io2 1001 end 1002 end; 1003 1004(* ------------------------------------------------------------------------- *) 1005(* A type of finite maps. *) 1006(* ------------------------------------------------------------------------- *) 1007 1008datatype 'value map = 1009 Map of 'value tree; 1010 1011(* ------------------------------------------------------------------------- *) 1012(* Map debugging functions. *) 1013(* ------------------------------------------------------------------------- *) 1014 1015(*BasicDebug 1016fun checkInvariants s m = 1017 let 1018 val Map tree = m 1019 1020 val _ = treeCheckInvariants tree 1021 in 1022 m 1023 end 1024 handle Bug bug => raise Bug (s ^ "\n" ^ "KeyMap.checkInvariants: " ^ bug); 1025*) 1026 1027(* ------------------------------------------------------------------------- *) 1028(* Constructors. *) 1029(* ------------------------------------------------------------------------- *) 1030 1031fun new () = 1032 let 1033 val tree = treeNew () 1034 in 1035 Map tree 1036 end; 1037 1038fun singleton key_value = 1039 let 1040 val tree = treeSingleton key_value 1041 in 1042 Map tree 1043 end; 1044 1045(* ------------------------------------------------------------------------- *) 1046(* Map size. *) 1047(* ------------------------------------------------------------------------- *) 1048 1049fun size (Map tree) = treeSize tree; 1050 1051fun null m = size m = 0; 1052 1053(* ------------------------------------------------------------------------- *) 1054(* Querying. *) 1055(* ------------------------------------------------------------------------- *) 1056 1057fun peekKey (Map tree) key = treePeekKey key tree; 1058 1059fun peek (Map tree) key = treePeek key tree; 1060 1061fun inDomain key m = Option.isSome (peek m key); 1062 1063fun get m key = 1064 case peek m key of 1065 NONE => raise Error "KeyMap.get: element not found" 1066 | SOME value => value; 1067 1068fun pick (Map tree) = treePick tree; 1069 1070fun nth (Map tree) n = treeNth n tree; 1071 1072fun random m = 1073 let 1074 val n = size m 1075 in 1076 if n = 0 then raise Bug "KeyMap.random: empty" 1077 else nth m (randomInt n) 1078 end; 1079 1080(* ------------------------------------------------------------------------- *) 1081(* Adding. *) 1082(* ------------------------------------------------------------------------- *) 1083 1084fun insert (Map tree) key_value = 1085 let 1086 val tree = treeInsert key_value tree 1087 in 1088 Map tree 1089 end; 1090 1091(*BasicDebug 1092val insert = fn m => fn kv => 1093 checkInvariants "KeyMap.insert: result" 1094 (insert (checkInvariants "KeyMap.insert: input" m) kv); 1095*) 1096 1097fun insertList m = 1098 let 1099 fun ins (key_value,acc) = insert acc key_value 1100 in 1101 List.foldl ins m 1102 end; 1103 1104(* ------------------------------------------------------------------------- *) 1105(* Removing. *) 1106(* ------------------------------------------------------------------------- *) 1107 1108fun delete (Map tree) dkey = 1109 let 1110 val tree = treeDelete dkey tree 1111 in 1112 Map tree 1113 end; 1114 1115(*BasicDebug 1116val delete = fn m => fn k => 1117 checkInvariants "KeyMap.delete: result" 1118 (delete (checkInvariants "KeyMap.delete: input" m) k); 1119*) 1120 1121fun remove m key = if inDomain key m then delete m key else m; 1122 1123fun deletePick (Map tree) = 1124 let 1125 val (key_value,tree) = treeDeletePick tree 1126 in 1127 (key_value, Map tree) 1128 end; 1129 1130(*BasicDebug 1131val deletePick = fn m => 1132 let 1133 val (kv,m) = deletePick (checkInvariants "KeyMap.deletePick: input" m) 1134 in 1135 (kv, checkInvariants "KeyMap.deletePick: result" m) 1136 end; 1137*) 1138 1139fun deleteNth (Map tree) n = 1140 let 1141 val (key_value,tree) = treeDeleteNth n tree 1142 in 1143 (key_value, Map tree) 1144 end; 1145 1146(*BasicDebug 1147val deleteNth = fn m => fn n => 1148 let 1149 val (kv,m) = deleteNth (checkInvariants "KeyMap.deleteNth: input" m) n 1150 in 1151 (kv, checkInvariants "KeyMap.deleteNth: result" m) 1152 end; 1153*) 1154 1155fun deleteRandom m = 1156 let 1157 val n = size m 1158 in 1159 if n = 0 then raise Bug "KeyMap.deleteRandom: empty" 1160 else deleteNth m (randomInt n) 1161 end; 1162 1163(* ------------------------------------------------------------------------- *) 1164(* Joining (all join operations prefer keys in the second map). *) 1165(* ------------------------------------------------------------------------- *) 1166 1167fun merge {first,second,both} (Map tree1) (Map tree2) = 1168 let 1169 val tree = treeMerge first second both tree1 tree2 1170 in 1171 Map tree 1172 end; 1173 1174(*BasicDebug 1175val merge = fn f => fn m1 => fn m2 => 1176 checkInvariants "KeyMap.merge: result" 1177 (merge f 1178 (checkInvariants "KeyMap.merge: input 1" m1) 1179 (checkInvariants "KeyMap.merge: input 2" m2)); 1180*) 1181 1182fun union f (Map tree1) (Map tree2) = 1183 let 1184 fun f2 kv = f (kv,kv) 1185 1186 val tree = treeUnion f f2 tree1 tree2 1187 in 1188 Map tree 1189 end; 1190 1191(*BasicDebug 1192val union = fn f => fn m1 => fn m2 => 1193 checkInvariants "KeyMap.union: result" 1194 (union f 1195 (checkInvariants "KeyMap.union: input 1" m1) 1196 (checkInvariants "KeyMap.union: input 2" m2)); 1197*) 1198 1199fun intersect f (Map tree1) (Map tree2) = 1200 let 1201 val tree = treeIntersect f tree1 tree2 1202 in 1203 Map tree 1204 end; 1205 1206(*BasicDebug 1207val intersect = fn f => fn m1 => fn m2 => 1208 checkInvariants "KeyMap.intersect: result" 1209 (intersect f 1210 (checkInvariants "KeyMap.intersect: input 1" m1) 1211 (checkInvariants "KeyMap.intersect: input 2" m2)); 1212*) 1213 1214(* ------------------------------------------------------------------------- *) 1215(* Iterators over maps. *) 1216(* ------------------------------------------------------------------------- *) 1217 1218fun mkIterator (Map tree) = treeMkIterator tree; 1219 1220fun mkRevIterator (Map tree) = treeMkRevIterator tree; 1221 1222(* ------------------------------------------------------------------------- *) 1223(* Mapping and folding. *) 1224(* ------------------------------------------------------------------------- *) 1225 1226fun mapPartial f (Map tree) = 1227 let 1228 val tree = treeMapPartial f tree 1229 in 1230 Map tree 1231 end; 1232 1233(*BasicDebug 1234val mapPartial = fn f => fn m => 1235 checkInvariants "KeyMap.mapPartial: result" 1236 (mapPartial f (checkInvariants "KeyMap.mapPartial: input" m)); 1237*) 1238 1239fun map f (Map tree) = 1240 let 1241 val tree = treeMap f tree 1242 in 1243 Map tree 1244 end; 1245 1246(*BasicDebug 1247val map = fn f => fn m => 1248 checkInvariants "KeyMap.map: result" 1249 (map f (checkInvariants "KeyMap.map: input" m)); 1250*) 1251 1252fun transform f = map (fn (_,value) => f value); 1253 1254fun filter pred = 1255 let 1256 fun f (key_value as (_,value)) = 1257 if pred key_value then SOME value else NONE 1258 in 1259 mapPartial f 1260 end; 1261 1262fun partition p = 1263 let 1264 fun np x = not (p x) 1265 in 1266 fn m => (filter p m, filter np m) 1267 end; 1268 1269fun foldl f b m = foldIterator f b (mkIterator m); 1270 1271fun foldr f b m = foldIterator f b (mkRevIterator m); 1272 1273fun app f m = foldl (fn (key,value,()) => f (key,value)) () m; 1274 1275(* ------------------------------------------------------------------------- *) 1276(* Searching. *) 1277(* ------------------------------------------------------------------------- *) 1278 1279fun findl p m = findIterator p (mkIterator m); 1280 1281fun findr p m = findIterator p (mkRevIterator m); 1282 1283fun firstl f m = firstIterator f (mkIterator m); 1284 1285fun firstr f m = firstIterator f (mkRevIterator m); 1286 1287fun exists p m = Option.isSome (findl p m); 1288 1289fun all p = 1290 let 1291 fun np x = not (p x) 1292 in 1293 fn m => not (exists np m) 1294 end; 1295 1296fun count pred = 1297 let 1298 fun f (k,v,acc) = if pred (k,v) then acc + 1 else acc 1299 in 1300 foldl f 0 1301 end; 1302 1303(* ------------------------------------------------------------------------- *) 1304(* Comparing. *) 1305(* ------------------------------------------------------------------------- *) 1306 1307fun compare compareValue (m1,m2) = 1308 if pointerEqual (m1,m2) then EQUAL 1309 else 1310 case Int.compare (size m1, size m2) of 1311 LESS => LESS 1312 | EQUAL => 1313 let 1314 val Map _ = m1 1315 1316 val io1 = mkIterator m1 1317 and io2 = mkIterator m2 1318 in 1319 compareIterator compareValue io1 io2 1320 end 1321 | GREATER => GREATER; 1322 1323fun equal equalValue m1 m2 = 1324 pointerEqual (m1,m2) orelse 1325 (size m1 = size m2 andalso 1326 let 1327 val Map _ = m1 1328 1329 val io1 = mkIterator m1 1330 and io2 = mkIterator m2 1331 in 1332 equalIterator equalValue io1 io2 1333 end); 1334 1335(* ------------------------------------------------------------------------- *) 1336(* Set operations on the domain. *) 1337(* ------------------------------------------------------------------------- *) 1338 1339fun unionDomain (Map tree1) (Map tree2) = 1340 let 1341 val tree = treeUnionDomain tree1 tree2 1342 in 1343 Map tree 1344 end; 1345 1346(*BasicDebug 1347val unionDomain = fn m1 => fn m2 => 1348 checkInvariants "KeyMap.unionDomain: result" 1349 (unionDomain 1350 (checkInvariants "KeyMap.unionDomain: input 1" m1) 1351 (checkInvariants "KeyMap.unionDomain: input 2" m2)); 1352*) 1353 1354local 1355 fun uncurriedUnionDomain (m,acc) = unionDomain acc m; 1356in 1357 fun unionListDomain ms = 1358 case ms of 1359 [] => raise Bug "KeyMap.unionListDomain: no sets" 1360 | m :: ms => List.foldl uncurriedUnionDomain m ms; 1361end; 1362 1363fun intersectDomain (Map tree1) (Map tree2) = 1364 let 1365 val tree = treeIntersectDomain tree1 tree2 1366 in 1367 Map tree 1368 end; 1369 1370(*BasicDebug 1371val intersectDomain = fn m1 => fn m2 => 1372 checkInvariants "KeyMap.intersectDomain: result" 1373 (intersectDomain 1374 (checkInvariants "KeyMap.intersectDomain: input 1" m1) 1375 (checkInvariants "KeyMap.intersectDomain: input 2" m2)); 1376*) 1377 1378local 1379 fun uncurriedIntersectDomain (m,acc) = intersectDomain acc m; 1380in 1381 fun intersectListDomain ms = 1382 case ms of 1383 [] => raise Bug "KeyMap.intersectListDomain: no sets" 1384 | m :: ms => List.foldl uncurriedIntersectDomain m ms; 1385end; 1386 1387fun differenceDomain (Map tree1) (Map tree2) = 1388 let 1389 val tree = treeDifferenceDomain tree1 tree2 1390 in 1391 Map tree 1392 end; 1393 1394(*BasicDebug 1395val differenceDomain = fn m1 => fn m2 => 1396 checkInvariants "KeyMap.differenceDomain: result" 1397 (differenceDomain 1398 (checkInvariants "KeyMap.differenceDomain: input 1" m1) 1399 (checkInvariants "KeyMap.differenceDomain: input 2" m2)); 1400*) 1401 1402fun symmetricDifferenceDomain m1 m2 = 1403 unionDomain (differenceDomain m1 m2) (differenceDomain m2 m1); 1404 1405fun equalDomain m1 m2 = equal (K (K true)) m1 m2; 1406 1407fun subsetDomain (Map tree1) (Map tree2) = 1408 treeSubsetDomain tree1 tree2; 1409 1410fun disjointDomain m1 m2 = null (intersectDomain m1 m2); 1411 1412(* ------------------------------------------------------------------------- *) 1413(* Converting to and from lists. *) 1414(* ------------------------------------------------------------------------- *) 1415 1416fun keys m = foldr (fn (key,_,l) => key :: l) [] m; 1417 1418fun values m = foldr (fn (_,value,l) => value :: l) [] m; 1419 1420fun toList m = foldr (fn (key,value,l) => (key,value) :: l) [] m; 1421 1422fun fromList l = 1423 let 1424 val m = new () 1425 in 1426 insertList m l 1427 end; 1428 1429(* ------------------------------------------------------------------------- *) 1430(* Pretty-printing. *) 1431(* ------------------------------------------------------------------------- *) 1432 1433fun toString m = "<" ^ (if null m then "" else Int.toString (size m)) ^ ">"; 1434 1435end 1436 1437structure IntMap = 1438KeyMap (IntOrdered); 1439 1440structure IntPairMap = 1441KeyMap (IntPairOrdered); 1442 1443structure StringMap = 1444KeyMap (StringOrdered); 1445