/core/sets/sets.factor

http://github.com/abeaumont/factor · Factor · 175 lines · 114 code · 54 blank · 7 comment · 26 complexity · 1f073310823bb44278bbc382cfccbd16 MD5 · raw file

  1. ! Copyright (C) 2010 Daniel Ehrenberg
  2. ! See http://factorcode.org/license.txt for BSD license.
  3. USING: assocs hashtables kernel math sequences vectors ;
  4. FROM: assocs => change-at ;
  5. IN: sets
  6. ! Set protocol
  7. MIXIN: set
  8. GENERIC: adjoin ( elt set -- )
  9. GENERIC: in? ( elt set -- ? )
  10. GENERIC: delete ( elt set -- )
  11. GENERIC: set-like ( set exemplar -- set' )
  12. GENERIC: fast-set ( set -- set' )
  13. GENERIC: members ( set -- seq )
  14. GENERIC: union ( set1 set2 -- set )
  15. GENERIC: intersect ( set1 set2 -- set )
  16. GENERIC: intersects? ( set1 set2 -- ? )
  17. GENERIC: diff ( set1 set2 -- set )
  18. GENERIC: subset? ( set1 set2 -- ? )
  19. GENERIC: set= ( set1 set2 -- ? )
  20. GENERIC: duplicates ( set -- seq )
  21. GENERIC: all-unique? ( set -- ? )
  22. GENERIC: null? ( set -- ? )
  23. GENERIC: cardinality ( set -- n )
  24. GENERIC: clear-set ( set -- )
  25. M: f cardinality drop 0 ;
  26. M: f delete 2drop ;
  27. M: f clear-set drop ; inline
  28. ! Defaults for some methods.
  29. ! Override them for efficiency
  30. M: set null? members null? ; inline
  31. M: set cardinality members length ;
  32. M: set clear-set [ members ] keep [ delete ] curry each ;
  33. M: set set-like drop ; inline
  34. <PRIVATE
  35. : ?members ( set -- seq )
  36. dup sequence? [ members ] unless ; inline
  37. : (union) ( set1 set2 -- seq )
  38. [ ?members ] bi@ append ; inline
  39. PRIVATE>
  40. M: set union
  41. [ (union) ] keep set-like ;
  42. <PRIVATE
  43. : tester ( set -- quot )
  44. fast-set [ in? ] curry ; inline
  45. : sequence/tester ( set1 set2 -- set1' quot )
  46. [ members ] [ tester ] bi* ; inline
  47. : small/large ( set1 set2 -- set1' set2' )
  48. 2dup [ cardinality ] bi@ > [ swap ] when ;
  49. PRIVATE>
  50. M: set intersect
  51. [ small/large sequence/tester filter ] keep set-like ;
  52. M: set diff
  53. [ sequence/tester [ not ] compose filter ] keep set-like ;
  54. M: set intersects?
  55. small/large sequence/tester any? ;
  56. <PRIVATE
  57. : (subset?) ( set1 set2 -- ? )
  58. sequence/tester all? ; inline
  59. PRIVATE>
  60. M: set subset?
  61. 2dup [ cardinality ] bi@ > [ 2drop f ] [ (subset?) ] if ;
  62. M: set set=
  63. 2dup [ cardinality ] bi@ eq? [ (subset?) ] [ 2drop f ] if ;
  64. M: set fast-set ;
  65. M: set duplicates drop f ;
  66. M: set all-unique? drop t ;
  67. <PRIVATE
  68. : (pruned) ( elt hash vec -- )
  69. 2over in? [ 3drop ] [
  70. [ drop adjoin ] [ nip push ] 3bi
  71. ] if ; inline
  72. : pruned ( seq -- newseq )
  73. [ f fast-set ] [ length <vector> ] bi
  74. [ [ (pruned) ] 2curry each ] keep ;
  75. PRIVATE>
  76. ! Sequences are sets
  77. INSTANCE: sequence set
  78. M: sequence in?
  79. member? ; inline
  80. M: sequence adjoin
  81. [ delete ] [ push ] 2bi ;
  82. M: sequence delete
  83. remove! drop ; inline
  84. M: sequence set-like
  85. [ members ] dip like ;
  86. M: sequence members
  87. [ pruned ] keep like ;
  88. M: sequence null?
  89. empty? ; inline
  90. M: sequence cardinality
  91. fast-set cardinality ;
  92. M: sequence clear-set
  93. delete-all ; inline
  94. : combine ( sets -- set/f )
  95. [ f ]
  96. [ [ [ ?members ] map concat ] [ first ] bi set-like ]
  97. if-empty ;
  98. : intersection ( sets -- set/f )
  99. [ f ] [ [ ] [ intersect ] map-reduce ] if-empty ;
  100. : gather ( ... seq quot: ( ... elt -- ... elt' ) -- ... newseq )
  101. map concat members ; inline
  102. : adjoin-at ( value key assoc -- )
  103. [ [ f fast-set ] unless* [ adjoin ] keep ] change-at ;
  104. : within ( seq set -- subseq )
  105. tester filter ;
  106. : without ( seq set -- subseq )
  107. tester [ not ] compose filter ;
  108. : ?adjoin ( elt set -- ? )
  109. 2dup in? [ 2drop f ] [ adjoin t ] if ; inline
  110. : union! ( set1 set2 -- set1 )
  111. ?members over [ adjoin ] curry each ;
  112. : diff! ( set1 set2 -- set1 )
  113. dupd sequence/tester [ dup ] prepose pick
  114. [ delete ] curry [ [ drop ] if ] curry compose each ;
  115. ! Temporarily for compatibility
  116. : unique ( seq -- assoc )
  117. [ dup ] H{ } map>assoc ;
  118. : conjoin ( elt assoc -- )
  119. dupd set-at ;
  120. : conjoin-at ( value key assoc -- )
  121. [ dupd ?set-at ] change-at ;