From a010550295d5ef9392e5cc0e60dd120fb0fe79e8 Mon Sep 17 00:00:00 2001
From: Kodi Arfer <hippo@Thoth.(none)>
Date: Thu, 16 Sep 2010 09:14:23 -0400
Subject: [PATCH] Containers galore.

I added the Bag, KeyHash, KeySet, and KeyBag types and modified Set so
that it can pass S02-builtin_data_types/set.t. I also edited
Actions.pm so you can say 'my %h is SomeType', although this only
works for variables with the % sigil, and the type has to be just a
type name, so for now if you want to say 'my %h is KeyHash[Int, 42]'
you have to instead say 'role R does KeyHash[Int, 42]; my %h is R'.

To make it possible to implement KeyHashes, I implemented a crude
means of overloading &infix:<=>: if you say '$c = $v' and the
container of $c has a PMC property "assignment_trapper" with value $t,
then &infix:<=> calls '$t.ASSIGN($v)' instead of the 'setref' opcode.

I spun the weighted-picking logic in Hash off into its own role,
WeightedPick, so Bag could use it. We can reverse this once hashes
permit non-string keys, in which case Bag (along with Set) can be
reimplemented with a hash.

While I was writing a patch, I fixed a bug in Duration.pm that was
exposed when masak++ made the Instant class do Real.
---
 build/Makefile.in       |    4 +-
 docs/ChangeLog          |    2 +
 docs/ROADMAP            |    3 +-
 src/Perl6/Actions.pm    |   12 ++++-
 src/builtins/assign.pir |    8 +++
 src/core/Bag.pm         |   59 +++++++++++++++++++++++++
 src/core/Duration.pm    |    3 -
 src/core/Hash.pm        |  112 ++++++++++++++++++++--------------------------
 src/core/KeyHash.pm     |  104 +++++++++++++++++++++++++++++++++++++++++++
 src/core/Set.pm         |   24 ++++++++--
 t/spectest.data         |    8 +++
 11 files changed, 264 insertions(+), 75 deletions(-)
 create mode 100644 src/core/Bag.pm
 create mode 100644 src/core/KeyHash.pm

diff --git a/build/Makefile.in b/build/Makefile.in
index f86bc9e..5e20f97 100644
--- a/build/Makefile.in
+++ b/build/Makefile.in
@@ -191,7 +191,6 @@ CORE_SOURCES = \
   src/core/Cool-num.pm \
   src/core/Cool-str.pm \
   src/core/List.pm \
-  src/core/Set.pm \
   src/core/Array.pm \
   src/core/Numeric.pm \
   src/core/Real.pm \
@@ -210,6 +209,9 @@ CORE_SOURCES = \
   src/core/Range.pm \
   src/core/EnumMap.pm \
   src/core/Hash.pm \
+  src/core/Set.pm \
+  src/core/Bag.pm \
+  src/core/KeyHash.pm \
   src/core/Enum.pm \
   src/core/IO.pm \
   src/core/IO/ArgFiles.pm \
diff --git a/docs/ChangeLog b/docs/ChangeLog
index 5806310..94eb888 100644
--- a/docs/ChangeLog
+++ b/docs/ChangeLog
@@ -3,6 +3,8 @@
 + Instants and Durations
 + speedup for slurp() and .reverse built-ins
 + various improvements to the Set type
++ add Bag, KeyHash, KeySet, KeyBag, KeyWeight
++ permit setting the implementation type of a %var with 'is' ('my %h is KeyBag')
 + revamp of series operator code, and adaption to new spec
 + implement ...^ up-to-but-excluding-series operator
 + allow :r and :ratchet modifiers on regex quoting constructs
diff --git a/docs/ROADMAP b/docs/ROADMAP
index e6474e1..4913e4f 100644
--- a/docs/ROADMAP
+++ b/docs/ROADMAP
@@ -34,7 +34,7 @@ Ought to have items
 2 **    Rat, BigNum, numification improvements (C, colomon)
 2 ***   temp variables (C)
 2 ****  better longest token matching in regexes (A, D, pmichaud)
-2 ?     other S02 data types -- KeySet, KeyBag (A)
+2 ?     other S02 data types (A)
 2 ?     specialized Unicode bits -- .codes, .graphs, .bytes (A, C)
 
 Nice to have items
@@ -115,3 +115,4 @@ Completed ROADMAP items:
   - true hyper/cross/reverse/other metaoperators
   - synopsis 19 handling
   - other REPL improvements
+  - KeyHash and derivatives
diff --git a/src/Perl6/Actions.pm b/src/Perl6/Actions.pm
index 99f8231..efccf60 100644
--- a/src/Perl6/Actions.pm
+++ b/src/Perl6/Actions.pm
@@ -1049,9 +1049,15 @@ sub declare_variable($/, $past, $sigil, $twigil, $desigilname, $trait_list) {
     else {
         # Not an attribute - need to emit delcaration here.
         # Create the container
-        my $cont := $sigil eq '%' ??
-            PAST::Op.new( :name('&CREATE_HASH_FROM_LOW_LEVEL'), :pasttype('call') ) !!
-            PAST::Op.new( sigiltype($sigil), :pirop('new Ps') );
+        my $cont;
+        if $sigil eq '%' {
+            my $itype := has_compiler_trait($trait_list, '&trait_mod:<is>');
+            $cont := $itype
+               ?? PAST::Op.new(:pasttype('callmethod'), :name('new'), $itype[0])
+               !! PAST::Op.new( :name('&CREATE_HASH_FROM_LOW_LEVEL'), :pasttype('call') );
+        } else {
+            $cont := PAST::Op.new( sigiltype($sigil), :pirop('new Ps') );
+        }
         
         # Give it a 'rw' property unless it's explicitly readonly.
         my $readtype := trait_readtype($trait_list);
diff --git a/src/builtins/assign.pir b/src/builtins/assign.pir
index d462c4c..9963895 100644
--- a/src/builtins/assign.pir
+++ b/src/builtins/assign.pir
@@ -66,6 +66,11 @@ src/builtins/assign.pir - assignment operations
     whence()
 
   scalar_assign:
+    .local pmc trapper
+    trapper = getprop 'assignment_trapper', cont
+    if null trapper goto check_nil_assign
+    goto item_assign
+  check_nil_assign:
     # check for Nil assignment
     $I0 = isa source, ['Nil']
     unless $I0 goto item_assign
@@ -81,6 +86,9 @@ src/builtins/assign.pir - assignment operations
     source = source.'item'()
   have_source:
     source = descalarref source
+    if null trapper goto normal_assignment
+    .tailcall trapper.'ASSIGN'(source)
+  normal_assignment:
     setref cont, source
     .return (cont)
 
diff --git a/src/core/Bag.pm b/src/core/Bag.pm
new file mode 100644
index 0000000..9eff052
--- /dev/null
+++ b/src/core/Bag.pm
@@ -0,0 +1,59 @@
+use v6;
+
+class Bag does Associative does WeightedPick {
+    # We could use a hash here, but right now hash keys coerce to Str,
+    # so instead let's use an array of Pairs for the time being.
+    has @!p;
+
+    multi readonly(@a) { @a }
+    multi readonly($x) { $x }
+
+    multi method new()       { self.bless: * }
+
+    multi method new(@elems) {
+        my @p;
+        for @elems -> $e {
+            if @p.grep(*.key eqv $e)[0] {
+                ++$^p.value;
+            } else {
+                push @p, $e => 1;
+            }
+        }
+        self.bless: *, p => @p;
+    }
+
+    multi method new(*@elems) { self.new: @elems }
+
+    multi method new(Bag $b) { $b }
+
+    multi method new(Set $s) { self.new: $s.keys }
+
+    method !STORE(\$args) {
+        die "Bags are immutable, but you tried to modify one"
+    }
+
+    method at_key($k) { 
+        .key eqv $k and return readonly .value for @!p;
+        0;
+    }
+
+    method keys()     { readonly @!p>>.key }
+    method values()   { readonly @!p>>.value }
+    method pairs()    { readonly @!p }
+    method elems()    { [+] self.values }
+    method exists($k) { ? do self.keys.grep: * eqv $k }
+
+    method Bool()     { ?@!p }
+    method Numeric()  { self.elems }
+    method Str()      { self.perl }
+    method hash()     { @!p.hash }
+    method flat()     { @!p.flat }
+
+    method perl() {
+        'bag(' ~ self.list>>.perl.join(', ') ~ ')';
+    }
+}
+
+our sub bag(*@args) { Bag.new: |@args }
+
+# vim: ft=perl6
diff --git a/src/core/Duration.pm b/src/core/Duration.pm
index 97effe2..3f98ab7 100644
--- a/src/core/Duration.pm
+++ b/src/core/Duration.pm
@@ -30,9 +30,6 @@ our multi sub infix:<+>(Duration $a, Duration $b) {
 our multi sub infix:<->(Duration $a, Real $b) {
     Duration.new: $a.x - $b;
 }
-our multi sub infix:<->(Real $a, Duration $b) {
-    Duration.new: $a - $b.x;
-}
 our multi sub infix:<->(Duration $a, Duration $b) {
     Duration.new: $a.x - $b.x;
 }
diff --git a/src/core/Hash.pm b/src/core/Hash.pm
index b4e135c..1f1661a 100644
--- a/src/core/Hash.pm
+++ b/src/core/Hash.pm
@@ -1,4 +1,52 @@
-role Hash is EnumMap {
+use v6;
+
+role WeightedPick {
+
+    sub weighted-pick(@pairs) {
+        my @weights = [\+] @pairs>>.value;
+        my $value = @weights[*-1].rand;
+        return @pairs[0] if @weights[0] > $value;
+        my ($l, $r) = (0, @weights.end);
+        my $middle = floor ($r + $l) / 2;
+        while $middle > $l {
+            if @weights[$middle] < $value {
+                $l = $middle;
+            }
+            else {
+                 $r = $middle;
+            }
+            $middle = floor ($r + $l) / 2;
+        }
+        @pairs[$r];
+    }
+
+    multi method pick() { weighted-pick(self.pairs).key }
+
+    multi method pick($n is copy) {
+        $n <= 0 and return Nil;
+        my @p = self.pairs>>.clone.grep: *.value;
+        gather {
+            while $n-- && @p {
+                my $pp = weighted-pick @p;
+                take $pp.key;
+                --$pp.value or @p .= grep: {.key !eqv $pp.key};
+            }
+        }
+    }
+
+    multi method pick(Whatever) { self.pick: Inf }
+
+    multi method roll($n is copy = 1) {
+       gather {
+            take self.pick for ^$n;
+       }
+    }
+
+    multi method roll(Whatever) { self.roll: Inf }
+
+}
+
+role Hash is EnumMap does WeightedPick {
     method at_key($key) {
         my $z = Any!butWHENCE(
                     { pir::set__vQsP($!storage, $key, $z); }
@@ -97,68 +145,6 @@ role Hash is EnumMap {
         self.pairs.sort(&by)
     }
 
-    multi method pick($num is copy = 1) {
-        if ($num == 1) {
-            my @weights = [\+] self.values;
-            my $value = @weights[*-1].rand;
-            return self.keys[0] if @weights[0] > $value;
-            my ($l, $r) = (0, @weights.elems-1);
-            my $middle = floor ($r + $l) / 2;
-            while $middle > $l {
-                if @weights[$middle] < $value {
-                    $l = $middle;
-                }
-                else {
-                     $r = $middle;
-                }
-                $middle = floor ($r + $l) / 2;
-            }
-            return self.keys[$r];
-        }
-
-        my %copyHash = @.pairs.grep({ .value != 0});
-        gather {
-            while $num > 0 && %copyHash {
-                take my $picked = %copyHash.pick();
-                unless --%copyHash{$picked} {
-                    %copyHash.delete($picked);
-                }
-                $num--;
-            }
-        }
-    }
-
-    multi method pick(Whatever) {
-        self.pick(Inf);
-    }
-
-    multi method roll($num is copy = 1) {
-        if ($num == 1) {
-            my @weights = [\+] self.values;
-            my $value = @weights[*-1].rand;
-            return self.keys[0] if @weights[0] > $value;
-            my ($l, $r) = (0, @weights.elems-1);
-            my $middle = floor ($r + $l) / 2;
-            while $middle > $l {
-                if @weights[$middle] < $value {
-                    $l = $middle;
-                }
-                else {
-                     $r = $middle;
-                }
-                $middle = floor ($r + $l) / 2;
-            }
-            return self.keys[$r];
-        }
-
-        gather {
-            take self.roll() for ^$num;
-        }
-    }
-
-    multi method roll(Whatever) {
-        self.roll(Inf);
-    }
 }
 
 
diff --git a/src/core/KeyHash.pm b/src/core/KeyHash.pm
new file mode 100644
index 0000000..3374f5d
--- /dev/null
+++ b/src/core/KeyHash.pm
@@ -0,0 +1,104 @@
+use v6;
+
+class KeyHashTrapper {
+
+    has $.kh;
+    has $.key;
+
+    # # This fails with errors that change from run to run—perhaps
+    # # because of a bug in Hash.pm.
+    # method ASSIGN($val) {
+    #     $.kh.okay-val($val)
+    #       ?? ($.kh.Hash::at_key($.key) = $val)
+    #       !! $.kh.Hash::delete($.key);
+    #     $.kh{$.key};
+    # }
+
+    method ASSIGN($val) { Q:PIR {
+        .local pmc self
+        self = find_lex 'self'
+        .local pmc kh
+        kh = getattribute self, '$!kh'
+        .local pmc store
+        store = getattribute kh, '$!storage'
+        .local pmc key
+        key = getattribute self, '$!key'
+        .local pmc val
+        val = find_lex '$val'
+
+        $P0 = kh.'okay-val'(val)
+        if $P0 goto set
+        delete store[key]
+        goto done
+      set:
+        store[key] = val
+      done:
+        %r = kh.'at_key'(key)
+    } }
+
+}
+
+class DefaultDefault {};
+
+role KeyHash[::T = Any, $default = DefaultDefault] does Hash {
+
+    has $!default-value = $default ~~ DefaultDefault
+      ?? do { given T {
+          when Bool       { False }
+          when Num        { 0.Num }
+          when Rat        { 0.Rat }
+          when Numeric    { 0 }
+          when Stringy    { '' }
+          default         { T }
+        } }
+      !! $default;
+
+    method !get($key) { Q:PIR {
+        $P0 = find_lex 'self'
+        $P1 = getattribute $P0, '$!storage'
+        $P0 = find_lex '$key'
+        %r = $P1[$P0]
+    } }
+
+    method at_key($key) {
+        my T $subscript = self.exists($key)
+          ?? self!get: $key
+          !! $!default-value;
+        pir::setprop__vPsP($subscript, 'assignment_trapper',
+            KeyHashTrapper.new: kh => self, :$key);
+        $subscript;
+    }
+
+    method okay-val($v) {
+        $default ~~ DefaultDefault ?? ?$v !! $v !eqv $default
+    }
+
+    method elems() { [+] self.values }    
+
+    method grab(Int $n is copy = 1) {
+        gather {
+            while $n-- && self.keys {
+                take my $picked = self.pick;
+                --self.{$picked} or self.delete: $picked;
+            }
+        }
+    }
+
+    method Numeric() { self.elems }
+
+    method perl() { sprintf 'KeyHash[%s, %s].new(%s)',
+        T.perl,
+        $!default-value.perl,
+        self.pairs.map(*.perl).join(', ')
+    }
+
+}
+
+class KeySet does KeyHash[Bool] { }
+
+class KeyBag does KeyHash[Int] {
+    # Without real UInts, we have to cheat a bit.
+    method okay-val($v) { $v > 0 }
+}
+
+class KeyWeight does KeyHash[Rat] { } # XXX Should be FatRat
diff --git a/src/core/Set.pm b/src/core/Set.pm
index ac3d26e..85e74a0 100644
--- a/src/core/Set.pm
+++ b/src/core/Set.pm
@@ -1,8 +1,13 @@
+use v6;
+
 class Set does Associative {
     # We could use a hash here, but right now hash keys coerce to Str,
     # so instead let's use an array and &uniq for the time being.
     has @!elems;
 
+    multi method new() {
+        self.bless: *;
+    }
     multi method new(@elems) {
         self.bless(self.CREATE, :elems( uniq @elems ));
     }
@@ -16,6 +21,10 @@ class Set does Associative {
         $set;
     }
 
+    method !STORE(\$args) {
+        die 'Sets are immutable, but you tried to modify one'
+    }
+
     sub contains(@array, $value) {
         for @array {
             if $value === $_ {
@@ -25,7 +34,7 @@ class Set does Associative {
         return False;
     }
 
-    method keys() { @!elems }
+    method keys() { { @^readonly-elems }(@!elems) }
     method values() { True xx +@!elems }
     method elems() { +@!elems }
     method exists($elem) { contains(@!elems, $elem) }
@@ -34,9 +43,14 @@ class Set does Associative {
         contains(@!elems, $key);
     }
 
-    method Num() { +self.elems }
     method Bool() { ?self.elems }
-    method hash() { hash @!elems Z=> True xx * }
+    method Numeric() { +self.elems }
+    method Str() { self.perl }
+    method hash() { hash self.flat }
+    method flat() { @!elems Z=> True xx * }
+
+    method pick(*@args) { @!elems.pick: |@args }
+    method roll(*@args) { @!elems.roll: |@args }
 
     multi method union(@otherset) {
         self.new((@!elems, @otherset));
@@ -93,7 +107,7 @@ class Set does Associative {
     }
 
     method perl() {
-        'Set.new(' ~ join(', ', map { .perl }, @!elems) ~ ')';
+        'set(' ~ join(', ', map { .perl }, @!elems) ~ ')';
     }
 }
 
@@ -137,4 +151,6 @@ our multi sub  infix:«(>)»(    %a, %b) { Set.new( %a).superset(%b) }
 our multi sub  infix:«(>)»(    @a, %b) { Set.new(|@a).superset(%b) }
 our multi sub  infix:«(>)»(    @a, @b) { Set.new(|@a).superset(@b) }
 
+our sub set(*@args) { Set.new: |@args }
+
 # vim: ft=perl6
diff --git a/t/spectest.data b/t/spectest.data
index c84a7b0..3bbd41a 100644
--- a/t/spectest.data
+++ b/t/spectest.data
@@ -68,6 +68,7 @@ S02-builtin_data_types/array_extending.t
 S02-builtin_data_types/array_ref.t
 S02-builtin_data_types/array.t
 S02-builtin_data_types/assigning-refs.t
+S02-builtin_data_types/bag.t
 S02-builtin_data_types/bool.t
 S02-builtin_data_types/capture.t
 S02-builtin_data_types/catch_type_cast_mismatch.t
@@ -76,6 +77,11 @@ S02-builtin_data_types/flattening.t
 S02-builtin_data_types/hash_ref.t
 S02-builtin_data_types/hash.t
 S02-builtin_data_types/infinity.t
+S02-builtin_data_types/instants-and-durations.t
+S02-builtin_data_types/keybag.t
+S02-builtin_data_types/keyhash.t
+S02-builtin_data_types/keyset.t
+S02-builtin_data_types/keyweight.t
 S02-builtin_data_types/lists.t
 S02-builtin_data_types/mixed_multi_dimensional.t
 S02-builtin_data_types/multi_dimensional_array.t
@@ -88,6 +94,7 @@ S02-builtin_data_types/pair.t
 S02-builtin_data_types/parcel.t
 S02-builtin_data_types/parsing-bool.t
 S02-builtin_data_types/range.t
+S02-builtin_data_types/set.t
 S02-builtin_data_types/sigils-and-types.t
 S02-builtin_data_types/subscripts_and_context.t
 S02-builtin_data_types/type.t
@@ -596,6 +603,7 @@ S32-str/words.t                                            # icu
 S32-temporal/calendar.t
 S32-temporal/Date.t
 S32-temporal/DateTime.t
+S32-temporal/DateTime-Instant-Duration.t
 S32-trig/e.t
 # S32-trig/pi.t
 S32-trig/sin.t                                             # long
-- 
1.7.0.4