Changes between Initial Version and Version 1 of PerlMapScriptExamples35ex12


Ignore:
Timestamp:
Jan 29, 2009, 6:56:22 AM (15 years ago)
Author:
jmckenna
Comment:

--

Legend:

Unmodified
Added
Removed
Modified

  • PerlMapScriptExamples35ex12

    v1 v1  
     1= plsscalc.pl =
     2{{{
     3#!perl
     4#!/usr/bin/perl
     5
     6## This script finds all the section (s) and quarter-section (qs) combinations
     7# within a given search radius around a given qs origin. This script is for
     8# display output only, hence, it asks for user input, and displays a grid of
     9# found qs. The actual script would be converted into a function that would return
     10# a suitable structure for further computation. The maximum search radius allowed is
     11# 2.5 miles. Higher numbers become non-sensical in that even at 2.5 mi search radius,
     12# an area of more than 19.5 sq mi is searched and 441 qs are returned.
     13#
     14# Puneet Kishor
     15# pkishor@geoanalytics.com
     16# August 2002
     17# Use under the same license as Mapserver
     18
     19## Define the PLSS structure.
     20# Each row is an array of qs in a township.
     21# Each element of the row array is a hash with values for that s and qs.
     22# There are 12 row arrays with 12 qs in each array, hence, a 144 element structure
     23@row0 = (
     24            { s => 6, qs => 'nw' }, { s => 6, qs => 'ne' },
     25            { s => 5, qs => 'nw' }, { s => 5, qs => 'ne' },
     26            { s => 4, qs => 'nw' }, { s => 4, qs => 'ne' },
     27            { s => 3, qs => 'nw' }, { s => 3, qs => 'ne' },
     28            { s => 2, qs => 'nw' }, { s => 2, qs => 'ne' },
     29            { s => 1, qs => 'nw' }, { s => 1, qs => 'ne' }
     30         );
     31@row1 = (
     32            { s => 6, qs => 'sw' }, { s => 6, qs => 'se' },
     33            { s => 5, qs => 'sw' }, { s => 5, qs => 'se' },
     34            { s => 4, qs => 'sw' }, { s => 4, qs => 'se' },
     35            { s => 3, qs => 'sw' }, { s => 3, qs => 'se' },
     36            { s => 2, qs => 'sw' }, { s => 2, qs => 'se' },
     37            { s => 1, qs => 'sw' }, { s => 1, qs => 'se' }
     38         );
     39@row2 = (
     40            { s => 7, qs => 'nw' }, { s => 7, qs => 'ne' },
     41            { s => 8, qs => 'nw' }, { s => 8, qs => 'ne' },
     42            { s => 9, qs => 'nw' }, { s => 9, qs => 'ne' },
     43            { s => 10, qs => 'nw' }, { s => 10, qs => 'ne' },
     44            { s => 11, qs => 'nw' }, { s => 11, qs => 'ne' },
     45            { s => 12, qs => 'nw' }, { s => 12, qs => 'ne' }
     46        );
     47@row3 = (
     48            { s => 7, qs => 'sw' }, { s => 7, qs => 'se' },
     49            { s => 8, qs => 'sw' }, { s => 8, qs => 'se' },
     50            { s => 9, qs => 'sw' }, { s => 9, qs => 'se' },
     51            { s => 10, qs => 'sw' }, { s => 10, qs => 'se' },
     52            { s => 11, qs => 'sw' }, { s => 11, qs => 'se' },
     53            { s => 12, qs => 'sw' }, { s => 12, qs => 'se' }
     54                );
     55@row4 = (
     56            { s => 18, qs => 'nw' }, { s => 18, qs => 'ne' },
     57            { s => 17, qs => 'nw' }, { s => 17, qs => 'ne' },
     58            { s => 16, qs => 'nw' }, { s => 16, qs => 'ne' },
     59            { s => 15, qs => 'nw' }, { s => 15, qs => 'ne' },
     60            { s => 14, qs => 'nw' }, { s => 14, qs => 'ne' },
     61            { s => 13, qs => 'nw' }, { s => 13, qs => 'ne' }
     62        );
     63@row5 = (
     64            { s => 18, qs => 'sw' }, { s => 18, qs => 'se' },
     65            { s => 17, qs => 'sw' }, { s => 17, qs => 'se' },
     66            { s => 16, qs => 'sw' }, { s => 16, qs => 'se' },
     67            { s => 15, qs => 'sw' }, { s => 15, qs => 'se' },
     68            { s => 14, qs => 'sw' }, { s => 14, qs => 'se' },
     69            { s => 13, qs => 'sw' }, { s => 13, qs => 'se' }
     70        );
     71@row6 = (
     72            { s => 19, qs => 'nw' }, { s => 19, qs => 'ne' },
     73            { s => 20, qs => 'nw' }, { s => 20, qs => 'ne' },
     74            { s => 21, qs => 'nw' }, { s => 21, qs => 'ne' },
     75            { s => 22, qs => 'nw' }, { s => 22, qs => 'ne' },
     76            { s => 23, qs => 'nw' }, { s => 23, qs => 'ne' },
     77            { s => 24, qs => 'nw' }, { s => 24, qs => 'ne' }
     78        );
     79@row7 = (
     80            { s => 19, qs => 'sw' }, { s => 19, qs => 'se' },
     81            { s => 20, qs => 'sw' }, { s => 20, qs => 'se' },
     82            { s => 21, qs => 'sw' }, { s => 21, qs => 'se' },
     83            { s => 22, qs => 'sw' }, { s => 22, qs => 'se' },
     84            { s => 23, qs => 'sw' }, { s => 23, qs => 'se' },
     85            { s => 24, qs => 'sw' }, { s => 24, qs => 'se' }
     86        );
     87@row8 = (
     88            { s => 30, qs => 'nw' }, { s => 30, qs => 'ne' },
     89            { s => 29, qs => 'nw' }, { s => 29, qs => 'ne' },
     90            { s => 28, qs => 'nw' }, { s => 28, qs => 'ne' },
     91            { s => 27, qs => 'nw' }, { s => 27, qs => 'ne' },
     92            { s => 26, qs => 'nw' }, { s => 26, qs => 'ne' },
     93            { s => 25, qs => 'nw' }, { s => 25, qs => 'ne' }
     94        );
     95@row9 = (
     96            { s => 30, qs => 'sw' }, { s => 30, qs => 'se' },
     97            { s => 29, qs => 'sw' }, { s => 29, qs => 'se' },
     98            { s => 28, qs => 'sw' }, { s => 28, qs => 'se' },
     99            { s => 27, qs => 'sw' }, { s => 27, qs => 'se' },
     100            { s => 26, qs => 'sw' }, { s => 26, qs => 'se' },
     101            { s => 25, qs => 'sw' }, { s => 25, qs => 'se' }
     102         );
     103@row10 = (
     104            { s => 31, qs => 'nw' }, { s => 31, qs => 'ne' },
     105            { s => 32, qs => 'nw' }, { s => 32, qs => 'ne' },
     106            { s => 33, qs => 'nw' }, { s => 33, qs => 'ne' },
     107            { s => 34, qs => 'nw' }, { s => 34, qs => 'ne' },
     108            { s => 35, qs => 'nw' }, { s => 35, qs => 'ne' },
     109            { s => 36, qs => 'nw' }, { s => 36, qs => 'ne' }
     110         );
     111@row11 = (
     112            { s => 31, qs => 'sw' }, { s => 31, qs => 'se' },
     113            { s => 32, qs => 'sw' }, { s => 32, qs => 'se' },
     114            { s => 33, qs => 'sw' }, { s => 33, qs => 'se' },
     115            { s => 34, qs => 'sw' }, { s => 34, qs => 'se' },
     116            { s => 35, qs => 'sw' }, { s => 35, qs => 'se' },
     117            { s => 36, qs => 'sw' }, { s => 36, qs => 'se' }
     118          );
     119
     120# End PLSS structure
     121
     122## Ask user input for the origin.
     123# Input values are township (t), range (r), s, qs, and search radius (sr).
     124# The sr is calculated in increments of 0.25 miles since each qs is 0.25 m sq.
     125# Maximum sr allowed is 2.5 m. Right now there is some array creation
     126# error for sr greater than 2.5. Also, way too many qs are returned for such
     127# high values.
     128print "Enter a township (10): ";
     129$t = <STDIN>; chop($t);
     130
     131print "Enter a range (10): ";
     132$r = <STDIN>; chop($r);
     133
     134print "Enter a section between 1 and 36 (1): ";
     135$s = <STDIN>; chop($s);
     136
     137print "Enter a quarter-section like ne, nw, se, sw (ne): ";
     138$qs = <STDIN>; chop($qs);
     139
     140print "Enter a search radius less than 2.5 miles (0.5): ";
     141$sr = <STDIN>; chop($sr);
     142# End user input
     143
     144## set some defaults
     145$t = 10 if ($t == "");
     146$r = 10 if ($r == "");
     147$s = 1 if ($s == "");
     148$qs = "ne" if ($qs == "");
     149$sr = 0.5 if ($sr == "");
     150
     151# Given a sr, num_of_skins is the number of "concentric" squares of qs around
     152# our origin. This values has a higher bound of 2.5 m.
     153$num_of_skins = ($sr > 2.5 ? 2.5 / 0.25 : int($sr / 0.25));
     154# End defaults
     155
     156#print "s: $s, qs: $qs, r: $r, n: $num_of_skins \n";
     157
     158## Start calculations
     159# First loop through the PLSS structure row by row.
     160for $i (0..11) {
     161    $thisrow = "row" . $i;
     162   
     163    # For each row, loop through each hash element by element
     164    for $j (0..11) {
     165   
     166        # Check if our s,qs matches the hash
     167        if (($s == $$thisrow[$j]{'s'}) && ($qs eq $$thisrow[$j]{'qs'})) {
     168       
     169            # Calculate the number of qs
     170            $num_of_qs = ($num_of_skins * 2 + 1) * ($num_of_skins * 2 + 1);
     171           
     172            print "\nThe following $num_of_qs qs were found within $sr miles of $t$r$s$qs\n\n";
     173
     174            # Loop through each row in the "concentric" square of qs around our origin.
     175            # Negative rows are above the origin, positive elements are below.
     176            for ($k = -$num_of_skins; $k <= $num_of_skins; $k++) {
     177           
     178                # Find the row number and copy it to a temporary current row
     179                $row = $i + $k;
     180                if ($row < 0) {
     181                    $row += 12;
     182                    $tw = $t + 1;
     183                } elsif ($row > 11) {
     184                    $row -= 12;
     185                    $tw = $t - 1;
     186                } else {
     187                    $tw = $t;
     188                }
     189                $currrow = "row" . $row;
     190                @currrow = @$currrow;
     191               
     192                # Loop through each hash element in the current row. Once again, Negative
     193                # elements are to the left of origin, positive elements are to the right.
     194                for ($l = -$num_of_skins; $l <= $num_of_skins; $l++) {
     195               
     196                    # Calculate each hash element's position correctly
     197                    $cell = $j + $l;
     198                    if ($cell < 0) {
     199                        $cell += 12;
     200                        $rg = $r - 1;
     201                    } elsif ($cell > 11) {
     202                        $cell -= 12;
     203                        $rg = $r + 1;
     204                    } else {
     205                        $rg = $r;
     206                    }
     207                    $sec = $currrow[$cell]{'s'};
     208                   
     209                    ## Prefix a 0 so the output looks pretty (this script is for
     210                    # display only. This step won't be needed in actual computation).
     211                    $tw = "0" . $tw if ($tw < 10);
     212                    $rg = "0" . $rg if ($rg < 10);
     213                    $sec = "0" . $sec if ($sec < 10);
     214                    # End prefix
     215                   
     216                    print " $tw$rg$sec$currrow[$cell]{'qs'} ";
     217                }
     218                print "\n";
     219            }
     220        }
     221    }
     222}
     223}}}
     224----
     225back to PerlMapScript