1#!perl
2
3use strict;
4use Test::More;
5use Data::Dumper;
6
7require_ok( "Starlink::AST" );
8require_ok( "Starlink::AST::PGPLOT" );
9
10use File::Spec;
11
12BEGIN {
13 unless (exists $ENV{'DISPLAY'}) {
14   plan skip_all => '$DISPLAY is not set.';
15   exit;
16 }
17
18 eval { require PGPLOT; PGPLOT::pgbegin(0,"/xw",1,1) };
19 if ( $@ ) {
20   plan skip_all => "PGPLOT module not installed.";
21   exit;
22 }
23
24 eval "use Astro::FITS::CFITSIO;";
25 if ( $@ ) {
26   plan skip_all => "Astro::FITS::CFITSIO not installed.";
27   exit;
28 }
29
30 eval "use Astro::FITS::Header::CFITSIO;";
31 if ( $@ ) {
32   plan skip_all => "Astro::FITS::Header::CFITSIO not installed.";
33   exit;
34 }
35
36 plan tests => 5;
37
38};
39
40Starlink::AST::Begin();
41
42# FITS File
43# ---------
44my $file = File::Spec->catfile( "data", "m31.fit" );
45
46# Get FITS Header
47# ---------------
48
49my $header = new Astro::FITS::Header::CFITSIO( File => $file );
50my @cards = $header->cards();
51
52# Make FitsChan
53# -------------
54my $wcsinfo;
55if ($header->can("get_wcs")) {
56  $wcsinfo = $header->get_wcs();
57} else {
58  # Use fallback position
59  $wcsinfo = get_wcs( $header );
60}
61isa_ok( $wcsinfo, "Starlink::AST::FrameSet" );
62
63# Set up window
64# -------------
65my $nx = $header->value("NAXIS1");
66my $ny = $header->value("NAXIS2");
67PGPLOT::pgpage();
68PGPLOT::pgwnad( 0,1,0,1 );
69
70my ( $x1, $x2, $y1, $y2 ) = (0,1,0,1);
71
72my $xscale = ( $x2 - $x1 ) / $nx;
73my $yscale = ( $y2 - $y1 ) / $ny;
74my $scale = ( $xscale < $yscale ) ? $xscale : $yscale;
75my $xleft   = 0.5 * ( $x1 + $x2 - $nx * $scale );
76my $xright  = 0.5 * ( $x1 + $x2 + $nx * $scale );
77my $ybottom = 0.5 * ( $y1 + $y2 - $ny * $scale );
78my $ytop    = 0.5 * ( $y1 + $y2 + $ny * $scale );
79
80# Read data
81# ---------
82my $array = read_file( $file );
83
84PGPLOT::pggray( $array, $nx, $ny, 1, $nx, 1, $ny, 10000, 0,
85  [ $xleft-0.5*$scale, $scale, 0.0, $ybottom-0.5*$scale, 0.0, $scale ] );
86
87# Change FrameSet
88# ---------------
89#$wcsinfo->Set( System => "GALACTIC" );
90
91# AST axes
92# --------
93my $plot = Starlink::AST::Plot->new( $wcsinfo,
94   [$xleft,$ybottom,$xright,$ytop],[0.5,0.5, $nx+0.5, $ny+0.5], "Grid=1");
95isa_ok( $plot, "Starlink::AST::Plot" );
96
97my $status = $plot->pgplot();
98is( $status, 1, "Result from registering PGPLOT with AST" );
99
100#$plot->Set( Colour => 2, Width => 5 );
101$plot->Grid();
102
103# Switch to GRAPHICS frame for easy plotting
104$plot->Set( "Current=1" );
105$plot->Text("Test Text 1", [0.4,0.4],[0.0,1.0],"CC");
106$plot->Set( Colour => 3  );
107$plot->Text("Test Text 2", [0.5,0.5],[0.0,1.0],"CC");
108$plot->Set( Colour => 4 );
109$plot->Text("Test Text 3", [0.6,0.6],[0.0,1.0],"CC");
110
111$plot->Set( Colour => 6, Width => 5 );
112$plot->Mark( 6, [0.6,0.5,0.4], [0.3, 0.2,0.2]  );
113
114$plot->Set( Colour => 2, Width => 5 );
115$plot->PolyCurve( [0.2,0.3,0.25], [0.8,0.5,0.5]);
116
117# Plot some RA/Dec points
118my $ra1 = $wcsinfo->Unformat( 1, "0:40:00" );
119my $dec1 = $wcsinfo->Unformat( 2, "41:30:00" );
120my $ra2 = $wcsinfo->Unformat( 1, "0:44:00" );
121my $dec2 = $wcsinfo->Unformat( 2, "42:00:00" );
122$plot->Set(Current => 3);
123print "\n# Current Frame " . $plot->Get( "Domain" ) . "\n";
124print "# Plotting at $ra1, $dec1\n";
125print "# Plotting at $ra2, $dec2\n";
126
127$plot->Mark(24, [$ra1, $ra2],[$dec1,$dec2]);
128
129# Done!
130sleep(2);
131exit;
132
133sub read_file {
134   my $file = shift;
135
136   my $status = 0;
137   my $fptr = Astro::FITS::CFITSIO::open_file(
138             $file, Astro::FITS::CFITSIO::READONLY(), $status);
139
140   my ($array, $nullarray, $anynull);
141   $fptr->read_pixnull(
142     Astro::FITS::CFITSIO::TLONG(), [1,1], $nx*$ny, $array, $nullarray,
143     $anynull ,$status);
144   $fptr->close_file($status);
145
146   return $array;
147}
148
149# Implementation of the get_wcs method for old versions of Astro::FITS::Header
150
151sub get_wcs {
152  my $self = shift;
153  my $fchan = Starlink::AST::FitsChan->new();
154  for my $i ( $self->cards() ) {
155    $fchan->PutFits( $i, 0);
156  }
157  $fchan->Clear( "Card" );
158  return $fchan->Read();
159}
160