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 %_;
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:
Write a very useful application!
Use Perl to create, read and write a config file.
Easily edit the config file.
Configure multiple run time variables.
Pass variables between Applescript and Perl.
Handle errors and bad input.
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
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:
Display output from Perl to an Applescript dialog.
Execute Perl in Terminal to display its output.
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:
Visiting websites (Perlmonks of course!)
Displaying notifications
Application control
Applescript subroutines
Abusing buttons to widen dialogs
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
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.
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
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";
}
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";
}
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;
}
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
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;
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 ];
}
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.
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;
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 () ;
}
}
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
