use strict ;
use warnings ;

use constant SCALE => 100 ;

use Benchmark qw(timethese) ;

trial(   8, 6, 648768764) ;
trial(  50, 6, 121153645) ;
trial( 100, 6, 121153645) ;
trial(1000, 6, 747254362) ;

my $seed = 329323123 ;

for my $t([   10, 20_000],
          [   20, 10_000], 
          [   50,  5_000],
          [  100,  2_000],
          [  200,  1_000],
          [  500,    200],
          [ 1000,     50],
          [ 2000,     25]) {

  bench($t->[0], 6, $t->[1], $seed * ($t->[0] - 1) / $t->[0]) ;
} ;

sub trial {
  my ($n, $m, $seed) = @_ ;

  my $r_ships = trial_prep($n, $m) ;

  my $rs = new_round_simple($r_ships) ;
  srand $seed ;
  my @round_simple = map next_ship_simple($rs), (1..$n) ;

  $rs = new_round($r_ships) ;
  srand $seed ;
  my @round        = map next_ship($rs),        (1..$n) ;

  trial_check($r_ships, \@round_simple, \@round) ;

  print "trial($n, $m) OK\n" ;
} ;

sub trial_prep {
  my ($n, $m) = @_ ;

  $m = sqrt($m) ;
  my @ships = map { 2** (rand($m) ** 2) ; } (1..$n) ;

  return \@ships ;
} ;

sub trial_check {
  my ($r_ships, $r_round_simple, $r_round) = @_ ;

  my $n = scalar(@$r_ships) ;

  for my $i (0..$n-1) {
    my $s = $r_round_simple->[$i] ;
    if ($s != $r_round->[$i]) {
      die "\$round_simple[$i]=$s != \$round[$i]=$r_round->[$i]" ;
    } ;
    if ($r_ships->[$s]) {
      $r_ships->[$s] = 0 ;
    }
    else {
      die "\$round[$i] = $s (of $n) -- seen already ?" ;
    } ;
  } ;
} ;

our $r_ships ;
our $ns ;
our @round_simple ;
our @round ;
our @seeds ;
our $si ;
our $sis ;

sub bench {
  my ($n, $m, $count, $seed) = @_ ;

  srand $seed ;
  @seeds = map { rand() * $seed ; } (1..$count) ;
  $si = $sis = 0 ;

  $r_ships = trial_prep($n, $m) ;
  $ns = $n ;

  print "_" x 60, "\n" ;
  print "Benchmark $n ships.\n" ;
  timethese($count,
   { "simple"  => sub { my $rs = new_round_simple($r_ships) ;
                        srand $seeds[$sis++] ;
                        @round_simple = map next_ship_simple($rs), (1.
+.$ns) ;
                      },
     "tree  "  => sub { my $rs = new_round($r_ships) ;
                        srand $seeds[$si++] ;
                        @round        = map next_ship($rs),        (1.
+.$ns) ;
                      },
   } ) ;

  trial_check($r_ships, \@round_simple, \@round) ;

  print "bench($n, $m, $count) OK\n" ;
} ;

#=====================================================================
+====================
# "Simple" Round Management
#
# new_round_simple() takes array of ship weights and returns pointer t
+o "object" from
# which ships may be taken, in weighted random order.
#
# next_ship_simple() takes "object" and returns next ship (or undef if
+ none left).
#
# adjust_ship_simple() takes object, ship and weight adjustment and up
+dates ship
# weighting, if possible.  To reduce the weight the adjustment must be
+ -ve (!)
# Returns the adjustment made.  Trying to adjust a ship that's already
+ been processed has
# no effect.  Will not adjust to less than the minimum weight of '1'.
# 
# Ships are identified by simple ordinal, 0..n-1.
#
# Ship weights can be reals, but are converted to "fixed point" by mul
+tiplying by SCALE
# in new_round_simple().  This ensures that all the weight sums are ex
+act, which avoids
# some corner cases.  The array of weights given to new_round_simple()
+ is not changed,
# nor is it affected by adjust_ship_simple.  The scaled weights are fo
+rced to be >= 1.
#
# The "object" is an array:
#
#    Entry: 0: ref:Array of scaled weights, by ship ordinal
#           1: the current total weight
#         2..: the remaining ship ordinals

# NB: the weights given to new_round_simple() are assumed to be +ve (o
+r zero)
#
#     For simplicity this is forcing any weight that scales to 0 to be
+ 1.  Obviously
#     this could be adjusted to leave out any ships whose weight was t
+hat small.
#
#     This will *fail* if given -ve weight(s).  The extra step to forc
+e to 1 or to
#     leave out altogether, is left as an exercise.

sub new_round_simple {
  my ($r_ships) = @_ ;

  my $sum = 0 ;
  my $weights = [map { my $w = int($_ * SCALE) || 1 ; $sum += $w ; $w 
+} @$r_ships] ;

  return [$weights, $sum, 0..$#$r_ships] ;
} ;

sub next_ship_simple {
  my ($r_round) = @_ ;

  my $rnd = int(rand($r_round->[1] || return undef)) ;
  my $r_w = $r_round->[0] ;

  my $i = 1 ;
  0 until (($rnd -= $r_w->[$r_round->[++$i]]) < 0) ;

  my $ship = splice(@$r_round, $i, 1) ;

  $r_round->[1] -= $r_w->[$ship] ;
  $r_w->[$ship] = 0 ;

  return $ship ;
} ;

# NB: adjust_ship_simple() has not been tested

sub adjust_ship_simple {
  my ($r_round, $ship, $adjust) = @_ ;

  my $r_w = $r_round->[0] ;

  if (my $was = $r_w->[$ship]) {
    $adjust = int($adjust * SCALE) ;
    my $now = $was + $adjust ;
    if ($now < 1) { $now = 1 ; $adjust = 1 - $was ; } ;
    $r_w->[$ship] = $now ;
    $r_round->[1] += $adjust ;
  }
  else {
    $adjust = 0 ;
  } ;

  return $adjust ;
} ;

#=====================================================================
+====================
# "Complex" Round Management
#
# This provides the eequivalent functions to the "Simple" scheme:
#
#   round_simple()
#
#   next_ship()
#
#   adjust_ship()
# 
# And all the notes above apply (except for the description of the "ob
+ject").  Indeed,
# given the same state of the rand() seed, this next_ship() gives out 
+ships in the same
# (random) order as next_ship_simple().
#
# The "object" is an array:
#
#    Entry: 0: ref:Array of scaled weights & "leaves" (see below), by 
+ship ordinal
#           1: the current total weight
#         2..: the remaining ship ordinals or sub-sets
#
# Where:
#
#   - a "sub-set" is an array of the same general shape as the root:
#
#    Entry: 0: ref:Array of "parent"
#           1: the current total weight of the sub-set
#         2..: the remaining ship ordinals or sub-sets
#
#   - the scaled weights array is in two parts:
#
#    Entries 0..n-1    are the weights for ships 0..n-1.
#            n..2*n-1  are ref:Array the leaf sub-set in which the res
+pective ship
#                      appear(ed).
#
#    A weight of 0 means that the ship has been processed.  The second
+ part of this
#    array is required for adjust_ship(), but does not otherwise take 
+part in the
#    proceedings.  NB: for 1 level tree, the leaf addresses are undefi
+ned.
#
# So... the "object" is a tree.
#
# If the number of ships is small, then only the root is built, and th
+is is essentially
# the same as the "simple" scheme, except for the overhead of dealing 
+with the potential
# tree-ness.
#
# If the number of ships is large-ish, then a two level tree will be b
+uilt, and the
# process of selecting a ship first selects a sub-set, and then select
+s within the
# sub-set.  There is some overhead associated with updating the weight
+ of the root set,
# and removing sub-sets as they empty out.
#
# If the number of ships is larger, the a deeper tree is built.

# NB: see note on weight processing in new_round_simple().

sub new_round {
  my ($r_ships) = @_ ;

  my $count = scalar(@$r_ships) ;

  # Capture the weights in scaled form

  my $total = 0 ;
  my @weights = map { my $w = int($_ * SCALE) || 1 ; $total += $w ; $w
+ } @$r_ships ;
  $#weights += $count ;           # Space for leaf addresses

  # If count is small, short circuit and generate just the root set
  #
  # This is so that the penalty of using this scheme is as small as po
+sible for
  # small numbers of ships, compared to the "simple" scheme.

  if ($count <= 72) {             # NB: at least 2 * leaf node size be
+low.
    return [\@weights, $total, 0..$count-1] ;
  } ;

  # Now we need a plan for how to build the tree -- we want approximat
+ely even
  # branching factor, up to 24...  at least we think that's what we wa
+nt...
  # We also want ~ 24 entries in each leaf node.
  #
  # Can fiddle around with these numbers, but the running time is not 
+that sensitive
  # to this !

  my $pc = int($count / 24) ;

  my $r = 1 ;
  my $d = $pc ;     # branching factor

  while ($d > 24) { $d = int($pc**(1/++$r)) ; } ;

  my $nl = $d**($r) ;             # number of leaf nodes
  my $cl = int($count / $nl) ;    # count of entries per leaf
  my $cr = $count % $nl ;         # remainder of entries per leaf

  # Construct the leaf nodes

  my @round = (\@weights, $total) ; # For $r == 2 \@round is the answe
+r !

  my $first = 0 ;
  while ($first < $count) {
    my $c    = $cl + ($cr-- > 0 ? 1 : 0) ;
    my $last = $first + $c - 1 ;
    my @leaf = (\@round, 0, $first..$last) ;
    my $sum = 0 ;
    foreach my $s ($first..$last) {
      $sum += $weights[$s] ;
      $weights[$count + $s] = \@leaf ;
    } ;
    $leaf[1] = $sum ;
    push @round, \@leaf ;

    $first += $c ;
  } ;

# if (scalar(@round) != ($nl + 2)) {
#   die "Wrong size \@round -- is ", scalar(@round), ", expected ", $n
+l+2 ;
# } ;

  # Now build the leaves into tree -- already done for 2 level tree

  while (--$r) {
    my @temp = splice(@round, 2) ;    # Transfer nodes to temporary

    while (@temp) {
      my @set = (\@round, 0, splice(@temp, 0, $d)) ;  # Make a new set

      my $sum = 0 ;
      for my $i (2..$#set) {
        $set[$i]->[0] = \@set ;       # rehome each node
        $sum += $set[$i]->[1] ;       # collect weight of nodes
      } ;
      $set[1] = $sum ;

      push @round, \@set ;
    } ;

  # if (scalar(@round) != ($d**$r + 2)) {
  #   die "Wrong size \@round -- is ", scalar(@round), ", expected ", 
+$d**$r + 2 ;
  # } ;
  } ;

  # We're done !

  return \@round ;
} ;

sub next_ship {
  my ($r_round) = @_ ;

  my $r_w  = $r_round->[0] ;
  my $rnd  = int(rand($r_round->[1] || return undef)) ;
  my @rec ;
  my $r ;

  # If required, select leaf.  @rec is stack of parent positions.

  while (ref($r_round->[2])) {
    my $i = 1 ;
    0 until ($rnd -= $r_round->[++$i]->[1]) < 0 ;

    $rec[$r++] = $i ;                    # remember position in parent

    $r_round = $r_round->[$i] ;          # recurse
    $rnd += $r_round->[1] ;              # backtrack
  } ;

  # Now select ship in leaf.

  my $i = 1 ;
  0 until ($rnd -= $r_w->[$r_round->[++$i]]) < 0 ;

  my $ship = splice(@$r_round, $i, 1) ;  # remove from leaf

  # If there are parents, return up the tree updating weights and prun
+ing as required.

  while ($r) {
    $r-- ;
    my $w = $r_round->[1] -= $r_w->[$ship] ; # update local weight
    $r_round = $r_round->[0] ;           # parent
    if ($w == 0) {
      splice(@$r_round, $rec[$r], 1) ;   # discard set if dropped to z
+ero weight
    } ;
  } ;

  # Ready to return ship

  $r_round->[1] -= $r_w->[$ship] ;       # reduce weight of root

  $r_w->[$ship] = 0 ;                    # no longer of interest

  return $ship ;
} ;

# NB: adjust_ship() has not been tested

sub adjust_ship {
  my ($r_round, $ship, $adjust) = @_ ;

  my $r_w = $r_round->[0] ;
  my $off = scalar(@$r_w) / 2 ;

  if (my $was = $r_w->[$ship]) {
    $adjust = int($adjust * SCALE) ;
    my $now = $was + $adjust ;
    if ($now < 1) { $now = 1 ; $adjust = 1 - $was ; } ;
    $r_w->[$ship] = $now ;

    my $r_set = $r_w->[$off + $ship] || $r_round ;

    do {
      $r_set->[1] += $adjust ;
      $r_set = $r_set->[0] ;
    } until ($r_set == $r_w) ;
  }
  else {
    $adjust = 0 ;
  } ;

  return $adjust ;
} ;
[download]