Beefy Boxes and Bandwidth Generously Provided by pair Networks
Your skill will accomplish
what the force of many cannot
 
PerlMonks  

Cool Uses for Perl

( #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.

CUFP's
List EXE_FILES installed by CPAN
2 direct replies — Read more / Contribute
by usemodperl
on Jun 23, 2018 at 14:18
    EDIT: The original node was buggy so here's a fixed version that seems to show all the executables installed by CPAN! Original node below so I can be embarrassed forever.☺

    List EXE_FILES installed by CPAN:
    #!/usr/bin/perl -l use strict; use warnings; # List EXE_FILES installed by CPAN $_ = join '', `perldoc -uT perllocal`; @_ = (/EXE_FILES:\s([^>]+)/sg); my @z = (); for (@_) { my @x = split /\s+/; s/^\S+\/// for @x; push @z, @x; } %_ = map { $_ => 1 } @z; print $_ for sort keys %_; #print scalar keys %_;
    List EXE_FILES installed by CPAN, by module:
    #!/usr/bin/perl -l use strict; use warnings; # List EXE_FILES installed by CPAN, by module $_ = join '', `perldoc -uT perllocal`; my @m = (/=head2.*?\|([^>]+)/g); my @e = (/EXE_FILES:\s([^>]*)/sg); for (my $c = 0; $c < scalar @m; $c++) { $_{$m[$c]} = $e[$c] } my @z = (); my $t = 0; for (sort { lc($a) cmp lc($b) } keys %_) { if (my @x = split /\s+/, $_{$_}) { print; $t += scalar @x; s/^\S+\/// for @x; print " $_" for @x; print ""; } } #print $t;
    THE ORIGINAL NODE, DOES NOT WORK!:

    List EXE_FILES installed by CPAN:
    perl -le'chomp(@_=`perldoc -T perllocal`); # List EXE_FILES installed by CPAN $_=join"\n",@_;@_=split/\"Module\"\s/; @_=grep/EXE_FILES:\s[^"]+/,@_;for(@_){@x=split/\n/; @x=grep/EXE|0m/,@x;push@z,@x}s/^\s+\*\s+\"([^\"]+).?/$1/ for@z; @_=grep/EXE_FILES/,@z;@_=map{substr($_,11,length($_))}@_;undef@z; for(@_){if(/\s/){@x=split/\s/;push@z,$_ for@x}else{push@z,$_}} %_=map{s/^\S+\///;$_=>1}@z;print$_ for sort{lc($a)cmp lc($b)}keys%_'


    List EXE_FILES installed by CPAN, by module:
    perl -le'chomp(@_=`perldoc -T perllocal`); # List EXE_FILES installed by CPAN, by module $_=join"\n",@_; @_=split/\"Module\"\s/,$_; @_=grep/EXE_FILES:\s[^"]+/,@_;for(@_){@x=split/\n/; @x=grep/EXE_FILES|0m/,@x;push@z,@x}undef@x; s/^\s+\*\s+\"([^\"]+).?/$1/ for@z;my$m;for(@z){ if(/EXE_FILES:\s(.*)/){$_{$m}=$1}else{$m=$_;$_{$m}=1}} for(sort{lc($a)cmp lc($b)}keys %_){if($_{$_}=~/\s/){ @x=split/\s/,$_{$_};s/^\S+\/// for@x;$_{$_}=join"\n ", @x}else{$_{$_}=~s/^\S+\///g}print"$_\n $_{$_}\n"}'


    STOP REINVENTING WHEELS, START BUILDING SPACE ROCKETS!CPAN 🐪
Apple Perl Quine
No replies — Read more | Post response
by usemodperl
on Jun 19, 2018 at 22:09
    This perl code compiles and runs an apple mac app that decompiles and prints its own applescript source code:
    perl -Mautodie -we '$app="ApplePerlQuine\@perlmonks.org.app";die"not a +pple mac"unless${^O}eq"darwin";open$f,"|-","osacompile -o $app";print +$f qq~set myPATH to path to me as string\nset myPATH to myPATH & "Con +tents:Resources:Scripts:main.scpt"\nset myPATH to do shell script"ech +o " & myPATH & " | tr : / | sed -E \x27s/Macintosh HD//\x27"\ndisplay + dialog (do shell script ("osadecompile " & myPATH)) with title "$app +" buttons {"Use Perl!"} default button 1\n~;close$f;system("open $app +")'
Why is it so easy to make Perl apps for Apple Mac?
2 direct replies — Read more / Contribute
by Anonymous Monk
on Jun 17, 2018 at 13:40
    Compile your Perl to a portable binary application for Apple Mac (99k):
    echo 'display alert (do shell script "perl -v")' | osacompile -o perl. +app
    Write apps for Apple Mac in Perl: Pt.1, Pt.2, Pt.3
How to write apps for macOS/OSX in Perl! Part 3: Random DNS Server
No replies — Read more | Post response
by Anonymous Monk
on Jun 16, 2018 at 04:26
    Welcome to Part 3 of How to write apps for macOS/OSX in Perl! This app protects Internet Privacy by regularly changing DNS servers. It's designed to run constantly in the background. I use it all day every day for the past 2 months.

    This edition demonstrates how to:

    1. Write a very useful application!
    2. Use Perl to create, read and write a config file.
    3. Easily edit the config file.
    4. Configure multiple run time variables.
    5. Pass variables between Applescript and Perl.
    6. Handle errors and bad input.
    7. Use core Perl modules.

    See Part 1 to get started with Perl and the built-in Mac devtool Automator,
    and the demo Perl app for Mac: Perl ASN Check

    See Part 2 for more techniques to integrate Perl into Mac with Applescript,
    and the demo Perl app for Mac: Perl Version Tool

    This ~150 liner is ~120 lines of Applescript GUI logic linked to ~30 lines of core Perl code in the form of 3 one-liners! Hopefully our Mac-centric monks will pick up these techniques to write and share Mac apps to improve computing experiences with Perl! Remember: All Macs Have Perl!

      Compile this code with the instructions in Part 1
      to produce a 1.3MB portable binary application:

    Source:

    -- Set random DNS server every n minutes. # Demonstration Apple macOS/OSX app in AppleScript and Perl # Posted to perlmonks.org by Anonymous Monk 6/16/2018 # Node: How to write apps for macOS/OSX in Perl! Part 3: Random DNS Se +rver -- Part 1: Perl ASN Check https://perlmonks.org/?node_id=1216610 -- Part 2: Perl Version Tool https://perlmonks.org/?node_id=1216670 # DEFAULT DNS SERVERS: # 1.1.1.1 = Cloudflare # 8.8.8.8 = Google # 45.77.165.194 = Fourth Estate Zero Knowledge set DNS to "1.1.1.1 8.8.8.8 45.77.165.194" set DEFAULT_NETWORK to "Wi-Fi" set TITLE to "Random DNS Server" # CREATE AND/OR READ CONFIGURATION FILE: # 1. PASS APPLESCRIPT VARIABLES TO PERL -> # 2. SEND PERL VARIABLES TO APPLESCRIPT <- # 3. AND THAT LAST LINE... try set INI to do shell script "printf $HOME" & "/.dns.random.config" set CFG to do shell script " perl -Mautodie -we ' my $config = qq~" & INI & "~; if (-e $config) { open my $fh, q~<~, $config; @_ = <$fh>; close $fh; @_ = grep /\\S+/, @_; print @_; } else { open my $fh, q~>~, $config; print $fh qq~" & DNS & "~; close $fh; print qq~" & DNS & "~; } ' " on error oops display alert oops as critical end try set DNS to CFG # RUNTIME CONFIG LOOP repeat try set TXT to "DNS Servers: " & DNS & " Minutes between change? (blank to exit)" set EAE to "EXIT AND EDIT CONFIG" # GET DIALOG OBJECT CONTAINING INPUT AND CLICKED BUTTON VALUE set DUR to display dialog TXT with title TITLE default answer +"" buttons {EAE, "OK"} default button 2 set DUR_text to text returned of DUR as number set DUR_button to button returned of DUR if DUR_button is EAE then # EDIT CONFIG try do shell script "open -a TextEdit " & INI & "" return # EXIT on error oops display alert oops as critical return # EXIT end try end if if DUR_text is 0 then return # EXIT set DUR to DUR_text set NETS to do shell script "networksetup -listallnetworkservi +ces" set TXT to "Network Interfaces: " & NETS & " Network?" set NETWORK to text returned of (display dialog TXT with title + TITLE default answer DEFAULT_NETWORK buttons {"OK"} default button 1 +) try # DOES NETWORK EXIST? set hmm to do shell script " perl -we ' @_ = qx/networksetup -getinfo " & NETWORK & "/; $_ = join qq~\\n~, @_; print /Error/ ? 0 : 1; ' " on error oops display alert oops as critical return # EXIT end try if hmm as number is equal to 0 then display notification "Network not found! Exit..." with tit +le TITLE return # EXIT end if exit repeat # EXIT CONFIG LOOP on error oops display notification "This shouldn't happen!" with title TITLE return # EXIT end try end repeat # END CONFIG LOOP set MSG to button returned of (display dialog "Notification of change? +" buttons {"No", "Yes"} default button 2) # END CONFIG # MAIN EVENT LOOP repeat try # Use perl to read last line of resolv.conf as current DNS ser +ver. # Exclude current server and shuffle list to get new value. # Set new server and return the old and new values to applescr +ipt. set PERL to do shell script " perl -MList::Util=shuffle -Mautodie -we ' open my $fh, q~<~, q~/private/etc/resolv.conf~; chomp(@_ = <$fh>); close $fh; $_ = pop @_; my (undef,$cur) = split q~ ~; $_ = qq~" & DNS & "~; @_ = split /\\s+/; @_ = grep !/$cur/, @_; @_ = shuffle @_; my $new = pop @_; system(qq~networksetup -setdnsservers " & NETWORK & " +$new~); print qq~$cur $new~; ' " on error oops display alert oops as critical end try # AN APPLESCRIPT SPLIT set text item delimiters to {" "} set {CUR, NEW} to text items 1 thru 2 of PERL if MSG is "Yes" then display notification "DNS changed from " & CUR & " to " & NEW +with title TITLE end if delay ((DUR as integer) * 60) end repeat # MADE IN USA (This program, Perl, Apple, Me!) # b9ce5dcd671f9647fb86a6f3709a572ffd6e2aa490c005300585a555fabf9ce8 # 060c38ad8715a6a2381cc653ad5a7dd1815f3cf990c31594b4a1b20ef4fc9d27
How to write apps for macOS/OSX in Perl! Part 2
No replies — Read more | Post response
by Anonymous Monk
on Jun 14, 2018 at 17:00
    Welcome to Part 2 of How to write apps for macOS/OSX in Perl! See Part 1 to get started with the built-in macOS devtool Automator. This edition demonstrates how to:

    • Process choices with Perl from an Applescript dialog to:
      1. Display output from Perl to an Applescript dialog.
      2. Execute Perl in Terminal to display its output.
      3. Send output from Perl to an application (TextExit).
    Applescript is to the operating system what Javascript is the the web browser. It can do many things and what it can't do can always be handled by shell commands and especially Perl! When the code below is saved by Automator as something like PerlVersionTool.app you will have a 1.3MB portable binary application! Double click and ENJOY!
    • Other techniques covered here include:
      1. Visiting websites (Perlmonks of course!)
      2. Displaying notifications
      3. Application control
      4. Applescript subroutines
      5. Abusing buttons to widen dialogs
      6. How to rule your world with Perl!
    Source:
    (* Demonstration macOS/OSX app in AppleScript and Perl *) (* Posted to perlmonks.org by Anonymous Monk 6/14/2018 *) (* Node: How to write apps for macOS/OSX in Perl! Part 2 *) set TITLE to "Perl Version Tool" set PROMPT to "Make a selection" set _1 to "Perl version, patchlevel and license" set _2 to "Perl configuration summary" set _3 to "Perl command line help" set _4 to "Visit Perlmonks.org!" repeat set what to choose from list {_1, _2, _3, _4} with title TITLE wit +h prompt PROMPT OK button name {"View"} cancel button name {"Exit"} d +efault items _1 set what to what as string if what is _1 then set CMD to "perl -v" # ONE LINERS OR PROGRAMS OF ANY SIZE! else if what is _2 then set CMD to "perl -V" else if what is _3 then set CMD to "perl -h" else if what is _4 then display notification "Opening The Monastery Gates!" set CMD to "open https://perlmonks.org" else if what is "false" then return # EXIT end if if what is _2 then # SEND PERL CODE TO TERMINAL AND EXECUTE doShell(CMD) else if what is _3 then # CAPTURE PERL STDOUT set CMD to do shell script CMD # SEND PERL STDOUT TO TEXTEDIT textEdit(CMD) else # CAPTURE PERL STDOUT set RES to do shell script CMD # MAKE DIALOG WIDE set SPC to " + " # PRINT PERL STDOUT TO APPLESCRIPT ALERT display alert TITLE message RES buttons {SPC & "Cool" & SPC} d +efault button 1 end if end repeat # APPLESCRIPT SUBS: on doShell(CMD) try tell application "Terminal" activate tell application "System Events" to keystroke "n" using {c +ommand down} end tell tell application "System Events" tell application process "Terminal" set frontmost to true keystroke CMD keystroke return end tell end tell on error oops display alert oops as critical end try end doShell on textEdit(CMD) try tell application "TextEdit" activate tell application "System Events" to keystroke "n" using {c +ommand down} end tell tell application "System Events" tell application process "TextEdit" set frontmost to true keystroke CMD end tell end tell on error oops display alert oops as critical end try end textEdit
How to write apps for macOS/OSX in Perl!
3 direct replies — Read more / Contribute
by Anonymous Monk
on Jun 14, 2018 at 02:25
    macOS/OSX comes with tools that make it super easy to write native GUI applications with Applescript and Perl! This example uses the cool and free Robtex API to validate Autonomous System Numbers for networks in the global BGP table. Applescript provides plenty of ways to collect and display data, handle errors, and can launch terminals and text editors or any app and automate the entire operating system GUI while Perl does pretty much anything else you can imagine.

    Start : Applications -> Automator
    Select: File -> New
    Select: Application

    We're going to create an application but Automator can also encapsulate Perl into a Service, Image Capture Plugin, Dictation Command, Folder Action, Calendar Alarm, Print Plugin or Workflow.

    Now that Automator is open click the Library icon or select View -> Show Library.

    Select: Actions -> Utilities -> Run AppleScript (double click it)

    Replace the default code with this:

    (* Demonstration MacOS/OSX app in AppleScript and Perl *) (* Posted at perlmonks.org by Anonymous Monk 6/13/2018 *) (* Node: How to write apps for macOS/OSX in Perl! *) repeat repeat try set ASN to text returned of (display dialog "Autonomous Sy +stem Number: (Example: 714 is Apple Inc. 666 does not exist. Blank to exit.)" with +title "Perl ASN Check" default answer "" buttons {"Check"} default bu +tton 1) set ASN to ASN as number # require a number exit repeat # continue if ASN is numeric on error # not a number? display alert "Please enter an Autonomous System Number!" +as critical end try end repeat if ASN is equal to 0 then return # exit if blank # ALL MACS HAVE PERL BABY! set RES to do shell script " perl -MHTTP::Tiny -e ' my $r = HTTP::Tiny->new->get(q~https://freeapi.robtex.com/ +asquery/" & ASN & "~); if (length $r->{content}) { $r->{content} =~ /[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+/ ? print q~ASN Exists!~ : print q~ASN Not Found!~; } else { print q~Download failed!~ } ' " display alert RES end repeat

    Save the application and double click its icon in finder. BEHOLD! Perl apps for macOS/OSX!!!

    (Tips: In the Perl code avoid single quotes and be prepared to do some extra backslashing.)

perlpdf for perldoc as PDF
1 direct reply — Read more / Contribute
by Anonymous Monk
on Jun 02, 2018 at 05:40
    Type perlpdf instead of perldoc!

    This bash function uses pod2pdf to produce a very nice san-serif font PDF with title and footer and opens it with the "open" command (for OSX, adjust as needed). The tempfile is necessary for the PDF reader (Preview) to have a filename should one choose to save the file as, for example: "perldoc -q array.pdf". pod2pdf seems to call PDF::API2 about 10,000 times per page so it's slow on large documents

    function perlpdf() { P=perldoc; X="$P $@"; $P -uT "$@" | pod2pdf --title="$X" --footer-text="$X" > "/tmp/$X.pdf"; open "/tmp/$X.pdf"; }
    Type perlpdx instead of perlpdf!

    This one uses ghostscript ps2pdf via man via pod2man to produce a plainer looking serif font PDF with a more generic title and footer (perl version/date/etc) and a filename. It seems more complicated but the process is extremely fast.

    function perlpdx(){ P=perldoc; $P -uT "$@" | pod2man > "/tmp/$P $*.1"; man -t "/tmp/$P $*.1" | ps2pdf - "/tmp/$P $*.pdf"; open "/tmp/$P $*.pdf"; }
Safely read/write a file simultaneously
1 direct reply — Read more / Contribute
by golux
on May 16, 2018 at 20:40
    I'm working on a Client/Server project where a "progress file" gets updated (potentially quite often) and read from a separate (CGI) process. I was pretty sure having the writer reopening the progress file could cause the reader to have occasional problems, and also fairly sure that writing to a tempfile instead (and then moving the tempfile over the progress file) would be much safer (ie. atomic).

    But why Google it when you can write code to test it instead? ;-)

    Here's the result, which indicates I was correct on both counts, and happily the latter seems to be atomic enough that an error never occurs. Set or clear the value of $unsafe to try the different algorithms.

    #!/usr/bin/perl ############### ## Libraries ## ############### use strict; use warnings; use File::Copy; use Function::Parameters; use IO::File; ################## ## User-defined ## ################## my $file = 'file.txt'; my $rdelay = 0.03; # Read delay: 3/100th of a second my $wdelay = 0.01; # Write delay: 1/100th of a second my $unsafe = 1; # Set to zero to call the "safe" write algorit +hm ################## ## Main Program ## ################## $| = 1; if (fork) { writer($unsafe); } else { reader(); } ################# ## Subroutines ## ################# # # Writes to a file many times per second. # fun writer($unsafe) { my $count = 0; while (1) { if ($unsafe) { writefile1($file, $count++); } else { writefile2($file, $count++); } # Sleep for 1/100th of a second select(undef, undef, undef, $wdelay); } } # # Reads from the file, displaying number of total errors # (each time the $count was undefined). # fun reader() { sleep 1; # Give the writer time to create the file initiall +y my $nerrs = 0; # How many total errors did we get? while (1) { my $count = readfile($file); if ($count) { printf "%8d, ", $count; } else { printf "\nTotal errors = %d\n", ++$nerrs; sleep 1; } } select(undef, undef, undef, $rdelay); } # # Algorithm 1 # # Writes the $value directly to the file # This turns out to be quite prone to error when the file is read. # fun writefile1($file, $value) { my $fh = IO::File->new; open($fh, '>', $file) or die "Can't write '$file' ($!)\n"; print $fh "$value\n"; close($fh); } # # Algorithm 2 # # Writes the $value to a temp file, then moves the tempfile over the # actual destination. This turns out to be quite safe for reading. # fun writefile2($file, $value) { my $fh = IO::File->new; my $tmp = 'tmp.txt'; open($fh, '>', $tmp) or die "Can't write '$file' ($!)\n"; print $fh "$value\n"; close($fh); move($tmp, $file); } # # Reads the $value from the $file # fun readfile($file) { my $fh = IO::File->new; open($fh, '<', $file) or die "Can't read '$file' ($!)\n"; my $value = <$fh>; defined($value) or return 0; chomp($value); close($fh); return $value; }
    say  substr+lc crypt(qw $i3 SI$),4,5
Conways Game of Life in PDL
1 direct reply — Read more / Contribute
by mxb
on May 16, 2018 at 11:31

    Edit: Apparently this is in the PDL Documentation, as an example. Whoops! Still, it was a good learning exercise :)

    Rather than a ported numpy tutorial, this is a self developed implementation of Conways Game of Life written in Perl/PDL. Hopefully people find this interesting as I feel it shows how concise PDL code can be.

    The code is fairly straightforward. There is a single function conway() which accepts a single argument of the game arena. This is a two dimensional PDL matrix. Alive cells are represented by a one, dead ones by zero. The conway() function sums the value of each cell along with value of its nine neighbours into a temporary variable $tmp. It then applies the rules of the game, which are:

    • Any live cell with fewer than two live neighbors dies, as if caused by under population.
    • Any live cell with two or three live neighbors lives on to the next generation.
    • Any live cell with more than three live neighbors dies, as if by overpopulation.
    • Any dead cell with exactly three live neighbors becomes a live cell, as if by reproduction.

    This is implemented as an elementwise or and an elementwise and.

    The main loop of the game is in the body of the code and simply displays the generation and the game arena and awaits input

    The game arena is initialised with a 'glider', but feel free to experiment. As PDL wraps around by default, the surface is that of a torus.

    Enter a blank line for the next generation, anything else to exit

    Enjoy

    #!/usr/bin/env perl use strict; use warnings; use 5.016; use PDL; sub conway { my $pdl = shift; die "Not 2D piddle" unless $pdl->ndims == 2; # Add up all values: my $tmp = $pdl + # original $pdl->transpose->rotate(-1)->transpose + # north $pdl->transpose->rotate(-1)->transpose->rotate(-1) + # northeast $pdl->rotate(-1) + # east $pdl->transpose->rotate(1)->transpose->rotate(-1) + # southeast $pdl->transpose->rotate(1)->transpose + # south $pdl->transpose->rotate(1)->transpose->rotate(1) + # southwest $pdl->rotate(1) + # west $pdl->transpose->rotate(-1)->transpose->rotate(1); # northwest # Cell is alive if it's either: return ( $tmp == 4 & $pdl == 1 ) | # Alive +3 neighbors $tmp == 3; # Alive +2 neighbors or dead +3 neighbors } my $arena = pdl(byte, [ [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ], [ 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ], [ 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ], [ 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ], [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ], [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ], [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ], [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ], ] ); my $gen = 0; while (1) { print "Generation: $gen (press enter for next)\n"; print $arena; $arena = conway($arena); $gen++; exit if <STDIN> ne "\n"; }
Basic Neural Network in PDL
1 direct reply — Read more / Contribute
by mxb
on May 15, 2018 at 07:37

    As part of my ongoing quest to port tutorials from Python/numpy to Perl/PDL please graciously accept the following contribution to the Monastery.

    This is the Perl/PDL port of A Neural Network in 11 Lines of Python. While I've added some documentation, please reference the original blog post for full details.

    #!/usr/bin/env perl use strict; use warnings; use 5.016; use PDL; ###################################################################### # This example is ported from the tutorial at # https://iamtrask.github.io/2015/07/12/basic-python-network/ ###################################################################### # # In this example, we are training a neural network of two layers # (one set of weights). # It has the following variables: # $X - input neurons # $y - desired output values # $syn0 - single layer of weights # $l1 - output neurons # # This is our 'non-linear' function. It accepts two arguments. # The first argument is a piddle of values, and the second argument # is a flag. # # If the flag is unset, the function returns the elementwise Sigmoid # Function (https://en.wikipedia.org/wiki/Sigmoid_function). # # If the flag is set, the function returns the elementwise derivative # of the Sigmoid Function. sub nonlin { my ( $x, $deriv ) = @_; return $x * ( 1 - $x ) if defined $deriv; return 1 / ( 1 + exp( -$x ) ); } # $X is are our input values. It contains four examples of three # inputs. It is the following matrix: # # [ # [0 0 1] # [0 1 1] # [1 0 1] # [1 1 1] # ] my $X = pdl( [ [ 0, 0, 1 ], [ 0, 1, 1 ], [ 1, 0, 1 ], [ 1, 1, 1 ] ] ); # $y is the output vector. It is the following desired outputs for # the four input vectors above: # [0 0 1 1] my $y = pdl( [ 0, 0, 1, 1 ] )->transpose; # $syn0 is the first layer of weights, connecting the input values # ($X) to our first layer ($l1). It is initialised to random values # between -1 and 1. my $syn0 = ( ( 2 * random( 3, 1 ) ) - 1 )->transpose; # $l1 is the second (output) layer: my $l1; # This is the training loop. It performs 10000 training interations. for ( 0 .. 10000 ) { # Predict the outputs for all four examples (full batch training) # This is performed by applying the non-linear function # elementwise over the dot product of our input examples matrix # ($X) and our weights between layers 0 (input) and 1 (output) # ($syn0): $l1 = nonlin( $X x $syn0 ); # Calculate the error by comparing calculated values ($l1) to # known output values ($y) my $l1_error = $y - $l1; # Calculate the 'error weighted derivative'. This is the # elementwise product of the errors and the derivative of the # non-linear function across the outputs my $l1_delta = $l1_error * nonlin( $l1, 1 ); # Update the weights between the layers $syn0 += ( $X->transpose x $l1_delta ); } # Display output say "Expected output:", $y; say "Output After Training:", $l1;

    Running it on my machine takes approximately 1.5 seconds and gives output similar to:

    % perl nn_tutorial.pl Expected output: [ [0] [0] [1] [1] ] Output After Training: [ [0.0096660515] [0.0078649669] [ 0.99358927] [ 0.99211856] ]
Locate Survey Markers (US-Only, uses USGS WebService)
No replies — Read more | Post response
by roboticus
on May 04, 2018 at 18:38

    Hello, all--

    I had a friend who wanted to find some survey markers near his house, so I looked around and found a webservice that would locate some survey markers in an area. Since I coded it up, I thought I'd publish it here, in case there's anyone else who might like to try it. It's rough (as it's a one-off), but should be easy enough to modify.

    As is often the case, all the heavy lifting is done by some handy CPAN modules (JSON, HTTP::Request, LWP::UserAgent and Math::Trig). I was especially pleased to find Math::Trig--I was trying to derive it myself and needed arc-cosine. When I found Math::Trig had acos and looked over the docs, I found that it already had all the great-circle math as well!

    Anyway, I hope someone finds it useful...

    #!env perl # # websvc_usgs_fetch_bounding_box.pl <LAT> <LON> <dist> # # Use the USGS "Bounding Box Service" to find survey markes within the # rough rectangle whose sides are <dist> miles from the specified lati +tude # and longitude. # # 20180504 original version # use strict; use warnings; use Data::Dump 'pp'; use HTTP::Request; use JSON; use LWP::UserAgent; use Math::Trig qw( :great_circle deg2rad ); my $LAT = shift; my $LON = shift; my $center_dec = [ $LON, $LAT ]; my $squaradius_mi = shift or die <<EOMSG; Expected: perl websvc_usgs_fetch_bounding_box.pl LAT LON RAD LAT - latitude like 38.1234, LON - longitude like -78.1234, RAD - radius in miles (actually roughly a rectangle rather than ci +rcle) EOMSG my $Re_mi = 3958.8; # radius of earth in miles # Figure how approximately how long a degree is in both the longitudin +al and # latitudinal directions. my $mi_per_degree = miles_per_degree([ NESW($LON, $LAT) ]); # Now find the (min/max) * (lat,lon) for the bounding rectangle to sea +rch # for survey markers my $deg_per_mi_lat = 1 / $mi_per_degree->[1]; my $deg_per_mi_lon = 1 / $mi_per_degree->[0]; my $min_lat = $center_dec->[1] - $squaradius_mi*$deg_per_mi_lat; my $max_lat = $center_dec->[1] + $squaradius_mi*$deg_per_mi_lat; my $min_lon = $center_dec->[0] - $squaradius_mi*$deg_per_mi_lat; my $max_lon = $center_dec->[0] + $squaradius_mi*$deg_per_mi_lat; # We'll use the DDMMSS format for the lat/lon $min_lat = dec_to_DDMMSS($min_lat, "N", "S"); $max_lat = dec_to_DDMMSS($max_lat, "N", "S"); $min_lon = dec_to_DDMMSS($min_lon, "E", "W"); $max_lon = dec_to_DDMMSS($max_lon, "E", "W"); # Now fetch the data, and print the results my $URL = "http://geodesy.noaa.gov/api/nde/bounds?" ."minlat=$min_lat&maxlat=$max_lat" ."&minlon=$min_lon&maxlon=$max_lon"; my $request = HTTP::Request->new(GET=>$URL, [ 'Content-Type'=>'applica +tion/json; charset=UTF-8' ]); my $ua = LWP::UserAgent->new; my $response = $ua->request($request); if (! exists $response->{_content}) { # crappy error detection/handling but it meets my current needs print pp($response), "\n"; print "***** expected response->{content}!!!!!!!!\n"; } my $r = decode_json($response->{_content}); print "Found ", scalar(@$r), " markers within $squaradius_mi miles cen +tered around ", pp($center_dec), "\n"; print <<EOHDR; LATITUDE LONGITUDE NAME PID ---------- ---------- -------------------- ---------- EOHDR for my $hr (@$r) { printf "%-10s %-10s %-20s %-10s\n", $hr->{lat}, $hr->{lon}, $hr->{ +name}, $hr->{pid}; } sub dec_to_DDMMSS { my ($dec, $dir_pos, $dir_neg) = @_; # Unfortunately, they use 2 sig digs for N/S and 3 for E/W my $fmt = $dir_pos eq 'N' ? "%s%02d%02d%02d.%03d" : "%s%03d%02d%02 +d.%03d"; my $dir = $dir_pos; if ($dec < 0) { $dec = -$dec; $dir = $dir_neg; } my ($deg, $min, $sec, $sfrac) = (int($dec), 0, 0, 0); $dec = 60 * ($dec - $deg); $min = int($dec); $dec = 60 * ($dec - $min); $sec = int($dec); $sfrac = int(1000*($dec-$sec)); return sprintf $fmt, $dir, $deg, $min, $sec, $sfrac; } sub dms_to_DDMMSS { my $dms = shift; my ($deg, $dir, $min, $sec, $sfrac); if ($dms =~ /^\s*(\d+)\s*([NEWS])\s*(\d+)\s*'\s*([\d\.]+)\s*"\s*$/ +) { ($deg, $dir, $min, $sec, $sfrac) = ($1, $2, $3, $4, 0); if ($sec =~ /(\d+)\.(\d+)/) { ($sec,$sfrac) = ($1,$2); } } else { die "Unexpected format <$dms>!"; } # Build the return value: For N/S use <xDDMMSS.s*>, for E/W use <x +DDDMMSS.s*> if ($dir eq "N" or $dir eq "S") { return sprintf "%s%02d%02d%02d.%s", $dir, $deg, $min, $sec, $s +frac; } else { return sprintf "%s%03d%02d%02d.%s", $dir, $deg, $min, $sec, $s +frac; } } sub NESW { deg2rad($_[0]), deg2rad(90-$_[1]) } sub dms_to_dec { my $dms = shift; my ($deg, $dir, $min, $sec, $sfrac); if ($dms =~ /^\s*(\d+)\s*([NEWS])\s*(\d+)\s*'\s*([\d\.]+)\s*"\s*$/ +) { ($deg, $dir, $min, $sec, $sfrac) = ($1, $2, $3, $4, 0); if ($sec =~ /(\d+)\.(\d+)/) { ($sec,$sfrac) = ($1,$2); } } else { die "Unexpected format <$dms>!"; } $dir = ($dir eq 'N' or $dir eq 'E') ? 1 : -1; return $dir * ($deg + $min/60.0 + (0 + ("$sec.$sfrac"))/3600.0); } # compute number of miles per degree at the specified lat/lon sub miles_per_degree { my $news = shift; my $news_1lat = [ @$news ]; $news_1lat->[1] += deg2rad(1.0); my $news_1lon = [ @$news ]; $news_1lon->[0] += deg2rad(1.0); my $dLat_km = great_circle_distance(@$news, @$news_1lat, $Re_mi); my $dLon_km = great_circle_distance(@$news, @$news_1lon, $Re_mi); return [ $dLat_km, $dLon_km ]; }

    A sample run gives me:

    $ perl websvc_usgs_fetch_bounding_box.pl 34.1234 -78.1234 1.5 Found 11 markers within 1.5 miles centered around [-78.1234, 34.1234] LATITUDE LONGITUDE NAME PID ---------- ---------- -------------------- ---------- 34.14829 -78.09827 WINNABOW RM 4 EB0192 34.14832 -78.09805 WINNABOW EB0189 34.14856 -78.09788 WINNABOW RM 3 EB0191 34.09944 -78.12361 P 117 EB0198 34.11095 -78.11490 FLOWERS EB2124 34.11178 -78.11387 Q 117 EB0197 34.11812 -78.10776 BECK EB2125 34.12278 -78.10611 R 117 EB0195 34.12708 -78.10360 CAMPBELL EB2108 34.14593 -78.10423 WINNABOW AZ MK 2 EB1389 34.14722 -78.11694 N 235 EB0300

    ...roboticus

    When your only tool is a hammer, all problems look like your thumb.

Stone Jam -- 21 challenging puzzles with perl Tk
3 direct replies — Read more / Contribute
by Discipulus
on May 03, 2018 at 04:00
    Hello nuns and monks!

    April was the month dedicated to Perl/Tk here at the monastery (grin grin..) and during this time I developed another funny Tk puzzle. I have some unanswered question I put here even if the game is perfectly functioning.

    I took the inspiration from a puzzle game of my daughter and suddenly I had the idea to translete in perl.

    The program presents 21 different puzzles where you have to move a red stone up to border of the tablebaord, while other stones have to be shifted to make the path free.

    The challenge, for me, was to reproduce some realistic moves for canvas: I was for some method to produce some brick-like piece unable to collide themselves. I had no chance till the moment I focused on free tiles, recalculating possible moves for all stones everytime one get moved. CPU cycles are so cheap nowadays..

    • there is some better way to achieve the above? For my own sanity I abstracted the board avoiding direct coordinates calculations.
    About the graphic: I planned to use some advanced tecnique for this game like texture applied to stones or tile (graphic ones) applied to them but I had absolutely no luck in this and I ended with la Mondrian color scheme (with, as always, the high contrast option: many many people has problems with colors..)
    • what happened to the -tile option for canvas? How can I fill canvas objects (rectangles, ovals..) with Photos or advanced grafic?

    About the code: I realized about free space too late, also the moves caclulation was modified in fieri so the resulting code can be probably shortened a lot. Anyway the code is complete and runs fine and some of the puzzles is really challenging.

    Have fun!

    PS added to my github repos: Stone-Jam I'd like issues and eventual reports to be directed there.

    L*

    There are no rules, there are no thumbs..
    Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.
Repeatedly edit a file hacking PPI::Cache
No replies — Read more | Post response
by Discipulus
on Apr 13, 2018 at 07:34
    Hello monks and nuns,

    this is a quick hack on PPI::Cache and PPI itself. The program looks for the file named last_hex_id_file.sto which contains the last hex generated for the perl document. If the file is not found (as normal the first time you run the program) it ask for the path of a perl document to parse: then generates the cache and store the hex in the above file.

    When a new file or some cache content is loaded it ask for a PPI class to iterate over: each element is printed out and you are asked if you want to modify it.

    At the end of the cylce the new document is put in the cache and you are asked for an eventual output file. Next time you run the program the newer version is automatically loaded from the cache: because of this run in a new folder for each perl document you want to modify.

    use strict; use warnings; use PPI; use PPI::Cache; use Term::ReadLine; use Storable qw(nstore retrieve); my $term = Term::ReadLine->new('PPI cache hack'); my $last_hex_id_file = 'last_hex_id_file.sto'; my $perl_doc; my $cache; # not found the last_hex_id_file.sto file: ask for a new perl document + to parse unless (-e $last_hex_id_file){ print "cache file $last_hex_id_file not found.\n". "Insert the full path of a new file to edit and press ente +r (or CTRL-C to terminate)\n"; my $path = $term->readline('FILE PATH:'); die "Some problem with [$path]! " unless -e -r -f -s $path; my $doc = PPI::Document->new($path) or die "Unable to load $path v +ia PPI! "; $cache = PPI::Cache->new( path => './',readonly => 0); # store the original in the cache $cache->store_document($doc) or die "Unable to store into the cach +e!"; # get a copy to work with from the cache $perl_doc = $cache->get_document($doc->hex_id); print "loading from cache ok\n" if ref $perl_doc eq 'PPI::Document +'; #store_hex($doc->hex_id); nstore (\$doc->hex_id, $last_hex_id_file); } # last_hex_id_file.sto is here: load from it my $last_hex = retrieve($last_hex_id_file); print "'last_hex_id_file.sto' succesfully read: using $$last_hex\n"; $cache = PPI::Cache->new( path => './',readonly => 0) unless ref $c +ache eq 'PPI::Cache'; $perl_doc = $cache->get_document( $$last_hex ); print "Which PPI class do you want to edit?\n"; my $class = $term->readline('PPI CLASS:'); print "\n\nEach element of the type $class will be proposed for edit ( +the content).\n". "insert your new input terminating it with CTRL-Z on a empty l +ine.\n". "use a bare ENTER to skip the current element\n\n"; foreach my $it ( @{$perl_doc->find($class)} ) { print "STATEMENT: ",$it->statement,"\n", "CONTENT: ",$it->content,"\n\n"; my @in; while ( my $line = $term->readline('EDIT:') ){ push @in,$line; } if (@in){ $it->set_content(join "\n",@in); } } # store in the $cache->store_document($perl_doc); print "storing cache hex_id: ",$perl_doc->hex_id," in $last_hex_id_fil +e\n"; nstore (\$perl_doc->hex_id, $last_hex_id_file); # ask for an eventual output file print "Enter a filename if you want to save the current version (or EN +TER to skip)\n"; my $out = $term->readline('OUTPUT FILE:'); $perl_doc->save( $out ) if $out;
    L*

    PS if you pass PPI::Token::Quote in the above program you can use it to translate a program into another language with easy.

    There are no rules, there are no thumbs..
    Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.
perl6 Array of hashes AoH
No replies — Read more | Post response
by teun-arno
on Mar 19, 2018 at 15:26

    Perl5 has array of hashes ( AoH ) this can be done in perl6 also :

    D:\perl6.scripts\myown>perl6 -v This is Rakudo Star version 2018.01 built on MoarVM version 2018.01 implementing Perl 6.c.

    I am on windows10

    use v6; # create 3 hashes, showing mixed inits that can be used in perl6 : my %hsh0 = ( "Name" => "George H. W. Bush", "Function" => <president o +f USA> , 'Time' => <2001-2009>); my %hsh1 = ( "Name" => "Bill Clinton", "Function" => <president of USA +> , 'Time' => <1993-2001>) ; my %hsh2 = ( "Name" , "Barack Obama", "Function" , <President of USA +> , 'Time' , <2009-2017> ) ; # Subscript Adverbs : :exists :k :v :p :delete #if ( %hsh1<Name>:exists) { # Use this when keys have No Spaces !! my $key = 'Name' ; if ( %hsh1{$key}:k) { # Can I use %hsh1{Name}:exists : Yes works! say "Found Name element in %hsh1"; } # there is an other use for <> construct : , but {} also works!! say %hsh1{}:v.perl; #Show all values say %hsh1.pairs.perl; # push the several hashes onto the array : @arr my @arr ; # Please notice the : after the push @arr.push: { %hsh0 } ; @arr.push: { %hsh1 } ; @arr.push: { %hsh2 } ; # show some entries. using serveral formats that perl6 has : say '@arr.[0].{"Name"} = ' ~ @arr.[0].{'Name'}; say '@arr.[1].<Name> = ' ~ @arr.[1].<Name> ; say @arr.end.fmt('%+4d') ; # How many items ( hashes ) are in the ar +ray. # dump @arr dd @arr; # try looping over the @arr , and detect the keys stored in the hash. +It's more simple than I thought ( after some experimenting ) for 0 .. @arr.end -> $idx { say "@arr idx : $idx"; my %x = @arr[$idx]; for %x.kv -> $key, $value { printf "%10.10s : %-20.20s\n" , $key, $value; # please notice +printf NOT using () ; } }

    Output

    D:\perl6.scripts\myown>perl6 array_hash_3.p6 Found Name element in %hsh1 ($("president", "of", "USA"), "1993-2001", "Bill Clinton") (:Function($("president", "of", "USA")), :Time("1993-2001"), :Name("Bi +ll Clinton")).Seq @arr.[0].{"Name"} = George H. W. Bush @arr.[1].<Name> = Bill Clinton +2 Array @arr = [{:Function($("president", "of", "USA")), :Name("George H +. W. Bush"), :Time("2001-2009")}, {:Function($("president", "of", "US +A")), :Name("Bill Clinton"), :Time("1993-2001")}, {:Function($("Presi +dent", "of", "USA")), :Name("Barack Obama"), :Time("2009-2017")}] @arr idx : 0 Function : president of USA Time : 2001-2009 Name : George H. W. Bush @arr idx : 1 Function : president of USA Time : 1993-2001 Name : Bill Clinton @arr idx : 2 Function : President of USA Time : 2009-2017 Name : Barack Obama

    Could not find any usefull examples on this subject : This is what I came up with.
    Hope it's usefull for somebody else.

     have fun with Perl6
perl6 matrix arrayof arrays
2 direct replies — Read more / Contribute
by teun-arno
on Mar 19, 2018 at 15:03

    Started with perl6 shortly.. perl5 has AoA ... wanted to know if something can be done in perl6...
    It seems that it can be done using perl6 :

    C:\WINDOWS\system32>perl6 -v This is Rakudo Star version 2018.01 built on MoarVM version 2018.01 implementing Perl 6.c.

    So here is the code which works under windows10

    use v6; my @arr = [ [ 1.1,2.2,3.3,4.4,5.5 ], [ 10,20,30,40,50 ], [ 100,200,300,400,500 ], [ 1000,2000,3000,4000,5000 ], ]; dd @arr; # dump the matrix loop ( my $row=0; $row <= @arr.end; $row++) { #say "Idx : $row"; loop (my $col=0 ; $col <= @arr[$row].end ; $col++ ) { print "@arr[$row][$col].fmt("%7.1f")\t"; } print "\n"; } my $aant_cols = ( @arr[0].end ) ; # It's a matrix : so Just take one +row to find out the number of columns # cannot use @arr[0].elems : gives +an error print "=======\t" x $aant_cols + 1 , "\n"; loop ( my $col=0 ; $col <= $aant_cols ; $col++ ) { printf "%7.1f" , [+] @arr[*;$col] ; # calculate the total for each + column print "\t" } say "";

    The above creates the following result

    Array @arr = [1.1, 2.2, 3.3, 4.4, 5.5, 10, 20, 30, 40, 50, 100, 200, 300, 400, 500, 1000, 2000, 3000, 4000, 5000]
        1.1     2.2     3.3     4.4     5.5
       10.0    20.0    30.0    40.0    50.0
      100.0   200.0   300.0   400.0   500.0
     1000.0  2000.0  3000.0  4000.0  5000.0
    ======= ======= ======= ======= =======
     1111.1  2222.2  3333.3  4444.4  5555.5

    Please notice : All columns are totalled ( =sum in excel ) .

    Could not find any usefull examples in the perl6 documentation. So I learned it myself.
    Hope it's of use for sombody else

    Have fun with perl6

Add your CUFP
Title:
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?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and all is quiet...

    How do I use this? | Other CB clients
    Other Users?
    Others making s'mores by the fire in the courtyard of the Monastery: (3)
    As of 2018-06-25 04:26 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      Should cpanminus be part of the standard Perl release?



      Results (126 votes). Check out past polls.

      Notices?