1. my role Baggy does QuantHash {
  2. # A Bag/BagHash/Mix/MixHash consists of a single hash with Pairs.
  3. # The keys of the hash, are the .WHICH strings of the original object key.
  4. # The values are Pairs containing the original object key and value.
  5. has %!elems; # key.WHICH => (key,value)
  6. # The Baggy role takes care of all mutable and immutable aspects that are
  7. # shared between Bag,BagHash,Mix,MixHash. Any specific behaviour for
  8. # mutable and immutable aspects of Mix/MixHash need to live in Mixy.
  9. # Immutables aspects of Bag/Mix, need to live to Bag/Mix respectively.
  10. #--- private methods
  11. method !WHICH() {
  12. self.^name
  13. ~ '|'
  14. ~ self.keys.sort.map( { $_.WHICH ~ '(' ~ self.AT-KEY($_) ~ ')' } );
  15. }
  16. method !PAIR(\key,\value) { Pair.new(key, my Int $ = value ) }
  17. method !TOTAL() {
  18. nqp::if(
  19. (my $storage := nqp::getattr(%!elems,Map,'$!storage')),
  20. nqp::stmts(
  21. (my $total = 0),
  22. (my $iter := nqp::iterator($storage)),
  23. nqp::while(
  24. $iter,
  25. $total = $total
  26. + nqp::getattr(nqp::iterval(nqp::shift($iter)),Pair,'$!value')
  27. ),
  28. $total
  29. ),
  30. 0
  31. )
  32. }
  33. method !SANITY(%hash --> Nil) {
  34. my @toolow;
  35. my $elems := nqp::getattr(%hash,Map,'$!storage');
  36. my $iter := nqp::iterator($elems);
  37. while $iter {
  38. my \tmp := nqp::shift($iter);
  39. my \pair := nqp::iterval(tmp);
  40. my $value := pair.value;
  41. @toolow.push( pair.key ) if $value < 0;
  42. nqp::deletekey($elems,nqp::iterkey_s(tmp)) if $value <= 0;
  43. }
  44. fail "Found negative values for {@toolow} in {self.^name}" if @toolow;
  45. }
  46. method !LISTIFY(&formatter, str $joiner) {
  47. nqp::stmts(
  48. (my $pairs := nqp::getattr(%!elems,Map,'$!storage')),
  49. (my int $elems = nqp::elems($pairs)),
  50. (my $list := nqp::setelems(nqp::list_s,$elems)),
  51. (my $iter := nqp::iterator($pairs)),
  52. (my int $i = -1),
  53. nqp::while(
  54. $iter,
  55. nqp::bindpos_s($list,($i = nqp::add_i($i,1)),
  56. formatter(
  57. (my $pair := nqp::iterval(nqp::shift($iter))).key,
  58. $pair.value
  59. )
  60. )
  61. ),
  62. nqp::p6box_s(nqp::join($joiner,$list))
  63. )
  64. }
  65. #--- interface methods
  66. method !SET-SELF(Baggy:D: Mu \elems) {
  67. %!elems := elems;
  68. if nqp::istype(self, Bag) || nqp::istype(self, Mix) {
  69. my $iter := nqp::iterator(nqp::getattr(%!elems,Map,'$!storage'));
  70. while $iter {
  71. my \pair = nqp::iterval(nqp::shift($iter));
  72. nqp::bindattr(pair,Pair,'$!value',
  73. nqp::decont(nqp::getattr(pair,Pair,'$!value'))
  74. );
  75. }
  76. }
  77. self
  78. }
  79. multi method ACCEPTS(Baggy:U: $other) {
  80. $other.^does(self)
  81. }
  82. multi method ACCEPTS(Baggy:D: Mu $other) {
  83. $other (<+) self && self (<+) $other
  84. }
  85. multi method ACCEPTS(Baggy:D: Baggy:D $other --> Bool:D) {
  86. nqp::p6bool(
  87. nqp::unless(
  88. nqp::eqaddr(self,$other),
  89. nqp::if(
  90. (%!elems.elems
  91. == nqp::getattr($other,$other.WHAT,'%!elems').elems),
  92. nqp::stmts(
  93. (my $iter := nqp::iterator(
  94. nqp::getattr(%!elems,Map,'$!storage'))),
  95. (my $oelems := nqp::getattr(
  96. nqp::getattr($other,$other.WHAT,'%!elems'),Map,'$!storage')),
  97. nqp::while(
  98. $iter,
  99. nqp::stmts(
  100. nqp::shift($iter),
  101. nqp::unless(
  102. (nqp::existskey($oelems,nqp::iterkey_s($iter))
  103. && nqp::getattr(nqp::iterval($iter),Pair,'$!value')
  104. == nqp::getattr(nqp::atkey(
  105. $oelems,nqp::iterkey_s($iter)),Pair,'$!value')),
  106. return False
  107. )
  108. )
  109. ),
  110. 1
  111. )
  112. )
  113. )
  114. )
  115. }
  116. multi method AT-KEY(Baggy:D: \k) { # exception: ro version for Bag/Mix
  117. my $elems := nqp::getattr(%!elems,Map,'$!storage');
  118. my str $which = nqp::unbox_s(k.WHICH);
  119. nqp::existskey($elems,$which)
  120. ?? nqp::getattr(nqp::decont(nqp::atkey($elems,$which)),Pair,'$!value')
  121. !! 0
  122. }
  123. multi method DELETE-KEY(Baggy:D: \k) {
  124. my $elems := nqp::getattr(%!elems,Map,'$!storage');
  125. my str $which = nqp::unbox_s(k.WHICH);
  126. if nqp::existskey($elems,$which) {
  127. my \v = nqp::getattr(
  128. nqp::decont(nqp::atkey($elems,$which)),
  129. Pair,'$!value');
  130. nqp::deletekey($elems,$which);
  131. v
  132. }
  133. else {
  134. 0
  135. }
  136. }
  137. multi method EXISTS-KEY(Baggy:D: \k) {
  138. nqp::p6bool(
  139. nqp::existskey(
  140. nqp::getattr(%!elems,Map,'$!storage'),nqp::unbox_s(k.WHICH)));
  141. }
  142. #--- object creation methods
  143. multi method new(Baggy:_: +@args) {
  144. my $elems := nqp::hash();
  145. my str $which;
  146. for @args {
  147. $which = nqp::unbox_s(.WHICH);
  148. if nqp::existskey($elems,$which) {
  149. my $value :=
  150. nqp::getattr(nqp::atkey($elems,$which),Pair,'$!value');
  151. $value = $value + 1;
  152. }
  153. else {
  154. nqp::bindkey($elems,$which,self!PAIR($_,1));
  155. }
  156. }
  157. nqp::create(self)!SET-SELF($elems)
  158. }
  159. method new-from-pairs(*@pairs) {
  160. my $elems := nqp::hash();
  161. my str $which;
  162. my int $seen-pair;
  163. for @pairs {
  164. when Pair {
  165. $seen-pair = 1;
  166. $which = nqp::unbox_s(.key.WHICH);
  167. if nqp::existskey($elems,$which) {
  168. my $value :=
  169. nqp::getattr(nqp::atkey($elems,$which),Pair,'$!value');
  170. $value = $value + .value;
  171. }
  172. else {
  173. nqp::bindkey($elems,$which,self!PAIR(.key,.value));
  174. }
  175. }
  176. default {
  177. $which = nqp::unbox_s(.WHICH);
  178. if nqp::existskey($elems,$which) {
  179. my $value :=
  180. nqp::getattr(nqp::atkey($elems,$which),Pair,'$!value');
  181. $value = $value + 1;
  182. }
  183. else {
  184. nqp::bindkey($elems,$which,self!PAIR($_,1));
  185. }
  186. }
  187. }
  188. self!SANITY($elems) if $seen-pair;
  189. nqp::create(self)!SET-SELF($elems)
  190. }
  191. #--- iterator methods
  192. multi method iterator(Baggy:D:) {
  193. Rakudo::Iterator.Mappy-values(%!elems)
  194. }
  195. multi method keys(Baggy:D:) {
  196. Seq.new(class :: does Rakudo::Iterator::Mappy {
  197. method pull-one() {
  198. $!iter
  199. ?? nqp::iterval(nqp::shift($!iter)).key
  200. !! IterationEnd
  201. }
  202. method push-all($target --> IterationEnd) {
  203. nqp::while( # doesn't sink
  204. $!iter,
  205. $target.push(nqp::iterval(nqp::shift($!iter)).key)
  206. )
  207. }
  208. }.new(%!elems))
  209. }
  210. multi method kv(Baggy:D:) {
  211. Seq.new(Rakudo::Iterator.Mappy-kv-from-pairs(%!elems))
  212. }
  213. multi method values(Baggy:D:) {
  214. Seq.new(class :: does Rakudo::Iterator::Mappy {
  215. method pull-one() is raw {
  216. $!iter
  217. ?? nqp::getattr(nqp::decont(
  218. nqp::iterval(nqp::shift($!iter))),Pair,'$!value')
  219. !! IterationEnd
  220. }
  221. method push-all($target --> IterationEnd) {
  222. nqp::while( # doesn't sink
  223. $!iter,
  224. $target.push(nqp::getattr(nqp::decont(
  225. nqp::iterval(nqp::shift($!iter))),Pair,'$!value'))
  226. )
  227. }
  228. }.new(%!elems))
  229. }
  230. multi method antipairs(Baggy:D:) {
  231. Seq.new(class :: does Rakudo::Iterator::Mappy {
  232. method pull-one() {
  233. nqp::if(
  234. $!iter,
  235. nqp::iterval(nqp::shift($!iter)).antipair,
  236. IterationEnd
  237. )
  238. }
  239. method push-all($target --> IterationEnd) {
  240. nqp::while(
  241. $!iter,
  242. $target.push(nqp::iterval(nqp::shift($!iter)).antipair),
  243. )
  244. }
  245. }.new(%!elems))
  246. }
  247. proto method kxxv(|) { * }
  248. multi method kxxv(Baggy:D:) {
  249. Seq.new(class :: does Rakudo::Iterator::Mappy {
  250. has Mu $!key;
  251. has int $!times;
  252. method pull-one() is raw {
  253. nqp::if(
  254. $!times,
  255. nqp::stmts(
  256. ($!times = nqp::sub_i($!times,1)),
  257. $!key
  258. ),
  259. nqp::if(
  260. $!iter,
  261. nqp::stmts(
  262. ($!key := nqp::getattr(
  263. (my $pair := nqp::decont(
  264. nqp::iterval(nqp::shift($!iter)))),
  265. Pair,
  266. '$!key'
  267. )),
  268. ($!times =
  269. nqp::sub_i(nqp::getattr($pair,Pair,'$!value'),1)),
  270. $!key
  271. ),
  272. IterationEnd
  273. )
  274. )
  275. }
  276. method skip-one() { # the default skip-one, too difficult to handle
  277. nqp::not_i(nqp::eqaddr(self.pull-one,IterationEnd))
  278. }
  279. method push-all($target --> IterationEnd) {
  280. nqp::while(
  281. $!iter,
  282. nqp::stmts(
  283. ($!key := nqp::getattr(
  284. (my $pair := nqp::decont(
  285. nqp::iterval(nqp::shift($!iter)))),
  286. Pair,
  287. '$!key'
  288. )),
  289. ($!times =
  290. nqp::add_i(nqp::getattr($pair,Pair,'$!value'),1)),
  291. nqp::while( # doesn't sink
  292. ($!times = nqp::sub_i($!times,1)),
  293. $target.push($!key)
  294. )
  295. )
  296. )
  297. }
  298. }.new(%!elems))
  299. }
  300. multi method invert(Baggy:D:) {
  301. Seq.new(Rakudo::Iterator.Invert(%!elems.values.iterator))
  302. }
  303. #--- introspection methods
  304. multi method WHICH(Baggy:D:) { self!WHICH }
  305. method total(Baggy:D:) { self!TOTAL }
  306. multi method elems(Baggy:D: --> Int:D) { %!elems.elems }
  307. multi method Bool(Baggy:D: --> Bool:D) {
  308. nqp::p6bool(nqp::elems(nqp::getattr(%!elems,Map,'$!storage')))
  309. }
  310. multi method hash(Baggy:D: --> Hash:D) {
  311. my \h = Hash.^parameterize(Any, Any).new;
  312. h = %!elems.values;
  313. h;
  314. }
  315. method default(Baggy:D: --> 0) { }
  316. multi method Str(Baggy:D: --> Str:D) {
  317. self!LISTIFY(-> \k,\v {v==1 ?? k.gist !! "{k.gist}({v})"}, ' ')
  318. }
  319. multi method gist(Baggy:D: --> Str:D) {
  320. my str $name = nqp::unbox_s(self.^name);
  321. ( nqp::chars($name) == 3 ?? nqp::lc($name) !! "$name.new" )
  322. ~ '('
  323. ~ self!LISTIFY(-> \k,\v {v==1 ?? k.gist !! "{k.gist}({v})"}, ', ')
  324. ~ ')'
  325. }
  326. multi method perl(Baggy:D: --> Str:D) {
  327. '('
  328. ~ self!LISTIFY( -> \k,\v {"{k.perl}=>{v}"}, ',')
  329. ~ ").{self.^name}"
  330. }
  331. #--- selection methods
  332. proto method grabpairs (|) { * }
  333. multi method grabpairs(Baggy:D:) {
  334. %!elems.DELETE-KEY(%!elems.keys.pick);
  335. }
  336. multi method grabpairs(Baggy:D: $count) {
  337. if nqp::istype($count,Whatever) || $count == Inf {
  338. my @grabbed = %!elems{%!elems.keys.pick(%!elems.elems)};
  339. %!elems = ();
  340. @grabbed;
  341. }
  342. else {
  343. %!elems{ %!elems.keys.pick($count) }:delete;
  344. }
  345. }
  346. proto method pickpairs(|) { * }
  347. multi method pickpairs(Baggy:D:) {
  348. %!elems.AT-KEY(%!elems.keys.pick);
  349. }
  350. multi method pickpairs(Baggy:D: Callable:D $calculate) {
  351. self.pickpairs( $calculate(self.total) )
  352. }
  353. multi method pickpairs(Baggy:D: $count) {
  354. %!elems{ %!elems.keys.pick(
  355. nqp::istype($count,Whatever) || $count == Inf
  356. ?? %!elems.elems
  357. !! $count
  358. ) };
  359. }
  360. proto method grab(|) { * }
  361. multi method grab(Baggy:D:) {
  362. my \grabbed := self.roll;
  363. %!elems.DELETE-KEY(grabbed.WHICH)
  364. if %!elems.AT-KEY(grabbed.WHICH).value-- == 1;
  365. grabbed;
  366. }
  367. multi method grab(Baggy:D: Callable:D $calculate) {
  368. self.grab( $calculate(self.total) )
  369. }
  370. multi method grab(Baggy:D: $count) {
  371. if nqp::istype($count,Whatever) || $count == Inf {
  372. my @grabbed = self!ROLLPICKGRABN(self.total,%!elems.values);
  373. %!elems = ();
  374. @grabbed;
  375. }
  376. else {
  377. my @grabbed = self!ROLLPICKGRABN($count,%!elems.values);
  378. for @grabbed {
  379. if %!elems.AT-KEY(.WHICH) -> $pair {
  380. %!elems.DELETE-KEY(.WHICH) unless $pair.value;
  381. }
  382. }
  383. @grabbed;
  384. }
  385. }
  386. proto method pick(|) { * }
  387. multi method pick(Baggy:D:) { self.roll }
  388. multi method pick(Baggy:D: Callable:D $calculate) {
  389. self.pick( $calculate(self.total) )
  390. }
  391. multi method pick(Baggy:D: $count) {
  392. my $hash := nqp::getattr(%!elems,Map,'$!storage');
  393. my int $elems = nqp::elems($hash);
  394. my $pairs := nqp::setelems(nqp::list,$elems);
  395. my \iter := nqp::iterator($hash);
  396. my int $i = -1;
  397. my $pair;
  398. nqp::while(
  399. nqp::islt_i(($i = nqp::add_i($i,1)),$elems),
  400. nqp::bindpos($pairs,$i,Pair.new(
  401. nqp::getattr(
  402. ($pair := nqp::iterval(nqp::shift(iter))),Pair,'$!key'),
  403. nqp::assign(nqp::p6scalarfromdesc(nqp::null),
  404. nqp::getattr($pair,Pair,'$!value'))
  405. ))
  406. );
  407. self!ROLLPICKGRABN(
  408. nqp::istype($count,Whatever) || $count == Inf ?? self.total !! $count,
  409. $pairs
  410. )
  411. }
  412. proto method roll(|) { * }
  413. multi method roll(Baggy:D:) {
  414. nqp::stmts(
  415. (my Int $rand = self.total.rand.Int),
  416. (my Int $seen = 0),
  417. (my \iter := nqp::iterator(nqp::getattr(%!elems,Map,'$!storage'))),
  418. nqp::while(
  419. iter && ($seen = $seen + nqp::getattr(
  420. nqp::iterval(nqp::shift(iter)),Pair,'$!value')) <= $rand,
  421. nqp::null
  422. ),
  423. nqp::if(
  424. $seen > $rand,
  425. nqp::getattr(nqp::iterval(iter),Pair,'$!key'),
  426. Nil
  427. )
  428. )
  429. }
  430. multi method roll(Baggy:D: $count) {
  431. nqp::istype($count,Whatever) || $count == Inf
  432. ?? Seq.new(Rakudo::Iterator.Roller(self))
  433. !! self!ROLLPICKGRABN($count, %!elems.values, :keep);
  434. }
  435. method !ROLLPICKGRABN(\count, @pairs, :$keep) { # N times
  436. Seq.new(class :: does Iterator {
  437. has Int $!total;
  438. has int $!elems;
  439. has $!pairs;
  440. has int $!todo;
  441. has int $!keep;
  442. method !SET-SELF($!total, \pairs, \keep, \todo) {
  443. $!elems = pairs.elems; # reifies
  444. $!pairs := nqp::getattr(pairs,List,'$!reified');
  445. $!todo = todo;
  446. $!keep = +?keep;
  447. self
  448. }
  449. method new(\total,\pairs,\keep,\count) {
  450. nqp::create(self)!SET-SELF(
  451. total, pairs, keep, keep ?? count !! (total min count))
  452. }
  453. method pull-one() {
  454. if $!todo {
  455. $!todo = nqp::sub_i($!todo,1);
  456. my Int $rand = $!total.rand.Int;
  457. my Int $seen = 0;
  458. my int $i = -1;
  459. nqp::while(
  460. nqp::islt_i(($i = nqp::add_i($i,1)),$!elems),
  461. ($seen = $seen + nqp::atpos($!pairs,$i).value),
  462. nqp::if(
  463. $seen > $rand,
  464. nqp::stmts(
  465. nqp::unless(
  466. $!keep,
  467. nqp::stmts(
  468. --(nqp::atpos($!pairs,$i)).value,
  469. --$!total,
  470. )
  471. ),
  472. return nqp::atpos($!pairs,$i).key
  473. )
  474. )
  475. );
  476. }
  477. IterationEnd
  478. }
  479. }.new(self.total,@pairs,$keep,count))
  480. }
  481. #--- classification method
  482. proto method classify-list(|) { * }
  483. multi method classify-list( &test, \list) {
  484. fail X::Cannot::Lazy.new(:action<classify>) if list.is-lazy;
  485. my \iter = (nqp::istype(list, Iterable) ?? list !! list.list).iterator;
  486. while (my $value := iter.pull-one) !=:= IterationEnd {
  487. my $tested := test($value);
  488. if nqp::istype($tested, Iterable) { # multi-level classify
  489. X::Invalid::ComputedValue.new(
  490. :name<mapper>,
  491. :method<classify-list>,
  492. :value<an Iterable item>,
  493. :reason(self.^name ~ ' cannot be nested and so does not '
  494. ~ 'support multi-level classification'),
  495. ).throw;
  496. }
  497. else {
  498. self{$tested}++;
  499. }
  500. }
  501. self;
  502. }
  503. multi method classify-list( %test, |c ) {
  504. self.classify-list( { %test{$^a} }, |c );
  505. }
  506. multi method classify-list( @test, |c ) {
  507. self.classify-list( { @test[$^a] }, |c );
  508. }
  509. multi method classify-list(&test, **@list, |c) {
  510. self.classify-list(&test, @list, |c);
  511. }
  512. proto method categorize-list(|) { * }
  513. multi method categorize-list( &test, \list ) {
  514. fail X::Cannot::Lazy.new(:action<categorize>) if list.is-lazy;
  515. my \iter = (nqp::istype(list, Iterable) ?? list !! list.list).iterator;
  516. my $value := iter.pull-one;
  517. unless $value =:= IterationEnd {
  518. my $tested := test($value);
  519. # multi-level categorize
  520. if nqp::istype($tested[0],Iterable) {
  521. X::Invalid::ComputedValue.new(
  522. :name<mapper>,
  523. :method<categorize-list>,
  524. :value<a nested Iterable item>,
  525. :reason(self.^name ~ ' cannot be nested and so does not '
  526. ~ 'support multi-level categorization'),
  527. ).throw;
  528. }
  529. # simple categorize
  530. else {
  531. loop {
  532. self{$_}++ for @$tested;
  533. last if ($value := iter.pull-one) =:= IterationEnd;
  534. nqp::istype(($tested := test($value))[0], Iterable)
  535. and X::Invalid::ComputedValue.new(
  536. :name<mapper>,
  537. :method<categorize-list>,
  538. :value('an item with different number of elements '
  539. ~ 'in it than previous items'),
  540. :reason('all values need to have the same number '
  541. ~ 'of elements. Mixed-level classification is '
  542. ~ 'not supported.'),
  543. ).throw;
  544. };
  545. }
  546. }
  547. self;
  548. }
  549. multi method categorize-list( %test, |c ) {
  550. self.categorize-list( { %test{$^a} }, |c );
  551. }
  552. multi method categorize-list( @test, |c ) {
  553. self.categorize-list( { @test[$^a] }, |c );
  554. }
  555. multi method categorize-list( &test, **@list, |c ) {
  556. self.categorize-list( &test, @list, |c );
  557. }
  558. #--- coercion methods
  559. method Set() { Set.new(self.keys) }
  560. method SetHash() { SetHash.new(self.keys) }
  561. }
  562. multi sub infix:<eqv>(Baggy:D \a, Baggy:D \b) {
  563. nqp::p6bool(
  564. nqp::unless(
  565. nqp::eqaddr(a,b),
  566. nqp::eqaddr(a.WHAT,b.WHAT)
  567. && nqp::getattr(nqp::decont(a),a.WHAT,'%!elems')
  568. eqv nqp::getattr(nqp::decont(b),b.WHAT,'%!elems')
  569. )
  570. )
  571. }