{$G+}
{$m 1024,0,0}                   {requires little stack and no heap}
Uses ModeXLib,Crt,Dos;

Var OldInt9:Pointer;            {pointer to old keyboard handler}
    active:Boolean;             {set, if hard copy already in motion}
    no:Word;                    {Number of picture, for assigning filenames}
    installed:Boolean;          {already installed ?}

    Mode,                       {current VGA-Mode: 13h, ffh (Mode X)}
                                {or 0 (neither of the two}
    Split_at,                   {Split-Line (graphic line}
    LSA,                        {Linear Starting Address}
    Skip:Word;                  {Number of bytes to skip}

Procedure GetMode;
{sets current graphic mode 13h or Mode X (No. 255)}
{and frame data (Split-Line, Start address)}
Begin
  Mode:=$13;                    {Mode 13h Standard}
  asm                           {set Bios-Mode}
    mov ax,0f00h                {Function: Video-Info}
    int 10h
    cmp al,13h                  {Bios-Mode 13h set ?}
    je @Bios_ok
    mov mode,0                  {if no -> neither Mode 13h nor X active}
  @bios_ok:
  End;
  If Mode=0 Then Exit;          {wrong mode -> abort}

  Port[$3c4]:=4;                {read out TS-Register 4 (Memory Mode)}
  If Port[$3c5] and 8 = 0 Then  {Chain 4 (Bit 3) inactive ?}
    Mode:=$ff;                  {then Mode X}

  Port[$3d4]:=$0d;              {Linear Starting Address Low (CRTC 0dh)}
  LSA:=Port[$3d5];              {read out}
  Port[$3d4]:=$0c;              {Linear Starting Address High (CRTC 0ch)}
  LSA:=LSA or Port[$3d5] shl 8; {read out and enter}

  Port[$3d4]:=$18;              {Line Compare CRTC 18h}
  Split_at:=Port[$3d5];         {read out}
  Port[$3d4]:=7;                {Overflow Low}
  Split_at:=Split_at or         {mask out Bit 4 and move to Bit 8}
    (Port[$3d5] and 16) shl 4;
  Port[$3d4]:=9;                {Maximum Row Address}
  Split_at:=Split_at or         {mask out Bit 6 and move to Bit 9}
    (Port[$3d5] and 64) shl 3;
  Split_at:=Split_at shr 1;     {convert to screen lines}

  Port[$3d4]:=$13;              {Row Offset (CRTC Register 13h)}
  Skip:=Port[$3d5];             {read out}
  Skip:=Skip*2-80               {read difference to "normal" line spacing}
End;


Procedure PCXShift;assembler;
{prepares current palette for PCX (shift 2 to the left)}
asm
  mov si,offset palette         {pointer to palette in ds:si}
  mov cx,768                    {process 768 bytes}
@lp:
  lodsb                         {get value}
  shl al,2                      {shift}
  mov ds:[si-1],al              {write back to old position}
  loop @lp                      {and complete loop}
End;

Var pcx:File;                   {PCX file to disk}

Procedure Hardcopy(Startaddr,splt:Word;s : string);
{copies graphic 320x200 (Mode 13 o. X) as PCX to file s}
{current screen start (Linear Starting Address) in Startaddr}
{Split line in splt}
Var Buf:Array[0..57] of Byte;   {receives data before saving}
    Aux_Ofs:Word;
const
  Header1:Array[0..15] of Byte  {PCX header, first part}
    =($0a,5,1,8, 0,0, 0,0, $3f,1, 199,0,$40,1,200,0);
  Header2:Array[0..5] of Byte   {PCX header, first part}
    =(0,1,$40,1,0,0);
  plane:Byte=0;                 {current plane no.}

var count:Byte;                 {number of equivalent characters}
    value,                      {value just fetched}
    lastbyt:Byte;               {previous value}
    i:word;                     {byte counter}

begin
asm                             {read out palette}
  xor al,al                     {start with color 0}
  mov dx,3c7h                   {use Pixel Read Address }
  out dx,al                     {to inform DAC of this}

  push ds                       {pointer es:di to palette}
  pop es
  mov di,offset palette
  mov cx,768                    {read out 768 bytes}
  mov dx,3c9h                   {Pixel Color Value}
  rep insb                      {and read}

  cmp mode,13h                  {Mode X ?}
  je @Linear                    {then:}
  mov dx,03ceh                  {set write and read mode to 0}
  mov ax,4005h                  {using GDC-Register 5 (GDC Mode)}
  out dx,ax
@Linear:
End;

  Assign(pcx,s);                {open file for writing}
  Rewrite(pcx,1);

  BlockWrite(pcx,Header1,16);   {write Header part 1}
  PCXShift;                     {prepare palette}
  BlockWrite(pcx,palette,48);   {enter first 16 colors}
  BlockWrite(pcx,Header2,6);    {write Header part 1}
  FillChar(buf,58,0);           {write 58 nulls (fill header)}
  BlockWrite(pcx,buf,58);
  plane:=0;                     {start with Plane 0}
  count:=1;                     {initialize number with 1}
  If splt<200 Then
    If Mode = $ff Then
      splt:=splt*80 Else        {calculate Split-Offset}
      splt:=splt*320 Else       {varies depending on mode}
    Splt:=$ffff;
  If Mode=$13 Then              {LSA refers to the plane model !}
    Startaddr:=Startaddr*4;
  for i:=0 to 64000 do Begin    {process each pixel}
  If i shr 2 < splt Then
  aux_ofs:=(i div 320) * skip   {set auxiliary offset taking }
                                {line width into consideration}
  Else
  aux_ofs:=((i shr 2 - splt) div 320) * skip;
                                {with splitting reference to VGA-Start}
asm                             {read out pixel}
  mov ax,0a000h                 {load segment}
  mov es,ax
  mov si,i                      {load offset}
  cmp mode,13h                  {Mode 13h ?}
  je @Linear1
  shr si,2                      {no, then calculate offset}
@Linear1:
  cmp si,splt                   {Split-Line reached ?}
  jb @continue                  {no, then continue}
  sub si,splt                   {otherwise, apply everything else}
  sub si,startaddr              {to screen start}
@continue:
  add si,startaddr              {add start address}
  add si,aux_ofs                {add auxiliary offset}

  cmp mode,13h                  {Mode 13h ?}
  je @Linear2                   {no, then Mode X read method}
  mov dx,03ceh                  {using GDC-Register 4 (Read Plane Select)}
  mov ah,plane                  {select current plane}
  inc plane                     {and continue shifting}
  mov al,4
  and ah,03h
  out dx,ax
@Linear2:
  mov al,es:[si]                {read out byte}
  mov value,al                  {and save in value variable}
End;
  If i<>0 Then Begin            {no compression with first byte}
  If (Value = lastbyt) Then Begin{same bytes ?}
    Inc(Count);                 {then increment counter}
    If (Count=64) or            {counter too high already ?}
     (i mod 320 =0)  Then Begin {or beginning of line ?}
      buf[0]:=$c0 or (count-1); {then buffer}
      buf[1]:=lastbyt;          {write counter status and value}
      count:=1;                 {reinitialize counter}
      BlockWrite(pcx,buf,2);    {and to disk}
    End;
  End Else                      {different bytes :}
    If (Count > 1) or           {several of the same ?}
    (lastbyt and $c0 <> 0) Then {value too large for direct writing ?}
    Begin
      buf[0]:=$c0 or count;     {then write number and value to file}
      buf[1]:=lastbyt;
      lastbyt:=Value;           {current value for further compression}
      Count:=1;                 {save and reinitialize}
      BlockWrite(pcx,buf,2);
    End Else Begin              {single, legal byte:}
      buf[0]:=lastbyt;          {direct writing}
      lastbyt:=Value;           {save current value for later}
      BlockWrite(pcx,buf,1);
    End;

  End Else lastbyt:=value;      {with first byte save only}
End;
  buf[0]:=$0c;                  {insert ID palette}
  blockwrite(pcx,buf[0],1);     {and write}
  blockwrite(pcx,palette,256*3);{and add palette}
  Close(pcx);                   {close file}
End;


Procedure Action;
{called upon activation of the hot-key}
Var nrs:String;                 {string for assigning name}
Begin
  if not active Then Begin      {only if not already active}
    active:=true;               {note as active}
    str(no,nrs);                {convert number to string and increment}
    Inc(no);
    GetMode;                    {get graphic mode etc.}
    If Mode <> 0 Then
      HardCopy(LSA,Split_at,'hard'+nrs+'.pcx');
                                {run hard copy}
    active:=false;              {release renewed activation}
  End;
End;

Procedure Handler9;interrupt;assembler;
{new interrupt handler for keyboard IRQ}
asm
   pushf
   call [oldint9]               {call old IRQ 1 - handler}

  cli                           {no further interrupts}
  in al,60h                     {read scan code}
  cmp al,34d                    {G ?}
  jne @finished                 {no -> end handler}
  xor ax,ax                     {load 0 segment}
  mov es,ax
  mov al,es:[417h]              {read keyboard status}
  test al,8                     {Bit 8 (Alt key) set ?}
  je @finished                  {no -> end handler}

  call action                   {run hard copy}
@finished:
  sti                           {allow interrupts again}
End;

Procedure identification;assembler;
{Dummy-Procedure, contains Copyright message for installation ID}
{NOT EXECUTABLE CODE !}
asm
  db 'Screen-Grabber, (c) Data Becker 1995/Abacus 1995';
End;

Procedure Check_Inst;assembler;
{Checks whether Grabber is already installed}
asm
  mov installed,1               {Assumption: already installed}
  push ds                       {ds still needed !}
  les di,oldint9                {load pointer to old handler}
  mov di,offset identification  {Procedure identification in same segment}
  mov ax,cs                     {set ds:si to identification of this program}
  mov ds,ax
  mov si,offset identification
  mov cx,20                     {compare 20 characters}
  repe cmpsb
  pop ds                        {restore ds}
  jcxz @installed               {equal, then already installed}
  mov installed,0               {not installed: note}
@installed:
End;

Begin
  no:=0;                        {first filename: hard0.pcx}
  GetIntVec(9,OldInt9);         {get old interrupt vector}
  Check_Inst;                   {check whether already installed}
  If not installed Then Begin   {if no:}
    SetIntVec(9,@Handler9);     {install new handler}
    WriteLn('Grabber installed');
    WriteLn('(c) Data Becker 1995/Abacus 1995');
    WriteLn('Activation with <alt> g');
    Keep(0);                    {output message and exit resident}
  End;
  WriteLn('Grabber already installed');
                                {if already installed, message and exit}
End.
