{$m $ff02,0,87117}
{$i-}

program IDE (input, output);

uses
  crt, dos;

var
  KeyUp, KeyDown, Escape, PageUp, PageDown : boolean;
  Lijn                                     : array[0..331] of ^string;
  TotaalLijnen                             : longint;
  HeapStatus                               : pointer;
  FileName                                 : string;
  EXEFileName                              : string;
  Horizon, XPos, YPos                      : longint;

var
  Buffer      : array[-1..4007] of shortint;
  OldX, OldY  : longint;

procedure SaveDosScreen;
  begin
    OldX:= wherex;
    OldY:= wherey;
    move (mem[$b800 : $0000], Buffer, 4000);
  end;

procedure RestoreDosScreen;
  begin
    textmode (co80);
    gotoxy (OldX, OldY);
    move (Buffer, mem[$b800 : $0000], 4000);
  end;


procedure About;
  var
    Ch : char;
  begin
    window (37, 7, 67, 13);
    textcolor (yellow);
    textbackground (blue);
    clrscr;
    gotoxy (3,3);
    writeln ('Turbo Forth I.D.E. - (c) 2025 Trashware Graphics.');
    writeln;
    writeln ('Press any key... .. ... ..');
    Ch:= readkey;
    window (1,1, 80, 25);
  end;

  procedure InitMemory;
    var
      c : longint;
    begin
      for c:= 0 to 331 do begin
        new (Lijn[c]);
        Lijn [c]^:= '';
      end;
      TotaalLijnen:= -1;
    end;

procedure Invoer (X, Y : longint; var Tekst : string; FieldWidth : longint);
  var
    Len, c : longint;
    Ch     : char;
  begin
    Len:= length (Tekst);
    for c:= Len + 1 to FieldWidth do begin
      Tekst:= Tekst + ' ';
    end;
    Escape:= false;
    KeyUp:= false;
    KeyDown:= false;
    PageUp:= false;
    PageDown:= false;
    repeat
      textbackground (black);
      textcolor (brown);
      gotoxy (X, Y);
      write (copy (Tekst, 1, FieldWidth));
      repeat
        gotoxy (X + Len, Y);
        write (#177#32);
        gotoxy (X + Len, Y);
        delay (67);
        gotoxy (X, Y);
        write (copy (Tekst, 1, FieldWidth));
        gotoxy (X + Len, Y);
        delay (77);
      until keypressed;
      Ch:= readkey;
      case Ch of
        #27: Escape:= true;
        #13:;
        #0: begin
          Ch:= readkey;
          case Ch of
            'H': KeyUp:= true;
            'P': KeyDown:= true;
            'K': if (Len > 0) then Len:= Len - 1;
            'M': if (Len < FieldWidth-1) then Len:= Len + 1;
            'G': Len:= 0;
            'O': begin
              Len:= FieldWidth;
              while (Tekst[Len] = #32) and (Len > 0) do dec (Len, 1);
            end;
            'I': PageUp:= true;
            'Q': PageDown:= true;
            'S': begin
              Tekst:= Tekst + ' ';
              delete (Tekst, Len + 1, 1);
            end;
            else begin
              gotoxy (1, 1); write (Ch);
            end;
          end;
        end;
        #8: begin
          delete (Tekst, Len, 1);
          Tekst:= Tekst + ' ';
          if Len > 0 then Len:= Len - 1;
        end
        else begin
          if Len < FieldWidth - 1 then Len:= Len + 1;
          insert (Ch, Tekst, Len);
        end;
      end;
    until (Ch = #13) or Escape or KeyUp or KeyDown or PageUp or PageDown;
    if (Ch = #13) then KeyDown:= true;
    Len:= FieldWidth;
    while (Tekst [length(Tekst)] = #32) do delete (Tekst, length(Tekst), 1);
  end;

procedure LoadProgram;
  var
    s       : searchrec;
    DirMask : string;
    T       : text;
    c       : longint;
  begin
     TotaalLijnen:= -1;
     FileName:= 'NONAME.4TH';
     Horizon:= 0;
     XPos:= 1;
     YPos:= 1;
     textbackground (black);
     textcolor (white);
     clrscr;
     writeln ('Which Turbo Forth program do you want to load? ');
     writeln;
     write ('Please enter (change) the dirmask: ');
     DirMask:= '*.4TH';
     Invoer (length('Please enter (change) the dirmask: ')+1, 3, DirMask, 33);
     textcolor (yellow);
     writeln;
     findfirst (DirMask, archive + directory, s);
     while (doserror = 0) do begin
       if (s.attr = archive) then
         write (s.name : 20);
       findnext (s);
     end;
     writeln;
     FileName:= '';
     textcolor (yellow);
     write ('Open file with filename? $');
     Invoer (length ('Open file with filename? $')+1, wherey, FileName, 33);
     if pos ('.', FileName) = 0 then begin
       FileName:= FileName + copy (DirMask, pos ('.', DirMask), length(DirMask)-pos('.',DirMask)+1);
     end;
     for c:= 0 to 331 do begin
       Lijn [c]^:= '';
     end;
     TotaalLijnen:= -1;
     assign (T, Filename);
     reset (T);
     if ioresult <> 0 then exit;
     TotaalLijnen:= 0;
     readln (T, Lijn[0]^);
     while (not eof (T)) and (TotaalLijnen < 331) do begin
       inc (TotaalLijnen, 1);
       readln (T, Lijn[TotaalLijnen]^);
     end;
     close (T);
  end;

function BepaalTotaalLijnen : longint;
  var
    Return : longint;
  begin
    Return:= 331;
    while Lijn[Return]^ = '' do dec (Return, 1);
    BepaalTotaalLijnen:= Return;
  end;

procedure SaveProgram;
  var
    s       : searchrec;
    DirMask : string;
    T       : text;
    c       : longint;
    Ch      : char;
  begin
     textbackground (cyan);
     textcolor (black);
     clrscr;
     textcolor (Red);
     writeln ('List of Turbo Forth programs already on disk: ');
     writeln;
     DirMask:= '*.4TH';
     findfirst (DirMask, archive + directory, s);
     while (doserror = 0) do begin
       if (s.attr = archive) then
         write (s.name : 20);
       findnext (s);
     end;
     writeln;
     textcolor (Black);
     write ('Save file as? $');
     Invoer (length ('Save file as? $')+1, wherey, FileName, 53);
     if pos ('.', FileName) = 0 then begin
       FileName:= FileName + '.4TH';
     end;
     assign (T, Filename);
     reset (T);
     if ioresult = 0 then begin
       close (T);
       writeln;
       textcolor (lightgreen);
       writeln ('This file already exists! Overwrite? [y/n]? ');
       repeat
         Ch:= readkey;
       until upcase(Ch) in ['Y', 'N'];
     end;
     if Ch = 'N' then exit;
     TotaalLijnen:= BepaalTotaalLijnen;
     rewrite (T);
     for c:= 0 to TotaalLijnen do
       writeln (T, Lijn [c]^);
     close (T);
  end;

  procedure Editor;
    var
      Lijntje : string;
      c       : longint;
    begin
       Lijntje:= '';
       for c:= 1 to 81 do Lijntje:= Lijntje + ' ';
       textbackground (black);
       textcolor (green);
       repeat
         for c:= 1 to 23 do begin
           gotoxy (1, c+1);
           textcolor (cyan);
           write (100 + (c-1 + horizon)*10 : 8,'  ');
           textcolor (lightgreen);
           write (Lijn[c-1+horizon]^ + copy (Lijntje, 1, 70-length(Lijn[c-1+horizon]^)));
         end;
         Invoer (11, YPos+1, Lijn[YPos-1+Horizon]^, 70);
         if KeyUp then
           if YPos > 1 then dec (YPos, 1)
             else if Horizon > 0 then dec (Horizon, 1);
         if KeyDown then
           if YPos < 23 then inc (YPos, 1)
             else if Horizon+YPos < 331 then inc (Horizon, 1);
         if PageUp then horizon:= horizon - 23;
         if PageDown then horizon:= horizon + 23;
         if horizon < 0 then begin
           YPos:= 1;
           Horizon:= 0;
         end;
         if horizon + YPos > 331 then begin
           Horizon:= 331-23;
           YPos:= 23;
         end;
       until Escape;
    end;

procedure MainMenu (OnlyDraw : boolean);
  var
    Ch             : char;
    Lijntje        : string;
    c, Keuze       : longint;
    QUIT           : boolean;
    SavedFileName  : string;
    T              : text;
  const
    Tekst    : array[1..7] of string = (
      'Load', 'Save', 'Edit', 'Run & Compile to .EXE', 'Help', 'About', ''
    );
    TekstPos : array[1..7] of longint = (
      3, 11, 18, 25, 51, 57, 0
    );
  begin
   QUIT:= false;
   repeat
    Keuze:= 1;
    textmode (co80);
    textbackground (BLACK);
    clrscr;
    Lijntje:= '';
    for c:= 1 to 79 do Lijntje:= Lijntje + ' ';
    repeat
      textbackground (black);
      textcolor (white);
      for c:= 1 to 23 do begin
        gotoxy (1, c+1);
        textcolor (cyan);
        write (100 + (c-1 + horizon)*10 : 8,'  ');
        textcolor (lightgreen);
        write (Lijn[c-1+horizon]^ + copy (Lijntje, 1, 70-length(Lijn[c-1+horizon]^)));
      end;
      textcolor (black);
      textbackground (LIGHTGRAY);
      gotoxy (1, 1);
      write (Lijntje + ' ');
      gotoxy (1, 25);
      write (Lijntje);
      mem [$b800 : $0000 + 25 * 160 -1]:= lightgray*16 + black;
      for c:= 1 to 6 do begin
        if Keuze = c then textbackground (Brown) else textbackground (LIGHTGRAY);
        gotoxy (TekstPos[c], 1);
        write (' '+Tekst [c] + ' ');
      end;
      if OnlyDraw then exit;
      Ch:= readkey;
      if Ch = #0 then begin
        Ch:= readkey;
        case Ch of
          'K': if Keuze > 1 then dec (Keuze, 1);
          'M': if Keuze < 6 then inc (Keuze, 1);
        end;
      end;
    until Ch in [#27, #13];
    if Ch = #13 then begin
      case Keuze of
        1: LoadProgram;
        2: SaveProgram;
        3: begin
          gotoxy (1, 25);
          write ('***++++ [ESC]ape = main menu ... .... ... ... ..***++++/++');
          Editor;
        end;
        4: begin
          SavedFileName:= FileName;
          FileName:= 'RUNNER$$.4th';
          assign (T, 'RUNNER$$.4th');
          rewrite (T);
          for c:= 0 to TotaalLijnen do begin
            writeln (T, Lijn[c]^);
          end;
          close (T);
          swapvectors;
          exec (getenv('COMSPEC'), '/C fc.exe RUNNER$$.4th');
          swapvectors;
          EXEFileName:= FileName;
          delete (EXEFileName, pos ('.', EXEFileName), length(EXEFileName)-pos ('.', EXEFileName) + 1);
          RestoreDosScreen;
          swapvectors;
          exec (getenv ('COMSPEC'), '/C '+EXEFileName);
          swapvectors;
          SaveDosScreen;
          directvideo:= false;
          writeln(#10#13'Press any key to return to the Turbo Forth IDE.');
          Ch:= readkey;
          FileName:= SavedFileName;
        end;
        5: begin
          RestoreDosScreen;
          swapvectors;
          exec (getenv ('COMSPEC'), '/C readme help.4th');
          swapvectors;
        end;
        6: begin
          About;
        end;
      end;
    end else
      if Ch = #27 then begin
        textbackground (lightgray);
        textcolor (black);
        gotoxy (1, 25);
        write ('Really return to ms/dos or Windows 11? [y/n]?');
        repeat
            Ch:= readkey;
        until upcase (Ch) in ['Y', 'N'];
        Quit:= (upcase (Ch) = 'Y');
      end;
   until Quit;
  end;

var
  TestTekst : string;

begin
  Mark (HeapStatus);
  nosound;
  FileName:= 'NONAME.4TH';
  Horizon:= 0;
  XPos:= 1;
  YPos:= 1;
  InitMemory;
  SaveDosScreen;
  MainMenu (false);
  Release (HeapStatus);
  RestoreDosScreen;
  halt (0);
end.