{$i-,s-,r-}
{$m $ff02,0,0}

program BB8BASIC (input, output);

uses
  crt, dos, CORE,CORE2,CORE3,CORE5, CYPHER,TANK, ERRORS,graph;

type
  VariablesBuffer = array[0..53001] of byte;
  string17        = string[22];

const
  MAX_FILES  = 45;

var
  AVar           : ^VariablesBuffer;
  HighestVarPos  : longint;
  KP             : boolean;
  EOFILE         : array[0..MAX_FILES] of boolean;
  AFILE          : array[0..MAX_FILES] of text;
  FMODE          : array[0..MAX_FILES] of char;
  buffer         : array[0..4001] of shortint;
  dosx, dosy     : integer;
  _VarName       : array[0..777] of string17;
  VarIndex       : integer;
  ProgramCounter : integer;

var
  Segment       : word;
  OPTION_BASE   : shortint;

var
  EXPRESSION  : string;
  INDEX       : integer;
  STOP        : boolean;
  FORLOOPINDEX: longint;
  STDOUT      : text;

const
  PAPER : byte = BLACK;
  INK   : byte = LIGHTGRAY;

function IsString (Tekst : string) : boolean;
  begin
    IsString:= ((pos ('"', Tekst) > 0) or (pos ('$', Tekst) > 0)) and
      ((pos ('LEN', Tekst) = 0) and (pos ('ASC', Tekst) = 0))
  end;

procedure trim (var Tekst : string);
  begin
    while (Tekst[1] = ' ') do
      delete (Tekst, 1, 1);
    while (Tekst[length (Tekst)] = ' ') do
      delete (Tekst, length (Tekst), 1);
  end;

  function IsAlphaBet (Tekst : char) : boolean;
    begin
      IsAlphaBet:= (Tekst in ['A'..'Z', 'a'..'z', '$']);
    end;

procedure SaveVariable (VarName : string; Value : string);
  var
(*    TheVar   : TheConstruct;*)
    Len      : byte;
    Temp     : string;
    IsString : boolean;
    IsReal   : boolean;
    R        : real;
    Found    : boolean;
    c        : longint;
  begin
    while (pos (' ', VarName) > 0) do delete (VarName, pos (' ', VarName), 1);
    UpString (VarName);
    if VarIndex < 777 then begin
      inc (VarIndex, 1);
      _VarName [VarIndex]:= VarName;
    end
      else
        exit;
    IsString:= pos ('$', VarName) > 0;
    IsReal:= not IsString;
    Len:= length (VarName);
    Found:= false;
    for c:= 0 to HighestVarPos+1 do begin
      move (AVar^[c], Temp[0], Len+1);
      if Temp = VarName then begin
        case IsReal of
          true:   begin
            R:= INFIX (Value);
            move (R, AVar^[c + Len + 1], sizeof (real));
          end;
          false: begin
            move (Value[0], AVar^[c+Len + 1], 256);
          end;
        end;
        Found:= true;
        c:= HighestVarPos+1;
      end;
    end;
    if (not Found) and (HighestVarPos < 53001-256*2) then begin
        move (VarName[0], AVar^[HighestVarPos], Len+1);
        inc (HighestVarPos, Len + 1);
        case IsReal of
          true:   begin
            R:= INFIX (Value);
            move (R, AVar^[HighestVarPos], sizeof (real));
            inc (HighestVarPos, sizeof (real));
          end;
          false: begin
            move (Value[0], AVar^[HighestVarPos], 256);
            inc (HighestVarPos, 256);
          end;

        end;
    end;
  end;

function LoadVariable (VarName : string) : string;
  var
(*    TheVar   : TheConstruct;*)
    Len      : byte;
    Temp     : string;
    IsString : boolean;
    IsReal   : boolean;
    R        : real;
    Return   : string;
    c        : longint;
    Found    : boolean;
  begin
    IsString:= pos ('$', VarName) > 0;
    IsReal:= not IsString;
    Len:= length (VarName);
    Found:= false;
    for c:= 0 to HighestVarPos+1 do begin
      move (AVar^[c], Temp[0], Len+1);
      if Temp = VarName then begin
        case IsReal of
          true:   begin
            move (AVar^[c + Len + 1], R, sizeof (real));
            str (R, Return);
          end;
          false: move (AVar^[c+Len + 1], Return[0], 256);
        end;
        Found:= true;
        c:= HighestVarPos + 1;
      end;
    end;
    if Found then
       LoadVariable:= Return
    else begin
      if IsString then begin
        LoadVariable:= ''
      end
          else begin
            LoadVariable:= '0';
          end;
    end;
  end;

function ReplaceVariables (Tekst : string) : string;
  var
(*    TheVar   : TheConstruct;*)
    Len      : byte;
    Return   : string;
    c, p     : integer;
    a, b     : integer;
    Tekst2   : string;
    r        : real;
    i        : integer;
  begin
    if pos ('[', Tekst) > 0 then begin
      a:= pos ('[', Tekst);
      b:= pos (']', Tekst);
      Tekst2:= Tekst;
      delete (Tekst2, b, 255);
      delete (Tekst2, 1, a);
      delete (Tekst, a, length (Tekst2) + 2);
      Tekst2:= ReplaceVariables (Tekst2);
      R:= INFIX (Tekst2);
      I:= round (R);
      str (I, Tekst2);
      insert (Tekst2, Tekst, a);
      insert ('[', Tekst, a);
      insert (']', Tekst, a+length (Tekst2)+1);
    end;
    Len:= length (Tekst);
    for c:= 0 to VarIndex do begin
       p:= pos (_VarName[c], Tekst);
       while p > 0 do begin
        delete (Tekst, p, length (_VarName[c]));
        Tekst2:= LoadVariable (_VarName[c]);
        if pos ('$', _VarName[c]) > 0 then
          Tekst2:= '"'+Tekst2+'"';
        insert (Tekst2, Tekst, p);
        p:= pos (_VarName[c], Tekst);
      end;
    end;
    ReplaceVariables:= Tekst;
  end;

function ReplaceVariables0 (Tekst : string) : string;
  var
(*    TheVar   : TheConstruct;*)
    Len      : byte;
    Return   : string;
    c, p     : integer;
    a, b     : integer;
    Tekst2   : string;
    r        : real;
    i        : integer;
  begin
    if pos ('[', Tekst) > 0 then begin
      a:= pos ('[', Tekst);
      b:= pos (']', Tekst);
      Tekst2:= Tekst;
      delete (Tekst2, b, 255);
      delete (Tekst2, 1, a);
      delete (Tekst, a, length (Tekst2) + 2);
      Tekst2:= ReplaceVariables (Tekst2);
      R:= INFIX(Tekst2);
      I:= round (R);
      str (I, Tekst2);
      insert (Tekst2, Tekst, a);
      insert ('[', Tekst, a);
      insert (']', Tekst, a+length (Tekst2)+1);
    end;
    ReplaceVariables0:= Tekst;
  end;

procedure Dim (VarName : string; Getal : integer);
  var
    Tekst : string;
    Temp  : string;
    c     : integer;
  begin
    UpString (VarName);
    if pos ('$', VarName) = 0 then
      Tekst:= '0'
        else
          Tekst:= '';
    for c:= OPTION_BASE to Getal do begin
      str (c, Temp);
      SaveVariable (VarName+'['+Temp+']', Tekst);
    end;
  end;

procedure CopyFile (Tekst, Tekst2 : string);
  var
    Buffer2: array[0..1025] of shortint;
    Size   : longint;
    F,F2   : file;
    c      : longint;
  begin
    {$I-}
    assign (F, Tekst);
    reset (F, 1);
    assign (F2, Tekst2);
    rewrite (F2, 1);
    Size:= filesize (F);
    for c:= 1 to Size div 1024 do begin
      blockread (F, Buffer2, 1024);
      blockwrite (F2, Buffer2, 1024);
    end;
    Size:= Size mod 1024;
    blockread (F, Buffer2, SIze);
    blockwrite (F2, Buffer2, Size);
    close (F);
    close (F2)
  end;

procedure SaveDosScreen;
  begin
     move (mem[$b800:0], buffer, 4000);
     dosx:= wherex;
     dosy:= wherey;
  end;

procedure RestoreDosScreen;
  begin
      textmode (co80);
      move (buffer, mem[$b800:0], 4000);
      gotoxy (dosx, dosy);
  end;

procedure Clear;
  var
    C  : integer;
  begin
    FoutMelding:= false;
    FoutTekst:= '';
    STOP:= false;
    OPTION_BASE:= 1;
    for c:= 0 to MAX_FILES do FMODE[c]:= 'C';
    for c:= 0 to 777 do _VarName[c]:= '';
    VarIndex:= -1;
    HighestVarPos:= 0;
    Paper:= BLUE;
    Ink:= LightGray;
    ForLoopIndex:= -1;
    textbackground (Paper);
    textcolor (Ink);
    gotoxy (1, 1);
    SaveVariable ('VGAHI', '11');
    SaveVariable ('TEXT', '3');
    SaveVariable ('FLASHING', '128');
    SaveVariable ('BLACK', '0');
    SaveVariable ('BLUE', '1');
    SaveVariable ('GREEN', '2');
    SaveVariable ('CYAN', '3');
    SaveVariable ('RED', '4');
    SaveVariable ('MAGENTA', '5');
    SaveVariable ('BROWN', '6');
    SaveVariable ('LIGHTGRAY', '7');

    SaveVariable ('DARKGRAY', '8');
    SaveVariable ('LIGHTBLUE', '9');
    SaveVariable ('LIGHTGREEN', '10');
    SaveVariable ('LIGHTCYAN', '11');
    SaveVariable ('LIGHTRED', '12');
    SaveVariable ('LIGHTMAGENTA', '13');
    SaveVariable ('YELLOW', '14');
    SaveVariable ('WHITE', '15');
    SEGMENT:= $A000;
  end;

function NextToken : string;
  var
      Temp    : string;
      Say     : boolean;
      Len     : integer;
  begin
     Temp:= '';
     Len:= length (Expression);
     if (Index <= Len) and (Expression[Index] in [',', ';', '=', '<',
      '>']) then begin
       inc (Index, 1);
       NextToken:= Expression [Index-1];
       exit;
     end;
     while (Index <= Len) and (Expression[Index] = ' ') do
         inc (Index, 1);
     if Expression [Index] = '[' then
       while (Index <= Len) and (Expression[Index] = ' ') do
           inc (Index, 1);
     if Expression [Index] = ']' then
       while (Index <= Len) and (Expression[Index] = ' ') do
           inc (Index, 1);
     Say:= Expression[Index] = '"';
     while (Index <= Len) and (Say or (Expression[Index]<>#32)) do begin
        Temp:= Temp + Expression[Index];
        inc (Index, 1);
        if Expression[Index] = '"' then Say:= not Say
     end;
     NextToken:= Temp
  end;

function Expect (Tekst : string) : boolean;
  var
    Token : string;
  begin
    Token:= NextToken;
    UpString (Token);
    UpString (Tekst);
    if Token <> Tekst then begin
      Foutmelding:= true;
      Fouttekst:= Tekst + ' expected.';
      Expect:= false;
      exit;
    end
      else
        Expect:= true;
  end;

  procedure Shell;
    var Token : string;
    begin
      Token:= nexttoken;
      UpString (Token);
      Token:= ReplaceVariables (Token);
      Token:= _CALCSTRING (Token);
      exec (Token, '');
    end;

  var
    Escape : boolean;

function Preprocess (Tekst : string) : string;
  var
    c, c0, d, e : integer;
    Temp        : string;
    I           : integer;
  begin
    c:= 1;
    UpString (Tekst);
(*    while (pos(' ', Tekst) > 0) do delete (Tekst, pos (' ', Tekst), 1);
    for c:= 1 to TotalCommands do begin
      if pos (Com[c], Tekst) > 0 then
        insert (' ', Tekst, pos (Com[c], Tekst));
    end;
*)
    repeat
      if Tekst[c] = '[' then begin
        d:= c-1;
        e:= 0;
        while (d >= 1) and (Tekst[d] = ' ') do begin
          dec (d, 1);
          inc (e, 1);
        end;
        inc (d, 1);
        delete (Tekst, d, e);
        c:= c + e + 1;
      end;
      if Tekst[c] in [':', ',', ';', '='] then begin
        insert (' ', Tekst, c);
        inc (c, 2);
        insert (' ', Tekst, c);
      end;
      c:= c + 1;
    until c > length (Tekst);
    Preprocess:= Tekst;
  end;


procedure EXECUTECOM (TEKST : string);
  var
    TEMP0, TEMP, TEMP3 : string;
    P                  : integer;
    TOKEN              : string;
    X                  : word;
    Y                  : byte;
    A, B               : string;
    CH                 : char;
  procedure GETPARAM;
    var
      TEMP2 : string;
    begin
      TEMP:= '';
      TEMP2:= NEXTTOKEN;
      while TEMP2 <> '' do begin
        TEMP:= TEMP + TEMP2;
        TEMP2:= NEXTTOKEN;
      end;
    end;
  procedure PRINT (TEKST : string);
    var
      C       : byte;
      TEKST2  : string;
    begin
      if pos ('"', TEKST) = 0 then
        writeln (stdout, 'TEKST:= REPLACEVARIABLES(''', TEKST, ''');');
      writeln (stdout, 'TEKST:= _CALCSTRING (TEKST);');
      if pos ('"', TEKST) = 0 then begin
         TRIM (TEKST);
         UPSTRING (TEKST);
         writeln (stdout, 'PRINTVGA ((wherex-1)*8, (wherey-1)*8, TEKST );');
      end else begin
        for C:= 1 to length (TEKST) do
          if TEKST[C] = '"' then TEKST[C]:= '''';
        writeln (stdout, 'PRINTVGA ((wherex-1)*8, (wherey-1)*8, ', TEKST, ');');
      end;
    end;
  begin
    if FOUTMELDING then
      exit;
    P:= pos (':', TEKST);
    while (P > 0) do begin
      TEMP0:= copy (TEKST, 1, P-1);
      EXECUTECOM (TEMP0);
      delete (TEKST, 1, P);
      P:= pos (':', TEKST);
    end;
    TEKST:= PREPROCESS (TEKST);
    EXPRESSION:= TEKST;
    INDEX:= 1;
    repeat
      TOKEN:= NEXTTOKEN;
      TRIM (TOKEN);
      UPSTRING (TOKEN);
      if TOKEN = 'IMAGE' then begin
        GETPARAM;
        UPSTRING (TEMP);
        TRIM (TEMP);
        if pos('IMAGE', TEMP) > 0 then
          delete (TEMP, pos('IMAGE', TEMP), 5);
        writeln (stdout, 'TEKST:= REPLACEVARIABLES('+''''+TEMP+''''+');');
        writeln (stdout, 'TEKST:= ANYTHING(TEKST);');
        writeln (stdout, 'TRIM (TEKST);');
        writeln (stdout, 'while (pos(''"'', TEKST) > 0) do delete (TEKST, pos(''"'', TEKST), 1);');
        writeln (stdout, 'SHOWIMAGEVGA (TEKST);');
      end else
      if TOKEN = 'PRINT' then begin
        GETPARAM;
        while (pos (';', TEMP) > 0) do begin
          TEMP3:= copy (TEMP, 1, pos(';', TEMP)-1);
          PRINT (TEMP3+#32);
          delete (TEMP, 1, pos(';', TEMP));
        end;
        PRINT (TEMP);
        writeln (stdout, 'gotoxy (1, wherey+1);');
      end else
      if TOKEN = 'POKE' then begin
        GETPARAM;
        P:= pos (',', TEMP);
        A:= copy (TEMP, 1, P-1);
        delete (TEMP, 1, P);
        B:= TEMP;
        A:= REPLACEVARIABLES (A);
        B:= REPLACEVARIABLES (B);
        X:= round (INFIX(A));
        Y:= round (INFIX(B));
        writeln (stdout, 'mem[SEGMENT : X]:= Y;');
      end
      else if TOKEN = 'CLS' then begin
        writeln (stdout, 'setbkcolor (PAPER);');
        writeln (stdout, 'cleardevice;');
        writeln (stdout, 'setcolor (INK);');
        writeln (stdout, 'directvideo:= false;');
        writeln (stdout, 'gotoxy (1, 1);');
      end else
      if TOKEN = 'INPUT' then begin
        GETPARAM;
        while (pos (';', TEMP) > 0) do begin
          TEMP3:= copy (TEMP, 1, pos(';', TEMP)-1);
          PRINT (TEMP3+#32);
          delete (TEMP, 1, pos(';', TEMP));
        end;
        TEMP3:= '';
        writeln (stdout, 'READLNVGA (TEKST);');
        writeln (stdout, 'delete (TEKST, length(TEKST), 1);');
        writeln (stdout, 'SAVEVARIABLE (''', TEMP, '''', ', TEKST);');
        writeln (stdout, 'gotoxy (1, wherey+1);');
      end else
      if TOKEN = 'LET' then
      begin
        TEMP3:= NEXTTOKEN;
        GETPARAM;
        TRIM (TEMP3);
        UPSTRING (TEMP3);
        if pos('=', TEMP) > 0 then
          delete (TEMP, 1, pos('=', TEMP));
        TRIM (TEMP);
(*        TEMP:= REPLACEVARIABLES (TEMP);
        TEMP:= _CALCSTRING (TEMP);
*)
        if pos('INKEY$', TEMP) > 0 then begin
          writeln (stdout, 'repeat until keypressed;');
          writeln (stdout, 'Ch:= readkey;');
          writeln (stdout, 'SAVEVARIABLE (''', TEMP3, ''''+', '+'Ch'+');');
        end
          else
            writeln (stdout, 'SAVEVARIABLE (''', TEMP3, ''''+', '+''''+TEMP+''''+');');
      end;
    until TOKEN ='';
  end;

var
  FILENAME, PASFILENAME, EXEFILENAME : string;
  T                                  : text;
  C                                  : longint;
  X,Y                                : byte;
  TEKST                              : string;

begin
  writeln;
  textcolor (WHITE);
  writeln ('BB8BASIC ".BAS" to ".PAS" compiler, version 1.0');
  if paramcount < 1 then begin
    textcolor (DARKGRAY);
    writeln ('usage: ', paramstr(0), ' <basic_program_text_file[.BAS]>');
    writeln ('this produces the pascal file and the executable... ....');
    writeln;
    textcolor (GREEN);
    writeln ('Note that this program needs "TPC.EXE", several ".TPU" - files &');
    writeln ('"BB8CORE2.PAS" & "TURBO.TPL" .... ... .... ....');
    halt (0);
  end;
  SAVEDOSSCREEN;
  FILENAME:= paramstr (1);
  TRIM (FILENAME);
  UPSTRING (FILENAME);
  if pos ('.', FILENAME) = 0 then
    FILENAME:= FILENAME + '.BAS';
  writeln ('Compiling '+FileName+' .... ... .... ....');
  PASFILENAME:= copy (FILENAME, 1, pos('.BAS', FileName)-1)+'.PAS';
  EXEFILENAME:= copy (FILENAME, 1, pos('.BAS', FileName)-1)+'.EXE';
  writeln ('Writing header "BB8CORE2.PAS" to '+PASFILENAME+' .... ... ....');
  assign (T, 'BB8CORE3.PAS');
  reset (T);
  assign (stdout, PASFILENAME);
  rewrite (stdout);

  x:= wherex;
  y:= wherey;
  for C:= 1 to 283 do begin
    readln (T, TEKST);
    gotoxy (1, 1);
    write (TEKST);
    writeln (stdout, TEKST);
  end;
  close (T);

  gotoxy (x, y);

  writeln ('Parsing the "BASIC-program": '+FILENAME, ' .... ... .... ....');

  x:= wherex;
  y:= wherey;

  assign (T, FILENAME);
  reset (T);
  readln (T, TEKST);
  while not (eof(T)) do begin
    TEKST:= PREPROCESS (TEKST);

    gotoxy (1, 1);
    write (TEKST);

    EXECUTECOM (TEKST);
    readln (T, TEKST);
  end;
  TEKST:= PREPROCESS (TEKST);
  gotoxy (1, 1);
  write (TEKST);
  EXECUTECOM (TEKST);
  close (T);
(*  writeln (stdout, 'dispose (AVAR);');*)
  writeln (stdout, 'end.');
  close (stdout);

  gotoxy (x, y);

  writeln ('Calling "TPC.EXE" .... ... ....');
  exec (getenv ('COMSPEC'), '/C TPC.EXE '+PASFILENAME);

(*  VGAINIT;
  CLEAR;
  SAVEVARIABLE ('AAP$', 'is een aap.');
  assign (STDOUT, 'TEST.C');
  rewrite (stdout);
  writeln (stdout, 'var TEKST : string;');
  EXECUTECOM ('AAP$ = "is een aap."');
  EXECUTECOM ('PRINT AAP$:INPUT "Hoeveel is 1 plus 1? ";BERT');
  EXECUTECOM ('KOFFIE = 4');
  EXECUTECOM ('IMAGE "VADER.RAW"');
  close (stdout);
  writeln (LOADVARIABLE('KOFFIE'));
  readln;
*)
(*  RESTOREDOSSCREEN;*)
end.
