

Task

Define a data type consisting of a fixed number of 'buckets', each containing a nonnegative integer value, which supports operations to:

 get the current value of any bucket
 remove a specified amount from one specified bucket and add it to another, preserving the total of all bucket values, and clamping the transferred amount to ensure the values remain non-negative

In order to exercise this data type, create one set of buckets, and start three concurrent tasks:

 As often as possible, pick two buckets and make their values closer to equal.
 As often as possible, pick two buckets and arbitrarily redistribute their values.
 At whatever rate is convenient, display (by any means) the total value and, optionally, the individual values of each bucket.


The display task need not be explicit; use of e.g. a debugger or trace tool is acceptable provided it is simple to set up to provide the display.


This task is intended as an exercise in atomic operations.   The sum of the bucket values must be preserved even if the two tasks attempt to perform transfers simultaneously, and a straightforward solution is to ensure that at any time, only one transfer is actually occurring — that the transfer operation is atomic.




var bucket
var bucket-size
 
\ The 'bucket' will be a simple array of some values:
: genbucket \ n --
  a:new swap
  (
    \ make a random int up to 1000
    rand-pcg n:abs 1000 n:mod 
    a:push
  ) swap times
  bucket ! ;
 
\ display bucket and its total:
: .bucket 
  bucket lock @ 
    dup . space
    ' n:+ 0 a:reduce . cr
  bucket unlock drop ;
 
\ Get current value of bucket #x
: bucket@ \ n -- bucket[n]
  bucket @
  swap a:@ nip ;
 
\ Transfer x from bucket n to bucket m
: bucket-xfer \ m n x --
  >r bucket @
  \ m n bucket
  over a:@ r@ n:-
  rot swap a:!
  \ m bucket
  over a:@ r> n:+
  rot swap a:!
  drop ;
 
\ Get two random indices to check (ensure they're not the same):
: pick2
  rand-pcg n:abs bucket-size @ n:mod dup >r
  repeat
    drop
    rand-pcg n:abs bucket-size @ n:mod 
    r@ over n:=
  while! 
  r> ;
 
\ Pick two buckets and make them more equal (by a quarter of their difference): 
: make-equal 
  repeat
    pick2
    bucket lock @
    third a:@ >r
    over a:@ r> n:-
    \ if they are equal, do nothing
    dup not if
      \ equal, so do nothing
      drop -rot 2drop
    else
      4 n:/ n:int
      >r -rot r>
      bucket-xfer
    then
    drop
    bucket unlock drop
  again ;
 
\ Moves a quarter of the smaller value from one (random) bucket to another:
: make-redist
  repeat
    pick2 bucket lock @
      \ n m bucket
      over a:@ >r \ n m b b[m]
      third a:@ r>  \ n m b b[n]
      n:min 4 n:/ n:int
      nip bucket-xfer
 
    bucket unlock drop
  again ;
 
: app:main
  \ create 10 buckets with random positive integer values:
  10 genbucket bucket @ a:len bucket-size ! drop
 
  \ print the bucket
  .bucket 
 
  \ the problem's tasks:
  ' make-equal t:task
  ' make-redist t:task
 
  \ the print-the-bucket task. We'll do it just 10 times and then quit:
  ( 1 sleep .bucket ) 10 times
  bye ;