Beefy Boxes and Bandwidth Generously Provided by pair Networks
Syntactic Confectionery Delight
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??
  • This is the same algorithm that JavaFan described (brute force).
  • It tracks water usage, if you want to optimize a solution that way, but that's commented out right now. I suspect that the shortest path solution is always the least water used solution.
  • Call it with a series of numbers on the command line. The first is the target number, and all subsequent numbers are jug capacities.
  • It can handle any number of jugs.
  • I wrote a jug object with Moose, mostly for fun.
  • Formatting courtesy of Perl::Tidy because Yours::Truly wrote some long lines.
  • I waste CPU and memory as if I'm writing in Perl or something.
#!/usr/bin/perl use strict; use warnings; package Jug; use Moose; use List::Util qw( min ); has water => ( is => 'ro', isa => 'Int', default => 0, ); has capacity => ( is => 'ro', isa => 'Int', required => 1, ); sub clone { my $self = shift; return __PACKAGE__->new( water => $self->water, capacity => $self->capacity ); } sub fill { my $self = shift; my $used = $self->capacity - $self->water; $self->{water} = $self->capacity; return $used; } sub empty { shift->{water} = 0 } sub _add { my ( $self, $water ) = @_; my $space = $self->capacity - $self->water; my $used = min $space, $water; $self->{water} += $used; return $used; } sub add_from { my ( $self, $other_jug ) = @_; die 'bad jug' unless $other_jug->isa(__PACKAGE__); $other_jug->{water} -= $self->_add( $other_jug->water ); return 0; } __PACKAGE__->meta->make_immutable; package main; use List::Util qw( first ); $ARGV[0]++; my @paths = ( [ { desc => 'starting state', jugs => [ map { Jug->new( capacity => $_ ) } @ARGV ], used => 0, } ] ); $paths[0][0]{target} = shift @{ $paths[0][0]{jugs} }; $paths[0][0]{strstate} = string_state( $paths[0][0] ); my %seen_states = ( $paths[0][0]{strstate} => 1 ); sub solution { return first { $_->[-1]->{target}->water == $_->[-1]->{target}->capacity - 1; } @paths; } while ( !solution() ) { # @paths = sort { $a->[-1]->{used} <=> $b->[-1]->{used} } @paths; my $p = shift @paths; my $last_state = $p->[-1]; foreach my $next_state ( grep { !$seen_states{ $_->{strstate} }++ +} next_states($last_state) ) { push @paths, [ @{$p}, $next_state ]; } } my @solution = @{ solution() }; my $step = 0; foreach my $state (@solution) { my $strstate = $state->{strstate}; $strstate =~ s{\A(\d+)/\d+}{$1/T}; printf "%03d. [ %s ] %s\n", $step++, $strstate, $state->{desc}; } printf "USED %d units in %d steps\n", $solution[-1]->{used}, $#solutio +n; exit; sub string_state { my $state = shift; return join q{ }, map { $_->water . '/' . $_->capacity } $state->{ +target}, @{ $state->{jugs} }; } sub new_state { my ( $state, $desc ) = @_; return { jugs => [ map { $_->clone } @{ $state->{jugs} } ], target => $state->{target}->clone, used => $state->{used}, desc => $desc }; } sub next_states { my $state = shift; my @out; foreach my $jug_index ( 0 .. $#{ $state->{jugs} } ) { my $jug = $state->{jugs}->[$jug_index]; if ( $jug->water < $jug->capacity ) { my $next = new_state( $state, "fill jug $jug_index" ); $next->{used} += $next->{jugs}->[$jug_index]->fill(); push @out, $next; } if ( $jug->water > 0 ) { my $next; foreach my $other_index ( 0 .. $#{ $state->{jugs} } ) { next if $other_index == $jug_index; $next = new_state( $state, "pour jug $jug_index into jug $other_index" ); my $other = $next->{jugs}->[$other_index]; $other->add_from( $next->{jugs}->[$jug_index] ); push @out, $next; } $next = new_state( $state, "pour jug $jug_index into targe +t" ); $next->{target}->add_from( $next->{jugs}->[$jug_index] ); push @out, $next; $next = new_state( $state, "empty jug $jug_index" ); $next->{jugs}->[$jug_index]->empty(); push @out, $next; } } $_->{strstate} = string_state($_) for @out; return @out; }

Update: After some work last night refactoring this into more objects and other fun stuff, it now can really find least water solutions, but it takes a really long time to do it.

#!/usr/bin/perl use strict; use warnings; use Data::Dumper; package Jug; use Moose; use List::Util qw( min ); has water => ( is => 'ro', isa => 'Int', default => 0, ); has capacity => ( is => 'ro', isa => 'Int', required => 1, ); sub clone { my $self = shift; return __PACKAGE__->new( water => $self->water, capacity => $self->capacity ); } sub fill { my $self = shift; die 'no way to fill infinite jug' if !$self->capacity; my $used = $self->capacity - $self->water; $self->{water} = $self->capacity; return $used; } sub empty { shift->{water} = 0 } sub _add { my ( $self, $water ) = @_; my $space = $self->capacity ? ( $self->capacity - $self->water ) : + $water; my $used = min $space, $water; $self->{water} += $used; return $used; } sub add_from { my ( $self, $other_jug ) = @_; die 'bad jug' unless $other_jug->isa(__PACKAGE__); $other_jug->{water} -= $self->_add( $other_jug->water ); return 0; } __PACKAGE__->meta->make_immutable; package State; use Moose; has desc => ( is => 'ro', isa => 'Str', required => 1 ) +; has jugs => ( is => 'ro', isa => 'ArrayRef[Object]', required => 1 ) +; has target => ( is => 'ro', isa => 'Object', required => 1 ) +; has used => ( is => 'ro', isa => 'Int', default => 0 ) +; sub clone { my $self = shift; return $self->make_next( $self->desc ); } sub make_next { my ( $self, $desc ) = @_; return __PACKAGE__->new( target => $self->target->clone, used => $self->used, jugs => [ map { $_->clone } @{ $self->jugs } ], desc => $desc ); } sub string { my $self = shift; return join q{ }, $self->target->water . '/T', map { $_->water . '/' . $_->capacity } @{ $self->jugs }; } sub next_states { my $self = shift; my @out; foreach my $jug_index ( 0 .. $#{ $self->jugs } ) { my $jug = $self->jugs->[$jug_index]; my $next; if ( $jug->water < $jug->capacity ) { $next = $self->make_next("fill jug $jug_index"); $next->{used} += $next->jugs->[$jug_index]->fill(); push @out, $next; $next = $self->make_next("pour target into jug $jug_index" +); $next->jugs->[$jug_index]->add_from( $next->target ); push @out, $next; } if ( $jug->water > 0 ) { foreach my $other_index ( 0 .. $#{ $self->{jugs} } ) { next if $other_index == $jug_index; $next = $self->make_next( "pour jug $jug_index into jug $other_index"); my $other = $next->jugs->[$other_index]; $other->add_from( $next->jugs->[$jug_index] ); push @out, $next; } $next = $self->make_next("pour jug $jug_index into target" +); $next->{target}->add_from( $next->jugs->[$jug_index] ); push @out, $next; # $next = $self->make_next( "empty jug $jug_ind +ex" ); # $next->jugs->[$jug_index]->empty(); # push @out, $next; } } return @out; } __PACKAGE__->meta->make_immutable; package Path; use Moose; has states => ( is => 'ro', isa => 'ArrayRef[Object]', required => 1 ) +; sub last_state { shift->states->[-1] } sub used { shift->last_state->used() } sub steps { scalar @{ shift->states } } sub states_cloned { map { $_->clone } @{ shift->states }; } sub string { join q{ }, map { $_->string } @{ shift->states }; } sub has_loop { my $self = shift; my %seen; foreach my $state ( @{ $self->states } ) { return 1 if $seen{ $state->string }++; } return 0; } sub extend { my $self = shift; return grep { !$_->has_loop() } map { __PACKAGE__->new( states => [ $self->states_cloned, $_ ] + ) } $self->last_state->next_states(); } __PACKAGE__->meta->make_immutable; package main; use List::Util qw( first ); my $least_water = 1; my $target_water = shift @ARGV; my %seen_paths; my @paths; { my $target_jug = Jug->new( capacity => 0 ); my $start = State->new( desc => 'starting state', jugs => [ map { Jug->new( capacity => $_ ) } @ARGV ], target => $target_jug ); @paths = ( Path->new( states => [$start] ) ); } sub solution { # This sometimes causes a run time "Can't call last_state on undefine +d value" # but the equivalent code doesn't. What's up with that? # return first { $_->last_state->target->water == $target_water } +@paths; foreach my $path (@paths) { return $path if $path->last_state->target->water == $target_wa +ter; } return 0; } while ( !solution() ) { if (0) { printf "paths: %d, steps %d\n", scalar @paths, $paths[0]->step +s; my @h; $h[ $_->steps ]++ for @paths; foreach my $n ( 0 .. $#h ) { # printf "%d: %d\n", $n, $h[$n]||0; } } @paths = sort { $a->used <=> $b->used || $a->steps <=> $b->steps } + @paths if $least_water; my $extend_from = shift @paths; push @paths, grep { !$seen_paths{ $_->string }++ } $extend_from->e +xtend(); } my $solution_path = solution(); my $step = 0; foreach my $state ( @{ $solution_path->states } ) { printf "%03d. [ %s ] %s\n", $step++, $state->string, $state->desc; } printf "USED %d units in %d steps\n", $solution_path->used, $solution_path->steps - 1; exit;

In reply to Re: Challenge: N Jugs Problem by kyle
in thread Challenge: N Jugs Problem by Limbic~Region

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others exploiting the Monastery: (3)
As of 2024-03-28 17:17 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found