A Perl Based Cave Mapping Program

CaveView
A Perl based Cave Mapping Program
Michael Lake

Table of Contents


Introduction

This document details the program CaveView, which reads CaveMap XML cave map files and outputs a Postscript cave map.

The author can be contacted via email at: Mike.Lake@uts.edu.au

Quick Start

This documentation was written using noweb---a literate programming tool (Ref. [cite noweb]). There is a short document on using noweb in the CaveScript root directory.

Table [->] summarises how to generate the code and documentation using the literate programming tool - noweb.

Table [->] briefly describes simple usage of the main CaveView program - cv.


To create: Run:
All the files: noweb cv.nw
Makefile for this project notangle -t4 -RMakefile cv.nw | cpif Makefile
CaveView program cv:notangle -t4 -L -Rcv cv.nw | cpif cv
LaTeX documentation noweave -t4 -delay -index cv.nw > cv.tex
latex cv.tex
HTML documentation noweave -html -filter l2h -x cv.nw | htmltoc > cv.html
Quick summary of noweb usage [*]

Once the Makefile is created it is much simpler to invoke make than to type all teh notangle or noweave commands. See Section [->] for details on the Makefile.


Run: Input file: Output file:
./cv mycavemycave.xml mycave.ps
gv mycave.ps
Quick summary of cv program usage [*]

Interpreting noweb Cross References

Throughout the dvi and Postscript documentation you will see that each chunk of code is uniquely identified by a page number and an alphabetic sub-page reference. An example is:

10b <cavesurvey.dtd 9>+=== (15) 10a 11

This line tells us that we are now in code chunk 10b. This code chunk is on page 10 and it is the second code chunk defined on this page.

The construct <cavesurvey.dtd 9>+=== tells us that we are in a code chunk called cavesurvey.dtd, that its definition began in chunk 9 and the +=== means we are adding to its definition (noweb concatenates definitions with the same name in order of appearance).

At the right margin we find: (15) 10a 11

This tells us that the chunk we're defining is used within chunk 15, and that this current chunk is continued from chunk 10a and is continued in chunk 11.

At the end of each code chunk a %def is be used to define any variables within that code chunk that we want to cross reference. These defined variables get listed in the noweb index with a page number to where they were defined. The LaTeX hyperref package is being used so this page number will be a hyperlink and show as underlined.

Any defined variables enclosed in double square brackets like this [[variable]] in the documentation text becomes a hyperlink, again to the place where that variable is defined.

Required Perl Modules

The following Perl modules will need to be present on your system. Table [->] lists the modules and the version that is currently being used. The latest versions can be found at the CPAN site (http://www.cpan.org); alternatively the version currently being used for this program can be downloaded from this web site.


Module Name Version used Required For
XML::Parser 2.6 XML parsing
Math::MatrixReal 1.2 Bezier curve calculations
List of required Perl modules. [*]

Makefile for the Project

[*]

The following Makefile provides a convenient way to create the code or documentation after modifications to the noweb source file rather than typing all the notangle or noweave commands. In fact all development is usually done changing the noweb source file and running the appropriate make command. One generally never changes the output files directly (except for quick hacks).

To extract the Makefile:

notangle -t4 -RMakefile cv.nw > Makefile

Run ``make help'' to see what options there are.

One can then modify the noweb source file and extract the new code or documentation.

For instance, after making changes to the program via the noweb source file I run ``make dvi'' to see my changes in xdvi or do a ``make cv'' to create the up-to-date cv program.

<Makefile>=
# Makefile for creating cv scripts

NW_SOURCE = cv.nw

# List of all files for a distribution
DIST_LIST = README
DIST_LIST := $(DIST_LIST) cv.html
DIST_LIST := $(DIST_LIST) cv.tex
DIST_LIST := $(DIST_LIST) cv.ps
DIST_LIST := $(DIST_LIST) cv.nw
DIST_LIST := $(DIST_LIST) cv

# If the user just types 'make' with no args then some help, being the 
# first routine will be invoked.
help:
        @echo 'Usage: make [cv dvi ps html all clean Makefile]'

# Create code and examples
##########################
cv: $(NW_SOURCE)
        notangle -t4 -Rcv $(NW_SOURCE) > cv

# Create Perl Modules
#####################
pm: $(NW_SOURCE)
        notangle -t4 -RBernstein.pm $(NW_SOURCE) | cpif Bernstein.pm
        notangle -t4 -RMyPostscript.pm $(NW_SOURCE) | cpif MyPostscript.pm

Makefile: $(NW_SOURCE)
        notangle -t4 -RMakefile $(NW_SOURCE) | cpif Makefile

# Create documentation
######################
dvi: $(NW_SOURCE)
        noweave -t4 -delay -index $(NW_SOURCE) >| cv.tex
        latex cv.tex
        @echo 
        @echo 'Running "latex cv.tex" ...'
        latex cv.tex
        @echo 'You may need to run latex again.'
        @echo 
        @echo 'latex cv.tex'
        @echo 

ps: dvi
        dvips cv.dvi -o cv.ps

html: $(NW_SOURCE)
        noweave -html -filter l2h -index $(NW_SOURCE) | htmltoc >| cv.html

# Create everything or remove all unnecessary files
###################################################
all: cv dvi ps html
        
clean:
        lintex


The Program

This is where the main program cv is defined ie. what code chunks in noweb make up the program and the order that they need to be in.

<cv>=
<cv main>
<cv xml subroutines1>
<cv xml subroutines2>
<cv survex subroutines>
<cv wall subroutines>
<cv math subroutines>
<cv postscript subroutines>

Preface

TODO History, authors, revision dates etc...

<cv main>= (<-U) [D->]
#!/usr/bin/perl -w

use strict;

####################################################
# Abstract: This program processes a CaveScriptXML Cave Map file
#                       into a Postscript file.
# Usage is: ./cv mycave
#
# Creation Date:                        01-11-1999
# Last Modification Date:       16-04-2000
# This version:                         0.1
#
####################################################

# June 2000: 

Required Modules

The following Perl modules, written by other persons, are required;

<cv main>+= (<-U) [<-D->]
# Perl modules from CPAN
use XML::Parser;                # For XML parsing
use Math::MatrixReal;   # For matrix operations
require Math::Spline;   # TODO do we need this? For Spline curve calculations.

The latest versions can be found at the CPAN site (http://www.cpan.org).

The remaining Perl modules are collections of Perl functions written for this program.

<cv main>+= (<-U) [<-D->]
# My own Perl modules
use Bernstein;                  # For calculating Bernstein co-efficients
use Bezier;                             # For calculating Bezier stuff
use MyPostscript;               # For PostScript lines etc.
use misc;

TODO perldoc -q module h2xs -XA -n My::Module

Variables and Declarations

<cv main>+= (<-U) [<-D->]
my $date;
my $path = "";                  
my $legref;

my $dim=0.4;                                    # fractal dimension of cave wall
my $seed=65000;                                 # random seed for unique cave wall

my $p1;                                                 # Instance of an XML parser
my ($j, $string);
my (@context, $context);
my (@stn_name, @svx_positions);
my ($leg_name);

my $type = "rel";

# Postscript related stuff.
my $PPI   = 72;       # Points per inch in PostScript 
my $MPI   = 2.54;     # Millimetres per inch
my $scale = 100;      # Scale of map 1:scale
my $xf;               # times factor = 72 / (2.54 x scale) 

my ($tmp_abs, @tmp);
my $last_command;
my $join;                               # Flag [0|1] to indicate whether the next WALL DATA 
                                                # should join the last WALL DATA.
my $new_wall;
my @wall_coords_cumulative;

my ($file, $file_xml, $file_ps, $file_svx, $file_pos, $file_3d);
my $oldhandle;

Main

<cv main>+= (<-U) [<-D->]
####################################################
# Start of Main
####################################################

usage(0) if $#ARGV != 0; 
print_title();

$date = `date`;
chop $date;

$file = shift;
#       die "No file specified\nUsage" unless defined($file);

$file_xml = $file.".xml";       # CaveScript XML file
$file_ps  = $file.".ps";        # CaveScript postscript output file
$file_svx = $file.".svx";       # Survex data file
$file_pos = $file.".pos";       # Survex position file
$file_3d  = $file.".3d";        # Survex 3d file

print "Running Cavern and writing 3d & position file...\n";
# Note: output 3d file in ASCII for the present.
system ("cd shot_data; cavern -a $file_svx > /dev/null; cd ..");

# Survex printps is setup to create a file called 'Printout.ps'
# this is here so a comparison can be made if required.
#print "Running Survex printps and writing postscript file...\n";
#system ("cd shot_data; printps -n -p --scale=1:100 $file_3d > /dev/null; cd ..");


# Check that we have a well formed document
# -----------------------------------------
# If no style is specified the parser will just check for well-formedness.
$p1 = new XML::Parser();
if ($p1->parsefile($file_xml))
{
        print "File: ", $file_xml, " parses OK.\n";
}
else
{
        print "Document not well-formed!\n";
        exit(0);
}


# Setup the style of Parser that we want for use later
# ----------------------------------------------------
# OK if we are here we have at least a well formed document to play with.
$p1 = new XML::Parser(Style => 'Subs', ErrorContext => 2);
$p1->setHandlers(       XMLDecl => \&handle_decl,
                                        Doctype => \&handle_doctype,
                        Comment => \&handle_comment,
                        Char    => \&handle_char
                );


# Read our Survex position information and open required files
# ------------------------------------------------------------
@svx_positions = read_pos_file("shot_data/".$file_pos);
# print_array(@svx_positions);
#$path = $path.".";

# Open a file handle for writing CaveScript Map to.
open (FILE_PS, ">$file_ps") ||
        die "Cannot open file $file_ps for writing\!";


# Write the start of our Postscript file
# --------------------------------------
$xf = 100 * $PPI/($MPI * $scale);
$oldhandle = select FILE_PS;
write_ps_header();
write_ps_defines();
write_ps_survex();
write_ps_debug();
select $oldhandle; 


# Parse our CaveScript XML file
# -----------------------------
print "Parsing CaveScript-XML file...\n";
print $p1->parsefile($file_xml);


# Finish up
# ---------
$oldhandle = select FILE_PS;
nice_ps_title();
print "showpage\n";
write_ps_trailer(0,0,595,842);
select $oldhandle; 
close (FILE_PS);


####################################################
# End of Main
####################################################

Small Functions

<cv main>+= (<-U) [<-D]
sub print_title
{
print <<Title;

**************************************
***        CaveView v0.1           ***
*** A System for Drawing Cave Maps ***
***         Mike Lake              *** 
**************************************

Title
}

sub usage
{
        my $error_level = @_;
        print "Usage is: $0 xml_file (no extension)\n";
        exit($error_level);
}


XML Subroutines

Subroutines 1

<cv xml subroutines1>= (<-U)
sub handle_decl 
{
        my ($p, $Version, $Encoding, $Standalone) = @_;
        print FILE_PS "\n% CaveScript XML CaveMap FILE";
        print FILE_PS "\n% ---------------------------";
        print FILE_PS "\n% XML: Ver=$Version\n";
}

sub handle_doctype
{
        my ($p, $Name, $Sysid, $Pubid, $Internal) = @_;
        print FILE_PS "% Sys=$Sysid\n";
}

sub handle_comment
{
        # Comments in the Postscript output won't be seen by a user so
        # we could prob dispense with any comment processing.
        #my ($p, $string) = @_;
        #$string = trim_whitespace($string);
        #print "\nXML Comment: $string\n";
}

sub handle_default
{
        # covers situation where there is no registered handler
        my ($p, $string) = @_;

        # debug line
    #my $line = $p->current_line; print "$line DEFAULT ";

        $string = trim_whitespace($string);
    if ($string eq "") {return;}

    my $line = $p->current_line; print ;
        print  "Line ", $line, " Unknown tag, data: ", $string, "\n";
}

sub handle_char
{
        my ($p, $string) = @_;
        my ($current_element);
        my (@tmp, @wall_coords_rel, @wall_coords_abs);

        # debug line
    #my $line = $p->current_line; 
        #print "$line CHAR ";

        # remove leading and trailing whitespace - including newlines 
        $string = trim_whitespace($string);
        # return if the string is null
        if ($string eq "") 
        {
                # debug line
        #my $line = $p->current_line; 
                #print "$line CHAR NONE\n";
                return;
        }

        # Obtain the context of the string ie what is the current element we
        # are in? Is it a WALL or AVEN or DATA etc...
        $current_element = $p->current_element;
        @context = $p->context;
        $context = join (" ", @context);

        # debug line
        # print "We are ", $p->depth; print " elements deep ";
        # print "within $context \n";

        # Now an elseif for all tags

        # Wall Data
        if( $context =~ /WALL/ && $current_element =~ /DATA/ )
        {
                @wall_coords_rel = extract_wall_data($string);
                if ($#wall_coords_rel == 0)
                {
                        print "\nError: no wall data within WALL.DATA element!";
                        print "\n  Subroutine handle_char()";
                        exit(0);
                }
                else
                {
                        # why doesn't this line work using push() ?
                        # @wall_coords_cumulative = push(@wall_coords_cumulative, @wall_coords);
                        @wall_coords_abs = transform_coords(@wall_coords_rel);
                        @tmp = (@wall_coords_cumulative, @wall_coords_abs);
                        @wall_coords_cumulative = @tmp;
                }
        }

        # Wall XSpline data
        elsif( $context =~ /WALL/ && $current_element =~ /XSPLINE/  )
        {
                process_xspline_data($string); 
        }

        # TODO There's no Data in a <BR/> 
        elsif( $context =~ /BR/ && $current_element =~ /DATA/  )
        {
                # The next string of wall data does not nessessarily have
                # C1 continuity with the last string of data.
                # print "moveto $string curveto close\n";
        }

        # Aven Data
        elsif( $context =~ /AVEN/ && $current_element =~ /DATA/  )
        {
                @wall_coords_rel = extract_wall_data($string);
                if ($#wall_coords_rel == 0)
                {
                        print "\nError: no wall data within WALL.DATA element!";
                        print "\n  Subroutine handle_char()";
                        exit(0);
                }
                else
                {
                        # why doesn't this line work using push() ?
                        # @wall_coords_cumulative = push(@wall_coords_cumulative, @wall_coords);
                        @wall_coords_abs = transform_coords(@wall_coords_rel);
                        @tmp = (@wall_coords_cumulative, @wall_coords_abs);
                        @wall_coords_cumulative = @tmp;
                }
        }

        else
        {
        my $line = $p->current_line;
                print "Line $line: Unknown context for char data: $string\n";
        }       
}


Subroutines 2

STYLES

Subs

Each time an element starts, a subroutine by that name in the package specified by the Pkg option is called with the same parameters that the Start handler gets called with.

Similarly each time an element ends, a subroutine with that name appended with an underscore (_), is called with the same parameters that the End handler gets called with.

This is specified like so...

$p1 = new XML::Parser(Style => 'Subs', ErrorContext => 2);

<cv xml subroutines2>= (<-U)
# TODO If I return values from these how do I access the return value?

sub CAVEMAP
{
        print "CAVEMAP\n";
}

sub CAVEMAP_
{
        print "\n";
}

sub BR
{ 
        my ($p, $element, %attr) = @_;
        print "BREAK\n";
}

sub AVEN
{
        my ($p, $element, %attr) = @_;

        if (%attr)
        { 
                # Must test for a null attr and only if not null print it otherwise the 
                # print will raise an error. This only occurs if an element has zero 
                # attributes. 
                print         "\nAVEN ";
        print FILE_PS "\n% AVEN ";

                # Avens can have a name.        
                if ($attr{"NAME"})      
                {
                        print         "NAME=", $attr{"NAME"};
                print FILE_PS "NAME=", $attr{"NAME"};   # Helps debug Postscript file.
                }
        } print FILE_PS "\n";


}

sub AVEN_
{
        # Now we have all the DATA coordinates as one array and we are going to write
        # a new aven section so begin a new PostScript path.
    print FILE_PS "\nnewpath\n";
        draw_wall_lines(@wall_coords_cumulative);
        # End of the wall section so stroke the data onto the PostScript path.
    printf FILE_PS "closepath\n";
    printf FILE_PS "stroke\n";

        # Clean up
        @wall_coords_cumulative = (); # Clear cumulative data from the wall array.
}

sub WALL
{ 
        my ($p, $element, %attr) = @_;

        if (%attr)
        { 
                # Must test for a null attr and only if not null print it otherwise the 
                # print will raise an error. This only occurs if an element has zero 
                # attributes. 
                print         "\nWALL ";
        print FILE_PS "\n% WALL ";

                # Walls can have a name.        
                if ($attr{"NAME"})      
                {
                        print         "NAME=", $attr{"NAME"};
                print FILE_PS "NAME=", $attr{"NAME"};   # Helps debug Postscript file.
                }

                # A WALL element can append a Survex "path" which will apply to all
                # DATA elements within that WALL. This is the same as when Survex
                # has a *begin statement. Note that _WALL must remove anything that
                # we append here.
                # TODO We should probably have this as an element within WALL like;
                # <BEGIN PREFIX="extension"> <DATA> etc....</DATA> </BEGIN>
                # which surrounds the DATA we want to scope.
                if ($attr{"BEGIN"})     
                {
                        $path = $attr{"BEGIN"}.".";
                        print "  BEGIN=$path";
                }
        } print FILE_PS "\n";

        # Set the flag which indicates that the next WALL DATA should join the 
        # last WALL DATA.       
        #$new_wall = 1;
}

sub WALL_
{
        # Now we have all the DATA coordinates as one array and we are going to write
        # a new wall section so begin a new PostScript path.
    print FILE_PS "\nnewpath\n";
        draw_wall_lines(@wall_coords_cumulative);
        # End of the wall section so stroke the data onto the PostScript path.
    printf FILE_PS "stroke\n";

        # Clean up
        @wall_coords_cumulative = (); # Clear cumulative data from the wall array.
}

sub DATA
{ 
        my ($p, $element, %attr) = @_;

        $legref = $attr{"REF"};         
        if ( $legref =~ /,/) #Test if input string contains sub-string ','
        # eg. <DATA REF="85,86">
        {       
                # TODO Some countries use a comma for decimal pt. Really need to 
                # check for ...
                # Wall is WRT a survey leg. 
                @stn_name = split(/,/, $legref);
                # eg. @stn_name will now be (85, 86)
        }
        else
        # eg. <DATA REF="86">
        {
        # Wall is WRT a single station. "stn_name" is like "80"
        @stn_name = $legref; # This will be a one element array.
        }
        # At this point @stn_name is either a one or two dim array.
        # TODO we need to check for a null ie no station specified like.
        # eg. <DATA REF="">
}

sub DATA_
{ 
        my ($p, $element, %attr) = @_;
        #print "curveto\n";
        #if (!$join)
        #{
        #       print "curveto\n";
        #}
        $new_wall = 0;
}

sub XSPLINE
{
        my ($p, $element, %attr) = @_;
        print "\nXSPLINE\n";
}

sub XSPLINE_
{
        my ($p, $element, %attr) = @_;
        print "\n";
}

sub FRACT
{
        my ($p, $element, %attr) = @_;
        $dim = $attr{"DIM"};
        $seed = $attr{"SEED"};
        print "Fractal dim=", $dim, " seed=", $seed, "\n";
}

sub SERIES
{
        my ($p, $element, %attr) = @_;
        print "SERIES ", $attr{"NAME"};
        print "\n";
}

sub STN
{
        my ($p, $element, %attr) = @_;

        # The %attr should be non-null as all stations must have at least an "ID".
        if ($attr{"DESC"})
        {
                # DESC attr is non-null ie there is a description so print it.
                print %%, " ", $attr{"ID"}, "; ", $attr{"DESC"}, "\n";
        }
        else
        {
                # DESC attr is null ie no description so don't print the semicolon..
                print %%, " ", $attr{"ID"}, "\n";
        }
}

sub SHOT
{ 
        my ($p, $element, %attr) = @_;
        print "%% ";
        print $attr{"FROM"}, "\t", $attr{"TO"}, "\t";
        print $attr{"DIST"}, "\t", $attr{"BEAR"}, "\t", $attr{"ELEV"};
        print "\n";
}

Survex subroutines

The Survex position file, mycave.pos, created when cavern is run contains the locations of all survey stations. Function read_pos_file reads this file and returns an array where each line of the array is the easting, northing, height and name of a station.

mycave.pos is like:

        ( Easting, Northing, Altitude )
        (    0.50,     2.00,     0.00 ) \mycave.85
        (    9.77,     5.56,    -1.22 ) \mycave.86

The array @svx_positions is like:

     Easting   Northing  Altitude
     0.50      2.00      0.00   \mycave.85
     9.77      5.56     -1.22   \mycave.86

Usage example: @svx_positions = read_pos_file("shot_data/".$file_pos);

<cv survex subroutines>= (<-U) [D->]
# Read in a Survex format position file and return an array of positions. 
sub read_pos_file
{
        # Open files.
        my ($file_in) = @_;
        my ($i, @svx_positions);

        # print "\nUsing input file: $_[0]\n";
        open (IN,  $file_in) ||
           die "Cannot open file $file_in for reading\!";

        # The Survex position file is like this:
        # ( Easting, Northing, Altitude )
        # (    0.50,     2.00,     0.00 ) \mycave.85
        # (    9.77,     5.56,    -1.22 ) \mycave.86
        $i=0;
        while (<IN>) 
        {
                # Get rid of the opening brackets ie (
                s/\(/ /g; 
                # Get rid of the closing brackets ie )
                s/\)/ /g; 
                # Get rid of the commas.
                s/,/ /g;
                # Get rid of leading spaces.
                s/^\s+//;
                chomp;
                push (@svx_positions, $_);
        }
        # The Survex position array returned is now like this:
    # Easting   Northing  Altitude
    # 0.50      2.00      0.00   \mycave.85
    # 9.77      5.56     -1.22   \mycave.86
        return @svx_positions;

        close (IN);
}

This function is passed a string containing a station name and an array of the survex positions. The function looks up the station name and returns the co-ordinates of the station as an array of two numbers.

Usage example: ($x1, $y1) = lookup_pos($path.$stn_name[0], @svx_positions);

<cv survex subroutines>+= (<-U) [<-D]
sub lookup_pos
{
        # This function is passed a string containing a station name 
        # and an array of the survex positions. The function looks up the 
        # station name and returns the co-ordinates of the station
        # as an array of two numbers.

        # TODO - make a hash table of key=mycave.88 value = "coord string"
        # This would be much faster!

        my ($i, $stn_name_full, @svx_positions, @stn_data, @coord);

        ($stn_name_full, @svx_positions) = @_;
        #print "\nLooking for $stn_name_full ..."; 

        for ($i=0; $i<=$#svx_positions; $i++)
        {
                if ($svx_positions[$i] =~ /$stn_name_full$/) 
                # TODO more reliable pattern match!
                {
                        # print " Found $stn_name_full on line $i\n";
                        @stn_data = split(/\s+/, $svx_positions[$i]);
                        last;   # Found station so break out of for loop.
                }
        } 

        @coord = ($stn_data[0], $stn_data[1]);
        return @coord;
}


Wall Calculation and Drawing Subroutines

<cv wall subroutines>= (<-U)

sub extract_wall_data
{
        my $data = $_[0];
        my (@wall_coords_rel, $array_size);

        @wall_coords_rel = split(/\s+/, $data); # eg. -0.81 0.0 -0.07 1.0 etc... 

    # Note: array_size of the wall data must be an even number as the 
        # array was pairs of wall coordinates. Here we can do a data 
        # integrity test.
    $array_size = @wall_coords_rel;       # eg. $array_size will be 12 
        if ($array_size % 2)    # Modulus ie remainder after division by 2      
        {
                print "\nError: data must be PAIRS of coordinates, ";
                print "you seem to have an odd number.";
                print "\n  Subroutine extract_wall_data()";
                # TODO - how should we exit this function here?
                return 1;
        }

        return @wall_coords_rel;
}

sub draw_wall_lines 
{
        # Usage: draw_wall_lines(@wall_coords_cumulative);

        # There are two code sections here.
        # 1. for drawing straight line segments from the XML file DATA sections
        # 2. for drawing Bezier segments from the XML file DATA sections
        # Use one or the other by setting $BEZIERS = 0 or 1
        my $BEZIERS = 1;

        # Assign wall elements to array
        # -----------------------------
        # This is a big long array of all the wall coordinates for the entire
        # WALL element.
        my @wall_coords = @_;   
        my $array_size = @wall_coords;

        # Data integrity check
        # --------------------
    # Note: array_size of the wall data must be an even number as the 
        # array was pairs of wall coordinates. Here we can do a data 
        # integrity test eg. $array_size might be 12 
        if ($array_size % 2)    # Modulus ie remainder after division by 2      
        {
                print "Error: data must be PAIRS of coordinates, ";
                print "you seem to have an odd number.";
                print "\n  Subroutine draw_wall_lines()";
                # TODO - how should we exit this function here?
                return 1;
        }
        # debug lines
        # print "Abs wall coordinates.";
        # print "\nArray size:", $array_size, "\n"; print_array(@wall_coords); 


        # Print a comment to the Postscript file for readability.
        print FILE_PS "\n% WALL LINES\n";
        print FILE_PS "% ------------\n";


        # Here is where we choose between the two code sections.        
        if (!$BEZIERS)
        {
                # BEGIN Code for using straight line segments in the XML file DATA sections.
                my ($i, $x, $y);                                                                        # for straight lines
                $x = $wall_coords[0];
                $y = $wall_coords[1]; 
                printf FILE_PS "%-.3f %-.3f moveto\n", $xf*$x, $xf*$y; 

                for ($i=2; $i<$array_size; $i=$i+2)
                {
                        $x = $wall_coords[$i]; 
                        $y = $wall_coords[$i+1]; 
                        printf FILE_PS "%-.3f %-.3f lineto\n", $xf*$x, $xf*$y;
                }
                # END Code for using straight line segments in the XML file DATA sections.
        }
        else
        {
                # BEGIN Code for using Beziers in the XML file DATA sections.
                # TODO @wall_coords is an array of points for a 'long' Bezier of degree
                # greater than 3. We need to split this into short degree 3 Beziers.
                my ($i, $row, $rows, $cols, @array);
                my ($cBezier, $qBezier, $lBezier, $rVector);
                my ($x1, $y1, $x2, $y2, $x3, $y3, $x4, $y4);    # for Beziers

                # We need to create a subroutine which takes a long Bezier (ie a long 
                # array of x,y points) and creates another array which will be
                # longer and each group of four points will be a short Bezier.
 
                # @sBeziers = (@lBezier)        # where @lBezier = @wall_coords
                $rows = $array_size/2;
                $lBezier = Math::MatrixReal->new($rows,2);
                
                $i = 0;
                for ($row=1; $row<=$rows; $row++)
                {
                        $lBezier->assign($row,1,$xf*$wall_coords[$i]);          # assign x coord
                        $lBezier->assign($row,2,$xf*$wall_coords[$i+1]);        # assign y coord        
                        $i = $i + 2;
                }
                # debug lines
                # print "The lBezier values are scaled up from the abs wall_coordinates\n";
                # print "by: ", $xf, " times.\n"; 
                # print $lBezier; # Debug line.

                # Calculate the cubic Bezier object.
                ($cBezier, $qBezier) = Blong2Bcubic($lBezier);
                # print $cBezier; # Debug line.

                ($rows, $cols) = $cBezier->dim();               # $cols should always be 2.

                # Draw lines of our calculated Bezier
                for ($row=1; $row<=$rows; $row++)
                {
                        $rVector = $cBezier->row($row);
                        $rVector =~ s/\[|\]|\n//g;
                        $_ = $rVector; 
                        #@array = split(/\s+/, $rVECTOR); # DOES NOT WORK 
                        # There is an  extra field at start!
                        # We have to convert string data like -6.71E-03 to real number format
                        @array = split;
                        printf FILE_PS "%.0f %.0f moveto\n", $array[0], $array[1];
                        for ($i=2; $i<=7; $i=$i+2)
                        {
                        printf FILE_PS "%.0f %.0f ", $array[$i], $array[$i+1];
                        }
                        printf FILE_PS "curveto\n"; 

                        # Debug line - show calculated cubic bezier.
                        #for ($i=0; $i<=7; $i=$i+2)
                        #{
                    #   printf FILE_PS "%.0f %.0f small_cross\n", $array[$i], $array[$i+1];
                        #}
                }

        # Debugging - show Bezier points.       
        $oldhandle = select FILE_PS;
        #label_points($qBezier, "small_circle");        # Quadratic Bezier points
        #label_points($cBezier, "small_circle");        # Cubic Bezier points
        #label_points($lBezier, "small_circle");        # Long Bezier points
        select $oldhandle; 

        } # END Code for using Beziers in the XML file DATA sections.
}


sub process_xspline_data
{
        my $data = $_[0];
        my (@xspline_array, $array_size);

        @xspline_array = split(/\s+/, $data); # eg. 0 0 0 1 1 0 0 etc...

    # Note: array_size of the x-spline data must be te same size as the wall
        # data that it refers to. We should check this.
        # TODO
    $array_size = @xspline_array;

        print "X-Spline data: ", $data;
}


Math Subroutines

H = frac(x_a - x_b)^2 + (y_a - y_b)^2

However, sintheta= fracx_b - x_aH and costheta= fracy_b - y_aH
x_1 --- = --- x_a + y_1 sintheta+ x_1 costheta
--- = --- x_a + fracy_1(x_b - x_a)H + fracx_1(y_b - y_a)H

and similarly ...

y_1 --- = --- y_a + y_1 costheta+ x_1 sintheta
--- = --- y_a + fracy_1(y_b - y_a)H + fracx_1(x_b - x_a)H

Notice that we can't use the leg length of the survey shot as this measurement has not had any closure corrections applied to it so we have to calculate the hypotenuse.


<cv math subroutines>= (<-U)

####################################################
# Maths for coordinate transformations
####################################################

sub transform_coords
{
        my ($xa, $xb, $ya, $yb, $x, $y);
        my (@wall_coords_rel, @wall_coords_abs, $array_size);

        @wall_coords_rel = @_;
    $array_size = @wall_coords_rel;

        # We already have the array of station names that the wall data is 
        # relative to. This array, @stn_name, is either a 1 or 2 dim array.
        # If it's a 1 dim array $#stn_name == 0 ie wall WRT a single station or 
        # if it's a 2 dim array $#stn_name == 1 ie wall WRT a survey leg.

        # Wall is relative to a single station.
        if ( $#stn_name == 0 )
        {
        # Wall is WRT a single station. "stn_name" is like "80"
        ($xa, $ya) = lookup_pos($path.$stn_name[0], @svx_positions);

                # debug line
                # print "\n   Stn $path$stn_name[0] at ($xa, $ya)";

        for ($j=0; $j<$array_size; $j=$j+2)
        {
                        $x = $wall_coords_rel[$j]; 
                        $y = $wall_coords_rel[$j+1]; 
                        # debug line
                        # printf "\nbefore translate (x,y) = %4.2f %4.2f", $x, $y;
                        ($x, $y) = translate($x, $y, $xa, $ya);
                        # debug line
                        # printf "\nafter                  = %4.2f %4.2f", $x, $y;
                push(@wall_coords_abs, $x, $y);
                        # Draw small squares around wall coordinates wrt single stations.
                        # printf FILE_PS "%-.2f %-.2f small_square\n", $xf*$x, $xf*$y;
        }
        }
        # Wall is relative to a survey leg.
        elsif ( $#stn_name == 1 )
        {
                # eg. @stn_name will be (85, 86)
        ($xa, $ya) = lookup_pos($path.$stn_name[0], @svx_positions);
        ($xb, $yb) = lookup_pos($path.$stn_name[1], @svx_positions);

                # debug lines
                # print "\n   Stn $path$stn_name[0] at ($xa, $ya) to";
                # print  " Stn $path$stn_name[1] at ($xb, $yb)";

        for ($j=0; $j<$array_size; $j=$j+2)  # eg. for 0,1
        {
                        $x = $wall_coords_rel[$j]; 
                        $y = $wall_coords_rel[$j+1]; 
                        # debug line
                        # printf "\nbefore rotate, translate (x,y) = %4.2f %4.2f", $x, $y;
                        ($x, $y) = rotate($x, $y, $xa, $ya, $xb, $yb); 
                        ($x, $y) = translate($x, $y, $xa, $ya);
                        # debug line
                        # printf "\nafter                          = %4.2f %4.2f", $x, $y;
                push(@wall_coords_abs, $x, $y);
                        # Draw small circles around wall coordinates wrt legs.
                        # printf FILE_PS "%-.2f %-.2f small_circle\n", $xf*$x, $xf*$y;
        }
        }
        # TODO this doesn't seem to pick up <DATA REF="">
        elsif ( $#stn_name eq "" )
        {
                print "\nError: no stations were specified in the DATA REF attribute.\n";
        }
        elsif ( $#stn_name > 1 )
        {
                print "\nError: more than 2 stations were specified in the ";
                print "DATA REF attribute.\n";
        }
        else
        {
                print "\nShould never be here in extract_wall_data()\n";
        }
        return @wall_coords_abs;
}

sub interpolate
{
        # Usage: return interpolate(0.5, @wall_coords_abs);
        my ($dx, @in_array) = @_;

        my @out_array;
        my ($x, $y, $spline, $spline_size, @sx, @sy, $i);
        my $in_size = @in_array;

        for ($i=0; $i<=$in_size-1; $i=$i+2)
        {
                push(@sx, $in_array[$i]);
                push(@sy, $in_array[$i+1]);
        }

        $spline_size = @sx;     # Note $spline_size is the total number of elements eg. 8
                                                # while $#sx is the number of the last element ie. 7 

        $spline = new Math::Spline(\@sx,\@sy);

        for ($x=$sx[1]; $x<=$sx[$spline_size-1]; $x=$x+$dx)
        {
                $y = $spline->evaluate($x);
                push(@out_array, $x);
                push(@out_array, $y);
        }
        return @out_array;
}

sub coords_add
{
        my ($x, $y, $xo, $yo);

        ($x, $y, $xo, $yo)= @_; 

        $x = $x + $xo; 
        $y = $y + $yo; 

        return $x, $y;
}

sub coords_sub
{
        my ($x, $y, $xo, $yo);

        ($x, $y, $xo, $yo)= @_; 

        $x = $x - $xo; 
        $y = $y - $yo; 

        return $x, $y;
}


sub rotate
{
  # Arguments are a pair of x y values defining the coordinates of a    
  # a point on the cave wall followed by two pairs of x y values being the
  # the TO and FROM survey coordinates. Hence there must be exactly 6 floats
  # as the arguments. 
  # xa ya x1 y1 x2 y2 where     a = point on the cave wall
  #                                                     1 = from station
  #                                                     2 = to station 
 
  my ($data, $tmp, @tmp);
  my ($xa, $ya);
  my ($x1, $y1, $x2, $y2, $hypot, $cosA, $sinA);
  my ($Xa, $Ya);

  ($xa, $ya, $x1, $y1, $x2, $y2) = @_;

  # Matrix equation for the orthogonal transformation is below
  # for a coordinate translation and clockwise rotation. 
  # Notice that the translation is done BEFORE the rotation and
  # formula below is for rotating a coordinate system clockwise with the 
  # angle increasing in value clockwise.

  # |x'|   | cos@ -sin@ | |x - x1|  where @ stands for angle theta.
  # |  | = |            |*|      |  ie @ = survey leg bearing! 
  # |y'|   | sin@  cos@ | |y - y1|

  # Here we will multiply by the deltaX and deltaY then divide by the 
  # hypotenuse rather than obtaining the actual bearing from the '.svx' file 
  # and taking the cos and sin of this.
  $hypot = sqrt( ($x1-$x2)*($x1-$x2) + ($y1-$y2)*($y1-$y2) ); 
        #print " hypot=$hypot\n";       
 
  # Let cosA be the cosine of the Angle that the survey leg makes with 
  # the original xy axes (ie NE axes) and sinA be likewise.
  $cosA = ($y2-$y1) / $hypot; # Order does not matter as -cos = +cos

  # For relative -> absolute: 
  # We need to reverse the angle of the rotation which can be done easily here.
  $sinA = ($x1-$x2) / $hypot;

  # Now we do the rotation.
  $Xa =  $cosA * $xa - $sinA * $ya; 
  $Ya =  $sinA * $xa + $cosA * $ya;

  # Now the X's and Y's are the new coords WRT the survey legs.
  @tmp = ($Xa, $Ya);
  return @tmp;
}

sub translate
{

        # Arguments are a pair of x y coords being the absolute data coordinates        
        # and a survey point they are to be relative to.
 
        my ($xa, $ya);          # Note lowercase x and y
        my ($Xa, $Ya);          # Note uppercase X and Y
        my ($x1, $y1); 
 
        ($xa, $ya, $x1, $y1) = @_; 

        ($Xa, $Ya) = coords_add($xa, $ya, $x1, $y1);

        return ($Xa, $Ya)
}


Postscript Subroutines

<cv postscript subroutines>= (<-U)

sub write_ps_debug
{
        my ($i, @coords);
        print FILE_PS "\n% CROSSES AT STATION POSITIONS\n";
        print FILE_PS "% ----------------------------\n";
        print FILE_PS "0.5 setlinewidth\n";
        @coords = split(/\s+/, $svx_positions[1]);
        for ($i=1; $i<=$#svx_positions; $i++)
        {
        @coords = split(/\s+/, $svx_positions[$i]);
        printf FILE_PS "%-.2f %-.2f small_cross\n", $xf*$coords[0], $xf*$coords[1];
        }
        print FILE_PS "1 setlinewidth\n";
}

sub nice_ps_title
{
# Ref: PostScript Language Tutorial and Cookbook, Adobe, p68
print <<TITLE;
/Times-Roman findfont 30 scalefont setfont
/printTitle
{ 0 0 moveto (CaveScript) show} def
100 700 translate
0.8 -0.25 0 % start increment end
{setgray printTitle -1 0.5 translate} for
1 setgray printTitle
TITLE
}


sub write_ps_survex 
{

my $file_3d_in  = "shot_data/mycave.3d";

# Open the Survex 3d file and read in #
open (FILE_3D_IN, "$file_3d_in" ) ||
   die "Cannot open file $_[0] for reading\!";

print FILE_PS "% SURVEY LEGS FROM SURVEX IMAGE FILE\n";
print FILE_PS "% ----------------------------------\n";
print FILE_PS "0.5 setlinewidth\n";

while (<FILE_3D_IN>) 
{
        s/^\s+//; # get rid of leading spaces.
        chomp;  
        @tmp = split;   # may as well split it now as we will use it.
        
        # Survex title, version or blank line
        if ( /^Survex/ || /^v/ ) 
        {
          printf FILE_PS "%s\n", "% ".$_;
        }

        # Survex 3d move command. If there is a move command it may have been preceded
        # by a draw command, in which case we will need to stroke that previous path
        # otherwise it won't show - hence the initial stroke.
        # Now we can start the move - a move means we are going to start a new path. 
        # Moves are followed by draw commands.
        elsif (/^move/)
        {
          # Survex:    move      0.50      2.00      0.00
          # Postcript: 176   577 moveto
          print FILE_PS "stroke newpath\n";
          printf FILE_PS "%-.2f %-.2f M\n", $xf*$tmp[1], $xf*$tmp[2];
        }

        # Survex 3d draw command
        elsif (/^draw/)
        {
          # Survex:     draw     10.04      5.66     -1.26
          # PostScript: 176   577 lineto
          printf FILE_PS "%-.2f %-.2f L\n", $xf*$tmp[1], $xf*$tmp[2];
          $last_command = "L";
        }

        # Survex 3d name command
        elsif (/^name/)
        {
                # Survex: name \mycave.89     10.04      5.66     -1.26
                # PostScript: 10.04  5.66 moveto (\mycave.89) show
                if ( $last_command eq "L" )
                { 
                        print FILE_PS "stroke\n\n";  $last_command = ""
                }
                if ( $last_command ne "N" ) 
                { 
                        print FILE_PS "newpath\n"; 
                }
                # We have two spaces before the stn name to avoid hitting stn symbol.
                printf FILE_PS "%-.2f %-.2f M (  %s) S\n", $xf*$tmp[2], $xf*$tmp[3], $tmp[1];
                $last_command = "N";
        }
        else
        { 
          printf FILE_PS "%s\n", "% What's this: ".$_;
        }
}
close (IN);

print FILE_PS "1 setlinewidth\n";

}


To Do

This is a dis-organised list of things to do.

Defined Chunks

[*]

Index