Category : Files from Magazines
Archive   : CARTOG1.ZIP
Filename : CART87.PAS

{$R-} { Range checking off }
{$B-} { Boolean complete evaluation off }
{$S+} { Stack checking on }
{$I+} { I/O checking on }
{$N-} { Numeric coprocessor }
{$V-} { Allow dynamic string arguments }
{$M 65500,16384,655360} {Turbo 3 default stack and heap}

PROGRAM MultiCard_Cartog;

Uses
Crt, Metagraf;

CONST Sqrt2 = 1.4142135623731;
PI = 3.1415926535898;
HalfPI = 1.5707963267949;
TwoPI = 6.2831853071796;
Radian = 1.7453292519943E-2;
RadianDiv100 = 1.7453292519943E-4; { PI/180/100, needed to convert }
{ data in WORLD.DAT to radians }

CONST XCENTER : INTEGER = 360; { Hercules Graphics constants. }
YCENTER : INTEGER = 174; { Screen center X and Y }
ASPECT : REAL = 1.5; { 720x348 aspect ratio }
R : REAL = 70; { Default map radius }
NotVisible : INTEGER = -32767; { Flag for point visibility }

TYPE LLREC = RECORD
CODE : ARRAY[0..1] OF CHAR;
LONGI, LATI: INTEGER; END;

TYPE S255 = STRING[255];
S64 = STRING[64];

VAR GrafixCard, Z: integer;
VAR scrnR: rect;

VAR LL : LLREC;
LLF : FILE OF LLREC;
FN, F,
SWITCHES : S64;

VAR LastX, LastY, XP, YP : INTEGER; { Save variables for plotting }
COLOR_GLB, P : INTEGER;

VAR I, J, K, MapType, M, X1,Y1,
X2, Y2, SX, SY, CENTER : INTEGER;

VAR L, L1, LONGR, LSTEP,
B, LATR, BSTEP, X, Y,
PHI1, Lambda0 : REAL;

VAR XX, YY, SA, SB : REAL;

VAR LastPtVis, GRID,
FileError : BOOLEAN;

{$I GRQuery.pas}

FUNCTION GETINT(VAR INS:S255; VAR OK:BOOLEAN): INTEGER;
{ Returns next integer from input string. Leading
characters upto the end of the numeric substring
are deleted.
}
VAR I, J, LEN, CODE : INTEGER;
VAR WS : STRING[20];
CONST NUM: SET OF CHAR=['0'..'9', '+', '-', '.', 'E'];
BEGIN
WS:=''; OK:=FALSE; GETINT:=0;
LEN:=LENGTH(INS); I:=1;
WHILE (I <= LEN) AND NOT(INS[I] IN NUM) DO I:=I+1;

IF I <= LEN THEN
REPEAT
WS:=WS + INS[I]; I:=I+1;
UNTIL NOT(INS[I] IN NUM) OR (I > LEN);

IF LENGTH(WS) > 0 THEN
BEGIN VAL (WS,J,CODE); OK:=(CODE = 0);
IF OK THEN GETINT:=J;
DELETE(INS,1,I);
END;
END; { GETINT. }

FUNCTION GETREAL(VAR INS:S255; VAR OK:BOOLEAN): REAL;
{ Returns next real number from input string. Leading
characters upto the end of the numeric substring
are deleted.
}
VAR I, CODE, LEN : INTEGER;
R : REAL;
WS : STRING[20];
CONST NUM: SET OF CHAR=['0'..'9', '+', '-', '.', 'E'];
BEGIN
WS:=''; OK:=FALSE; GETREAL:=0;
LEN:=LENGTH(INS); I:=1;
WHILE (I <= LEN) AND NOT(INS[I] IN NUM) DO I:=I+1;

IF I <= LEN THEN
REPEAT
WS:=WS + INS[I]; I:=I+1;
UNTIL NOT(INS[I] IN NUM) OR (I > LEN);

IF LENGTH(WS) > 0 THEN
BEGIN VAL(WS,R,CODE); OK:=(CODE=0);
IF OK THEN GETREAL:=R;
DELETE(INS,1,I);
END;
END; { GETREAL. }

PROCEDURE GetInputFile(VAR FileTitle: S64);
VAR OK : BOOLEAN;
BEGIN
REPEAT
ASSIGN(LLF, FileTitle); {$I- Reset I/O check }
RESET(LLF); {$I+ Set I/O check }
OK:= (IORESULT = 0);
IF NOT OK THEN
BEGIN
FileError:=TRUE;
WRITELN('File ',FileTitle,' not found,');
WRITE('Specify new file name: ');
READLN(FileTitle); IF FileTitle = '' THEN OK:=FALSE;
END;
UNTIL OK;
END; { GetInputFile. }

FUNCTION ArcCos(X: REAL): REAL;
VAR R : REAL;
BEGIN
IF ABS(X) < 1 THEN
BEGIN R:=ARCTAN(SQRT((1-X*X))/X);
IF X < 0 THEN R:=PI +R;
ArcCos:=R;
END
ELSE IF X = 1 THEN ArcCos:= 0
ELSE IF X =-1 THEN ArcCos:= PI;
END; { ArcCos. }

FUNCTION ArcSin(X: REAL): REAL;
BEGIN
IF ABS(X) < 1 THEN ArcSin:= ARCTAN(X/SQRT(1-SQR(X)))
ELSE IF X = 1 THEN ArcSin:= HalfPI
ELSE IF X =-1 THEN ArcSin:=-HalfPI;
END; { ArcSin. }

FUNCTION ArcTanH(X : Real): Real;
VAR A,T : REAL;
BEGIN
T:=ABS(X);
IF T < 1 THEN
BEGIN
A := 0.5 * LN((1 + T)/(1 - T));
IF X < 0 THEN ArcTanH := -A ELSE ArcTanH :=A;
END;
END; { ArcTanH. }

FUNCTION Meridian(Lambda, Lambda0: REAL):REAL;
{ Returns difference between current longitude and map center. }
VAR DelLam : REAL;
BEGIN
DelLam := Lambda - Lambda0;
IF DelLam < -PI THEN DelLam := DelLam + TwoPI
ELSE
IF DelLam > PI THEN DelLam := DelLam - TwoPI;
Meridian:=DelLam;
END; { Meridian. }

PROCEDURE Mercator(Lambda, Lambda0, Phi, R : REAL; VAR X, Y : REAL);
{ For R = 1: -Pi <= X <= Pi, -Pi/2 <= Y <= Pi/2. }
CONST MaxLat : REAL = 1.397; {~80 degrees. }
{ REAL = 1.483; ~85 degrees. }
BEGIN
IF ABS(Phi) < MaxLat THEN
BEGIN
Lambda := Meridian(Lambda, Lambda0);
X := R * Lambda;
Y := R * ArcTanH(SIN(Phi));
END
ELSE X := NotVisible;
END; { Mercator. }

PROCEDURE EquiCyl(Lambda, Lambda0, Phi, Phi1, R : REAL; VAR X, Y : REAL);
{ For R = 1: -Pi <= X <= Pi, -Pi/2 <= Y <= Pi/2. }
BEGIN
Lambda := Meridian(Lambda, Lambda0);
X := R * Lambda * COS(Phi1);
Y := R * Phi;
END; { EquiCyl. }

PROCEDURE Sinusoidal(Lambda, Lambda0, Phi, R : REAL; VAR X, Y : REAL);
{ For R = 1: -Pi <= X <= Pi and -Pi/2 <= Y <= Pi/2. }
BEGIN
Lambda := Meridian(Lambda, Lambda0);
X := R * Cos(Phi) * Lambda ;
Y := R * Phi;
END; { Sinusoidal. }

PROCEDURE Hammer(Lambda, Lambda0, Phi, R : REAL; VAR X, Y : REAL);
{ For R = 1: -2 û2 <= X <=2 û2 and - û2 <= Y <= û2. }
VAR K, CosPhi, HalfLambda : REAL;
BEGIN
HalfLambda := 0.5*Meridian(Lambda, Lambda0);
CosPhi:=COS(Phi);
K := R * SQRT2 / SQRT(1 +CosPhi * COS(HalfLambda));
X := 2 * K * CosPhi * (SIN(HalfLambda));
Y := K * SIN(Phi);
END; { Hammer. }

PROCEDURE Orthographic(Lambda, Lambda0, Phi, Phi1, R: REAL; VAR X, Y : REAL);
{ For R = 1: -2 <= X,Y <= 2. }
VAR CosC, CosL, SinPhi1, CosPhi1, SinPhi, CosPhi, R2 : Real;
BEGIN
Lambda :=Meridian(Lambda, Lambda0); R2:=R+R;
CosPhi1:=COS(Phi1); SinPhi1:=SIN(Phi1);
CosPhi :=COS(Phi); SinPhi:= SIN(Phi);
CosL :=COS(Lambda)*CosPhi;
CosC :=SinPhi1 * SinPhi + CosPhi1 * COSL;
IF CosC >= 0 THEN
BEGIN
X :=R2 * CosPhi * SIN(Lambda);
Y :=R2 * (CosPhi1 * SinPhi - SinPhi1 * COSL);
END ELSE X:=NotVisible;
END; { Orthographic. }

PROCEDURE Beep;
{ Sounds a tone when map is complete. }
BEGIN
Sound(880); Delay(250); NoSound;
END;

PROCEDURE PlotPt(VAR LastPtVis: BOOLEAN);
{ Draws a line from the last point to the current (XP,YP) if it is visible. }
VAR IX,IY: INTEGER;
LABEL XIT;
BEGIN
IX:=ROUND(XP); IY:=ROUND(YP);
IF LastPtVis THEN LineTo(IX,IY) ELSE MoveTo(IX,IY);
LastX:=IX; LastY:=IY; LastPtVis:=TRUE;
XIT:
END; { PlotPt. }

PROCEDURE CoordinateGrid(OUTLINE: BOOLEAN; MapType: INTEGER);
CONST LatitudeSpacing = 30;
LongitudeSpacing = 30;
VAR Longitude, Latitude, LatLimit,
MaxLat, LongIncr, LatIncr : INTEGER;
VAR LL, PP, A, R2, RA, XN, YN,
SINDT, COSDT : REAL;

BEGIN
CASE MapType OF
1: BEGIN MaxLat:=80; LongIncr:=360; LatIncr:=160; END;
2: BEGIN MaxLat:=90; LongIncr:=360; LatIncr:=180; END;
3: BEGIN MaxLat:=90; LongIncr:=360; LatIncr:=5; END;
4..5: BEGIN Maxlat:=90; LongIncr:=5; LatIncr:=5; END;
END; { CASE...}

LL:=0; PP:=Phi1;
IF OUTLINE THEN
BEGIN
IF MapType = 5 THEN PP:=0;
LatLimit:=MaxLat; { Draw only extreme latitudes }
{ to make map outline }
END
ELSE LatLimit:= MaxLat DIV LatitudeSpacing*LatitudeSpacing;

Latitude:=LatLimit;

WHILE Latitude >= -LatLimit DO { Draw parallels }

BEGIN
LATR:=Latitude*Radian;
LastPtVis:=FALSE;

Longitude:=-180;
WHILE Longitude <= 180 DO
BEGIN
LONGR:=Longitude*Radian;

CASE MapType OF
1: BEGIN MERCATOR(LONGR, LL, LATR, R, X, Y); END;
2: BEGIN EQUICYL(LONGR, LL, LATR, PP, R, X, Y); END;
3: BEGIN SINUSOIDAL(LONGR, LL, LATR, R, X, Y); END;
4: BEGIN HAMMER(LONGR, LL, LATR, R, X, Y); END;
5: BEGIN ORTHOGRAPHIC (LONGR, LL, LATR, PP, R, X, Y); END;
END; { CASE...}

IF X > -300 THEN
BEGIN
XP:=ROUND(X*ASPECT)+XCENTER;
YP:=YCENTER-ROUND(Y);
PlotPt(LastPtVis);
END ELSE LastPtVis:=FALSE;

Longitude:=Longitude+LongIncr;
END;

IF OUTLINE THEN
Latitude:=Latitude-2*MaxLat
ELSE
Latitude:=Latitude-LatitudeSpacing;
END;

IF OUTLINE THEN LL:=0 ELSE LL:=Lambda0;

Longitude:=-180; { Draw meridians }

IF MapType >= 4 THEN MaxLat:=90;
WHILE Longitude <= 180 DO
BEGIN
LONGR:=Longitude*Radian;
LastPtVis:=FALSE;
Latitude:=MaxLat;
WHILE Latitude >= -MaxLat DO
BEGIN
LATR:=Latitude*Radian;

CASE MapType OF
1: BEGIN MERCATOR(LONGR, LL, LATR, R, X, Y); END;
2: BEGIN EQUICYL(LONGR, LL, LATR, PP, R, X, Y); END;
3: BEGIN SINUSOIDAL(LONGR, LL, LATR, R, X, Y); END;
4: BEGIN HAMMER(LONGR, LL, LATR, R, X, Y); END;
5: BEGIN ORTHOGRAPHIC( LONGR, LL, LATR, PP, R, X, Y); END;
END; { CASE...}

IF X > -300 THEN
BEGIN
XP:=ROUND(X*ASPECT)+XCENTER;
YP:=YCENTER-ROUND(Y);
PlotPt(LastPtVis);
END ELSE LastPtVis:=FALSE;

Latitude:=Latitude-LatIncr;
END;

IF OUTLINE THEN
Longitude:=Longitude+360
ELSE
Longitude:=Longitude+LongitudeSpacing;
END;

IF OUTLINE AND (MapType=5) THEN
BEGIN
A:=0; { Draw circular outline }
LastPtVis:=False;
R2:=R + R;
RA:= R2 * Aspect;
SINDT:= 0.05996400648;
COSDT:= 0.99820053993;
X:=1; Y:=0;
XP:= ROUND(XCENTER + RA);
YP:= ROUND(YCENTER);
PlotPt(LastPtVis);
WHILE A <= TwoPI DO
BEGIN { Compute points on the circle }
XN:= X * COSDT - Y * SINDT;
YN:= X * SINDT + Y * COSDT;
X:= XN; Y:= YN;
XP:= XCENTER + ROUND(X*RA);
YP:= YCENTER + ROUND(Y*R2);
PlotPt(LastPtVis);
A:= A+0.06;
END; { While. }
END;
END; { CoordinateGrid. }

PROCEDURE DrawMap(MapType: INTEGER);
VAR Latitude, Longitude : REAL;
VAR LastX : INTEGER;
LABEL XIT;
BEGIN
LastPtVis:=FALSE; LastX:=0;

WHILE NOT EOF(LLF) DO
BEGIN
READ(LLF, LL);
IF KeyPressed THEN GOTO XIT;
LONGR:=LL.LONGI * RadianDiv100;
LATR :=LL.LATI * RadianDiv100;

IF LL.CODE = 'LS' THEN LastPtVis:=FALSE;
IF (LL.CODE = 'S ') OR (LL.CODE = 'LS') THEN
BEGIN
CASE MapType OF
1: BEGIN MERCATOR(LONGR, Lambda0, LATR, R, X, Y); END;
2: BEGIN EQUICYL(LONGR, Lambda0, LATR, Phi1, R, X, Y); END;
3: BEGIN SINUSOIDAL(LONGR, Lambda0, LATR, R, X, Y); END;
4: BEGIN HAMMER(LONGR, Lambda0, LATR, R, X, Y); END;
5: BEGIN ORTHOGRAPHIC(LONGR, Lambda0, LATR, Phi1, R, X, Y); END;
END; { CASE...}

IF X > -300 THEN
BEGIN
XP:=ROUND(X*ASPECT)+XCENTER;
IF ABS(LastX-XP) > 100 THEN LastPtVis:=FALSE;
YP:= YCENTER-ROUND(Y);
PlotPt(LastPtVis); LastX:=XP;
END ELSE LastPtVis:=FALSE;
END;
END;
XIT:
END; { DrawMap. }

(* --------------------- MAIN PROGRAM ------------------ *)

VAR RESP : CHAR;
VAR RESPSTRING : S255;
VAR OKAY : Boolean;

LABEL XIT;
BEGIN
DirectVideo := True;
GrQuery(GrafixCard);
CASE GrafixCard OF
DEB640x200, CGA640x200,
EGA640x200, EVR640x200,
TEC640x200: BEGIN
XCENTER := 320; { CGA Graphics constants. }
YCENTER := 99; { Screen center X and Y }
ASPECT := 2.4; { 640x200 aspect ratio }
R := 40; { Default map radius }
END;
EGAMono, EGA640x350,
MGA640x350: BEGIN
XCENTER := 320; { EGA Graphics constants. }
YCENTER := 174; { Screen center X and Y }
ASPECT := 1.37;{ 640x350 aspect ratio }
R := 70; { Default map radius }
END;
ATT640x400, DEB640x400,
EVR640x400, TEC640x400,
TOS640x400: BEGIN
XCENTER := 320; { ATT Graphics constants. }
YCENTER := 199; { Screen center X and Y }
ASPECT := 1.2; { 640x400 aspect ratio }
R := 70; { Default map radius }
END; { Check against newer version }
EGA640x480, MGA640x480,
VGA640x480:
BEGIN
XCENTER := 320; { VGA Graphics constants. }
YCENTER := 240; { Screen center X and Y }
ASPECT := 1; { 640x480 aspect ratio }
R := 95; { Default map radius }
END;
TEC720x352, HER720x348:
BEGIN
XCENTER := 360; { Herc/Tecmar constants. }
YCENTER := 174; { Screen center X and Y }
ASPECT := 1.5; { 720x352 aspect ratio }
R := 70; { Default map radius }
END;
END; {CASE...}
z:=Initgrafix(-GrafixCard);
ScreenRect(scrnR);

MapType:=1; F:=''; FileError:=FALSE;
FN:= 'WORLD.DAT'; { Default file name. }
ClearText;

IF ParamCount > 0 THEN
BEGIN
F:=ParamStr(1); { Parse command line for files. }
P:=POS('/', F); { Skip over switches. }
IF P > 0 THEN
BEGIN
SWITCHES:=COPY(F, P, Length(F)-P+1);
F:=COPY(F, 1, P-1);
END;
IF F <> '' THEN FN:=F;
END;

GetInputFile(FN);
IF FileError THEN ClrScr;

WHILE MapType > 0 DO (* MENU *)
BEGIN
TextColor(15);
ClearText;
GOTOXY(24,1); WRITELN('C A R T O G');
TextColor(7);
GOTOXY(1,3); WRITE(' ':4,'Graphics: ');
GOTOXY(15,3);
CASE GrafixCard OF
ATT640x400: write('AT&T DEB, 640x400');
DEB640x200: write('AT&T DEB, 640x200');
DEB640x400: write('AT&T DEB, 640x400');
CGA640x200: write('IBM CGA, 640x200');
EGAMono: write('IBM EGA, 640x350');
EGA640x200: write('IBM EGA, 640x200');
EGA640x350: write('IBM EGA, 640x350');
MGA640x350: write('IBM EGA, 640x350');
EGA640x480: write('IBM VGA, 640x480');
MGA640x480: write('IBM MGA, 640x480');
EVR640x200: write('Everex Edge, 640x200');
EVR640x400: write('Everex Edge, 640x400');
HER720x348: write('Hercules Adaptor, 720x348');
TEC720x352: write('Tecmar Graphics-Master, 720x352');
TEC640x200: write('Tecmar Graphics-Master, 640x200');
TEC640x400: write('Tecmar Graphics-Master, 640x400');
TOS640x400: write('Toshiba 3100, 640x400');
VGA640x480: write('Video-7 Vega Deluxe, 640x480');
END; {CASE...}
GOTOXY(1,24);
WRITE('':4,'Copyright 1987 by Robert Miller and Francis Reddy');
GOTOXY(5,5);
WRITELN('To PLOT: Choose a projection. Enter the Central ');
WRITELN(' ':4,'Meridian of the map (180 to -180 degrees, longitudes');
WRITELN(' ':4,'west of Greenwich negative). If applicable, enter');
WRITELN(' ':4,'the Standard Parallel (90 to -90 degrees, southern');
WRITELN(' ':4,'latitudes negative). The file WORLD.DAT must also be');
WRITELN(' ':4,'on the logged drive. A tone means the map is done.');
WRITELN;
WRITELN(' ':4,'Any key ABORTS plot and restores this MENU.');
TextColor(15);
WRITELN;
WRITE(' ':6,'1. Mercator');
WRITELN(' ':21,'4. Hammer');
WRITE(' ':6,'2. Equidistant Cylindrical');
WRITELN(' ':6,'5. Orthographic');
WRITELN(' ':6,'3. Sinusoidal');
WRITELN;
REPEAT
GOTOXY(1,18);
WRITE(' ':8,'Projection number (1-5) or Enter to quit:');
CLREOL;
GOTOXY(51,18);
READLN(RespString);
IF RespString = '' THEN
BEGIN
MapType := 0;
GOTO XIT;
END
ELSE
MapType := GETINT(RespString, OKAY);
UNTIL MapType IN [0..5];

WRITELN;
WRITE(' ':8,'Central Longitude of Map (default = 0): ');
READLN(RespString);
IF RespString = '' THEN Lambda0 := 0 ELSE
BEGIN
Lambda0 := GETREAL(RespString, OKAY);
Lambda0:=Lambda0*Radian;
END;

IF (MapType = 2) OR (MapType = 5) THEN
BEGIN
WRITE(' ':8,'Central Latitude of Map (default = 0): ');
READLN(RespString);
IF RespString = '' THEN Phi1 := 0 ELSE
BEGIN
IF RespString = '90' THEN Phi1 :=HalfPI ELSE
BEGIN
Phi1 := GETREAL(RespString, OKAY);
Phi1:=Phi1*Radian;
END;
END;
END;


CASE YCENTER OF { Optimize so Hammer and Ortho fill screen }
99: IF MapType >= 4 THEN R:=48 ELSE R:=40;
100: IF MapType >= 4 THEN R:=75 ELSE R:=70;
174: IF MapType >= 4 THEN R:=81 ELSE R:=70;
240: IF MapType >= 4 THEN R:=104 ELSE R:=95;
END; {CASE...}

WRITE(' ':8,'Plot Grid, Coastlines, or Both (G/C/B)? ');
READLN(RespString);
IF RespString = '' THEN RespString := 'C' ELSE
BEGIN
RESP:=RespString[1];
RESP:=UPCASE(RESP);
END;
GRID:=(RESP ='G') OR (RESP = 'B');

DirectVideo := False;

SetBitmap(GrafPg0);
EraseRect(scrnR);
SetDisplay(GrafPg0);

IF GRID THEN CoordinateGrid(FALSE, MapType);

CoordinateGrid(TRUE, MapType);

RESET(LLF);
IF (RESP = 'B') OR (RESP = 'C') THEN
BEGIN DrawMap(MapType); CLOSE(LLF);
END;

Beep;
Resp := Readkey;
SetDisplay(TextPg0); { Return to Text Mode }
XIT:
DirectVideo := True;
ClrScr;
END; { WHILE MapType > 0...}
END.