/* REXX */

/*
-----------------------------------------------------------------
  unpacker (v0.1h) = public domain : free for any use

  AUTHOR: rugxulo _AT_ gmail

  TESTED: Regina 3.7, BRexx 2.1.9, r4 4.00, ooREXX 4.1.3

  BUG:    Can't use unmatched '*'+'/' in embedded data files.
-----------------------------------------------------------------
*/

/* --- UNPACKER BEGINS --- */

allexclude='sizechec.inc linenum.inc tidy.inc readme.txt'

if arg() \= 0 then parse arg only . ; else only=''
parse source host . srcfile . ; lineno=0 ; writeln=0

if host='UNIX' then exclude=allexclude ''
else exclude=allexclude ''

if translate(only)='/ALL' then do ; only='' ; exclude='' ; end

bar = '===' ; prefix='/*' bar ; postfix = reverse(prefix)
headpost=' begins' postfix ; footpost=' ends' postfix

if lines(srcfile)=1 then do while lines(srcfile) \= 0
  call grab
end
else do lines(srcfile)
  call grab
end

exit

grab:
  line=linein(srcfile) ; lineno=lineno+1
  if pos(headpost,line) \= 0 then do
    parse var line (prefix) ' ' outfile (headpost) .
    if only='' then
      if wordpos(outfile,exclude)=0 then say outfile
      else say '...skipping...' outfile
    writeln=1
  end
  else if pos(footpost,line) \= 0 then writeln=0
  if pos(headpost,line)=0 & pos(footpost,line)=0 & writeln then do
    if (only='' & wordpos(outfile,exclude)=0) | only=outfile then ,
      call outline
  end
  else if pos(footpost,line) \= 0 & only=outfile then exit
return

outline:
  /* line=changeonce('{!TAB!}',line,'9'x) */
  call lineout outfile, line
return

changeonce: procedure
  parse arg before, str, after
  ofs=pos(before,str)
  if ofs \= 0 then do
    str=delstr(str,ofs,length(before))
    str=insert(after,str,ofs-1,length(after))
  end
return str

/* --- UNPACKER ENDS --- */

/*
------------------------------------------------------------
*** DATA BEGINS DATA BEGINS DATA BEGINS DATA BEGINS ***

/* these data files = public domain : free for any use */
------------------------------------------------------------

/* === invfnasm.pas begins === */
{$ifdef FPC}{$mode tp}{$endif}
{$ifdef DEBUG}{$R+,S+}{$else}{$R-,S-}{$endif}
{$I+}

program invfnasm; {public domain, nenies proprajho, free for any use}
var source,target,incfile:text; line:string; p,p2:byte;
const nasm{$ifdef BOTH}:boolean{$endif}={$ifdef FASM}not{$endif}true;

procedure adjust;

type charset = set of char;

  function len:byte;
  begin len := length(line) end;

  function copystr(ofs,num:integer):string;
  begin copystr := copy(line,ofs,num) end;

  function find(s:string):byte;
  begin find := pos(s,line) end;

  procedure ins(s:string;n:integer);
  begin insert(s,line,n) end;

  procedure del(ofs,num:integer);
  begin delete(line,ofs,num) end;

  function found(s:string):boolean;
  begin found := find(s) <> 0 end;

  procedure finddel(s:string);
  begin p := find(s); if p <> 0 then del(p,length(s)) end;

  procedure sub(old,new:string);
  begin p := find(old);
    if p <> 0 then begin del(p,length(old)); ins(new,p) end
  end;

{$ifdef TIDY}{$I tidy.inc}{$endif}

  procedure fixproc;
  begin p := find(' PROC ');
    if p <> 0 then begin
      repeat dec(p) until line[p] <> ' '; inc(p); line[p] := ':';
      del(p+1,len-p)
    end
  end;

  procedure incdec(wordset:charset);
  begin p := find('INC '); if p=0 then p := find('DEC ');
    if p <> 0 then begin inc(p,length('??C '));
      while line[p]=' ' do inc(p);
      if line[p] <> '[' then begin p2 := p;
        repeat inc(p2) until (p2=len) or (line[p2]=' ') or
          (not (line[p2] in wordset));
        if (line[p2]=' ') or (line[p2]='[') then dec(p2);
        if ((p2-p+1) > length('DX')) then begin
          ins(']',p2+1);
          if nasm then
            ins('s_' + copystr(p,p2-p+1) + '[',p)
          else
            ins('[',p)
        end
      end
    end
  end;

  procedure fixop1(wordset:charset);
  begin p2 := find(',');
    if (p2 <> 0) and (line[p2-1] <> ']') then begin dec(p2); p := p2;
      repeat dec(p) until (line[p]=' ') or
        (not (line[p] in wordset));
      inc(p);
      if ((p2-p+1) > length('DX')) and (line[p] <> '[') and
        (line[p] in ['A'..'Z']) then begin
          ins(']',find(','));
          if nasm then
            ins('s_' + copystr(p,p2-p+1) + '[',p)
          else
            ins('[',p)
      end
    end
  end;

  procedure fixop2(wordset:charset);
  begin p := find(','); p2 := find(';');
    if (p <> 0) and ((p2=0) or (p2 > p)) and (line[p] <> '[') then begin
      inc(p); p2 := p;
      while (p2 < len) and (line[p2] <> ' ') and
        (line[p2] in wordset) do
          inc(p2);
      if (line[p2]=' ') or (line[p2]='[') then dec(p2);
      if (p2 > p) and (p2-p+1 > length('DX')) and (line[p] in ['A'..'Z'])
        then begin
          ins(']',p2+1);
          if nasm then
            ins('s_' + copystr(p,p2-p+1) + '[',p)
          else
            ins('[',p)
      end
    end
  end;

  function brakdig:boolean;
  begin
    brakdig := (p <> 0) and (line[p-2]='_') and (line[p-1] in ['0'..'9'])
  end;

label print;

const insertseg:boolean=false;
  alphanum:charset = ['a'..'z','A'..'Z','0'..'9'];

{$ifdef LINENUM}{$I linenum.inc}begin linenum;{$else}
begin
{$endif}

{$ifdef TIDY}if tidy and (len=0) then exit;{$endif}

  if (line[1]=';') or found('LEA ') then goto print;
  if (not nasm) and (found(' DB ') or found(' DW ')) then goto print;
  sub(' DD ',' DW 0,');

  if nasm and (found(' DB ') or found(' DW ')) then begin
    p := find(' '); p2 := p; while (line[p2]=' ') do inc(p2);
    if p <> 1 then
      writeln(incfile,'%define s_',copystr(1,p-1),' ',line[p2+1]);
    goto print
  end;

  if found('CODE_SEG') or found('END') then exit;

  finddel('[0]');

  if not found(',O') then begin
    sub('ES:[','[ES:'); finddel('40:'); finddel('Word Ptr ');
    fixproc;

    p := find('],');
    if (p >= 4) and (line[p-2]='[') and (line[p-1] in ['0'..'9']) then begin
      line[p-2] := '_'; del(p,1)
    end;
    if nasm and found('+BX') then begin finddel('['); finddel(']') end;

    if nasm then begin
      fixop1(alphanum+['_','+']); fixop2(alphanum+['_','+'])
      end
    else begin
      fixop1(alphanum+['_']); fixop2(alphanum+['_'])
    end;

    p := find('['); if brakdig then del(p-2,2);
    p := find(']'); if brakdig then line[p-2] := '+';

    if nasm then begin
      incdec(alphanum+['+']); sub('+BX[','['); sub('[]','+')
      end
    else incdec(alphanum);

    sub('][','+');

    if found('RemoveNewInt9:') then insertseg := true;
    if insertseg and not found('[0') then sub('[','[cs:');
    if found('CLC') then insertseg := false
  end;

  print:
    writeln(target,line)
end;

{$ifdef SIZECHECK}{$I sizechec.inc}{$endif}

const oldasm='INVADERS.ASM'; newasm:string[8+1+3]='inv-fasm.asm';
  incname='inv-nasm.inc';

begin {main}

{$ifdef BOTH}
  if (paramcount > 0) then for p := 1 to paramcount do
    if paramstr(p)='fasm' then nasm := false;
{$endif}
  assign(source,oldasm); reset(source);

{$ifdef SIZECHECK}sizecheckold(oldasm);{$endif}

  if nasm then begin
    newasm[5] := 'n'; assign(incfile,incname); rewrite(incfile)
  end;
  assign(target,newasm); rewrite(target);

  if nasm then begin
    writeln(target,'%idefine offset'); writeln(target,'%define LEA MOV');
    writeln(target,'%define B byte');  writeln(target,'%define W word');
    writeln(target,'%include "',incname,'"')
    end
  else begin
    writeln(target,'OFFSET equ'); writeln(target,'Offset equ');
    writeln(target,'LEA equ MOV')
  end;

  while not eof(source) do begin readln(source,line); adjust end;

  if nasm then close(incfile); close(target); close(source);

{$ifdef SIZECHECK}sizechecknew(newasm){$endif}
end.
/* === invfnasm.pas ends === */

/* === sizechec.inc begins === */
function sizecheck(fname:string; fsize:longint):boolean;
var f:file of byte; s:longint;
begin {$ifndef __GPC__}filemode := 0;{$endif}
  assign(f,fname); reset(f); s := filesize(f); close(f);
  sizecheck := s = fsize
end;

procedure sizecheckold(fname:string);
begin if not sizecheck(fname,137621) then
  begin writeln('''',fname,''' input size mismatch!'); halt(2) end
end;

procedure sizechecknew(fname:string);
const size:longint=139526;
begin if not nasm then size := 133590;
  if not sizecheck(fname,size) then begin
    writeln('''',fname,''' output size mismatch!');
    writeln('Assembled .COM should be CRC32 = FFF22EF9 (like in .ZIP)');
    halt(3)
  end
end;
/* === sizechec.inc ends === */

/* === linenum.inc begins === */
procedure linenum;
const NUM:word=0;

{$ifdef VER55}{saves ~400 bytes}
procedure SayNum;
inline(
(* $CC/         { int3         } *)
  $B0/ord('$')/ { mov al,24h   }
  $CD/$29/      { PUTC(al,ERR) }
  $8B/$16/NUM/  { mov dx,NUM   }
  $B9/1028/     { mov cx,404h  }
  $D3/$C2/      { rol dx,cl    }
  $88/$D0/      { mov al,dl    }
  $24/15/       { and al,0Fh   }
  $3C/10/       { cmp al,0Ah   }
  $1C/105/      { sbb al,69h   }
  $2F/          { das          }
  $CD/$29/      { PUTC...      }
  $FE/$CD/      { dec ch       }
  $75/$EF/      { jnz .rol     }
  $B0/13/       { mov al,CR    }
  $CD/$29/      { PUTC...      }
  $B0/10/       { mov al,LF    }
  $CD/$29       { PUTC...      }
);
{$endif}

begin inc(NUM); if (NUM and $ff)=0 then
  {$ifdef VER55}SayNum{$else}writeln('linenum=',NUM:4){$endif}
end;
/* === linenum.inc ends === */

/* === tidy.inc begins === */
{
TODO:
  s,^ *\([^ ][^ ]*\)[ ][ ]*,\1 ,
  s,^ *\([^ ][^ ]*\) \([^ ][^ ]*\)[ ][ ]*,\1 \2 ,
}

function tidy:boolean;{62k vs. 139k output .ASM, saves disk space}

  function wanttidy:boolean;
  const msg='TIDY';
  var s:string[length(msg)+1]; b:byte; n:integer;
  begin wanttidy := false;
    if paramcount > 0 then for n := 1 to paramcount do begin
      b := length(paramstr(n));
      if (b=length(msg)) or (b=length(msg)+1) then begin
        s := paramstr(n);
        if (s[1]='/') or (s[1]='-') then delete(s,1,1);
        for b := 1 to length(msg) do s[b] := upcase(s[b]);
        if s=msg then wanttidy := true
      end
    end
  end;

  procedure sololabels;
  begin
    if (line[1] in ['A'..'Z']) and found(': ') then begin
      p := find(': ');
      writeln(target,copystr(1,p));
      del(1,p)
    end
  end;

  procedure notabs;
  var gottab:byte;
  const tab=#9;
  begin
    repeat
      gottab := find(tab);
      if gottab <> 0 then begin
        p := gottab; p2 := p;
        repeat inc(p2) until line[p2] <> tab; dec(p2);
        del(p,p2-p+1); ins(' ',p)
      end
    until gottab=0
  end;

  procedure nocomments;
  begin p := find(';');
    if p <> 0 then del(p,len-p+1)
  end;

  procedure noedgeblanks;
  begin p := 0;
    while (p <= len) and (line[p+1]=' ') do inc(p);
    if p <> 0 then del(1,p);

    p := len; p2 := p;
    if (p <> 0) and (line[p2]=' ') then begin
      repeat dec(p) until line[p] <> ' '; inc(p);
      del(p,p2-p+1)
    end
  end;

var istidy:boolean;

begin istidy := wanttidy;
  if istidy then begin
    sololabels;
    notabs;
    nocomments;
    noedgeblanks
  end;
  tidy := istidy
end;
/* === tidy.inc ends === */

/* === readme.txt begins === */
                          INVFASM / INV(OOP) / INVFNASM

PSR Invaders (despite using VGA) is only pure 8086 code. Turbo Pascal
5.5 output is 8086 friendly, so why was I (only) targeting FASM? (It
was simpler! Formerly, I'd privately targeted A86.) At least old NASM
0.98.39 (from 2005) can be rebuilt for 8086 host. (Beware that their
old, official 16-bit build was 186 only, heh.)

INVFASM.PAS (31-Jul-2019) is a single, simple .PAS (4 kb).

.EXE compiled by TP 5.5:
  5184 bytes / 3155     (UPX'd, 3.5 kb)

Using CTYPE.{SED,INC}:
  4768 / 3022           (3 kb, good!)

Targeting NASM isn't too much more work, thankfully, but trying to do
both is where it gets a bit confusing. I've already privately
rewritten it to use TP 5.5's OOP ("object") using separate units, but
without needing virtual methods. Hence, technically even old PIM
Modula-2 (or even old ANSI C) would have sufficed. The newer OOP
rewrite succeeds, but I still haven't added back in a few (optional)
niceties yet. That version is much more modular and simpler, cleaner
code.

NASM + FASM ("both"):
  10416 / 4815          (5 kb, good enough)
FASM:
   8336 / 4197          (4.5 kb)
NASM:
   9136 / 4437          (4.5 kb)

But TP 5.5 is already efficient, 8086-friendly, and has a good
smartlinker. It even omits dead code ("if false then" conditionals).
I had formerly just written a patch (unified Diff output) for NASM,
but that's ugly, kludgy, brittle, and cumbersome. So I ended up just
using so-called conditionals ("if nasm then") because, like I said, TP
strips out unneeded code. This code is not nearly as clear as the OOP
version.

NASM + FASM ("both"):
  7024 / 3901           (4 kb, good enough)
FASM:
  5984 / 3552           (3.5 kb)
NASM:
  6448 / 3639           (4 kb)

But these newer versions don't use the CTYPE kludge, which avoids
"sets" entirely (saving roughly half a kb). Probably not worth it,
honestly, especially since other compilers seem to not show any
improvements. Still, TP is the smallest output of all the DOS Pascal
compilers I've tried. But it probably doesn't matter in a practical
sense, just intellectual curiosity. (Cluster waste / slack space of a
FAT partition hurts more.)

For comparison, MiniSed (compiled by TC++) is 19 kb (or 12 kb UPX'd).
Eventually, I may manually translate that from ANSI C into Pascal (TP
dialect) or Oberon.
/* === readme.txt ends === */


# --- extract.awk begins ---
#!/usr/bin/awk -f

/[b]egins ===/{
  fname=$3 ; print fname
  while (getline > 0) {
    if ($0 !~ / [e]nds ===/) {
#     sub("{!TAB!}","\t")
      print > fname
    }
    else {
      close(fname)
      break
    }
  }
}
# --- extract.awk ends ---

------------------------------------------------------------
*** DATA ENDS DATA ENDS DATA ENDS DATA ENDS ***
------------------------------------------------------------
*/

/* EOF */
