FlyAKite Turbo Pascal listing




{Start of file FLYAKITE.PAS *************************************************}

{FLYAKITE - Kite flying program}
{Developed in Apple ][ Pascal and converted to TURBO Pascal 4.0 10/30/88}
(* 13-SEP-81, 1400 HRS *) {Apple ][ date}
{COPYRIGHT (c) 1981-1988 By author: Harry J Smith, Saratoga, CA}

{$I-}
{$R+}

PROGRAM FlyAKite;

USES  Printer, Crt, Graph; {Turbo Pascal 4.0 interface}

CONST  Revision = 'Last revised: 11/02/88, 0500 hours';

CONST  N = 4;  NT = 100;  EY = 0.005;  MaxR = 20;

TYPE
  ColorType = 0 .. MaxColors;

  DRec = RECORD
    CASE INTEGER OF
      1: (NR : INTEGER;
          HR, OOWR, Fac1R, Fac2R : REAL);
      2: (LenR, TR, ZetaR, SAR, FactR, XMR, YMR : REAL);
    END;

VAR
  Bell : CHAR; {COMMON CONSTANTS}
  PiO4, PiO2, Pi, Pi2 : REAL;

  T, EMu, Dublu, SA, DPR, Factor, A, OneOW, {COMMON VARIABLES}
  S, HP, H, SF, SI, IR,
  TXIn, TYIn, Zeta,
  RX, Factor1, Factor2,
  Scale, XMax, YMax       : REAL;
  Vector : RECORD
    CASE INTEGER OF
      1 : (X,  Y,  TX,  TY,
           XD, YD, TXD, TYD : REAL);
      2 : (XA  : PACKED ARRAY[1..4] OF REAL;
           XDA : PACKED ARRAY[1..4] OF REAL);
    END;

  Abort,
  Converge  : BOOLEAN;
  ADat      : ARRAY[0..20] OF DRec;
  FileName  : STRING[20];
  PrintName : STRING[8];

  OneCh     : CHAR; {MAIN PROGRAM VARIABLES}

  FDat      : FILE OF DRec; {FILES}
  OutP      : ^TEXT;

  Color            : ColorType;
  Dot2, Dot4,
  Device, Mode     : INTEGER;
  MaxXPix, MaxYPix : WORD;
  Palette          : PaletteType;

PROCEDURE SavePlot;
VAR
  Save             : TEXT;
  XG, YG,
  CBit, NPix       : INTEGER;
BEGIN
  ASSIGN(Save, 'b:FlyAkite.OUT');
  REWRITE(Save); {Text file}
  FOR YG:= 0 TO MaxYPix DO BEGIN
    WRITE(Save, YG);
    CBit:= 0;  NPix:= 0;
    FOR XG:= 0 TO MaxXPix DO BEGIN
      IF GetPixel(XG, YG) = CBit THEN NPix:= NPix + 1
      ELSE BEGIN
        WRITE(Save, ' ', NPix);
        CBit:= (CBit + 1) MOD 2;  NPix:= 1;
      END
    END;
    IF NPix <> 0 THEN BEGIN
      WRITE(Save, ' ', NPix);
    END;
    WRITELN(Save);
  END;
  CLOSE(Save);
END; {SavePlot}

PROCEDURE PrintPlot;
VAR
  XG, YG,
  Line, Bit, Dot,
  Out1, Out2, Out3   : INTEGER;
  C1, C2, C3         : CHAR;
BEGIN
  WRITELN(Lst);
  WRITELN(Lst);
  WRITELN(Lst);
  FOR Line:= 0 TO MaxYPix DIV 12 DO BEGIN
    WRITE(Lst, CHR(27), '*', CHR(39), CHR(0), CHR(5));  {Start graphics mode}
    YG:= 12 * Line;
    FOR XG:= 0 TO MaxXPix DO BEGIN
      Out1:= 0;  Out2:= 0;  Out3:= 0;
      FOR Bit:= 0 TO 3 DO BEGIN
        Dot := GetPixel(XG, YG + Bit);      IF Dot <> 0 THEN  Dot:= 3;
        Out1:= 4 * Out1 + Dot;
        Dot := GetPixel(XG, YG + Bit + 4);  IF Dot <> 0 THEN  Dot:= 3;
        Out2:= 4 * Out2 + DOT;
        Dot := GetPixel(XG, YG + Bit + 8);  IF Dot <> 0 THEN  Dot:= 3;
        Out3:= 4 * Out3 + Dot;
      END;
      C1:= CHR(Out1);  C2:= CHR(Out2);  C3:= CHR(Out3);
      WRITE(Lst, C1, C2, C3, C1, C2, C3);
    END;
    WRITE(Lst, CHR(27), 'J', CHR(24), CHR(13)); {24 dot line feed}
  END;
  WRITELN(Lst);
  WRITELN(Lst);
  WRITELN(Lst);
END; {PrintPlot}

PROCEDURE MoveToL(X, Y : INTEGER);
BEGIN
  MoveTo(X, MaxYPix - Y);
END; {MoveToL}

PROCEDURE LineToL(X, Y : INTEGER);
BEGIN
  LineTo(X, MaxYPix - Y);
END; {LineToL}

FUNCTION ForceColor(Color : ColorType) : ColorType;
BEGIN
  Color:= Color MOD Palette.Size;
  IF Color = 0 THEN Color:= 1;
  SetColor(Color);
  ForceColor:= Color;
END; {ForceColor}

FUNCTION ATan2(Y, X : REAL) : REAL;
  VAR Temp : REAL;
BEGIN
  IF X = 0 THEN BEGIN
    IF Y > 0 THEN  ATan2:= PiO2
    ELSE IF Y < 0 THEN  ATan2:= -PiO2
    ELSE  ATan2:= 0;
  END
  ELSE BEGIN
    Temp:= ARCTAN(Y / X);
    IF X > 0 THEN  ATan2:= Temp
    ELSE
      IF Y >= 0 THEN  ATan2:= Temp + Pi
      ELSE  ATan2:= Temp - Pi;
  END;
END; {ATan2}

PROCEDURE Output2;
  VAR R : REAL;
BEGIN
  WITH Vector DO BEGIN
    R:= SQRT(SQR(X) + SQR(Y));
    A:= DPR * ATan2(Y, X);
    SA:= DPR * ATan2(TY, TX);
    WRITELN(OutP^, S:7:1, X:8:1, Y:8:1, TX:8:2, TY:8:2, T:8:2,
            SA:8:2, A:8:2, R:8:1, Factor:8:2);
  END;
END; {Output2}

PROCEDURE RHSF; {Evaluate the Right Hand Side Function}
BEGIN
  WITH Vector DO BEGIN
    T:= SQRT(SQR(TX) + SQR(TY));
    XD:= TX / T;  YD:= TY / T;
    TXD:= -EMu * ABS(YD * SQR(YD));
    TYD:= Dublu + EMu * ABS(YD) * YD * XD;
  END;
END; {RHSF}

PROCEDURE RKutta(VAR S : REAL; H : REAL); {MUST CALL RHSF BEFORE RKutta}
  {Runge-Kutta method of integration of ordinary differential equations}
VAR
  EK1, EK2, EK3,  XI : ARRAY[1..N] OF REAL;
  SR : REAL;
  I  : INTEGER;
BEGIN
  WITH Vector DO BEGIN
    SR:= S;
    FOR I:= 1 TO N DO BEGIN
      XI[I]:= XA[I];
      EK1[I]:= H * XDA[I];
      XA[I]:= XI[I] + EK1[I] / 2.0;
    END;
    S:= SR + H / 2.0;
    RHSF;
    FOR I:= 1 TO N DO BEGIN
      EK2[I]:= H * XDA[I];
      XA[I]:= XI[I] + EK2[I] / 2.0;
    END;
    RHSF;
    FOR I:= 1 TO N DO BEGIN
      EK3[I]:= H * XDA[I];
      XA[I]:= XI[I] + EK3[I];
    END;
    S:= SR + H;
    RHSF;
    FOR I:= 1 TO N DO BEGIN
      XA[I]:= XI[I] +
                (EK1[I] + 2.0 * EK2[I] + 2.0 * EK3[I] + H * XDA[I]) / 6.0;
    END;
  END;
END; {RKutta}

PROCEDURE AIRK(VAR S : REAL; SI, H : REAL); {Advance Integration by RKutta}
LABEL ExitAIRK;
  BEGIN
    IF SI = S THEN  GoTo ExitAIRK;
    H:= ABS(H);
    IF SI < S THEN  H:= -H;
    WHILE ABS(SI - S) > ABS(H) DO BEGIN
      RKutta(S, H);
      RHSF;
    END;
    H:= SI - S;
    IF H <> 0 THEN  RKutta(S, H);
    S:= SI;
ExitAIRK:
  END; {AIRK}

FUNCTION Functn(RX : REAL) : REAL;
BEGIN
  Factor:= RX;
  EMu:= Dublu * Factor;
  S:= 0;
  WITH Vector DO BEGIN
    X:= 0;  Y:= 0;
    TX:= TXIN;  TY:= TYIN;
  END;
  RHSF;
  AIRK(S, SI, H);
  RHSF;
  Output2;
  Functn:= A - Zeta;
END; {Functn}

PROCEDURE Root(X1, X2, EY : REAL; NT : INTEGER; VAR X : REAL);
LABEL ExitRoot;
VAR
  Y, Y1, Y2, P : REAL;
  I : INTEGER;  Ch : CHAR;
BEGIN
  Abort:= FALSE;
  Converge:= FALSE;
  Y2:= Functn(X2);
  X:= X1;
  Y:= Functn(X);
  FOR I:= 1 TO NT DO BEGIN
    IF ABS(Y) > ABS(Y2) THEN BEGIN
      X1:= X;  Y1:= Y;
    END
    ELSE BEGIN
      X1:= X2;  Y1:= Y2;
      X2:= X;   Y2:= Y;
    END;
    IF Y1 <> Y2 THEN BEGIN
      P:= Y2 / (Y1 - Y2);
      IF P > 1.0 THEN  P:= 1.0;
    END
    ELSE
      P:= 1.0;
    X:= X2 + P * (X2 - X1);
    Y:= Functn(X);
    IF ABS(Y) <= EY THEN BEGIN
      WRITELN(OutP^, 'CONVERGED');  Converge:= TRUE;  GoTo ExitRoot;
    END;
    REPEAT
      IF KEYPRESSED THEN BEGIN
        Ch:= ReadKey;
        IF Ch = '0' THEN BEGIN
          WRITELN(OutP^, 'MANUALLY ABORTED BEFORE CONVERGANCE');
          Abort:= TRUE;  GoTo ExitRoot;
        END;
      END;
    UNTIL NOT KEYPRESSED;
  END;
  WRITELN('DID NOT CONVERGE IN ', NT, ' ITERATIONS');
ExitRoot:
END; {Root}

PROCEDURE GetCase(N : INTEGER);
LABEL ExitGetCase;
BEGIN
  WITH ADat[N] DO BEGIN
    SI:= LenR;  T:= TR;  Zeta:= ZetaR;  SA:= SAR;  Factor:= FactR;
    XMax:= XMR;  YMax:= YMR;
  END;
  WITH ADat[0] DO BEGIN
    Factor1:= Fac1R;  Factor2:= Fac2R;  OneOW:= OOWR;  H:= HR;
  END;
  TYIN:= T * SIN(SA / DPR);
  TXIN:= T * COS(SA / DPR);
  S:= 0;
  WITH Vector DO BEGIN
    X:= 0;  Y:= 0;  TX:= TXIN;  TY:= TYIN;
  END;
  IF OneOW <= 0 THEN  GoTo ExitGetCase;
  Dublu:= 1.0 / OneOW;
  EMu:= Dublu * Factor;
  RHSF;
ExitGetCase:
END; {GetCase}

FUNCTION GetReal(LO, HI : REAL) : REAL;
VAR R : REAL;  OK : BOOLEAN;
BEGIN
  OK:= FALSE;
  REPEAT
    READLN(R);
    IF (IORESULT = 0) AND (R >= LO) AND (R <= HI) THEN  OK:= TRUE
      ELSE  WRITE(Bell);
  UNTIL OK;
  GetReal:= R;
END; {GetReal}

PROCEDURE Perp(DOTS : INTEGER);
VAR
  XP, YP, XL, YL : INTEGER;
  R : REAL;
BEGIN
  XP:= GetX;  YP:= MaxYPix - GetY;
  WITH Vector DO BEGIN
    R:= SQRT(SQR(TX) + SQR(TY));
    XL:= TRUNC(XP + DOTS * -TY / R);
    YL:= TRUNC(YP + DOTS *  TX / R);
  END;
  MoveToL(XL, YL);
  XL:= XP + XP - XL;
  YL:= YP + YP - YL;
  LineToL(XL, YL);
  MoveToL(XP, YP);
END; {Perp}

PROCEDURE Grid(XZ, YZ : INTEGER;  Scale : REAL);
VAR
  ScaleT : REAL;  N1, N2, N3, N4, I : INTEGER;
BEGIN
  WITH Vector DO BEGIN
    ScaleT:= 1000.0 * Scale;
    N1:= -TRUNC((XZ) / ScaleT);
    N2:=  TRUNC((MaxXPix - XZ) / ScaleT);
    N3:= -TRUNC((YZ) / ScaleT);
    N4:=  TRUNC((MaxYPix - YZ) / ScaleT);
    MoveToL(0, 0);
    SetColor(WHITE);  TX:= 1;  TY:= 0;
    FOR I:= N1 TO N2 DO BEGIN
      LineToL(TRUNC(I * ScaleT) + XZ, 0);  Perp(Dot4);
    END;
    LineToL(MaxXPix, 0);  TX:= 0;  TY:= 1;
    FOR I:= N3 TO N4 DO BEGIN
      LineToL(MaxXPix, TRUNC(I * ScaleT) + YZ);  Perp(Dot4);
    END;
    LineToL(MaxXPix, MaxYPix);  TX:= -1;  TY:= 0;
    FOR I:= N2 DOWNTO N1 DO BEGIN
      LineToL(TRUNC(I * ScaleT) + XZ, MaxYPix);  Perp(Dot4);
    END;
    LineToL(0, MaxYPix);  TX:= 0;  TY:= -1;
    FOR I:= N4 DOWNTO N3 DO BEGIN
      LineToL(0, TRUNC(I * ScaleT) + YZ);  Perp(Dot4);
    END;
    LineToL(0, 0);
  END;
END; {Grid}

PROCEDURE PlotSt;
LABEL ExitPlotSt;
VAR
  Ch              : CHAR;
  MinH, MaxH,
  ScaleF, IR, SV,
  Scale           : REAL;
  ScaleX          : REAL;
  XP, YP,
  XZ, YZ, CN      : INTEGER;
  St              : STRING;

  PROCEDURE PlotM(VAR S : REAL; SI, H : REAL);
  LABEL ExitPlotM;
  VAR R, HP : REAL;

    PROCEDURE CompH;
    BEGIN
      WITH Vector DO R:= T / SQRT(SQR(TXD) + SQR(TYD));
      HP:= 0.5 * SQRT(ScaleF * R);
      IF HP > MaxH THEN  HP:= MaxH
        ELSE IF HP < MinH THEN  H:= MinH;
      IF H < 0 THEN  HP:= -HP;
    END; {CompH}

    PROCEDURE Plot1;
    BEGIN
      WITH Vector DO BEGIN
        XP:= ROUND(X * Scale) + XZ;
        YP:= ROUND(Y * Scale) + YZ;
      END;
      LineToL(XP, YP);
    END; {Plot1}

  BEGIN {PlotM}
    IF SI < S THEN  H:= -H;
    CompH;
    WHILE ABS(SI - S) > ABS(HP) DO BEGIN
      RKutta(S, HP);  RHSF;  Plot1;  CompH;
      IF (XP < 0) OR (YP > MaxYPix) THEN  GoTo ExitPlotM;
    END;
    H:= SI - S;
    IF H <> 0 THEN BEGIN
      RKutta(S, H);  RHSF;  Plot1;
    END;
    S:= SI;
ExitPlotM:
  END; {PlotM}

BEGIN {PlotSt}
  ClrScr;  WRITELN;
  WRITELN('Note: Type an "S" after the plot to save it to B:FLYAKITE.OUT');
  WRITELN('      Type  a "P" after the plot to print it on LQ-2500 printer');
  WRITELN;
  WRITELN(
    'INPUT 1 <= L <= ', ADat[0].NR, ' LINE NUMBER TO PLOT OR 0 TO EXIT');
  CN:= TRUNC(GetReal(0, ADat[0].NR));
  IF CN = 0 THEN  GoTo ExitPlotSt;
  GetCase(CN);
  Dot2:= Round(MaxYPix / 100.0);
  Dot4:= Dot2 + Dot2;
  Scale:= 0.9 * MaxYPix / YMax;  ScaleX:= 0.9 * MaxXPix / XMax;
  IF Scale > ScaleX THEN  Scale:= ScaleX;
  ScaleF:= TRUNC(1.0 + 1.0 / Scale);
  IF ScaleF < 6 THEN  ScaleF:= 6;
  WRITELN('INPUT SCALE IN FEET/DOT OR 0 IF ', ScaleF:3:1, ' IS OK');
  ScaleX:= GetReal(0, 1000000.0);
  IF ScaleX <> 0 THEN  ScaleF:= ScaleX;
  Scale:= 1.0 / ScaleF;
  MinH:= ScaleF;  MaxH:= H;
  XZ:= ROUND((MaxXPix - XMax * Scale) / 2.0);
  YZ:= ROUND((MaxYPix - YMax * Scale) / 2.0);
  WRITELN('INPUT 0.1 <= X <= ', MaxXPix,
    ' DOT POSITION TO PLOT X=0 OR 0 IF ', XZ, ' IS OK');
  IR:= GetReal(0, MaxXPix);
  IF IR <> 0 THEN  XZ:= ROUND(IR);
  WRITELN('INPUT 0.1 <= Y <= ', MaxYPix,
    ' DOT POSITION TO PLOT Y=0 OR 0 IF ', YZ, ' IS OK');
  IR:= GetReal(0, MaxYPix);
  IF IR <> 0 THEN  YZ:= ROUND(IR);
  SetGraphMode(Mode);
  SetBkColor(Black);
  Color:= ForceColor(White);
  MoveToL(XZ, YZ);
  Perp(Dot4);
  WHILE SI > S+1000.0 DO BEGIN
    PlotM(S, S+1000.0, H);  Perp(Dot2);
  END;
  SV:= S+1000.0;
  PlotM(S, SI, H);  Perp(Dot4);
  PlotM(S, SV, H);  Perp(Dot2);
  REPEAT
    PlotM(S, S+1000.0, H);
    IF (XP > -1) AND (YP <= MaxYPix) THEN  Perp(Dot2);
  UNTIL (XP < 0) OR (YP > MaxYPix);
  GetCase(CN);  MoveToL(XZ, YZ);  SetColor(WHITE);
  REPEAT
    PlotM(S, S - 1000.0, H);
    IF (XP > -1) AND (YP <= MaxYPix) THEN  Perp(Dot2);
  UNTIL (XP < 0) OR (YP > MaxYPix);
  Grid(XZ, YZ, Scale);
  Color:= ForceColor(Yellow);
  XP:= 3 + Dot4;  YP:= 3 + Dot4;  MoveTo(XP, YP);
  OutText(FileName);
  OutText('  Flight # ');  Str(CN, St);          OutText(St);
  YP:= YP + Dot2 + TextHeight('M');  MoveTo(XP, YP);
  OutText('Scale = ');    Str(ScaleF:1:1, St);  OutText(St);
  OutText(' Ft/Pixel  1000 Ft/Tic');
  YP:= YP + Dot2 + TextHeight('M');  MoveTo(XP, YP);
  OutText('X=0 @ ');      Str(XZ, St);          OutText(St);
  OutText('  Y=0 @ ');    Str(YZ, St);          OutText(St);
  OutText(' of ');        Str(MaxXPix + 1, St); OutText(St);
  OutText('x');           Str(MaxYPix + 1, St); OutText(St);
  OutText(' Pixels');
  Ch:= ReadKey;  Ch:= UpCase(Ch);
  IF Ch = 'S' THEN  SavePlot;
  IF Ch = 'P' THEN  PrintPlot;
  RestoreCrtMode; {TEXTMODE;}
ExitPlotSt:
END; {PlotSt}

PROCEDURE ClearData;
VAR I : INTEGER;
BEGIN
  WITH ADat[0] DO BEGIN
    NR:= 1;  HR:= 600;  OOWR:= 8700.0;  Fac1R:= 20.0;  Fac2R:= 35.0;
  END;
  WITH ADat[1] DO BEGIN
    LenR:= 0;  TR:= 0;  ZetaR:= 0;  SAR:= 0;  FactR:= 0;  XMR:= 0;  YMR:= 0;
  END;
  FOR I:= 2 TO MaxR DO
    ADat[I]:= ADat[1];
END; {ClearData}

PROCEDURE CkIO(VAR J : INTEGER);
VAR Ch : CHAR;
BEGIN
  J:= IORESULT;
  IF J <> 0 THEN BEGIN
    WRITELN('IORESULT = ', J);
{   CASE J OF
      1: WRITELN('BAD BLOCK, PARITY ERROR (CRC)');
      3: WRITELN('BAD MODE, ILLEGAL OPERATION');
      8: WRITELN('NO ROOM, INSUFFICIENT SPACE');
      9: WRITELN('NO UNIT, NO SUCH VOLUMN ON LINE');
      10: WRITELN('NO FILE, NO SUCH FILE ON VOLUME');
      16: WRITELN('WRITE PROTECT ERROR');
    END;
}   Ch:= ReadKey;
  END;
END; {CkIO}

PROCEDURE Init;
VAR I : INTEGER;
BEGIN
  TextBackground(Black);
  TextColor(Yellow);
{ Device:= CGA;  Mode:= CGAHi; }
  Device:= Detect;  Mode:= 0;
  InitGraph(Device, Mode, '');
  MaxXPix:= GetMaxX;  MaxYPix:= GetMaxY;
  GetPalette(Palette);
  IF Palette.Size < 2 THEN  Palette.Size:= 2;
  RestoreCrtMode;

  ClrScr;
  WRITELN;
  WRITELN('Program FLYAKITE - A kite flying program');
  WRITELN(Revision);
  WRITELN('COPYRIGHT (c) 1981-1988 By author: Harry J Smith, Saratoga, CA');
  WRITELN;
  WRITELN('MEMAVAIL = ', MEMAVAIL);
  WRITELN;
  WRITELN('Device, Mode, MaxX, MaxY = ',
           Device, ' ', Mode, ' ', MaxXPix, ' ', MaxYPix);
  WRITE('Palette.Size: Colors = ', Palette.Size, ':');
  FOR I:= 0 TO Palette.Size - 1 DO
    WRITE(' ', Palette.Colors[I]);
  WRITELN;
  PiO4:= ArcTan(1.0);
  PiO2:= 2.0 * PiO4;
  Pi:= 2.0 * PiO2;
  Pi2:= 2.0 * Pi;
  DPR:= 180.0 / Pi;
  Bell:= CHR(7);
  FileName:= 'NOT-ENTERED-YET';
  PrintName:= 'CONSOLE:';
  OutP:= @Output;
  ClearData;
  WRITELN('HIT ANY KEY TO CONTINUE');
  OneCh:= ReadKey;
END; {Init}

PROCEDURE ScrHed;
BEGIN
  ClrScr;
  WRITELN('OUTPUT TOGGLE SET TO ', PrintName,
          '  FLIGHT FILE NAME IS ', FileName);
  WRITELN;
END; {ScrHed}

PROCEDURE Scr1;
BEGIN
  ScrHed;
  WRITELN('0.  QUIT, RETURN TO THE SYSTEM');
  WRITELN('1.  TOGGLE PRINTER: / CONSOLE:');
  WRITELN('2.  ENTER / EDIT / UPDATE  FLIGHT FILES');
  WRITELN('3.  COMPUTE WIND FACTORS FOR FLIGHT DATA FILE');
  WRITELN('4.  PLOT STRING PROFILE ON HIRES SCREEN');
  WRITELN('5.  SELECT GRAFMODE');
  WRITELN('6.  SELECT TEXTMODE');
  GOTOXY(1, 23);
  WRITE('SELECT OPTION ');
END; {Scr1}

PROCEDURE TogglePr;
BEGIN
  IF PrintName = 'CONSOLE:'
    THEN  OutP:= @Lst
    ELSE  OutP:= @Output;
  IF PrintName = 'CONSOLE:'
    THEN  PrintName:= 'PRINTER:'
    ELSE  PrintName:= 'CONSOLE:';
END; {TogglePr}

PROCEDURE DBM;
VAR Ch : CHAR;

  PROCEDURE ScrDBM;
  BEGIN
    ScrHed;
    WRITELN('0.  EXIT ENTER / EDIT / UPDATE');
    WRITELN('1.  TOGGLE PRINTER: / CONSOLE:');
    WRITELN('2.  ENTER NAME OF FLIGHT FILE LIKE  A:81DEC31A.FLY');
    WRITELN('3.  LOAD FLIGHT FILE FROM DISK');
    WRITELN('4.  STORE FLIGHT FILE ONTO DISK');
    WRITELN('5.  CLEAR ALL FLIGHT DATA IN MAIN MEMORY');
    WRITELN('6.  ENTER PARAMETERS FOR THIS SET OF FLIGHTS');
    WRITELN('7.  ENTER FLIGHT DATA');
    WRITELN('8.  DISPLAY FLIGHT DATA');
    GOTOXY(1, 23);
    WRITE('SELECT OPTION ');
  END; {ScrDBM}

  PROCEDURE EnterName;
  VAR Ch : CHAR;  I : INTEGER;
  BEGIN
    ScrHed;
    WRITELN('INPUT FLIGHT FILE NAME');
    READLN(FileName);
    FOR I:= 1 TO Length(FileName) DO
      FileName[I]:= UpCase(FileName[I]);
  END; {EnterName}

  PROCEDURE LoadFile;
  LABEL ExitLoadFile;
  VAR I, J : INTEGER;  Ch : CHAR;
  BEGIN
    REPEAT
      ScrHed;
      WRITELN('DO YOU WISH TO LOAD FLIGHT FILE FROM DISK? (Y/N)');
      Ch:= ReadKey;  Ch:= UpCase(Ch);
    UNTIL (Ch = 'Y') OR (Ch = 'N');
    WRITELN;
    IF Ch = 'Y' THEN BEGIN
      ClearData;
      Assign(FDat, FileName);
      RESET(FDat);  CkIO(J);
      IF J=0 THEN BEGIN
        READ(FDat, ADat[0]);  CkIO(J);
        IF J <> 0 THEN  GoTo ExitLoadFile;
        FOR I:= 1 TO ADat[0].NR DO BEGIN
          READ(FDat, ADat[I]);  CkIO(J);
          IF J <> 0 THEN  GoTo ExitLoadFile;
        END;
        CLOSE(FDat);  CkIO(J);
      END;
    END;
ExitLoadFile:
  END; {LoadFile}

  PROCEDURE StoreFile;
  LABEL ExitStoreFile;
  VAR I, J : INTEGER;  Ch : CHAR;
  BEGIN
    REPEAT
      ScrHed;
      WRITELN('DO YOU WISH TO STORE FLIGHT FILE ONTO DISK? (Y/N)');
      Ch:= ReadKey;  Ch:= UpCase(Ch);
    UNTIL (Ch = 'Y') OR (Ch = 'N');
    WRITELN;
    IF Ch = 'Y' THEN BEGIN
      Assign(FDat, FileName);
      REWRITE(FDat);  CkIO(J);
      IF J=0 THEN BEGIN
        FOR I:= 0 TO ADat[0].NR DO BEGIN
          WRITE(FDat, ADat[I]);  CkIO(J);
          IF J <> 0 THEN  GoTo ExitStoreFile;
        END;
        CLOSE(FDat);  CkIO(J);
      END;
    END;
ExitStoreFile:
  END; {StoreFile}

  PROCEDURE ClearTest;
  VAR Ch : CHAR;
  BEGIN
    REPEAT
      ClrScr;
      WRITELN('DO YOU WISH TO CLEAR ALL FLIGHT DATA IN MAIN MEMORY? (Y/N)');
      Ch:= ReadKey;  Ch:= UpCase(Ch);
    UNTIL (Ch = 'Y') OR (Ch = 'N');
    IF Ch = 'Y' THEN  ClearData;
  END; {ClearTest}

  PROCEDURE DispData;
  VAR CN : INTEGER;  Ch : CHAR;
  BEGIN
    ClrScr;
    WRITELN(OutP^);  WRITELN(OutP^);
    WRITELN(OutP^, 'FLIGHT DATA FILE ', FileName);
    WRITELN(OutP^);  WRITELN(OutP^, '  FAC1    FAC2    ONEOW     H');
    WITH ADat[0] DO
      WRITELN(OutP^, Fac1R:8:2, Fac2R:8:2, OOWR:8:1, HR:8:1);
    WRITELN(OutP^);  WRITELN(OutP^,
      '  LEN      T     ZETA     SA    FACTOR    XKITE   YKITE   FLIGHT');
    FOR CN:= 1 TO ADat[0].NR DO
      WITH ADat[CN] DO
        WRITELN(OutP^, LenR:7:1, TR:8:2, ZetaR:8:2, SAR:8:2, FactR:8:2,
                    XMR:8:1, YMR:8:1, CN:6);
    WRITELN(OutP^, 'EOF');
    IF PrintName = 'CONSOLE:' THEN  Ch:= ReadKey;
  END; {DispData}

  PROCEDURE EnterHed;
  VAR Ch : CHAR;

    PROCEDURE ScreH;
    BEGIN
      ScrHed;
      WITH ADat[0] DO BEGIN
        WRITELN('0.  EXIT ENTERING PAPAMERERS');
        WRITELN('1.  INPUT INTEGRATION STEP SIZE,           H = ',HR:8:1);
        WRITELN('2.  INPUT LENGTH OF ONE POUND OF STRING, 1/W = ',OOWR:8:1);
        WRITELN('3.  INPUT LOW GEUSS AT WIND FACTOR,  FACTOR1 = ',Fac1R:8:2);
        WRITELN('4.  INPUT HIGH GUESS AT WIND FACTOR, FACTOR2 = ',Fac2R:8:2);
      END;
      GOTOXY(1, 23);
      WRITE('SELECT OPTION ');
    END; {ScreH}

    PROCEDURE InH;
    BEGIN
      WITH ADat[0] DO BEGIN
        ClrScr;
        WRITELN;  WRITELN(
          'INPUT H, INTEGRATION INTERVAL SIZE IN FEET OF STRING LENGTH');
        WRITELN('  OR 0 IF ', HR:3:1, ' IS OK');
        IR:= GetReal(0, 10000);
        IF IR <> 0 THEN  HR:= IR;
      END;
    END; {InH}

    PROCEDURE InOOW;
    BEGIN
      WITH ADat[0] DO BEGIN
        ClrScr;
        WRITELN;  WRITELN(
        'INPUT 1/W, LENGTH IN FEET OF ONE POUND OF KITE STRING USED');
        WRITELN('  OR 0 IF ', OOWR:3:1, ' IS OK');
        IR:= GetReal(0, 100000.0);
        IF IR <> 0 THEN  OOWR:= IR;
      END;
    END; {InOOW}

    PROCEDURE InFact1;
    BEGIN
      WITH ADat[0] DO BEGIN
        ClrScr;
        WRITELN;  WRITELN(
          'INPUT FACTOR1, LOW GEUSS AT WIND FACTOR');
        WRITELN('  OR 0 IF ', Fac1R:4:2, ' IS OK');
        IR:= GetReal(0, 100000.0);
        IF IR <> 0 THEN  Fac1R:= IR;
      END;
    END; {InFact1}

    PROCEDURE InFact2;
    BEGIN
      WITH ADat[0] DO BEGIN
        ClrScr;
        WRITELN;  WRITELN(
          'INPUT FACTOR2, HIGH GEUSS AT WIND FACTOR');
        WRITELN('  OR 0 IF ', Fac2R:4:2, ' IS OK');
        IR:= GetReal(0, 100000.0);
        IF IR <> 0 THEN  Fac2R:= IR;
      END;
    END; {InFact2}

  BEGIN {EnterHed}
    REPEAT
      ScreH;
      Ch:= ReadKey;
      CASE Ch OF
        '1': InH;
        '2': InOOW;
        '3': InFact1;
        '4': InFact2;
      END;
    UNTIL Ch = '0';
  END; {EnterHed}

  PROCEDURE EnterData;
  VAR CN : INTEGER;  Ch : CHAR;

    PROCEDURE ScrDat;
    BEGIN
      ScrHed;
      WRITELN(ADat[0].NR, ' LINES ENTERED, ON LINE ', CN, ' NOW');
      WRITELN;
      WITH ADat[CN] DO BEGIN
        WRITELN('0.  EXIT ENTERING FLIGHT DATA');
        WRITELN('1.  INPUT LENTH OF STRING OUT, LEN = ', LenR:8:1);
        WRITELN('2.  INPUT TENSION IN STRING,     T = ', TR:8:2);
        WRITELN('3.  INPUT ANGLE TO KITE,      ZETA = ', ZetaR:8:2);
        WRITELN('4.  INPUT ANGLE OF STRING,     SAR = ', SAR:8:2);
        WRITELN('5.  ADD A NEW LINE OF DATA');
        WRITELN('6.  DELETE A LINE OF DATA');
        WRITELN('7.  ADVANCE TO NEXT LINE IN CYCLE');
      END;
      GOTOXY(1, 23);
      WRITE('SELECT OPTION ');
    END; {ScrDat}

    PROCEDURE InLen;
    BEGIN
      WITH ADat[CN] DO BEGIN
        ClrScr;
        WRITELN;  WRITELN(
          'INPUT LEN, LENTH OF STRING OUT IN FEET');
        WRITELN('  OR 0 IF ', LenR:3:1, ' IS OK FOR LINE ', CN);
        IR:= GetReal(0, 100000.0);
        IF IR <> 0 THEN  LenR:= IR;
      END;
    END; {InLen}

    PROCEDURE InT;
    BEGIN
      WITH ADat[CN] DO BEGIN
        ClrScr;
        WRITELN;  WRITELN(
          'INPUT T, TENSION IN STRING AT FLYER IN POUNDS');
        WRITELN('  OR 0 IF ', TR:4:2, ' IS OK FOR LINE ', CN);
        IR:= GetReal(0, 10000);
        IF IR <> 0 THEN  TR:= IR;
      END;
    END; {InT}

    PROCEDURE InZeta;
    BEGIN
      WITH ADat[CN] DO BEGIN
        ClrScr;
        WRITELN;  WRITELN(
          'INPUT ZETA, ELEVATION ANGLE TO KITE IN DEGREES');
        WRITELN('  OR 0 IF ', ZetaR:4:2, ' IS OK FOR LINE ', CN);
        IR:= GetReal(-360, 360);
        IF IR <> 0  THEN  ZetaR:= IR;
        IF IR = 360 THEN  ZetaR:= 0;
      END;
    END; {InZeta}

    PROCEDURE InSA;
    BEGIN
      WITH ADat[CN] DO BEGIN
        ClrScr;
        WRITELN;  WRITELN(
          'INPUT SA, ANGLE OF STRING AT FLYER IN DEGREES');
        WRITELN('  OR 0 IF ', SAR:4:2, ' IS OK FOR LINE ', CN);
        IR:= GetReal(-360, 360);
        IF IR <> 0  THEN  SAR:= IR;
        IF IR = 360 THEN  SAR:= 0;
      END;
    END; {InSA}

    PROCEDURE AddLine;
    BEGIN
      WITH ADat[0] DO BEGIN
        IF NR < MaxR THEN  NR:= NR+1;
        CN:= NR;
      END;
    END; {AddLine}

    PROCEDURE DelLine;
    VAR I, J : INTEGER;
    BEGIN
      J:= ADat[0].NR;
      IF J > 1 THEN BEGIN
        FOR I:= CN TO J - 1 DO
          ADat[I]:= ADat[I+1];
        WITH ADat[J] DO BEGIN
          LenR:= 0;  TR:= 0;  ZetaR:= 0;  SAR:= 0;
          FactR:= 0;  XMR:= 0;  YMR:= 0;
        END;
        J:= J - 1;  ADat[0].NR:= J;
      END;
      IF CN > J THEN  CN:= J;
    END; {DelLine}

    PROCEDURE AdvLine;
    BEGIN
      IF CN >= ADat[0].NR THEN  CN:= 1
        ELSE  CN:= CN+1;
    END; {AdvLine}

  BEGIN {EnterData}
    CN:= 1;
    IF ADat[0].NR = 0
      THEN  ADat[0].NR:= 1;
    REPEAT
      ScrDat;
      Ch:= ReadKey;
      CASE Ch OF
        '1': InLen;
        '2': InT;
        '3': InZeta;
        '4': InSA;
        '5': AddLine;
        '6': DelLine;
        '7': AdvLine;
      END;
    UNTIL Ch = '0';
  END; {EnterData}

BEGIN {DBM}
  REPEAT
    ScrDBM;
    Ch:= ReadKey;
    CASE Ch OF
      '1': TogglePr;
      '2': EnterName;
      '3': LoadFile;
      '4': StoreFile;
      '5': ClearTest;
      '6': EnterHed;
      '7': EnterData;
      '8': DispData;
    END;
  UNTIL Ch = '0';
END; {DBM}

PROCEDURE CompFact;
VAR CN, CNMax : INTEGER;  Ch : CHAR;
BEGIN
  ClrScr;
  WRITELN('INPUT FIRST FLIGHT NUMBER IN FILE TO PROCESS <= ', ADat[0].NR);
  CN:= TRUNC(GetReal(1, ADat[0].NR));
  WRITELN('INPUT LAST FLIGHT NUMBER IN FILE TO PROCESS <= ', ADat[0].NR);
  CNMax:= TRUNC(GetReal(CN, ADat[0].NR));
  WRITELN('TYPE 0 TO ABORT COMPUTING FACTORS');
  WRITELN(OutP^);  WRITELN(OutP^);
  WRITELN(OutP^, 'COMPUTE WIND FACTORS FOR FLIGHT FILE ',
    FileName, ' FOR FLIGHT ', CN, ' THRU ', CNMax);
  REPEAT
    GetCase(CN);
    IF( OneOW > 0) AND (T > 0) THEN BEGIN
      WRITELN(OutP^);  WRITELN(OutP^);  WRITELN(OutP^,
'  LEN       T     ZETA     SA     FAC1    FAC2   ONEOW     H     FLIGHT');
      WRITELN(OutP^, SI:7:1, T:8:2, Zeta:8:2, SA:8:2, Factor1:8:2,
      Factor2:8:2, OneOW:8:1, H:8:1, CN:6);
      WRITELN(OutP^);  WRITELN(OutP^,
        '   S       X       Y       TX      TY       T      SA     ZETA',
        '     R     FACTOR');
      Root(Factor1, Factor2, EY, NT, RX);
      WITH ADat[CN], Vector DO BEGIN
        IF Converge THEN BEGIN
          XMR:= X;  YMR:= Y;  FactR:= Factor;
        END ELSE BEGIN
          XMR:= 0;  YMR:= 0;  FactR:= 0;
        END;
      END;
    END;
    CN:= CN+1;
  UNTIL (CN > CNMax) OR (OneOW <= 0) OR Abort;
  IF PrintName = 'CONSOLE:' THEN  Ch:= ReadKey;
END;

BEGIN {FlyAKite}
  Init;
  REPEAT
    REPEAT
      Scr1;
      OneCh:= ReadKey;
      CASE OneCh OF
        '1': TogglePr;
        '2': DBM;
        '3': CompFact;
        '4': PlotSt;
        '5': BEGIN SetGraphMode(Mode);  SetBkColor(Black); END;
        '6': RestoreCrtMode;
      END;
    UNTIL OneCh = '0';
    REPEAT
      ClrScr;
      WRITELN('DO YOU WISH TO RETURN TO THE SYSTEM? (Y/N)');
      OneCh:= ReadKey;  OneCh:= UpCase(OneCh);
    UNTIL (OneCh = 'Y') OR (OneCh = 'N');
  UNTIL OneCh = 'Y';
  ClrScr;
END. {FlyAKite}

Return to FlyAKite Program
Return to Harry's Home Page


This page accessed times since October 20, 2004.
Page created by: hjsmithh@sbcglobal.net
Changes last made on Tuesday, 08-Jul-08 15:51:29 PDT

1