1. # This file implements the following set operators:
  2. # (<+) precedes (ASCII)
  3. # ≼ precedes
  4. # (>+) succeeds (ASCII)
  5. # ≽ succeeds
  6. proto sub infix:<<(<+)>>($, $ --> Bool:D) is pure {
  7. DEPRECATED(
  8. "set operator {$*INSTEAD // "(<=)"}",
  9. "",
  10. "6.d",
  11. :what("Set operator {$*WHAT // "(<+)"}"),
  12. :up( 1 + ?$*WHAT )
  13. );
  14. {*}
  15. }
  16. multi sub infix:<<(<+)>>(Setty:D \a, QuantHash:D \b --> Bool:D) {
  17. nqp::if(
  18. (my $a := a.RAW-HASH),
  19. nqp::if(
  20. (my $b := b.RAW-HASH) && nqp::isge_i(nqp::elems($b),nqp::elems($a)),
  21. nqp::stmts(
  22. (my $iter := nqp::iterator($a)),
  23. nqp::while(
  24. $iter && nqp::existskey($b,nqp::iterkey_s(nqp::shift($iter))),
  25. nqp::null
  26. ),
  27. nqp::p6bool(nqp::isfalse($iter))
  28. ),
  29. False
  30. ),
  31. True
  32. )
  33. }
  34. multi sub infix:<<(<+)>>(Mixy:D \a, Baggy:D \b --> Bool:D) {
  35. nqp::if(
  36. (my $a := a.RAW-HASH),
  37. nqp::if(
  38. (my $b := b.RAW-HASH) && nqp::isge_i(nqp::elems($b),nqp::elems($a)),
  39. nqp::stmts(
  40. (my $iter := nqp::iterator($a)),
  41. nqp::while(
  42. $iter,
  43. nqp::if(
  44. nqp::not_i(nqp::existskey(
  45. $b,
  46. (my $key := nqp::iterkey_s(nqp::shift($iter)))
  47. )) ||
  48. nqp::getattr(nqp::decont(nqp::atkey($a,$key)),Pair,'$!value')
  49. > nqp::getattr(nqp::decont(nqp::atkey($b,$key)),Pair,'$!value'),
  50. (return False)
  51. )
  52. ),
  53. True
  54. ),
  55. False
  56. ),
  57. True
  58. )
  59. }
  60. multi sub infix:<<(<+)>>(Baggy:D \a, Baggy:D \b --> Bool:D) {
  61. nqp::if(
  62. (my $a := a.RAW-HASH),
  63. nqp::if(
  64. (my $b := b.RAW-HASH) && nqp::isge_i(nqp::elems($b),nqp::elems($a)),
  65. nqp::stmts(
  66. (my $iter := nqp::iterator($a)),
  67. nqp::while(
  68. $iter,
  69. nqp::if(
  70. nqp::not_i(nqp::existskey(
  71. $b,
  72. (my $key := nqp::iterkey_s(nqp::shift($iter)))
  73. )) ||
  74. nqp::isgt_i(
  75. nqp::getattr(nqp::decont(nqp::atkey($a,$key)),Pair,'$!value'),
  76. nqp::getattr(nqp::decont(nqp::atkey($b,$key)),Pair,'$!value')
  77. ),
  78. (return False)
  79. )
  80. ),
  81. True
  82. ),
  83. False
  84. ),
  85. True
  86. )
  87. }
  88. multi sub infix:<<(<+)>>(QuantHash:U $a, QuantHash:U $b --> True ) {}
  89. multi sub infix:<<(<+)>>(QuantHash:U $a, QuantHash:D $b --> True ) {}
  90. multi sub infix:<<(<+)>>(QuantHash:D $a, QuantHash:U $b --> Bool:D ) {
  91. not $a.elems
  92. }
  93. multi sub infix:<<(<+)>>(QuantHash:D $a, QuantHash:D $b --> Bool:D ) {
  94. return False if $a.AT-KEY($_) > $b.AT-KEY($_) for $a.keys;
  95. True
  96. }
  97. multi sub infix:<<(<+)>>(Any $, Failure:D $b) { $b.throw }
  98. multi sub infix:<<(<+)>>(Failure:D $a, Any $) { $a.throw }
  99. multi sub infix:<<(<+)>>(Any $a, Any $b --> Bool:D) {
  100. nqp::if(
  101. nqp::istype($a,Mixy) || nqp::istype($b,Mixy),
  102. infix:<<(<+)>>($a.Mix, $b.Mix),
  103. infix:<<(<+)>>($a.Bag, $b.Bag)
  104. )
  105. }
  106. # U+227C PRECEDES OR EQUAL TO
  107. proto sub infix:<≼>(|) is pure {*}
  108. multi sub infix:<≼>($a, $b --> Bool:D) {
  109. my $*WHAT = "≼";
  110. my $*INSTEAD = "⊆";
  111. infix:<<(<+)>>($a, $b)
  112. }
  113. # $a (>+) $b === $a R(<+) $b
  114. proto sub infix:<<(>+)>>(|) is pure {*}
  115. multi sub infix:<<(>+)>>($a, $b --> Bool:D) {
  116. my $*WHAT = "(>+)";
  117. my $*INSTEAD = "(>=)";
  118. infix:<<(<+)>>($b, $a)
  119. }
  120. # U+227D SUCCEEDS OR EQUAL TO
  121. proto sub infix:<≽>(|) is pure {*}
  122. multi sub infix:<≽>($a, $b --> Bool:D) {
  123. my $*WHAT = "≽";
  124. my $*INSTEAD = "⊇";
  125. infix:<<(<+)>>($b, $a)
  126. }