{$I-,F+}
{$M $FF02,0,65535}

unit CORE3;

interface

uses
  graph, dos;

(* images need to be in the SCX -RAW image file format.
   do this with PICTVIEW.Exe && ALCHEMY.exe
   maybe use option -u for uniform palette in the alchemy options when
   (finally) converting to .raw .... ... ...
   use option -c16 with alchemy, ; .... ... ... , or it "hangs" .... ... ..
*)

procedure RUN (TEKST : string);
procedure SHOWIMAGEMCGA (FILENAME : string);
procedure SHOWIMAGEVGA (FILENAME : string);
procedure SHOWIMAGEMCGABOX (FILENAME : string; X1,Y1, X2,Y2 : integer);
procedure GETPAL (COLORNO : byte; var R,G,B : byte);
procedure SETPAL (COLORNO : byte; R,G, B : byte);
function  GETFILESIZE (TEKST : string) : longint;
procedure WISSEL (var A : integer; Var B : integer);
procedure CLSMCGA (COLOUR : integer);

implementation

procedure RUN (TEKST : string);
  begin
    exec (copy (TEKST, 1, pos(' ', Tekst)-1),
      copy (TEKST, pos(' ', TEKST)+1,
      length (TEKST) - (pos(' ', TEKST)+1) +1
    ));
  end;

procedure GETPAL (COLORNO : byte; var R,G,B : byte);
  begin
    port[$3c7]:= COLORNO;
    R:= port[$3c9];
    G:= port[$3c9];
    B:= port[$3c9];
  end;

procedure SETPAL (COLORNO : byte; R,G, B : byte);
  begin
    port[$3c8]:= COLORNO;
    port[$3c9]:= R;
    port[$3c9]:= G;
    port[$3c9]:= B;
  end;

procedure UPSTRING (var FILENAME : string);
  var
    C   : byte;
  begin
    for C:= 1 to length (FILENAME) do
      FILENAME[C]:= upcase (FILENAME[c]);
  end;

function  GETFILESIZE (TEKST : string) : longint;
  var
    FILENAME  : string;
    T         : text;
    LINE      : string;
    TEMP      : string;
    RETURN    : longint;
    CODE      : integer;
    C         : byte;
  begin
    RUN ('dir '+TEKST+' >INFO.DAT');
    assign (T, 'INFO.DAT');
    reset (T);
    FILENAME:= copy (TEKST, 1, pos('.', TEKST)-1);
    UPSTRING (FILENAME);
    while (pos(' ', FILENAME) > 0) do
      delete (FILENAME, pos (' ', FILENAME), 1);
    readln (T, LINE);
    UPSTRING (LINE);
    while (not (eof(T)) and (pos(FILENAME, LINE) = 0)) do begin
      readln (T, LINE);
      UPSTRING (LINE);
    end;
    close (T);
    TEMP:= '';
    C:= 0;
    repeat
      C:= C+1;
    until (LINE[C] in ['0'..'9']) or (C=255) or (C > length(LINE));
    TEMP:= TEMP + LINE[C];
    inc (C, 1);
    while (LINE[C] in ['0'..'9']) and (C<=length (LINE)) do begin
      TEMP:= TEMP + LINE[C];
      inc (C, 1);
      if LINE[C]=',' then
        inc (C, 1);
    end;
(*    for C:= 1 to length (LINE) do
      if LINE[C] in ['0'..'9'] then
        TEMP:= TEMP + LINE[C];
*)
    val (TEMP, RETURN, CODE);
    GETFILESIZE:= RETURN;
  end;

procedure SHOWIMAGEMCGA (FILENAME : string);
(*  type
    tBuffer = array[0..32001] of byte;
  var
    Buffer : ^tBuffer;
  *)
  var
    EXTENSION : string;
    F2        : file;
    PALETTE   : array[0..257, 0..2] of byte;
    SIZE      : longint;
    C, D,E    : byte;
    W         : word;
    L         : longint;
  begin
    EXTENSION:= '';
    EXTENSION:= copy (FILENAME, pos ('.', FILENAME),
      length(FILENAME) - pos ('.', FILENAME)+1
    );
    FILENAME:= copy (FILENAME, 1, pos('.', FILENAME)-1);
(*    new (Buffer);*)
    assign (F2, FILENAME + '.RAW');
    reset (F2, 1);
(*    SIZE:= GETFILESIZE (FILENAME + '.RAW');*)
    SIZE:= filesize (F2);
    blockread (F2, PALETTE[0, 0], 14); { get rid of header, palette var
      used as dummy filler here .... ... .... ... ...}
    if SIZE = 64800 then blockread (F2, PALETTE[0, 0], 18);
    if SIZE = 64000+16*3+14 then
      blockread (F2, PALETTE[0,0], 16*3)
        else
          blockread (F2, PALETTE[0, 0], 256*3);
    blockread (F2, mem[$a000:0], 64000);
(*    move (Buffer^, mem[$a000:0], 32000);
    blockread (F2, Buffer^, 32000);
    move (Buffer^, mem[$a000:32000], 32000);
*)
    close (F2);
    if SIZE = 64000+16*3+14 then begin
      for C:= 0 to 7 do
          SETPAL (C, PALETTE[C, 0] div 4, PALETTE[C, 1] div 4, PALETTE[C, 2] div 4);
      for C:= 8 to 15 do
          SETPAL (C, PALETTE[C, 0] mod 4, PALETTE[C, 1] mod 1, PALETTE[C, 2] mod 4);
    end else
      begin
        for C:= 0 to 255 do
          SETPAL (C, PALETTE[C, 0] shr 2, PALETTE[C, 1] shr 2, PALETTE[C, 2] shr 2);
      end;
(*    dispose (Buffer);*)
  end;

procedure WISSEL (var A : integer; Var B : integer);
  var
    Hulp : integer;
  begin
    Hulp:= A;
    A   := B;
    B   := HULP;
  end;

procedure SHOWIMAGEMCGABOX (FILENAME : string; X1,Y1, X2,Y2 : integer);
(*  type
    tBuffer = array[0..32001] of byte;
  var
    Buffer : ^tBuffer;
  *)
  var
    EXTENSION : string;
    F2        : file;
    PALETTE   : array[0..257, 0..2] of byte;
    SIZE      : longint;
    C, D,E    : integer;
    A         : real;
    B         : integer;
    W         : word;
    L         : longint;
    DX        : real;
    DY        : real;
    Q         : integer;
    I, J      : integer;
    Z         : real;
    LINE,LINE2: array[0..321] of byte;
  begin
    EXTENSION:= '';
    EXTENSION:= copy (FILENAME, pos ('.', FILENAME),
      length(FILENAME) - pos ('.', FILENAME)+1
    );
    FILENAME:= copy (FILENAME, 1, pos('.', FILENAME)-1);
(*    new (Buffer);*)
    assign (F2, FILENAME + '.RAW');
    reset (F2, 1);
(*    SIZE:= GETFILESIZE (FILENAME + '.RAW');*)
    SIZE:= filesize (F2);
    blockread (F2, PALETTE[0, 0], 14); { get rid of header, palette var
      used as dummy filler here .... ... .... ... ...}
    if SIZE = 64800 then blockread (F2, PALETTE[0, 0], 18);
    if SIZE = 64000+16*3+14 then
      blockread (F2, PALETTE[0,0], 16*3)
        else
          blockread (F2, PALETTE[0, 0], 256*3);
    if (X2 < X1) then WISSEL (X1, X2);
    if (Y2 < Y1) then WISSEL (Y1, Y2);
    DX:= 320 / (abs(X2-X1)+1);
    DY:= 200 / (abs(Y2-Y1)+1);
    A:=0;
    B:=0;
    W:=Y1;
    I:= 0;
    J:= X2;
    Z:= Y1;
    Q:= 0;
    J:=0;
    J:= Y1;
    repeat
      for W:= 1 to (200 div (abs(Y2-Y1)+1))+1 do
        blockread (F2, LINE, 320);
      A:= 0;
      I:= X1;
      repeat
        mem[$a000:I + J*320]:= LINE [round (A)];
        A:= A+ DX;
        inc (I, 1);
      until I > X2;
      inc (J, 1);
    until J > Y2;
(*    move (Buffer^, mem[$a000:0], 32000);
    blockread (F2, Buffer^, 32000);
    move (Buffer^, mem[$a000:32000], 32000);
*)
    close (F2);
    if SIZE = 64000+16*3+14 then begin
      for C:= 0 to 7 do
          SETPAL (C, PALETTE[C, 0] div 4, PALETTE[C, 1] div 4, PALETTE[C, 2] div 4);
      for C:= 8 to 15 do
          SETPAL (C, PALETTE[C, 0] mod 4, PALETTE[C, 1] mod 1, PALETTE[C, 2] mod 4);
    end else
      begin
        for C:= 0 to 255 do
          SETPAL (C, PALETTE[C, 0] shr 2, PALETTE[C, 1] shr 2, PALETTE[C, 2] shr 2);
      end;
(*    dispose (Buffer);*)
  end;

procedure SHOWIMAGEVGA (FILENAME : string);
(*  type
    tBuffer = array[0..32001] of byte;
  var
    Buffer : ^tBuffer;
  *)
  var
    EXTENSION : string;
    F2        : file;
    PALETTE   : array[0..257, 0..2] of byte;
    SIZE      : longint;
    C, D,E    : byte;
    W         : word;
    L         : longint;
    X, Y      : integer;
    LINE      : array[0..321] of byte;
  begin
    EXTENSION:= '';
    EXTENSION:= copy (FILENAME, pos ('.', FILENAME),
      length(FILENAME) - pos ('.', FILENAME)+1
    );
    FILENAME:= copy (FILENAME, 1, pos('.', FILENAME)-1);
(*    new (Buffer);*)
    assign (F2, FILENAME + '.RAW');
    reset (F2, 1);
(*    SIZE:= GETFILESIZE (FILENAME + '.RAW');*)
    SIZE:= filesize (F2);
    blockread (F2, PALETTE[0, 0], 14); { get rid of header, palette var
      used as dummy filler here .... ... .... ... ...}
    if SIZE = 64000+16*3+14 then
      blockread (F2, PALETTE[0,0], 16*3)
        else
          blockread (F2, PALETTE[0, 0], 256*3);
    for Y:= 0 to 479 do begin
      if Y <= 199 then
        blockread (F2, LINE, 320)
          else
            Y:= 479;
      for X:= 0 to 639 do begin
        putpixel (X, Y*2, LINE[X div 2]);
        putpixel (X, Y*2+1, LINE[X div 2]);
      end;
    end;
(*    move (Buffer^, mem[$a000:0], 32000);
    blockread (F2, Buffer^, 32000);
    move (Buffer^, mem[$a000:32000], 32000);
*)
    close (F2);
    if SIZE = 64000+16*3+14 then begin
      for C:= 0 to 7 do
          SETPAL (C, PALETTE[C, 0] div 4, PALETTE[C, 1] div 4, PALETTE[C, 2] div 4);
      for C:= 8 to 15 do
          SETPAL (C, PALETTE[C, 0] mod 4, PALETTE[C, 1] mod 1, PALETTE[C, 2] mod 4);
    end else
      begin
        for C:= 0 to 255 do
          SETPAL (C, PALETTE[C, 0] shr 2, PALETTE[C, 1] shr 2, PALETTE[C, 2] shr 2);
      end;
(*    dispose (Buffer);*)
  end;

procedure CLSMCGA (COLOUR : integer);
  begin
    fillchar (mem[$a000:0], 64000, COLOUR);
  end;

begin
end.