
{$m $ff02,0,65535}
{$i-,r-,s-,d+}

program IDE (input, output);

uses
  crt, dos;

type
  string127 = string[127];

var
  KeyUp, KeyDown, Escape, PageUp, PageDown : boolean;
  CtrlY                                    : boolean;
  Lijn                                     : array[-1..437] of ^string127;
  TotaalLijnen                             : longint;
  HeapStatus                               : pointer;
  FileName                                 : string127;
  EXEFileName                              : string127;
  Horizon, XPos, YPos                      : longint;

var
    InVoegen  : boolean;

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

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

function UpString (Tekst : string) : string;
  var
      c, len : integer;
      Haakjes: boolean;
  begin
      c:= 2;
      len:= length (Tekst);
      Haakjes:= (Tekst[1] = '"');
      Tekst[1]:= upcase (Tekst[1]);
      repeat
        if Tekst[c] = '"' then Haakjes:= not Haakjes;
        if not Haakjes then Tekst[c]:= upcase (Tekst[c]);
        c:= c + 1;
      until c>len;
      UpString:= Tekst;
  end;

function Preprocess (Tekst : string) : string;
  var
    c, c0, d, e : integer;
    Temp        : string;
    I           : integer;
  begin
    c:= 1;
    Tekst:= 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 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 (cyan);
    clrscr;
    gotoxy (3,3);
    textcolor (white);
    write ('U');
    textcolor (yellow);
    write ('ltra ');
    textcolor (magenta);
    write ('B');
    textcolor (yellow);
    writeln ('asic I.D.E. - (c) 2025 Trashware Graphics.');
    writeln ('(c) De '#1'''nnen - la ligne de la Belgique');
    writeln ('Press any key... .. ... ..');
    Ch:= readkey;
    window (1,1, 80, 25);
  end;

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

  procedure InsertLine;
    var
      c   : integer;
    begin
      for c:= 437 downto YPos+Horizon+1 do begin
        Lijn[c]^:= Lijn[c-1]^;
      end;
      Lijn[YPos+Horizon]^:= '';
      if TotaalLijnen < 433 then inc(TotaalLijnen, 1);
    end;

    procedure EraseLine;
      var
        c  : integer;
        t  : text;
      begin
        assign (T, 'TEMP$$$$.TXT');
        rewrite (T);
        for c:= YPos+Horizon to 437 do
          writeln (T, Lijn[c]^);
        close (T);
        reset (T);
        for c:= YPos+Horizon-1 to 436 do
          readln (T, Lijn[c]^);
        close (T);
        if TotaalLijnen >0 then dec (TotaalLijnen, 1);
      end;

    function AllSpaces2 (Tekst : string) : boolean;
      label Eruit;
      var
        c : integer;
        Ja: boolean;
      begin
        if Tekst = '' then
          AllSpaces2:= true
            else begin
              Ja:= true;
              for c:= 1 to length (Tekst) do begin
                if Tekst[c] <> ' ' then begin
                  Ja:= false;
                  goto Eruit;
                end;
              end;
            end;
        Eruit:;
        AllSpaces2:= Ja;
      end;


  procedure DeleteLine;
    var
      c, c2 : integer;
      tekst : string127;
      f     : file;
    begin
      assign (f, 'CLEANER.$$$');
      rewrite (f, 1);
      for c:= Horizon+YPos+1 to 437 do begin
        blockwrite (f, Lijn[c]^, sizeof(Lijn[c]^));
      end;
      close (f);
      for c:= 0 to 437 do
        Lijn[c]^:= '';
      reset (f, 1);
      c2:= 0;
      for c:= Horizon+YPos to 437 do begin
        blockread (f, Tekst, sizeof(Tekst));
        if AllSpaces2 (tekst) (* <> '' *) then begin
          lijn[c2]^:= tekst;
          c2:= c2 + 1;
        end;
      end;
      close (f);
      if TotaalLijnen>0 then dec (TotaalLijnen, 1);
    end;

  function AllSpaces (Tekst : string) : boolean;
    var
      c      : integer;
      IsZo   : boolean;
    label
      Eruit;
    begin
      IsZo:= true;
      for c:= 1 to length (Tekst) do
        if Tekst[c] <> ' ' then begin
          IsZo:= false;
          goto Eruit;
        end;
      Eruit:;
      AllSpaces:= IsZo;
    end;

procedure Invoer (X, Y : longint; var Tekst : string127; FieldWidth : longint);
  var
    Len, c    : longint;
    Ch        : char;
  const
    Lijntje : string = '                                                            ';
  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;
    CtrlY:= false;
    repeat
      textbackground (blue);
      textcolor (brown);
      gotoxy (X, Y);
      write (copy (Tekst, 1, FieldWidth));
      repeat
        gotoxy (X + Len, Y);
        write (#177#32);
        gotoxy (X + Len, Y);
        delay (37);
        gotoxy (X, Y);
        write (copy (Tekst, 1, FieldWidth));
        gotoxy (57, 25);
        write (X + Len - 2 : 5);
        gotoxy (57+7, 25);
        write (YPos+Horizon : 5);
        gotoxy (57+14, 25);
        if Invoegen then write ('INS') else write('OVR');
        gotoxy (X + Len, Y);
        delay (17);
      until keypressed;
      Ch:= readkey;
      case Ch of
        #25: CtrlY:= true;
        #27: Escape:= true;
        #13:;
        #0: begin
          Ch:= readkey;
          case Ch of
            'R': Invoegen:= not Invoegen;
            'H': KeyUp:= true;
            'P': KeyDown:= true;
            'K': if (Len > 0) then Len:= Len - 1;
            'M': if (Len < FieldWidth-1) then Len:= Len + 1;
            'G': begin
              Len:= 0;
            end;
            '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;
          if Invoegen then
            insert (Ch, Tekst, Len)
              else
                Tekst[Len]:= Ch;
        end;
      end;
    until CtrlY or (Ch = #13) or Escape or KeyUp or KeyDown or PageUp or PageDown;
    if (Ch = #13) then begin
      KeyDown:= true;
      if InVoegen then begin
        InsertLine;
      end;
    end;
    if CtrlY then EraseLine;
    Len:= FieldWidth;
    while (Tekst [length(Tekst)] = #32) do delete (Tekst, length(Tekst), 1);
  end;

procedure LoadProgram;
  var
    s       : searchrec;
    DirMask : string127;
    T       : text;
    c       : longint;
    q       : byte;
  begin
     TotaalLijnen:= -1;
     FileName:= 'NONAME00.BAS';
     Horizon:= 0;
     XPos:= 1;
     YPos:= 1;
     textbackground (blue);
     textcolor (white);
     clrscr;
     writeln ('Which Ultra Basic - program do you want to load? ');
     writeln;
     write ('Please enter (change) the dirmask: ');
     DirMask:= '*.BAS';
     Invoer (length('Please enter (change) the dirmask: ')+1, 3, DirMask, 33);
     textcolor (yellow);
     writeln;
     findfirst (DirMask, archive + directory, s);
     q:= 0;
     while (doserror = 0) do begin
       if (s.attr = archive) then
         write (s.name : 15);
       q:= q+1;
       if q=5 then begin
         writeln;
         q:= 0;
       end;
       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 433 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 < 433) do begin
       inc (TotaalLijnen, 1);
       readln (T, Lijn[TotaalLijnen]^);
     end;
     close (T);
  end;

procedure _LoadProgram (Tekst : string);
  var
    s       : searchrec;
    DirMask : string127;
    T       : text;
    c       : longint;
    q       : byte;
  begin
     TotaalLijnen:= -1;
     FileName:= Tekst;
     if pos('.', FileName) = 0 then FileName:= FileName + '.BAS';
     Horizon:= 0;
     XPos:= 1;
     YPos:= 1;
     TotaalLijnen:= -1;
     assign (T, Filename);
     reset (T);
     if ioresult <> 0 then exit;
     TotaalLijnen:= 0;
     readln (T, Lijn[0]^);
     while (not eof (T)) and (TotaalLijnen < 433) do begin
       inc (TotaalLijnen, 1);
       readln (T, Lijn[TotaalLijnen]^);
     end;
     close (T);
  end;

procedure SaveProgram;
  var
    s       : searchrec;
    DirMask : string;
    T       : text;
    c       : longint;
    Ch      : char;
  begin
     textbackground (blue);
     textcolor (black);
     clrscr;
     textcolor (cyan);
     writeln ('List of Ultra Basic - programs already on disk: ');
     writeln;
     DirMask:= '*.bas';
     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 + '.BAS';
     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 (blue);
       textcolor (green);
       repeat
         for c:= 1 to 23 do begin
           gotoxy (1, c+1);
           textcolor (cyan);
           write ('  ');
           textcolor (lightgreen);
           write (100+(c+Horizon-1)*10 : 7, ' ', Lijn[c-1+horizon]^ + copy (Lijntje, 1, 71-length(Lijn[c-1+horizon]^)));
         end;
         textbackground (lightgray);
         gotoxy (1, 25);
         write (' ');
         Invoer (10, YPos+1, Lijn[YPos-1+Horizon]^, 70);
         Lijn[YPos-1+Horizon]^:= Preprocess (Lijn[YPos-1+Horizon]^);
         while (pos(#32#32, Lijn[YPos-1+Horizon]^) > 0) do
           delete (Lijn[YPos-1+Horizon]^, pos ('  ', Lijn[YPos-1+Horizon]^), 1);
         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 < 433 then inc (Horizon, 1);
         if PageUp then if horizon >23 then horizon:= horizon-23 else
           horizon:= 0;
         if PageDown then if horizon < 433-23 then inc (horizon, 23) else
           horizon:= 433-23;
         if horizon < 0 then begin
           YPos:= 1;
           Horizon:= 0;
         end;
         if horizon + YPos > 433 then begin
           Horizon:= 433-25;
           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 (blue);
      textcolor (white);
      for c:= 1 to 23 do begin
        gotoxy (1, c+1);
        textcolor (black);
        write ('  ');
        textcolor (lightgreen);
        write (Lijn[c-1+horizon]^ + copy (Lijntje, 1, 79-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$$.bas';
          assign (T, 'RUNNER$$.bas');
          rewrite (T);
          for c:= 0 to TotaalLijnen do begin
            writeln (T, Lijn[c]^);
          end;
          close (T);
          textbackground (black);
          textcolor (lightgray);
          clrscr;
          exec ('PRECOMPI.exe', 'RUNNER$$');
          exec ('LINK.exe', 'RUNNER$$');
          EXEFileName:= FileName;
          delete (EXEFileName, pos ('.', EXEFileName), length(EXEFileName)-pos ('.', EXEFileName) + 1);
          RestoreDosScreen;
          exec ('RUNNER$$.EXE', '');
          SaveDosScreen;
          directvideo:= false;
          writeln(#10#13'Press any key to return to the Ultra Basic - IDE.');
          Ch:= readkey;
          FileName:= SavedFileName;
        end;
        5: begin
          RestoreDosScreen;
          exec ('readme.com', 'help.UBH');
        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:= 'NONAME00.BAS';
  Horizon:= 0;
  XPos:= 1;
  YPos:= 1;
  InVoegen:= true;
  InitMemory;
  SaveDosScreen;
  if paramcount = 1 then
    _LoadProgram (paramstr(1));
  MainMenu (false);
  Release (HeapStatus);
  RestoreDosScreen;
  halt (0);
end.