CGI/Perl Guide | Learning Center | Forums | Advertise | Login
Site Search: in

  Main Index MAIN
INDEX
Search Posts SEARCH
POSTS
Who's Online WHO'S
ONLINE
Log in LOG
IN

Home: Fun With Perl: Perl Quizzes - Learn Perl the Fun Way:
Cool Perl

 



Zhris
Enthusiast

Sep 21, 2013, 2:52 PM

Post #1 of 13 (159428 views)
Cool Perl Can't Post

Hi all,

I thought I would create a thread where gurus can share any cool / useful Perlish knowledge or snippets of code that others may be particularly interested in, then maybe discuss. This appears to be the most suitable topic this type of thread should exist in.

Feel free to input. Heres one to begin...

I often need to perform a substitution but want to preserve the original string. I used to copy the string into a new variable, then perform the substitution on that:


Code
use strict; 

my $str = 'hello world';
my $newstr = $str;
$newstr =~ s/o/u/g;

print $newstr;


But found this approach to be cleaner:


Code
use strict; 

my $str = 'hello world';
( my $newstr = $str ) =~ s/o/u/g;
print $newstr;


Regards,

Chris


BillKSmith
Veteran

Sep 21, 2013, 9:00 PM

Post #2 of 13 (159423 views)
Re: [Zhris] Cool Perl [In reply to] Can't Post

New versions of perl do even better.

Code
use strict; 
use warnings;
use 5.14.0;
my $str = 'hello world';
print $str =~ s/o/u/gr;

Good Luck,
Bill


Zhris
Enthusiast

Sep 22, 2013, 1:21 AM

Post #3 of 13 (159421 views)
Re: [BillKSmith] Cool Perl [In reply to] Can't Post

Thats very nice Bill, I'll remember that.

Heres another little snippet:


Code
map(($r=$_,map(($y=$r-$_/3,$l[24-$r] 
.=(' ','@')[$y**2-20*$y+($_**2)/3<0]),(0..30)),),(0..24));
print join("\n", map(reverse($_).$_, @l)), "\n";


Chris


BillKSmith
Veteran

Sep 23, 2013, 1:01 PM

Post #4 of 13 (159410 views)
Re: [Zhris] Cool Perl [In reply to] Can't Post

Oh, my head hurts from reading this one. All the real work is done as a side effect of map. I rewrote it to make it as clear as I possibly could. You are not interested in that. After all, this is the neat trick department. The following code generates the same output as yours. The graphics should be very clear. The math part is implemented as a family of anonymous subroutines (one for each row).


Code
use strict; 
use warnings;
use Readonly;
Readonly::Scalar my $AT => q(@);
Readonly::Scalar my $SPACE => q( );
for my $row (0..24) {
my $curve = select_curve($row);
my $line;
$line .= $curve->($_) < 0 ? $AT : $SPACE for (0..30) ;
print scalar reverse($line), $line, "\n";
}

sub select_curve {
my ($row) = @_;
return sub {
my ($col) = @_;
my $x = 24 - $row - $col / 3;
return $x**2 - 20 * $x + ( $col**2 ) / 3;
}
}

Good Luck,
Bill


Zhris
Enthusiast

Sep 24, 2013, 8:53 AM

Post #5 of 13 (159397 views)
Re: [BillKSmith] Cool Perl [In reply to] Can't Post

I admit that I didn't write the original snippet, but rather found it deep in the web a while back. I never took the time to fully understand how it worked, but have a considerably clearer idea since reading your rework. The original writer must have had headaches whilst designing the "curve" calculations, unless of course it is based on a widely established algorithm of some sort:


Code
my $x = 24 - $row - $col / 3;  
return $x**2 - 20 * $x + ( $col**2 ) / 3;


I'm interested in your coderef approach. Initially, it appears you forgot to refactor this part. However I think it may be more efficient since it only needs to interpolate $row once per row (25 times) and not per row/col (24 * 31 times)? My "refactored" version below will help to explain what I mean:


Code
use strict; 
use warnings;
use Readonly;
Readonly::Scalar my $AT => q(@);
Readonly::Scalar my $SPACE => q( );

for my $row (0..24) {
my $line;
$line .= select_curve($row, $_) < 0 ? $AT : $SPACE for (0..30) ;
print scalar reverse($line), $line, "\n";
}

sub select_curve {
my ($row, $col) = @_;
my $x = 24 - $row - $col / 3;
return $x**2 - 20 * $x + $col**2 / 3;
}


Chris


(This post was edited by Zhris on Sep 24, 2013, 8:59 AM)


BillKSmith
Veteran

Sep 24, 2013, 12:17 PM

Post #6 of 13 (159385 views)
Re: [Zhris] Cool Perl [In reply to] Can't Post

It should not be any surprise that your solution is the same as the one I chose not to post. It has one function of two variables (row and column).

In the approach that I did post, there is a different function for every row. Each of those functions is a simple quadratic function of one variable (column) only. Note: Once per row, the value of the variable $row is interpolated into the string which becomes the anonymous function of column for that row. The variable $row does not appear in the inner loop in any way!

In the real world, I would prefer your solution.


Your comments about the design of the equations are certainly true. I suspect that they are arranged to obscure the underlying design (much the same way the code was). I no longer remember enough analytic geometry (conic sections) to be much help.
Good Luck,
Bill


Zhris
Enthusiast

Sep 27, 2013, 1:18 PM

Post #7 of 13 (159340 views)
Re: [BillKSmith] Cool Perl [In reply to] Can't Post

It would be very cool if there was a pattern to the geometric equations making it easy to draw different shapes. Though I could have typed that heart a lot quicker than I could have programmed it. Inevitably, i'll stick to graphics modules for my drawing needs.

Heres another piece of code I wrote a while back, in its rough state. Its ultimately a blackjack / pontoon algorithm, which takes a list of cards and returns a string identifying the best hand. The main difficulty was that ace can be 1 or 11.

Possible hands:

Code
- The best hand of all is a Pontoon, which is 21 points in two cards - this can only consist of ace plus a picture card or ten. 
- Next best after a Pontoon is a Five Card Trick, which is a hand of five cards totaling 21 or less.
- A hand of three or four cards worth 21 points beats everything else except a Pontoon or Five Card Trick.
- Hands with 20 or fewer points and fewer than five cards rank in order of their point value - the nearer to 21 the better.
- Hands with more than 21 points are bust and are worthless.


main.pl

Code
#!/usr/bin/perl 
use strict;
use warnings FATAL => qw/all/;
use Data::Dumper;

our $deck =
{
'2H' => [2] ,
'3H' => [3] ,
'4H' => [4] ,
'5H' => [5] ,
'6H' => [6] ,
'7H' => [7] ,
'8H' => [8] ,
'9H' => [9] ,
'10H' => [10] ,
'JH' => [10] ,
'QH' => [10] ,
'KH' => [10] ,
'AH' => [1,11] ,
'2D' => [2] ,
'3D' => [3] ,
'4D' => [4] ,
'5D' => [5] ,
'6D' => [6] ,
'7D' => [7] ,
'8D' => [8] ,
'9D' => [9] ,
'10D' => [10] ,
'JD' => [10] ,
'QD' => [10] ,
'KD' => [10] ,
'AD' => [1,11] ,
'2S' => [2] ,
'3S' => [3] ,
'4S' => [4] ,
'5S' => [5] ,
'6S' => [6] ,
'7S' => [7] ,
'8S' => [8] ,
'9S' => [9] ,
'10S' => [10] ,
'JS' => [10] ,
'QS' => [10] ,
'KS' => [10] ,
'AS' => [1,11] ,
'2C' => [2] ,
'3C' => [3] ,
'4C' => [4] ,
'5C' => [5] ,
'6C' => [6] ,
'7C' => [7] ,
'8C' => [8] ,
'9C' => [9] ,
'10C' => [10] ,
'JC' => [10] ,
'QC' => [10] ,
'KC' => [10] ,
'AC' => [1,11] ,
};

my $total;
print Dumper pontoon(['AH', 'KC'], \$total), $total;

sub pontoon
{
my ($hand, $total) = @_;

return 'nohand' if (!@$hand);
#return 'ok' if (@$hand == 1); # can only be ok if 1 card in hand. No total here yet though.

($$total) = sort { $b <=> $a } # order highest total first
grep { $_ <= 21 } # filter totals less than 22
map { list_total($_) } @{sequences($hand)}; # convert list to total of elements

return 'bust' if (!$$total);
return 'fivecard' if (@$hand > 4);
return 'pontoon' if (@$hand == 2 && $$total == 21);
return 'twentyone' if ($$total == 21);
return 'ok';
}

# sequences could be more efficient when no sequences yet and/or only 1 value.
sub sequences
{
my ($hand) = @_;

return () unless @$hand;

my @sequences = ([]);

foreach my $card (@$hand)
{
my $values = $deck->{$card};

my @sequences_new;

foreach my $value (@$values)
{
my @sequences_copy = map { [@$_] } @sequences; # deep copy sequences

push @$_, $value foreach (@sequences_copy);

push @sequences_new, @sequences_copy;
}

@sequences = @sequences_new;
}

return \@sequences;
}

sub list_total
{
my ($list) = @_;

my $total;
$total += $_ foreach (@$list);

return $total;
}


I plan on eventually using the algorithm to replicate the fun single player game Target 21 ( http://www.youtube.com/watch?v=s4n-A_jMcOo ).

Chris


(This post was edited by Zhris on Sep 27, 2013, 2:05 PM)


Laurent_R
Veteran / Moderator

Sep 28, 2013, 8:30 AM

Post #8 of 13 (159318 views)
Re: [Zhris] Cool Perl [In reply to] Can't Post

Hmm, not sure I understand everything to your game and its rules, but it seems to me that you don't particularly care whether your ace or king or whatever is hearts, diamonds, clubs or spades. So I would think your initial hash ref could be made much simpler, not taking into account the card suit.


Zhris
Enthusiast

Sep 28, 2013, 6:21 PM

Post #9 of 13 (159311 views)
Re: [Laurent_R] Cool Perl [In reply to] Can't Post

Remember its mostly just an algorithm, not a game yet, the rules for blackjack can be found http://en.wikipedia.org/wiki/Blackjack. Theres also a couple of Perl nasties in there too, i.e. inappropriate global var, it will eventually be written in OOP. Although in blackjack the suit (hearts, diamonds, clubs, spades) doesn't particularly matter, i'll eventually need to keep track of all fifty two cards, assigning them to columns / piles. The suit will be important when displaying the appropriate image. I could even put my own twist on the game, i.e. set 4H => [0], therefore making it a special card that will only serve me in achieving a five card trick. I thought it would be best to jump straight into passing a "list of card keys" as oppose to a "list of list of values" to the entry function.


(This post was edited by Zhris on Sep 28, 2013, 8:00 PM)


Laurent_R
Veteran / Moderator

Sep 29, 2013, 9:05 AM

Post #10 of 13 (159293 views)
Re: [Zhris] Cool Perl [In reply to] Can't Post

Allright, I get your point, you want to make it more general than the pure Blackjack rules. Still, you could perhaps do something shorter to initialize your %deck hash table such as:


Code
for my $suit ('H', 'S', 'C', 'D') {  
$deck{"$_$suit"} = [$_] for 2..9;
$deck{"$_$suit"} = [10] for qw (K Q J);
$deck{"A$suit"} = [1, 10]};
}



Zhris
Enthusiast

Sep 29, 2013, 9:50 AM

Post #11 of 13 (159290 views)
Re: [Laurent_R] Cool Perl [In reply to] Can't Post

Thanks alot for the rough snippet Laurent, I will use that to initialize the default deck.


FishMonger
Veteran / Moderator

Sep 29, 2013, 10:09 AM

Post #12 of 13 (159287 views)
Re: [Zhris] Cool Perl [In reply to] Can't Post


Quote
I thought I would create a thread where gurus can share any cool / useful Perlish knowledge or snippets of code that others may be particularly interested in, then maybe discuss.


Wouldn't the "Perl Poetry" topic area be a better place for these types of posts?

I think your second post would be very suitable for your original intent but the other stuff would be better suited for the Beginner or Intermediate areas.

I like your original idea, but I think it can easily morph into nothing more than a duplication of the Beginner or Intermediate areas.


Zhris
Enthusiast

Sep 29, 2013, 11:31 AM

Post #13 of 13 (159281 views)
Re: [FishMonger] Cool Perl [In reply to] Can't Post

Hi Fishmonger,

You have made some very good points.

Unfortunately the forum doesn't have the right topic for this type of thread. Perl Poetry does certainly look more suitable for my second post atleast. The beginners and intermediate forums are generally set apart for users who have a problem and need a solution. I still don't think there is a suitable topic for my true intention.

Usually any discussions we have stem off an OP's original problem. My true intention was to create a thread where we can share some code, preferably something snazzy or currently working on, then discuss away (something more interesting than take this input data and produce this output data). I love to discuss Perl, after all its my number one hobby! I have actually shared code before (here and other forums), but have received no responses or the assumption I needed help with it.

The three snippets of code I posted are very unique / individual. I'm definitely trying to encompass too much variety under a single thread. It might be time to discontinue and possibly consider creating more specific threads as and when.

Chris


(This post was edited by Zhris on Sep 29, 2013, 11:40 AM)

 
 


Search for (options) Powered by Gossamer Forum v.1.2.0

Web Applications & Managed Hosting Powered by Gossamer Threads
Visit our Mailing List Archives