Permalink
Browse files

First version of Set/Bag changes from niecza, ported to rakudo

  • Loading branch information...
1 parent 7e80cd5 commit ea063604298fff0ab4374324409b3eea2572d418 @lizmat lizmat committed Aug 29, 2013
Showing with 321 additions and 134 deletions.
  1. +24 −0 src/core/Any.pm
  2. +73 −30 src/core/Bag.pm
  3. +0 −3 src/core/Cool.pm
  4. +32 −23 src/core/KeyBag.pm
  5. +12 −14 src/core/KeySet.pm
  6. +180 −64 src/core/Set.pm
View
@@ -1,5 +1,10 @@
+my class Bag { ... }
+my class KeyBag { ... }
+my class KeySet { ... }
my class MapIter { ... }
+my class Pair { ... }
my class Range { ... }
+my class Set { ... }
my class X::Bind::Slice { ... }
my class X::Bind::ZenSlice { ... }
@@ -739,6 +744,25 @@ my class Any { # declared in BOOTSTRAP
nqp::findmethod($list, 'FLATTENABLE_LIST')($list);
}
method FLATTENABLE_HASH() { nqp::hash() }
+
+ method Set() {
+ my @keys;
+ for self.list() {
+ when Pair { @keys.push(.key) if .value }
+ default { @keys.push($_) }
+ }
+ Set.new(@keys);
+ }
+ method KeySet() {
+ my @keys;
+ for self.list() {
+ when Pair { @keys.push(.key) if .value; }
+ default { @keys.push($_) }
+ }
+ KeySet.new(@keys);
+ }
+ method Bag() { Bag.new-from-pairs(self.list) }
+ method KeyBag() { KeyBag.new-from-pairs(self.list) }
}
Metamodel::ClassHOW.exclude_parent(Any);
View
@@ -1,5 +1,49 @@
my role Baggy { Any }
+only sub infix:<(.)>(**@p) {
+ my $set = Set.new: @p.map(*.Set.keys);
+ my @bags = @p.map(*.Bag);
+ Bag.new-from-pairs($set.map({ ; $_ => [*] @bags>>.{$_} }));
+}
+# U+228D MULTISET MULTIPLICATION
+only sub infix:<<"\x228D">>(**@p) {
+ infix:<(.)>(@p);
+}
+
+only sub infix:<(+)>(**@p) {
+ my $set = Set.new: @p.map(*.Set.keys);
+ my @bags = @p.map(*.Bag);
+ Bag.new-from-pairs($set.map({ ; $_ => [+] @bags>>.{$_} }));
+}
+# U+228E MULTISET UNION
+only sub infix:<<"\x228E">>(**@p) {
+ infix:<(+)>(@p);
+}
+
+proto sub infix:<<(<+)>>($, $ --> Bool) {*}
+multi sub infix:<<(<+)>>(Any $a, Any $b --> Bool) {
+ $a.Bag (<+) $b.Bag;
+}
+multi sub infix:<<(<+)>>(Baggy $a, Baggy $b --> Bool) {
+ so all $a.keys.map({ $a{$_} <= $b{$_} })
+}
+# U+227C PRECEDES OR EQUAL TO
+only sub infix:<<"\x227C">>($a, $b --> Bool) {
+ $a (<+) $b;
+}
+
+proto sub infix:<<(>+)>>($, $ --> Bool) {*}
+multi sub infix:<<(>+)>>(Baggy $a, Baggy $b --> Bool) {
+ so all $b.keys.map({ $b{$_} <= $a{$_} });
+}
+multi sub infix:<<(>+)>>(Any $a, Any $b --> Bool) {
+ $a.Bag (>+) $b.Bag;
+}
+# U+227D SUCCEEDS OR EQUAL TO
+only sub infix:<<"\x227D">>($a, $b --> Bool) {
+ $a (>+) $b;
+}
+
my class Bag is Iterable does Associative does Baggy {
has %!elems; # should be UInt
@@ -15,58 +59,57 @@ my class Bag is Iterable does Associative does Baggy {
method Numeric { self.elems }
method Real { self.elems }
method hash { %!elems.hash }
+ method Set { set self.keys }
+ method KeySet { KeySet.new(self.keys) }
+ method Bag { self }
+ method KeyBag { KeyBag.new-from-pairs(self.hash) }
+
method at_key($k) { +(%!elems{$k} // 0) }
method exists_key($k) { self.exists($k) }
# Constructor
method new(*@args --> Bag) {
my %e;
- sub register-arg($arg) {
- given $arg {
- when Pair { if .value { if %e.exists(.key) { %e{.key} += .value } else { %e{.key} = .value } } }
- when Set | KeySet { for .keys -> $key { %e{$key}++; } }
- when Associative { for .pairs -> $p { register-arg($p) } }
- when Positional { for .list -> $p { register-arg($p) } }
- default { %e{$_}++; }
- }
+ %e{$_} = True for @args;
+ self.bless(:elems(%e));
+ }
+ method new-from-pairs(*@pairs --> Bag) {
+ my %e;
+ for @pairs {
+ when Pair { %e{.key} = .value + (%e{.key} // 0); }
+ %e{$_}++;
}
-
- for @args {
- register-arg($_);
+ for %e -> $p {
+ die "Negative values are not allowed in Bags" if $p.value < 0;
+ %e.delete($p.key) if $p.value == 0;
}
self.bless(:elems(%e));
}
submethod BUILD (:%!elems) { }
+ method ACCEPTS($other) {
+ self.defined
+ ?? $other (<+) self && self (<+) $other
+ !! $other.^does(self);
+ }
+
multi method Str(Any:D $ : --> Str) { ~ self.pairs.map: { .key xx .value } }
multi method gist(Any:D $ : --> Str) { "bag({ self.pairs>>.gist.join(', ') })" }
- multi method perl(Any:D $ : --> Str) { 'Bag.new(' ~ %!elems.perl ~ ')' }
+ multi method perl(Any:D $ : --> Str) {
+ self.defined
+ ?? '(' ~ %!elems.perl ~ ').Bag'
+ !! "Bag";
+ }
method iterator() { %!elems.pairs.iterator }
method list() { %!elems.keys }
method pairs() { %!elems.pairs }
- method pick($count = 1) { my $kb = KeyBag.new(self); $kb.pick($count); }
- method roll($count = 1) { my $kb = KeyBag.new(self); $kb.roll($count); }
+ method pick($count = 1) { self.KeyBag.pick($count) }
+ method roll($count = 1) { self.KeyBag.roll($count) }
}
sub bag(*@a) returns Bag {
Bag.new(|@a);
}
-
-multi sub infix:<(|)>(Baggy $a, Any $b --> Bag) { $a (|) bag($b) }
-multi sub infix:<(|)>(Any $a, Baggy $b --> Bag) { bag($a) (|) $b }
-multi sub infix:<(|)>(Baggy $a, Baggy $b --> Bag) { bag((set($a) (|) set($b)).map({ ; $_ => $a{$_} max $b{$_} })) }
-
-multi sub infix:<(&)>(Baggy $a, Any $b --> Bag) { $a (&) bag($b) }
-multi sub infix:<(&)>(Any $a, Baggy $b --> Bag) { bag($a) (&) $b }
-multi sub infix:<(&)>(Baggy $a, Baggy $b --> Bag) { bag((set($a) (&) set($b)).map({ ; $_ => $a{$_} min $b{$_} })) }
-
-proto sub infix:<(.)>($, $ --> Bag) {*}
-multi sub infix:<(.)>(Any $a, Any $b --> Bag) { bag($a) (.) bag($b) }
-multi sub infix:<(.)>(Bag $a, Bag $b --> Bag) { bag((set($a) (|) set($b)).map({ ; $_ => $a{$_} * $b{$_} })) }
-
-proto sub infix:<(+)>($, $ --> Bag) {*}
-multi sub infix:<(+)>(Any $a, Any $b --> Bag) { bag($a) (+) bag($b) }
-multi sub infix:<(+)>(Bag $a, Bag $b --> Bag) { bag((set($a) (|) set($b)).map({ ; $_ => $a{$_} + $b{$_} })) }
View
@@ -212,9 +212,6 @@ my class Cool { # declared in BOOTSTRAP
method Int() { self.Numeric.Int }
method Num() { self.Numeric.Num }
method Rat() { self.Numeric.Rat }
-
- method set() { set self }
- method bag() { bag self }
}
Metamodel::ClassHOW.exclude_parent(Cool);
View
@@ -10,52 +10,61 @@ my class KeyBag does Associative does Baggy {
method Numeric { self.elems }
method Real { self.elems }
method hash { %!elems.hash }
+ method Set { set self.keys }
+ method KeySet { KeySet.new(self.keys) }
+ method Bag { Bag.new-from-pairs(self.hash) }
+ method KeyBag { self }
+
method at_key($k) {
Proxy.new(FETCH => { %!elems.exists($k) ?? %!elems{$k} !! 0 },
STORE => -> $, $value { if $value > 0 { %!elems{$k} = $value } else { %!elems.delete($k) }});
}
method exists_key($k) { self.exists($k) }
method delete_key($k) { %!elems.delete($k) }
- sub REGISTER ( @args, $e = {} ) {
- sub register-arg($arg) {
- given $arg {
- when Pair { $e{.key} += .value if .value }
- when Set | KeySet { for .keys -> $key { $e{$key}++; } }
- when Associative { for .pairs -> $p { register-arg($p) } }
- when Positional { for .list -> $p { register-arg($p) } }
- default { $e{$_}++; }
- }
- }
-
- register-arg($_) for @args;
- $e;
- }
-
# Constructor
method new(*@args --> KeyBag) {
- self.bless(:elems( REGISTER(@args) ));
+ my %e;
+ %e{$_}++ for @args;
+ self.bless(:elems(%e));
+ }
+ method new-from-pairs(*@pairs --> KeyBag) {
+ my %e;
+ for @pairs {
+ when Pair { %e{.key} = .value + (%e{.key} // 0); }
+ %e{$_}++;
+ }
+ for %e -> $p {
+ die "Negative values are not allowed in KeyBags" if $p.value < 0;
+ %e.delete($p.key) if $p.value == 0;
+ }
+ self.bless(:elems(%e));
}
submethod BUILD (:%!elems) { }
+ method ACCEPTS($other) {
+ self.defined
+ ?? $other (<+) self && self (<+) $other
+ !! $other.^does(self);
+ }
+
multi method Str(Bag:D:) { ~ self.pairs.map: { .key xx .value } }
multi method gist(Any:D $ : --> Str) { "keybag({ self.pairs>>.gist.join(', ') })" }
- multi method perl(Any:D $ : --> Str) { 'KeyBag.new(' ~ %!elems.perl ~ ')' }
+ multi method perl(Any:D $ : --> Str) {
+ self.defined
+ ?? %!elems.perl ~ '.KeyBag'
+ !! "KeyBag";
+ }
method iterator() { %!elems.pairs.iterator }
method list() { %!elems.keys }
method pairs() { %!elems.pairs }
- method push(*@args) {
- REGISTER( @args, %!elems );
- self
- }
-
method pick($count = 1) {
return self.roll if $count ~~ Num && $count == 1;
- my $temp-bag = KeyBag.new(self);
+ my $temp-bag = KeyBag.new-from-pairs(self.hash);
my $lc = $count ~~ Whatever ?? Inf !! $count;
gather while $temp-bag && $lc-- {
my $choice = $temp-bag.roll;
View
@@ -20,27 +20,25 @@ my class KeySet is Iterable does Associative {
# Constructor
method new(*@args --> KeySet) {
my %e;
- sub register-arg($arg) {
- given $arg {
- when Pair { %e{.key} = True; }
- when Set | KeySet { for .keys -> $key { %e{$key} = True; } }
- when Associative { for .pairs -> $p { register-arg($p); } }
- when Positional { for .list -> $p { register-arg($p); } }
- default { %e{$_} = True; }
- }
- }
-
- for @args {
- register-arg($_);
- }
+ %e{$_} = True for @args;
self.bless(:elems(%e));
}
submethod BUILD (:%!elems) { }
+ method ACCEPTS($other) {
+ self.defined
+ ?? $other (<=) self && self (<=) $other
+ !! $other.^does(self);
+ }
+
multi method Str(Any:D $ : --> Str) { ~%!elems.keys }
multi method gist(Any:D $ : --> Str) { "keyset({ %!elems.keys».gist.join(', ') })" }
- multi method perl(Any:D $ : --> Str) { 'KeySet.new(' ~ join(', ', map { .perl }, %!elems.keys) ~ ')' }
+ multi method perl(Any:D $ : --> Str) {
+ self.defined
+ ?? 'KeySet.new(' ~ join(', ', map { .perl }, %!elems.keys) ~ ')'
+ !! "KeySet";
+ }
method iterator() { %!elems.keys.iterator }
method list() { %!elems.keys }
Oops, something went wrong.

0 comments on commit ea06360

Please sign in to comment.