Beefy Boxes and Bandwidth Generously Provided by pair Networks
P is for Practical

Cool Uses for Perl

by gods
on Dec 07, 1999 at 23:20 UTC ( #1044=superdoc: print w/replies, xml ) Need Help??

This section is the place to post your general code offerings -- everything from one-liners to full-blown frameworks and apps.

EDI File Parsing Helps
No replies — Read more | Post response
by GotToBTru
on Sep 21, 2016 at 13:13

    Decompose ANSI X12 transmission into individual documents.

    use strict; use warnings; use Data::Dumper; my $ediFile = shift; my ($contents,$delim,$term,$txnCount,@transactions); { $/ = undef; open my $ifh,'<',$ediFile; $contents = <$ifh>; } ($delim,$term) = $contents =~ m/^ISA(.).{101}(.)/; $delim = quotemeta($delim); @transactions = $contents =~ m/(ST$delim.+?SE$delim\d+$delim\d+$term)/ +gs; ($txnCount) = $contents =~ m/${term}GE$delim(\d+)/; die "Parse error - transaction counts wrong" if ($txnCount != scalar @transactions); foreach my $transaction (@transactions) { # put into useful form for processing my @segments = split /$term/,$transaction; my ($segCount) = $transaction =~ m/${term}SE$delim(\d+)/; die "Parse error - segment counts wrong" if ($segCount != scalar @segments); my ($process_this); map { push @$process_this, [split /$delim/,$_] } @segments; print Dumper(\$process_this); }

    EDI File:

    ISA*00* *00* *02*AAAA *01*123456789 * +160921*0751*U*00401*0 00099836*0*P*:~GS*FA*AAAA*123456789*20160921*0751*99836*X*004010~ST*99 +7*998360001~AK1*SM*73 11~AK9*A*1*1*1~SE*4*998360001~ST*997*998360002~AK1*SM*7312~AK9*A*1*1*1 +~SE*4*998360002~GE*2* 99836~IEA*1*000099836~


    $VAR1 = \[ [ 'ST', '997', '998360001' ], [ 'AK1', 'SM', '7311' ], [ 'AK9', 'A', '1', '1', '1' ], [ 'SE', '4', '998360001' ] ]; $VAR1 = \[ [ 'ST', '997', '998360002' ], [ 'AK1', 'SM', '7312' ], [ 'AK9', 'A', '1', '1', '1' ], [ 'SE', '4', '998360002' ] ];
    But God demonstrates His own love toward us, in that while we were yet sinners, Christ died for us. Romans 5:8 (NASB)

extract (a range of) numbered lines from a file
4 direct replies — Read more / Contribute
by shmem
on Sep 19, 2016 at 16:49

    Ever wanted to get a range of lines extracted from some file? Easy: load into editor, highlight lines, copy (usually Ctrl<c>), go to target, paste (usually Ctrl<v>).

    You want to do that from the command line? With UNIX/Linux you have some options, combining the output of wc -l with head and tail.
    You could also combine sed and awk (TIMTOWTDI applies):

    sed -e '10,15p;4p;s/.*//' file | awk '!/^$/{print $0}' somefile

    I'm not aware of Windows tools to do this task.
    But anyways, this is unwieldy, specially if you want to read piped input into your editor of choice calling an external command.
    Perl to the rescue:

    #!/usr/bin/perl -n my $usage; BEGIN { $usage = "usage: $0 linespec file\n" . "linespec example: 2,5,32-42,4\n" . "this extracts lines 2,4,5 and 32 to 42 from file\n"; $spec=shift; die $usage unless $spec; @l=split/,/,$spec; for(@l){ ($s,$e)=split/-/; $e||=$s; $_=[$s,$e]; } } CHECK { unless(@ARGV) { push @ARGV, <DATA>; chomp @ARGV; } die $usage unless @ARGV; $file = $ARGV[0]; } # === loop ==== for $l(@l){ print if $.>=$l->[0] and $.<=$l->[1] } # === end === # END { if ($file) { open $fh,'<', $0; @lines = <$fh>; close $fh; open $fh,'>',$0; for(@lines){ print $fh $_; last if /^__DATA__$/; } print $fh $file,"\n"; } } __DATA__

    Above script, concisely named l (or e.g. lines if that one-letter identifier is already taken) and stored somewhere in any of your private $PATH locations, allows you to e.g. in vi

    : r ! l 11-13,42,125-234 somefile

    and have the specified lines from somefile read into your current buffer after the line of your cursor.
    To do the same with emacs, ask LanX, he knows the proper Ctrl-Shift-Meta-Alt-X encantations to do so.
    This code is self-modifying: it places the filename it is invoked upon after the __DATA__ token, so if you want to include more lines of the same file, it suffices to say

    : r ! l 1234-1500

    For that reason this piece of cr.. code is strictly personal and not suitable to be installed system-wide.

    perl -le'print map{pack c,($-++?1:13)+ord}split//,ESEL'
XML::Parser Namespace example
No replies — Read more | Post response
by GotToBTru
on Aug 31, 2016 at 11:57

    We use an application at $work that uses XML internally for everything. The applications that feed it often wrap the files into a single line, which is a nuisance. vi won't display them, and grep will return the entire file on any match. I've created the code below, based almost entirely on sample code from others, to extract some key information from files.

    The first interation (everything below except line 13) worked great until I encountered the namespace prefixes. It didn't take long to find out the solution, but I did not see it implemented in actual code. I guess everybody else thought it was obvious! The Namespaces => 1 in the constructor tells the parser to pull the namespace prefixes from the tag names (they are stored elsewhere), and for my simple example, that's all I need.

    Program notes: %interesting is the list of tags the parser will store as it parses the file. The values are stored in the hash %message with the tag as key. In my end handler, I choose a subset of tags based on the document type to display.

    #!/home/edi/perl/perl use strict; use warnings; use XML::Parser; my $parser = new XML::Parser( Handlers => { Start => \&hdl_start, End => \&hdl_end, Char => \&hdl_char, Default => \&hdl_def, }, Namespaces => 1); my (%message,$element); my %interesting = map { $_, 1 } qw/shipmentStatus responseToLoadTender customerIdentifier proNum lo +adTenderId eventType eventDate eventTime city seqnum customerId segme +ntId action date/; my $file = shift; $message{file} = $file; $parser->parsefile($file); #print "Placeholder\n"; sub hdl_start { my ($p,$elt,%attr) = @_; $element = $elt; } sub hdl_end { my ($p, $elt) = @_; return unless $interesting{$elt}; if ($elt eq 'shipmentStatus') { if ($message{eventType} !~ m/X6/ ) { printf "%-20s: %s\n", $_, $message{$_} for qw/file proNum loadTenderId city seqnum eventType eventDate + eventTime/; print "\n"; } } if ($elt eq 'responseToLoadTender') { printf "%-20s: %s\n", $_, $message{$_} for qw/file segmentId loadTenderId action date/; print "\n"; } } sub hdl_char { my ($p, $str) = @_; return unless $interesting{$element}; $message{$element} .= $str; } sub hdl_def {}
    But God demonstrates His own love toward us, in that while we were yet sinners, Christ died for us. Romans 5:8 (NASB)

Battleship solitaire puzzle generator
1 direct reply — Read more / Contribute
by toolic
on Aug 29, 2016 at 15:11


    This is a battleship solitaire puzzle generator. It creates a puzzle grid with a random number of clues. It also can display the corresponding puzzle solution. The solution has 10 ships on a 10x10 grid.


    Mostly because I felt like it. Also because I could not find anything that already existed online to easily do exactly what I wanted. There are some puzzle generators available which have GUI's with nice features, but they limit you to one puzzle per week (or month, or whatever), and it is difficult to annotate hard puzzles on the screen. This generator allows you to play as many puzzles as you want and to print them on paper to make annotations.


    Run the generator and redirect the output to a file. You can edit the file and fill in the ships directly in your editor. Or, you can print the file onto a piece of paper. Alternately, you could redirect the CSV output to a file, then use the conversion script to create an Excel file. Then you can complete the puzzle in Excel or print the Excel file onto paper.


    Consider this alpha code. Since I did not create any tests to automatically check the code, there are likely bugs. The approach is probably naive, and the ASCII representation is ugly. Any suggestions for improvements are welcome.

    Code for generator

    Code for Excel conversion

redirecting Molicious app to https
No replies — Read more | Post response
by Ea
on Aug 25, 2016 at 10:03
    (Quick post)

    Searched the fine web and didn't find a quick answer to how to redirect an http request to https in Mojolicious. I wanted to insure that logins were always secure. Finally cobbled together a solution and thought I should share and maybe get some improvements.

    1. Run 2 webservers: one to handle http and the other to handle https, which for me is two incantations of hypnotoad
    2. Add a route in your http App
    3. Add a sub to the http Controller
      sub https_redirect { my $self = shift; my $secure = $self->req->url->to_abs->scheme('https')->port(443); $self->redirect_to($secure); }
    4. Profit!

    All the sub does is redirect the request to the new protocol at the same url. I've seen a method in the docs to a is_secure method which could be useful somewhere. Also, I tried using $r->any('/login'), but it doesn't work for me and I'm moving on.

    Yes, I probably could've gotten a better answer inside 2 minutes on IRC (people are so very helpful), but it never occurs to me until afterwards.

    Sometimes I can think of 6 impossible LDAP attributes before breakfast. It's that time of year again!

Displaying my PM post count and XP on an LCD with RPi::WiringPi
2 direct replies — Read more / Contribute
by stevieb
on Aug 24, 2016 at 20:50

    Well, I've finally released RPi::WiringPi. This uses the WiringPi::API wrapper that wraps the C-based wiringPi Raspberry Pi hacking software.

    Anyway, I thought I'd throw something together that's kind of silly to play around with it. A couple of points: a) I know this isn't the proper way to web-scrape, it's just an example ;) b) forgive the global variables. The interrupt code in wiringPi library does not allow you to pass in any parameters, so until I submit a possible patch, globals are all I have. This was not meant to be prod code :D

    The following code, infinitely looping every 60 seconds, scrapes my number of posts and XP from PerlMonks (in a *very* crude way), collects up the current time, then prints the data out onto an LCD display attached to my Pi:

    p: 1293 18:15 x: 10361

    Number of posts and then the time on the top line, XP on the bottom.

    We introduce a button connected to a pin, when pressed, triggers an interrupt, and the interrupt handler rewrites the bottom line with the amount of XP remaining until my next PM level, instead of current XP (changes from x: 10361 to r: 1638. Every button press flips this back and forth.

    Pics: before button press, and after button press.

    use warnings; use strict; use LWP::Simple; use RPi::WiringPi; use RPi::WiringPi::Constant qw(:all); # catch a sigint. This allows us to # safely exit the while() loop and perform # emergency LCD/pin cleanup. The main class # catches die() my $continue = 1; $SIG{INT} = sub { $continue = 0; }; # initialize a Raspberry Pi object using the # BCM GPIO pin numbering scheme my $pi = RPi::WiringPi->new(setup => 'gpio'); # prepare and initialize the LCD my $lcd = $pi->lcd; # the following list of args looks daunting, but # it's very straightforward, and the docs are # pretty clear my %args = ( cols => 16, rows => 2, bits => 4, rs => 21, strb => 16, d0 => 12, d1 => 25, d2 => 24, d3 => 23, d4 => 0, d5 => 0, d6 => 0, d7 => 0, ); $lcd->init(%args); # set up a pin with a button, and set an # interrupt handler to do something when # the button is pressed my $button_pin = $pi->pin(26); # we're going to interrupt when the pin # goes LOW (off), so we'll pull it HIGH # with the built-in pull up resistor. # only when the button is pressed, will the # pin briefly go LOW, and this triggers # an interrupt $button_pin->pull(PUD_UP); # the second arg to interrupt_set() is the # name of the perl sub I've defined below # that I want handling the interrupt $button_pin->interrupt_set( EDGE_FALLING, 'button_press' ); my $button_presses = 0; my ($posts, $xp, $next); while ($continue){ my ( $sec,$min,$hour,$mday,$mon, $year,$wday,$yday,$isdst ) = localtime(); $min = "0$min" if length $min == 1; # get my post and xp count from PM ($posts, $xp) = perlmonks(); # manually get xp needed for next level $next = 12000 - $xp; # set the LCD cursor to top row, first # column, and print my num of PM posts $lcd->position(0, 0); $lcd->print("p: $posts"); # sub for bottom line, because the # code needs to be called also in our # interrupt handler. What's printed depends # on the cumulative number of button presses display_xp(); # on top row of the LCD at column 12, # we print the time $lcd->position(11, 0); $lcd->print("$hour:$min"); print "$hour:$min posts: $posts, " . "xp: $xp, next lvl: $next\n"; # rinse, repeat every minute sleep 60; } # wipe the LCD clean $lcd->clear; # reset pins to default state $pi->cleanup; sub button_press { # this is the interrupt handler print "button pressed\n"; $button_presses++; display_xp(); } sub display_xp { # this is the manager for the bottom LCD # row. It'll update things even when the # main program is sleeping in the while() # loop # print XP for 0 and even number of button # presses, and print XP remaining to next level # on odd number of presses $lcd->position(0, 1); if ($button_presses % 2){ $lcd->print("r: $next"); } else { $lcd->print("x: $xp"); } } sub perlmonks { my $url = ""; my $page = get $url; my @content = split /\n/, $page; my ($xp, $posts); my $i = 0; for (@content){ if (/Experience:/){ my $line = $i; $line += 2; $xp = $1 if $content[$line] =~ /(\d+)/; } if (/Writeups:/){ my $line = $i; $line += 2; $posts = $1 if $content[$line] =~ />(\d+)/; } $i++; } return ($posts, $xp); }

    Here's the code without all of the comments....

Raspberry Pi wiringPi API wrapper released
1 direct reply — Read more / Contribute
by stevieb
on Aug 16, 2016 at 15:06

    I was going to hold off on announcing my new WiringPi::API distribution until my larger project that depends on it is done, but since it's CPAN day, well...

    The module wraps the majority of documented and undocumented functions in wiringPi.

    wiringPi is a set of C libraries that allow you to muck with a Raspberry Pi, it's GPIO pins, drive LCDs and many other things.

    You can import the C functions directly keeping their original names as is:

    use WiringPi::API qw(:wiringPi);
    ...import the renamed Perl functions:
    use WiringPi::API qw(:perl);
    ...or use the module in the normal OO way:
    use WiringPi::API; my $wpi = WiringPi::API->new;

    Here's but a few of the features:

    • get Pi board revision
    • do conversions for the three pin numbering schemes (wiringPi, BCM and physical)
    • change pin modes and state
    • enable/disable internal pin pull-up/down resistors
    • utilize Pulse Width Modulation (PWM) on a per-pin basis
    • set/unset pin interrupts for EDGE_FALLING, EDGE_RISING and EDGE_BOTH events. These interrupts are run in separate C threads, and call back to a user defined Perl sub as the handler
    • initialize, manipulate and write data to external LCD screens (useful for sensor data, warnings etc)

    My larger project, RPi::WiringPi, which is currently in feature-freeze to give me time to finish unit tests and documentation, will take that much further, and make it much easier to do things. It should hit v1.00 (stable) within the next week. At that time, I'll make another announcement... I do have an initial basic howto written so far that covers some of the basics. Note that this distribution may not be stable until v1.00 is released.

    This was also posted here.

Elasticsearch and ntopng
1 direct reply — Read more / Contribute
by QuillMeantTen
on Aug 11, 2016 at 13:49

    During my internship I had to set up a network probe. They basically gave me root on a server with three network interfaces and 0 budget.
    I set up the following solution:

    1. Ntopng did the monitoring
    2. Elasticsearch retained ntopng logs for easy retrieval and analysis (one month were retained given the number of flows)
    3. Kibana was used for visualisation
    My orders were quite simple, they needed a network probe that would "just work", they needed a nice way to display the probe's data on any computer inside the department AND on the nice big screen in the IT den.

    Once the setup and the documentation was done I started writing a script to automate as many thing as I could. Namely database export, backup and restoration, service monitoring, interface monitoring (I spent a day wondering WHY an interface would go down by itself until someone told me that a maintenance crew did some voodoo on the routers and unplugged things) and such.
    So here is the code, I hope it will be useful to you, since I had most of en ELK stack there (except for the Logstash part) this script should be easily adapted to other situations.

Solution to A simple but difficult arithmetic puzzle
4 direct replies — Read more / Contribute
by talexb
on Aug 11, 2016 at 03:16

    From mjd's post A simple but difficult arithmetic puzzle, I present my solution.

    I ran this script and piped to output through egrep '17$' which gave me the answer (well, the four different arrangements of the answer that are mathematically equivalent). I won't reveal the solution to the puzzle, but suffice to say it's one of those solutions where you go, "Oh, right", but it's difficult enough that unlikely you'd come up with it quickly.

    Thanks mjd!

    Alex / talexb / Toronto

    Thanks PJ. We owe you so much. Groklaw -- RIP -- 2003 to 2013.

Get excel column letter from number
5 direct replies — Read more / Contribute
by bulrush
on Jul 26, 2016 at 06:33

    I found several chunks of code on the internet which were supposed to convert a 0-based column number in Excel to a letter, but I could get none of them to work with a value above 25. So here's the code I got working, for everyone's use. Enjoy.

    ###################################################################### # 7/25/2016 # In: Column index, 0-n. # Out: Letter(s) representing column in Excel. 0=A, 1=B, 25=Z, 26=AA.. +. # # Inspired by +get-the-excel-like-column-name-of-a-number # 7/25/2016 WORKS! sub excelpos2ltr {my($oldcol)=@_; # Col starts at 0='A' my($procname,$numeric,$ltr,$num2,$outs); $procname="excelpos2ltr"; # Alt method 4. $numeric = $oldcol % 26; $ltr = chr(65 + $numeric); #$num2 = intval($oldcol / 26); # old line $num2 = int($oldcol / 26); if ($num2 > 0) { $outs=excelpos2ltr($num2 - 1) . $ltr; } else { $outs=$ltr; } return $outs; }

    If you found any problems please put the code fix as a comment below.

Perl 6 SDL2 game
No replies — Read more | Post response
by holyghost
on Jul 25, 2016 at 02:04
    I need to have something to make a buffer for C32 byte arrays. This is for the SDL2 texture. I choose an Xpm file, as it faster parsable in perl. Buffer filling and swapping from a png package is less expensive, therefor I started a PNGImageObject. With PERL 6, SDL2::Raw panda package you can make the following perliminary game :
Remove Tabs and Newlines Inside Fields of Text Tab Delimited Files from Excel
1 direct reply — Read more / Contribute
by perldigious
on Jul 13, 2016 at 11:15

    I don't know if this is something that is common knowledge or not, but I figured this out once, and at the time I was overly pleased with myself. Now, wallowing in my hubris from this past epiphany (it felt like one for me anyway), I thought I'd share. I do realize there are simpler ways to read such files via various CPAN modules, but I still consider the code I write to be pretty amateurish (I'm actually an Electronics Engineer), so I'm still proud I figured this out at all.

    As far as I can tell, Text Tab Delimited type files saved out of Excel will have quotes added around individual tab delimited fields that have certain characters inside those fields, presumably so Excel can better handle them itself. My "trick" is essentially exploiting this to efficiently resolve lines that are read in from such files and split on tabs when the fields themselves can have tabs and/or newlines inside of them.

    while (my $line = <$TD_fh>) { chomp($line); my @data = split /\t/, $line; # This block of code strips tabs and newlines from inside individu +al tab delimited data fields. # Each individual tab or newline is replaced with a single space c +haracter. my $last_index = $#data; for (my $field_index=0; $field_index<$last_index; $field_index++) { if (($data[$field_index] =~ tr/"//) % 2 == 1) { my $new_string = "$data[$field_index] $data[$field_index+1 +]"; splice @data, $field_index, 2, $new_string; $line = join "\t", @data; $last_index--; $field_index--; } } if (($data[$last_index] =~ tr/"//) % 2 == 1) { $line .= " " . <$TD_fh>; redo; } # Make use of the resolved line and/or data however you please her +e. }

    So essentially it just comes down to always checking each field for an even number of quotes, and if that isn't found, some action needs to be taken (as far as I can tell, Excel "escapes" quotes themselves by adding another quote beside it). For all but the last field, the code assumes an extra tab was in there and consolidates the next field with the current one being looked at. For the last field, the code assumes an extra newline was in there and consolidates the next line with the current one being looked at. It's not glamorous or overly complex, but that's actually why I was proud of it. Relative to the other things I tried, it's extremely efficient as well.

    I did ultimately write this code in to a subroutine that returned the resolved split on tabs array for a line, but the biggest change to the code there is just replacing the "redo" line with a recursive call to the subroutine assigned to its local "@data" array.

    # This subroutine accepts a filehandle and a line read from that fileh +andle as arguments given in that order, it is meant for "Text (Tab de +limited)" type files. # It strips tabs and newlines from inside individual tab delimited dat +a fields. # It will modify the line that was passed to it (as if passed by refer +ence) to resolve it, and return an array of the completely resolved l +ine split on tabs. sub resolve_tab_delimited_file_line { my $fh = $_[0]; chomp($_[1]); # $_[1] being the read line passed in to this subrou +tine that is to be modified if necessary (as if passed by reference) my @data = split /\t/, $_[1]; my $last_index = $#data; for (my $field_index=0; $field_index<$last_index; $field_index++) { if (($data[$field_index] =~ tr/"//) % 2 == 1) { splice @data, $field_index, 2, "$data[$field_index] $data[ +$field_index+1]"; $_[1] = join "\t", @data; $last_index--; $field_index--; } } if (($data[$last_index] =~ tr/"//) % 2 == 1) { $_[1] .= " " . <$fh>; @data = &resolve_tab_delimited_file_line; } return @data; }

    Any thoughts from the monastery? Just curious if the monks think this is cool, stupid, obvious, irrelevant, or anything else? Or for that matter good or bad? Or can anyone point out any glaring oversight in the code where it isn't dealing with something that would make it choke and die a miserable death if encountered? That last one would make most of my office mates happy. I'm one of only two Perl Advocates swimming in a sea of Python Zealots, a group of which I recently read is sometimes referred to as a "smug". *snicker*

    I love it when things get difficult, after all, difficult pays the mortgage. - Dr. Keith Whites
    I hate it when things get difficult, so I'll just sell my house and rent cheap instead. - perldigious
Gray Code
2 direct replies — Read more / Contribute
by jdporter
on Jul 12, 2016 at 16:39

    I needed a quick Gray code (specifically, a binary reflected Gray code), so I whipped this up. The one CPAN module which seems to implement Gray code, Math-PlanePath is wayy too heavy for my needs.

    # returns a list of vectors of numbers in (0,1) sub gray2; sub gray2 { my($i) = @_; $i <= 1 and return([0],[1]); my @a = gray2($i-1); ( ( map { [ 0, @$_ ] } @a ), map { [ 1, @$_ ] } reverse @a ) } my @a = gray2(3); print "@$_\n" for @a;
    I reckon we are the only monastery ever to have a dungeon stuffed with 16,000 zombies.
Perl 6 SDL2 example - continued
1 direct reply — Read more / Contribute
by holyghost
on Jul 09, 2016 at 08:28
    In my previous example I said you could draw images on the screen of an SDL2 window. Here's how you create a texture (or surface) which has width 320 and height 200. Think of it as a rectangle where you can draw on :
    use SDL2::Raw; my $tile = SDL_CreateTexture($renderer, RGBA8888, STREAMING, 320, 200);
    To put pixels on the $tile texture, you can update the texture with an array of pixels (pixelpoints on the surface) Each pixel is 32 bits wide in SDL2, there is red, green blue and an alpha (transparent) channel (RGBA8888, where 8+8+8+8=32 bits).
    my $data = 0; ### pixelbuffer is empty sub render { SDL_UpdateTexture($tile, NULL, $data, 320*32); ### update 32 bits of 3 +20 pixels }
Perl 6 SDL2 example
1 direct reply — Read more / Contribute
by holyghost
on Jul 08, 2016 at 07:06
    If you install SDL2 ('panda install SDL2::Raw' in your command line), you can get this example from the SDL2 modules to work. Take a look at the render method and optionally draw images on a screen apart of points.
    use NativeCall; use SDL2::Raw; use nqp; my int ($w, $h) = 800, 600; my SDL_Window $window; my SDL_Renderer $renderer; my int $particlenum = 1000; constant $sdl-lib = 'SDL2'; sub SDL_RenderDrawPoints( SDL_Renderer $, CArray[int32] $points, int32 + $count ) returns int32 is native($sdl-lib) {*} SDL_Init(VIDEO); $window = SDL_CreateWindow( "Particle System!", SDL_WINDOWPOS_CENTERED_MASK, SDL_WINDOWPOS_CENTERED_MASK, $w, $h, SHOWN ); $renderer = SDL_CreateRenderer( $window, -1, ACCELERATED ); SDL_ClearError(); my SDL_RendererInfo $renderer_info .= new; SDL_GetRendererInfo($renderer, $renderer_info); say $renderer_info; say %PIXELFORMAT.pairs.grep({ $_.value == any($renderer_info.texf1, $r +enderer_info.texf2, $renderer_info.texf3) }); my num @positions = 0e0 xx ($particlenum * 2); my num @velocities = 0e0 xx ($particlenum * 2); my num @lifetimes = 0e0 xx $particlenum; my CArray[int32] $points .= new; my int $numpoints; sub update (num \df) { my int $xidx = 0; my int $yidx = 1; my int $pointidx = 0; loop (my int $idx = 0; $idx < $particlenum; $idx = $idx + 1) { my int $willdraw = 0; if (@lifetimes[$idx] <= 0e0) { if (rand < df) { @lifetimes[$idx] = rand * 10e0; @positions[$xidx] = ($w / 20e0).Num; @positions[$yidx] = (3 * $h / 50).Num; @velocities[$xidx] = (rand - 0.5e0) * 10; @velocities[$yidx] = (rand - 2e0) * 10; $willdraw = 1; } } else { if @positions[$yidx] > $h / 10 && @velocities[$yidx] > 0 { @velocities[$yidx] = @velocities[$yidx] * -0.6e0; } @velocities[$yidx] = @velocities[$yidx] + 9.81e0 * df; @positions[$xidx] = @positions[$xidx] + @velocities[$xidx] * df; @positions[$yidx] = @positions[$yidx] + @velocities[$yidx] * df; @lifetimes[$idx] = @lifetimes[$idx] - df; $willdraw = 1; } if ($willdraw) { $points[$pointidx++] = (@positions[$xidx] * 10).floor; $points[$pointidx++] = (@positions[$yidx] * 10).floor; } $xidx = $xidx + 2; $yidx = $xidx + 1; } $numpoints = ($pointidx - 1) div 2; } sub render { SDL_SetRenderDrawColor($renderer, 0x0, 0x0, 0x0, 0xff); SDL_RenderClear($renderer); SDL_SetRenderDrawColor($renderer, 0xff, 0xff, 0xff, 0x7f); SDL_RenderDrawPoints($renderer, $points, $numpoints); SDL_RenderPresent($renderer); } my $event =; my @times; my num $df = 0.0001e0; main: loop { my $start = nqp::time_n(); while SDL_PollEvent($event) { my $casted_event = SDL_CastEvent($event); given $casted_event { when *.type == QUIT { last main; } } } update($df); render(); @times.push: nqp::time_n() - $start; $df = nqp::time_n() - $start; } @times .= sort; my @timings = (@times[* div 50], @times[* div 4], @times[* div 2], @ti +mes[* * 3 div 4], @times[* - * div 100]); say "frames per second:"; say (1 X/ @timings).fmt("%3.4f"); say "timings:"; say ( @timings).fmt("%3.4f"); say ""; 'raw_timings.txt'.IO.spurt((1 X/ @times).join("\n"));

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

  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?

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

    How do I use this? | Other CB clients
    Other Users?
    Others imbibing at the Monastery: (9)
    As of 2016-09-27 08:45 GMT
    Find Nodes?
      Voting Booth?
      Extraterrestrials haven't visited the Earth yet because:

      Results (500 votes). Check out past polls.