{$N+,A+,G+,F+,D-,E-,L-,R-,S-,Q-,Y-,I-}

unit palette;

interface

uses math2;
const palette1=0; palette2=768*2;
var palette_process:array[0..7] of byte;

procedure init_pal2pal(where,ofset:word);
procedure Pal2Pal_asm(var triger:byte; startcol, endcol:byte; speed:integer; where,ofset:word);
procedure readonecolor(c:byte;var r,g,b:byte);
procedure setonecolor(c,r,g,b:byte);
procedure setonecolor2memW(c, r,g,b:byte; offs,where,ofset:word);
procedure readonecolor_from_memW(c:byte; var r,g,b:byte; offs,where,ofset:word);
procedure setonecolor_memW2memW(c1,c2:byte;pal_write,pal_read,where,ofset:word);
procedure palette2memW(offs,where,ofset:word);
procedure clear_palette2memW(offs,where,ofset:word);
procedure setpalette_from_memW(offs,where,ofset:word);
Procedure file_pal2memW(Filename:string; offs, where,ofset:word);


implementation

procedure setonecolor(c,r,g,b:byte);assembler;
asm
  mov dx,3c8h
  mov al,c
  out dx,al
  inc dx
  mov al,r
  out dx,al
  mov al,g
  out dx,al
  mov al,b
  out dx,al
end;

procedure readonecolor(c:byte;var r,g,b:byte);assembler;
asm
  mov dx,3c7h
  mov al,c
  out dx,al
  add dx,2
  in  al,dx
  les di,r
  mov [es:di],al
  in  al,dx
  les di,g
  mov [es:di],al
  in  al,dx
  les di,b
  mov [es:di],al
end;

procedure setonecolor2memW(c, r,g,b:byte; offs,where,ofset:word);
begin
memw[where:ofset+ (c*3)   shl 1 +offs]:=word(r shl 8);
memw[where:ofset+ (c*3+1) shl 1 +offs]:=word(g shl 8);
memw[where:ofset+ (c*3+2) shl 1 +offs]:=word(b shl 8);
end;

procedure setonecolor_memW2memW(c1,c2:byte;pal_write,pal_read,   where,ofset:word);
begin
memw[where:ofset+ (c1*3)   shl 1 +pal_write]:=memw[where:ofset+ (c2*3)   shl 1 +pal_read];
memw[where:ofset+ (c1*3+1) shl 1 +pal_write]:=memw[where:ofset+ (c2*3+1) shl 1 +pal_read];
memw[where:ofset+ (c1*3+2) shl 1 +pal_write]:=memw[where:ofset+ (c2*3+2) shl 1 +pal_read];
end;

procedure readonecolor_from_memW(c:byte; var r,g,b:byte; offs,where,ofset:word);
begin
r:= byte(memw[where:ofset+ (c*3)   shl 1 +offs] shr 8);
g:= byte(memw[where:ofset+ (c*3+1) shl 1 +offs] shr 8);
b:= byte(memw[where:ofset+ (c*3+2) shl 1 +offs] shr 8);
end;


procedure palette2memW(offs,where,ofset:word);
var c,r,g,b:byte;
begin
for c:=0 to 255 do begin
readonecolor(c, r,g,b);
memw[where:ofset+ (c*3)   shl 1 +offs]:=word(r shl 8);
memw[where:ofset+ (c*3+1) shl 1 +offs]:=word(g shl 8);
memw[where:ofset+ (c*3+2) shl 1 +offs]:=word(b shl 8);
end;
end;

Procedure file_pal2memW(Filename:string; offs, where,ofset:word);
var c,r,g,b:byte;
fr:file;
l:word;
begin
Assign(fr, filename);
Reset(fr, 1);
for l:=0 to 255 do
   begin
      BlockRead(fr, r, 1);
      BlockRead(fr, g, 1);
      BlockRead(fr, b, 1);
      memw[where:ofset+ (l*3)   shl 1 +offs]:=word(r shl 8);
      memw[where:ofset+ (l*3+1) shl 1 +offs]:=word(g shl 8);
      memw[where:ofset+ (l*3+2) shl 1 +offs]:=word(b shl 8);
   end;
Close(fr);
end;


procedure clear_palette2memW(offs,where,ofset:word);
var c:byte;
begin
for c:=0 to 255 do begin
memw[where:ofset+ (c*3)   shl 1 +offs]:=word(0);
memw[where:ofset+ (c*3+1) shl 1 +offs]:=word(0);
memw[where:ofset+ (c*3+2) shl 1 +offs]:=word(0);
end;
end;

procedure setpalette_from_memW(offs,where,ofset:word);
var c,r,g,b:byte;
begin
for c:=0 to 255 do begin
r:=byte(memw[where:ofset+ (c*3)   shl 1 +offs] shr 8);
g:=byte(memw[where:ofset+ (c*3+1) shl 1 +offs] shr 8);
b:=byte(memw[where:ofset+ (c*3+2) shl 1 +offs] shr 8);
setonecolor(c, r,g,b);
end;
end;


procedure init_pal2pal(where,ofset:word);
var
c,n,x,y,delta, c3:integer;
o:word;
begin
c3:=0;
for c:=0 to 255 do begin
    for n:=0 to 2 do begin
        o:=ofset + (n+c3) shl 1;
        x:=memw[where:o];
        y:=memw[where:o + (256*3*2)];
        delta:= abs(x-y) shr 8 {div 256};
        if delta=0 then delta:=1;
        memw[where:o + (256*3*2)*2]:=delta;
    end;
    c3:=c3+3;
end;
end;

(*
procedure Pal2Pal_asm_old(var triger:byte; startcol, endcol:byte; speed:integer; where,ofset:word);
var
vsi,endcol_6:word;
otsechka:byte;
begin
otsechka:=0;
if speed>127 then speed:=127;
vsi:=startcol*6 +ofset;
endcol_6:=endcol*6;
  asm
  {------self-modify-------}
  mov al, byte ptr speed
  mov cs:[offset @speed+2], al
  mov ax, endcol_6
  cmp ax, 128
  jb @next1
      mov word ptr cs:[offset @count], 0fe81h
      mov cs:[offset @count+2], ax; jmp @next
  @next1:
      mov cs:[offset @count+2], al
  @next:
  jmp @clear_prefetch; @clear_prefetch:
  {-------------------------}

  mov es, where
  mov cl, startcol
  xor ch, ch
  mov si, vsi
  push bp
  @c:
     {for c:=startcol to endcol do begin}
     mov bp, 4
     @n:{for n:=0 to 2 do begin}
       mov dx, es:[bp+si +256*3*2*2] {delta:=memw[where:(n+c*3) shl 1 + (256*3*2)*2] * speed;}
       @speed: imul dx, dx, 1

       mov bx, es:[bp+si]            {x:=memw[where:(n+c*3) shl 1];}
       mov di, es:[bp+si +256*3*2]   {y:=memw[where:(n+c*3) shl 1 + 256*3*2];}

       cmp bx, di {if x>y then begin}
       jle @skip1
          sub bx, dx      {x:=x-delta;}
          cmp bx, di; jge @sk1; mov bx, di; @sk1: {if x<y then x:=y;}
          mov es:[bp+si], bx {memw[where:(n+c*3) shl 1]:=x;}
          mov ch, 1
       @skip1:    {end;}

       cmp bx, di {if x<y then begin}
       jge @skip2
          add bx, dx      {x:=x+delta;}
          cmp bx, di; jle @sk2; mov bx, di; @sk2: {if x>y then x:=y;}
          mov es:[bp+si], bx {memw[where:(n+c*3) shl 1]:=x;}
          mov ch, 1
       @skip2:    {end;}

       mov al, bh  {=r/g/b shr 8}
       db $66; shl ax, 8

     sub bp, 2
     jns @n {end;}

  {setonecolor(c, r,g,b);}
  mov dx, 3c8h
  mov al, cl
  out dx, al
  inc dx
  db $66; shr ax, 8
  out dx, al
  db $66; shr ax, 8
  out dx, al
  db $66; shr ax, 8
  out dx, al

  inc cl
  add si, 3*2
  @count: cmp si, 6
  nop
  jbe @c
  pop bp
  mov otsechka, ch
end;

if otsechka=0 then triger:=0;
end;
*)

procedure Pal2Pal_asm(var triger:byte; startcol, endcol:byte; speed:integer; where,ofset:word);
var
vsi,endcol_6:word;
otsechka:byte;
begin
otsechka:=0;
if speed>127 then speed:=127;
vsi:=startcol*6 +ofset;
endcol_6:=endcol*6;
  asm
  {------self-modify-------}
  mov al, byte ptr speed
  mov cs:[offset @speed+2], al
  mov ax, endcol_6
  cmp ax, 128
  jb @next1
      mov word ptr cs:[offset @count], 0fe81h
      mov cs:[offset @count+2], ax; jmp @next
  @next1:
      mov cs:[offset @count+2], al
  @next:
  jmp @clear_prefetch; @clear_prefetch:
  {-------------------------}
  xor dx, dx
  db $8e,$e2 {mov fs, dx  (for otsechka}

  mov es, where
  mov cl, startcol
  mov si, vsi
  push bp
  @c:
     {for c:=startcol to endcol do begin}
     xor ch, ch
     mov bp, 4
     @n:{for n:=0 to 2 do begin}
       mov dx, es:[bp+si +256*3*2*2] {delta:=memw[where:(n+c*3) shl 1 + (256*3*2)*2] * speed;}
       @speed: imul dx, dx, 1

       mov bx, es:[bp+si]            {x:=memw[where:(n+c*3) shl 1];}
       mov di, es:[bp+si +256*3*2]   {y:=memw[where:(n+c*3) shl 1 + 256*3*2];}

       cmp bx, di {if x>y then begin}
       jle @skip1
          sub bx, dx      {x:=x-delta;}
          cmp bx, di; jge @sk1; mov bx, di; @sk1: {if x<y then x:=y;}
          mov es:[bp+si], bx {memw[where:(n+c*3) shl 1]:=x;}
          mov ch, 1
       @skip1:    {end;}

       cmp bx, di {if x<y then begin}
       jge @skip2
          add bx, dx      {x:=x+delta;}
          cmp bx, di; jle @sk2; mov bx, di; @sk2: {if x>y then x:=y;}
          mov es:[bp+si], bx {memw[where:(n+c*3) shl 1]:=x;}
          mov ch, 1
       @skip2:    {end;}

       mov al, bh  {=r/g/b shr 8}
       db $66; shl ax, 8

     sub bp, 2
     jns @n {end;}

  test ch, ch
  jz @skip_setonecolor
  {setonecolor(c, r,g,b);}
  mov dx, 3c8h
  mov al, cl
  out dx, al
  inc dx
  db $66; shr ax, 8
  out dx, al
  db $66; shr ax, 8
  out dx, al
  db $66; shr ax, 8
  out dx, al

  db $8e,$e2 {mov fs, dx  (for otsechka}
  @skip_setonecolor:

  inc cl
  add si, 3*2
  @count: cmp si, 6
  nop
  jbe @c
  pop bp
  db $8c,$e2 {mov dx, fs}
  mov otsechka, dl
end;

if otsechka=0 then triger:=0;
end;


end.