(*************************************************

  A FAZER:

 -Colocar em todos um parametro do segmento da memoria (util para "page flip"/"page buffer")

Verificar e/ou criar minhas proprias:
 -Move (parece "rep movsb")

*************************************************)
Unit dfs;
Interface
uses crt,strings;



{Funcoes uteis de uso geral}

function  val_(s:string):longint;
function  strp(s:string;tam:byte;c:char):string;
function  str_(num:longint):string;
function  stre(num:longint;tam:byte):string;
function  poe0(num:longint;tam:byte):string;

function  maior (a,b:real):real;
function  menor (a,b:real):real;
function  maiori(a,b:longint):longint;
function  menori(a,b:longint):longint;

function  ifint (expressao:boolean;v,f:longint):longint;
function  ifreal(expressao:boolean;v,f:real):real;
function  ifstr (expressao:boolean;v,f:string):string;


procedure trocachar(var a,b:char);
procedure trocaint(var a,b:integer);
procedure trocalint(var a,b:longint);
procedure trocareal(var a,b:real);



{Funcoes de controle de tempo, teclado e mouse}

procedure VSync;
procedure pausar(ms:Word);
procedure daumtempo(cs:word;resetar:boolean);
procedure limpakey;

function GetMouseX:word;
function GetMouseY:word;
function MouseClick:word;
procedure SetMouseXLimit(mn,mx:word);
procedure SetMouseYLimit(mn,my:word);
procedure MouseMove(x,y:word);



{Funcoes de modo texto}

{Endereco da tela (modo texto)}
const tela=$B800;

procedure SetText80x25;
procedure SetText80x50;
procedure limpatela80x25(c:char;cor:byte);
procedure limpatela80x50(c:char;cor:byte);

procedure putchar(x,y:byte;c:char);
function getchar(x,y:byte):char;
procedure putcor(x,y:byte;cor:byte);
function getcor(x,y:byte):byte;
procedure putcharcor(x,y:byte;c:char;cor:byte);

procedure putword(x,y:byte;v:word);
procedure putbytehex(x,y:byte;v:byte);
procedure putwordhex(x,y:byte;v:word);

procedure putstr(x,y:byte;s:string);
procedure putPChar(x,y:byte;s:PChar);
procedure putstrcor(x,y:byte;s:string;cor:byte);
procedure putPCharcor(x,y:byte;s:PChar;cor:byte);

procedure putstrtrans(x,y:byte;s:string;trans:char);
procedure putPChartrans(x,y:byte;s:PChar;trans:char);
procedure putstrtranscor(x,y:byte;s:string;trans:char;cor:byte);
procedure putPChartranscor(x,y:byte;s:PChar;trans:char;cor:byte);

procedure clearchar(x1,y1,x2,y2:byte;c:char);
procedure clearcor(x1,y1,x2,y2:byte;cor:byte);
procedure clearcharcor(x1,y1,x2,y2:byte;c:char;cor:byte);

function  InputText(x,y,tamvis,tamstr,cortexto:byte;inicial,caracs:string;corfora:byte;antes,depois:char;saida:string):string;

{Constantes uteis para a funcao InputText}
const maiusc='abcdefghijklmnopqrstuvwxyz';
      minusc='ABCDEFGHIJKLMNOPQRSTUVWXYZ';
      numeros='0123456789';

{Funcoes de arquivos}

function  FileExists(FileName: String): Boolean;

{Funcoes de classificacao (ordenacao)}

procedure bubblesort(var x:array of integer; n:word);
procedure selectsort(var x:array of integer; n:word);
procedure insersort(var x:array of integer; n:word);
procedure shellsort(var x:array of integer; n:word; incs:array of byte; numinc:byte);



(**********************************************************)



Implementation

function val_(s:string):longint;
var v:longint;
 code:integer;
begin
 val(s,v,code);
 val_:=v;
end;


function  strp(s:string;tam:byte;c:char):string;
begin
 while length(s)<tam do s:=c+s;
 strp:=s;
end;


function str_(num:longint):string;
var pascalepodre : string;
begin
 str(num,pascalepodre);
 str_:=pascalepodre;
end;


function  stre(num:longint;tam:byte):string;
var pascalepodre : string;
begin
 str(num,pascalepodre);
 while length(pascalepodre)<tam do pascalepodre:=' '+pascalepodre;
 stre:=pascalepodre;
end;


function  poe0(num:longint;tam:byte):string;
var pascalepodre : string;
begin
 str(num,pascalepodre);
 while length(pascalepodre)<tam do pascalepodre:='0'+pascalepodre;
 poe0:=pascalepodre;
end;


function maior(a,b:real):real;
 begin if a>b then maior:=a else maior:=b; end;
function menor(a,b:real):real;
 begin if a<b then menor:=a else menor:=b; end;
function maiori(a,b:longint):longint;
 begin if a>b then maiori:=a else maiori:=b; end;
function menori(a,b:longint):longint;
 begin if a<b then menori:=a else menori:=b; end;


function ifint(expressao:boolean;v,f:longint):longint;
 begin if expressao then ifint:=v else ifint:=f; end;
function ifreal(expressao:boolean;v,f:real):real;
 begin if expressao then ifreal:=v else ifreal:=f; end;
function ifstr(expressao:boolean;v,f:string):string;
 begin if expressao then ifstr:=v else ifstr:=f; end;


procedure trocachar(var a,b:char);
var temp:char;
begin
 temp:=a; a:=b; b:=temp;
end;


procedure trocaint(var a,b:integer);
var temp:integer;
begin
 temp:=a; a:=b; b:=temp;
end;


procedure trocalint(var a,b:longint);
var temp:longint;
begin
 temp:=a; a:=b; b:=temp;
end;


procedure trocareal(var a,b:real);
var temp:real;
begin
 temp:=a; a:=b; b:=temp;
end;


procedure VSync; assembler;
asm
    mov dx,3DAh
@l1:
    in al,dx
    and al,08h
    jnz @l1
@l2:
    in al,dx
    and al,08h
    jz  @l2
end;


procedure pausar(ms:Word); assembler;
asm
  mov ax,1000;
  mul ms;
  mov cx, dx;
  mov dx, ax;
  mov ah, 86h;
  int 15h;
end;

procedure daumtempo(cs:word;resetar:boolean);
{
 Espera cs centesimos de segundos.
 Caso alguma tecla seja pressionada, o procedure tambem termina.
 Caso resetar seja true, o buffer do readkey e' limpado.
}
var i : integer; {Loop}
begin
 i:=0;
 repeat
  pausar(10);  {delay(10);}
  inc(i);
 until (keypressed) or (i>=cs);
 if resetar then limpakey;  {Apaga o buffer de teclas}
end;

procedure limpakey;
{Limpa o buffer do teclado}
var k : char;    {Tecla pressionada (k = Key)}
begin
 while keypressed do k:=readkey;
end;

function GetMouseX:word; assembler;
asm
  mov ax,3
  int 33h
  mov ax,cx
end;

function GetMouseY:word; assembler;
asm
  mov ax,3
  int 33h
  mov ax,dx
end;


function MouseClick:word; assembler;
asm
  mov ax,3
  mov bx,0
  int 33h
  mov ax,bx
end;

procedure SetMouseXLimit(mn,mx:word); assembler;
asm
  mov ax,7
  mov cx,[mn]
  mov dx,[mx]
  int 33h
end;

procedure SetMouseYLimit(mn,my:word); assembler;
asm
  mov ax,8
  mov cx,[mn]
  mov dx,[my]
  int 33h
end;

procedure MouseMove(x,y:word); assembler;
asm
  mov ax,4
  mov cx,[x]
  mov dx,[y]
  int 33h
end;



procedure SetText80x25;
begin textmode(CO80); end;


procedure SetText80x50;
begin textmode(CO80+Font8x8); end;


procedure limpatela80x25(c:char;cor:byte);assembler;
asm
  mov ax,tela ;{Endereco da tela}
  mov es,ax

  mov al,[c]
  mov ah,[cor]
  xor di,di
  mov cx,2000 ;{Pego o caractere}
  rep stosw
end;


procedure limpatela80x50(c:char;cor:byte);assembler;
asm
  mov ax,tela ;{Endereco da tela}
  mov es,ax

  mov al,[c]
  mov ah,[cor]
  xor di,di
  mov cx,4000 ;{Pego o caractere}
  rep stosw
end;


procedure putchar(x,y:byte;c:char); assembler;
{
 1a. versao (muito ruim)
   gotoxy(x,y); write(c);
 2a. versao (muito boa)
   mem[tela:x+x+y*80]:=ord(c);
 3a. versao (a atual, ligeiramente mais rapida que a segunda)
}
asm
  mov ax,tela ;{Endereco da tela}
  mov es,ax

  xor bh,bh
  mov bl,[x]  ;{Pego o valor de x}
  mov al,[y]  ;{Pego o valor de y}
  mov dl,80
  mul dl      ;{Multiplico y por 80}
  add ax,bx   ;{Junto x com 80y}
  shl ax,1    ;{Muliplico tudo por 2 (estou trabalhando com bytes, nao words)}
  mov di,ax   ;{Enfim, mostro o endereco ao processador :)}
  mov al,[c]  ;{Pego o caractere}
  stosb
end;


function getchar(x,y:byte):char; assembler;
asm
  push ds

  mov ax,tela ;{Endereco da tela}
  mov ds,ax

  xor bh,bh
  mov bl,[x]  ;{Pego o valor de x}
  mov al,[y]  ;{Pego o valor de y}
  mov dl,80
  mul dl      ;{Multiplico y por 80}
  add ax,bx   ;{Junto x com 80y}
  shl ax,1    ;{Muliplico tudo por 2 (estou trabalhando com bytes, nao words)}
  mov si,ax   ;{Enfim, mostro o endereco ao processador :)}

  lodsb

  pop ds
end;


procedure putcor(x,y:byte;cor:byte); assembler;
asm
  mov ax,tela ;{Endereco da tela}
  mov es,ax

  xor bh,bh
  mov bl,[x]  ;{Pego o valor de x}
  mov al,[y]  ;{Pego o valor de y}
  mov dl,80
  mul dl      ;{Multiplico y por 80}
  add ax,bx   ;{Junto x com 80y}
  shl ax,1    ;{Muliplico tudo por 2 (estou trabalhando com bytes, nao words)}
  inc ax      ;{Chego ao byte de cor}
  mov di,ax   ;{Enfim, mostro o endereco ao processador :)}
  mov al,[cor];{Pego a cor}
  stosb
end;


function getcor(x,y:byte):byte; assembler;
asm
  push ds

  mov ax,tela ;{Endereco da tela}
  mov ds,ax

  xor bh,bh
  mov bl,[x]  ;{Pego o valor de x}
  mov al,[y]  ;{Pego o valor de y}
  mov dl,80
  mul dl      ;{Multiplico y por 80}
  add ax,bx   ;{Junto x com 80y}
  shl ax,1    ;{Muliplico tudo por 2 (estou trabalhando com bytes, nao words)}
  inc ax      ;{Chego ao byte de cor}
  mov si,ax   ;{Enfim, mostro o endereco ao processador :)}

  lodsb

  pop ds
end;


procedure putcharcor(x,y:byte;c:char;cor:byte); assembler;
asm
  mov ax,tela ;{Endereco da tela}
  mov es,ax

  xor bh,bh
  mov bl,[x]  ;{Pego o valor de x}
  mov al,[y]  ;{Pego o valor de y}
  mov dl,80
  mul dl      ;{Multiplico y por 80}
  add ax,bx   ;{Junto x com 80y}
  shl ax,1    ;{Muliplico udo por 2 (estou trabalhando com bytes, nao words)}
  mov di,ax   ;{Enfim, mostro o endereco ao processador :)}
  mov al,[c]  ;{Pego o caractere}
  mov ah,[cor];{Pego a cor}
  stosw
end;


{Obs.: O valor fica alinhado `a direita}
procedure putword(x,y:byte;v:word); assembler;
asm
  mov ax,0B800h ;{Endereco da tela}
  mov es,ax

  xor bh,bh
  mov bl,[x]  ;{Pego o valor de x}
  mov al,[y]  ;{Pego o valor de y}
  mov dl,80
  mul dl      ;{Multiplico y por 80}
  add ax,bx   ;{Junto x com 80y}
  shl ax,1    ;{Muliplico tudo por 2 (estou trabalhando com bytes, nao words)}
  mov di,ax   ;{Enfim, mostro o endereco ao processador :)}

  mov bx,[v]  ;{Pego o word a ser impresso}

  @vai:
    mov ax,bx ;{Preparo o word para pegar o resto}
    xor dx,dx

    mov cx,10 ;{Faco a divisao}
    div cx
    mov bx,ax ;{Atualizo o word}
    mov ax,dx ;{O resto fica no DX, mas tenho que trabalhar com AL}

    add al,48 ;{48='0'}
    stosb     ;{Escreve na tela}

    cmp bx,0  ;{Se BX=0, e' porque o numero ja acabou!}
    je @fim

    sub di,3  ;{Vai para o caractere anterior}
  jmp @vai
  @fim:
end;


procedure putbytehex(x,y:byte;v:byte); assembler;
asm
  mov ax,0B800h ;{Endereco da tela}
  mov es,ax

  xor bh,bh
  mov bl,[x]  ;{Pego o valor de x}
  mov al,[y]  ;{Pego o valor de y}
  mov dl,80
  mul dl      ;{Multiplico y por 80}
  add ax,bx   ;{Junto x com 80y}
  shl ax,1    ;{Muliplico tudo por 2 (estou trabalhando com bytes, nao words)}
  mov di,ax   ;{Enfim, mostro o endereco ao processador :)}

  mov al,[v]  ;{Pego o byte a ser impresso}
  mov ah,al

  shr al,4
    add al,48 ;{48='0'}
    cmp al,57 ;{57='9'}
    jle @addh
      add al,7
    @addh:
    stosb     ;{Escreve na tela}
    inc di

  mov al,ah
  and al,1111b
    add al,48 ;{48='0'}
    cmp al,57 ;{57='9'}
    jle @addl
      add al,7
    @addl:
    stosb     ;{Escreve na tela}
end;


procedure putwordhex(x,y:byte;v:word); assembler;
asm
  mov ax,0B800h ;{Endereco da tela}
  mov es,ax

  xor bh,bh
  mov bl,[x]  ;{Pego o valor de x}
  mov al,[y]  ;{Pego o valor de y}
  mov dl,80
  mul dl      ;{Multiplico y por 80}
  add ax,bx   ;{Junto x com 80y}
  shl ax,1    ;{Muliplico tudo por 2 (estou trabalhando com bytes, nao words)}
  mov di,ax   ;{Enfim, mostro o endereco ao processador :)}

  mov ax,[v]  ;{Pego o word a ser impresso}
  mov bl,al   ;{Faco uma copia do byte menos significativo}

  mov al,ah
  shr al,4
    add al,48 ;{48='0'}
    cmp al,57 ;{57='9'}
    jle @add1
      add al,7
    @add1:
    stosb     ;{Escreve na tela}
    inc di

  mov al,ah
  and al,1111b
    add al,48 ;{48='0'}
    cmp al,57 ;{57='9'}
    jle @add2
      add al,7
    @add2:
    stosb     ;{Escreve na tela}
    inc di

  mov al,bl
  shr al,4
    add al,48 ;{48='0'}
    cmp al,57 ;{57='9'}
    jle @add3
      add al,7
    @add3:
    stosb     ;{Escreve na tela}
    inc di

  mov al,bl
  and al,1111b
    add al,48 ;{48='0'}
    cmp al,57 ;{57='9'}
    jle @add4
      add al,7
    @add4:
    stosb     ;{Escreve na tela}
end;


(*procedure putstr(x,y:byte;s:string);
var i : byte;
    endereco : word;
begin
{  gotoxy(x,y); write(s);}
  endereco:=x+y*80;
  for i:=0 to length(s)-1 do
    mem[tela:endereco+i+i]:=ord(s[i+1]);
end;*)


procedure putstr(x,y:byte;s:string); assembler;
asm
  push ds     ;{Pascal me obriga a fazer isso...}

  lds si,[s]  ;{Pego o pointeiro para a string}
  lodsb       ;{Pego o tamanho da string}
  xor ch,ch
  mov cl,al   ;{Pega o tamanho}

  jcxz @fim   ;{String vazia soh serve para dar um bug maneiro}

  mov ax,tela ;{Endereco da tela}
  mov es,ax

  xor bh,bh
  mov bl,[x]  ;{Pego o valor de x}
  mov al,[y]  ;{Pego o valor de y}
  mov dl,80
  mul dl      ;{Multiplico y por 80}
  add ax,bx   ;{Junto x com 80y}
  shl ax,1    ;{Muliplico tudo por 2 (estou trabalhando com bytes, nao words)}
  mov di,ax   ;{Enfim, mostro o endereco ao processador :)}

  @vai:
    movsb
    inc di
  loop @vai
  @fim:

  pop ds      ;{Pascal me obriga a fazer isso...}
end;


procedure putPChar(x,y:byte;s:PChar); assembler;
asm
  push ds     ;{Pascal me obriga a fazer isso...}

  mov ax,tela ;{Endereco da tela}
  mov es,ax

  mov bh,0
  mov bl,[x]  ;{Pego o valor de x}
  mov al,[y]  ;{Pego o valor de y}
  mov dl,80
  mul dl      ;{Multiplico y por 80}
  add ax,bx   ;{Junto x com 80y}
  shl ax,1    ;{Muliplico tudo por 2 (estou trabalhando com bytes, nao words)}
  mov di,ax   ;{Enfim, mostro o endereco ao processador :)}

  lds si,[s]  ;{Pego o pointeiro para a string}

  @vai:

    lodsb     ;{Carrego o caractere}
    cmp al,0
    je @fim   ;{Se o caractere eh nulo, FIM!}

    stosb     ;{Escreve na tela}
    inc di    ;{Pula o byte de cor}
    jmp @vai  ;{recomeca tudo}

  @fim:

  pop ds      ;{Pascal me obriga a fazer isso...}
end;


procedure putstrcor(x,y:byte;s:string;cor:byte); assembler;
asm
  push ds     ;{Pascal me obriga a fazer isso...}

  lds si,[s]  ;{Pego o pointeiro para a string}
  lodsb       ;{Pego o tamanho da string}
  xor ch,ch
  mov cl,al   ;{Pega o tamanho}

  jcxz @fim   ;{String vazia soh serve para dar um bug maneiro}

  mov ax,tela ;{Endereco da tela}
  mov es,ax

  xor bh,bh
  mov bl,[x]  ;{Pego o valor de x}
  mov al,[y]  ;{Pego o valor de y}
  mov dl,80
  mul dl      ;{Multiplico y por 80}
  add ax,bx   ;{Junto x com 80y}
  shl ax,1    ;{Muliplico tudo por 2 (estou trabalhando com bytes, nao words)}
  mov di,ax   ;{Enfim, mostro o endereco ao processador :)}

  mov al,[cor]

  @vai:
    movsb
    stosb
  loop @vai
  @fim:

  pop ds      ;{Pascal me obriga a fazer isso...}
end;


procedure putPCharcor(x,y:byte;s:PChar;cor:byte); assembler;
asm
  push ds     ;{Pascal me obriga a fazer isso...}

  mov ax,tela ;{Endereco da tela}
  mov es,ax

  mov bh,0
  mov bl,[x]  ;{Pego o valor de x}
  mov al,[y]  ;{Pego o valor de y}
  mov dl,80
  mul dl      ;{Multiplico y por 80}
  add ax,bx   ;{Junto x com 80y}
  shl ax,1    ;{Muliplico tudo por 2 (estou trabalhando com bytes, nao words)}
  mov di,ax   ;{Enfim, mostro o endereco ao processador :)}

  lds si,[s]  ;{Pego o pointeiro para a string}

  mov ah,[cor]

  @vai:

    lodsb     ;{Carrego o caractere}
    cmp al,0
    je @fim   ;{Se o caractere eh nulo, FIM!}

    stosw     ;{Escreve na tela}
    jmp @vai  ;{recomeca tudo}

  @fim:

  pop ds      ;{Pascal me obriga a fazer isso...}
end;


procedure putstrtrans(x,y:byte;s:string;trans:char); assembler;
asm
  push ds     ;{Pascal me obriga a fazer isso...}

  lds si,[s]  ;{Pego o pointeiro para a string}
  lodsb       ;{Pego o tamanho da string}
  xor ch,ch
  mov cl,al   ;{Pega o tamanho}

  jcxz @fim   ;{String vazia soh serve para dar um bug maneiro}

  mov ax,tela ;{Endereco da tela}
  mov es,ax

  xor bh,bh
  mov bl,[x]  ;{Pego o valor de x}
  mov al,[y]  ;{Pego o valor de y}
  mov dl,80
  mul dl      ;{Multiplico y por 80}
  add ax,bx   ;{Junto x com 80y}
  shl ax,1    ;{Muliplico tudo por 2 (estou trabalhando com bytes, nao words)}
  mov di,ax   ;{Enfim, mostro o endereco ao processador :)}

  mov dl,[trans];{Pego o caractere transparente}

  @vai:

    lodsb     ;{Carrego o caractere}
    cmp al,dl
    je @trans ;{Se o caractere eh transparente}

    stosb     ;{Escreve na tela}
    jmp @opaco

    @trans:
    inc di    ;{Pula o caractere}
    @opaco:
    inc di    ;{Pula o byte de cor}

  loop @vai
  @fim:

  pop ds      ;{Pascal me obriga a fazer isso...}
end;


procedure putPChartrans(x,y:byte;s:PChar;trans:char); assembler;
asm
  push ds     ;{Pascal me obriga a fazer isso...}

  mov ax,tela ;{Endereco da tela}
  mov es,ax

  mov bh,0
  mov bl,[x]  ;{Pego o valor de x}
  mov al,[y]  ;{Pego o valor de y}
  mov dl,80
  mul dl      ;{Multiplico y por 80}
  add ax,bx   ;{Junto x com 80y}
  shl ax,1    ;{Muliplico tudo por 2 (estou trabalhando com bytes, nao words)}
  mov di,ax   ;{Enfim, mostro o endereco ao processador :)}

  lds si,[s]  ;{Pego o pointeiro para a string}

  mov dl,[trans];{Pego o caractere transparente}

  @vai:

    lodsb     ;{Carrego o caractere}
    cmp al,0
    je @fim   ;{Se o caractere eh nulo, FIM!}

    cmp al,dl
    je @trans ;{Se o caractere eh transparente}

    stosb     ;{Escreve na tela}
    jmp @opaco

    @trans:
    inc di    ;{Pula o caractere}
    @opaco:
    inc di    ;{Pula o byte de cor}
    jmp @vai  ;{recomeca tudo}

  @fim:

  pop ds      ;{Pascal me obriga a fazer isso...}
end;


procedure putstrtranscor(x,y:byte;s:string;trans:char;cor:byte); assembler;
asm
  push ds     ;{Pascal me obriga a fazer isso...}

  lds si,[s]  ;{Pego o pointeiro para a string}
  lodsb       ;{Pego o tamanho da string}
  xor ch,ch
  mov cl,al   ;{Pega o tamanho}

  jcxz @fim   ;{String vazia soh serve para dar um bug maneiro}

  mov ax,tela ;{Endereco da tela}
  mov es,ax

  xor bh,bh
  mov bl,[x]  ;{Pego o valor de x}
  mov al,[y]  ;{Pego o valor de y}
  mov dl,80
  mul dl      ;{Multiplico y por 80}
  add ax,bx   ;{Junto x com 80y}
  shl ax,1    ;{Muliplico tudo por 2 (estou trabalhando com bytes, nao words)}
  mov di,ax   ;{Enfim, mostro o endereco ao processador :)}

  mov ah,[cor]

  mov dl,[trans];{Pego o caractere transparente}

  @vai:

    lodsb     ;{Carrego o caractere}
    cmp al,dl
    je @trans ;{Se o caractere eh transparente}

    stosw     ;{Escreve na tela}
    jmp @opaco

    @trans:
    inc di    ;{Pula o caractere}
    inc di    ;{Pula o byte de cor}
    @opaco:

  loop @vai
  @fim:

  pop ds      ;{Pascal me obriga a fazer isso...}
end;


procedure putPChartranscor(x,y:byte;s:PChar;trans:char;cor:byte); assembler;
asm
  push ds     ;{Pascal me obriga a fazer isso...}

  mov ax,tela ;{Endereco da tela}
  mov es,ax

  mov bh,0
  mov bl,[x]  ;{Pego o valor de x}
  mov al,[y]  ;{Pego o valor de y}
  mov dl,80
  mul dl      ;{Multiplico y por 80}
  add ax,bx   ;{Junto x com 80y}
  shl ax,1    ;{Muliplico tudo por 2 (estou trabalhando com bytes, nao words)}
  mov di,ax   ;{Enfim, mostro o endereco ao processador :)}

  lds si,[s]  ;{Pego o pointeiro para a string}

  mov ah,[cor]

  mov dl,[trans];{Pego o caractere transparente}

  @vai:

    lodsb     ;{Carrego o caractere}
    cmp al,0
    je @fim   ;{Se o caractere eh nulo, FIM!}

    cmp al,dl
    je @trans ;{Se o caractere eh transparente}

    stosw     ;{Escreve na tela}
    jmp @opaco

    @trans:
    inc di    ;{Pula o caractere}
    inc di    ;{Pula o byte de cor}
    @opaco:
    jmp @vai  ;{recomeca tudo}

  @fim:

  pop ds      ;{Pascal me obriga a fazer isso...}
end;


procedure clearchar(x1,y1,x2,y2:byte;c:char); assembler;
asm
  mov ax,tela ;{Endereco da tela}
  mov es,ax

  mov bl,[x1] ;{Pego o valor de x1}
  mov bh,[x2] ;{Pego o valor de x2}
  mov dl,[y1] ;{Pego o valor de y1}
  mov dh,[y2] ;{Pego o valor de y2}

  cmp bl,bh   ;{x1 precisa ser menor que x2}
  jle @pulo1  ;{Se nao for}
  xchg bl,bh  ;{Eh necessario trocar}
  @pulo1:

  cmp dl,dh   ;{y1 precisa ser menor que y2}
  jle @pulo2  ;{Se nao for}
  xchg dl,dh  ;{Eh necessario trocar}
  @pulo2:

  mov al,dl   ;{Valor de y1, para multiplicar por 80}
  mov cl,80
  mul cl      ;{Multiplico y1 por 80}
  xor ch,ch
  mov cl,bl
  add ax,cx   ;{Junto x1 com 80y}
  shl ax,1    ;{Muliplico tudo por 2 (estou trabalhando com bytes, nao words)}
  mov di,ax   ;{Enfim, mostro o endereco ao processador :)}

  sub dh,dl   ;{dh = y2-y1}
              ;{DH -> Quantidade de linhas}

  mov cx,bx   ;{cx = (x1,x2)}
  sub ch,cl   ;{ch = x2-x1}
  mov dl,ch
  inc dl      ;{DL -> quantidade de colunas}

  add bl,80   ;{bl = x1+80-x2 -1}
  sub bl,bh   ;{Esse -1 eh anti-bug}
  dec bl
  shl bl,1
  xor bh,bh   ;{BX -> Pular "BX" bytes a cada linha}

  mov al,[c]  ;{Pego o caractere}
  xor ch,ch

  @looplinhas:

    mov cl,dl
    @loopcolunas:
      stosb
      inc di
    loop @loopcolunas

  cmp dh,0
  je @fim
  dec dh
  add di,bx
  jmp @looplinhas

  @fim:
end;


procedure clearcor(x1,y1,x2,y2:byte;cor:byte); assembler;
asm
  mov ax,tela ;{Endereco da tela}
  mov es,ax

  mov bl,[x1] ;{Pego o valor de x1}
  mov bh,[x2] ;{Pego o valor de x2}
  mov dl,[y1] ;{Pego o valor de y1}
  mov dh,[y2] ;{Pego o valor de y2}

  cmp bl,bh   ;{x1 precisa ser menor que x2}
  jle @pulo1  ;{Se nao for}
  xchg bl,bh  ;{Eh necessario trocar}
  @pulo1:

  cmp dl,dh   ;{y1 precisa ser menor que y2}
  jle @pulo2  ;{Se nao for}
  xchg dl,dh  ;{Eh necessario trocar}
  @pulo2:

  mov al,dl   ;{Valor de y1, para multiplicar por 80}
  mov cl,80
  mul cl      ;{Multiplico y1 por 80}
  xor ch,ch
  mov cl,bl
  add ax,cx   ;{Junto x1 com 80y}
  shl ax,1    ;{Muliplico tudo por 2 (estou trabalhando com bytes, nao words)}
  inc ax      ;{O byte da cor fica ao lado, hehehe}
  mov di,ax   ;{Enfim, mostro o endereco ao processador :)}

  sub dh,dl   ;{dh = y2-y1}
              ;{DH -> Quantidade de linhas}

  mov cx,bx   ;{cx = (x1,x2)}
  sub ch,cl   ;{ch = x2-x1}
  mov dl,ch
  inc dl      ;{DL -> quantidade de colunas}

  add bl,80   ;{bl = x1+80-x2 -1}
  sub bl,bh   ;{Esse -1 eh anti-bug}
  dec bl
  shl bl,1
  xor bh,bh   ;{BX -> Pular "BX" bytes a cada linha}

  mov al,[cor];{Pego a cor}
  xor ch,ch

  @looplinhas:

    mov cl,dl
    @loopcolunas:
      stosb
      inc di
    loop @loopcolunas

  cmp dh,0
  je @fim
  dec dh
  add di,bx
  jmp @looplinhas

  @fim:
end;


procedure clearcharcor(x1,y1,x2,y2:byte;c:char;cor:byte); assembler;
asm
  mov ax,tela ;{Endereco da tela}
  mov es,ax

  mov bl,[x1] ;{Pego o valor de x1}
  mov bh,[x2] ;{Pego o valor de x2}
  mov dl,[y1] ;{Pego o valor de y1}
  mov dh,[y2] ;{Pego o valor de y2}

  cmp bl,bh   ;{x1 precisa ser menor que x2}
  jle @pulo1  ;{Se nao for}
  xchg bl,bh  ;{Eh necessario trocar}
  @pulo1:

  cmp dl,dh   ;{y1 precisa ser menor que y2}
  jle @pulo2  ;{Se nao for}
  xchg dl,dh  ;{Eh necessario trocar}
  @pulo2:

  mov al,dl   ;{Valor de y1, para multiplicar por 80}
  mov cl,80
  mul cl      ;{Multiplico y1 por 80}
  xor ch,ch
  mov cl,bl
  add ax,cx   ;{Junto x1 com 80y}
  shl ax,1    ;{Muliplico tudo por 2 (estou trabalhando com bytes, nao words)}
  mov di,ax   ;{Enfim, mostro o endereco ao processador :)}

  sub dh,dl   ;{dh = y2-y1}
              ;{DH -> Quantidade de linhas}

  mov cx,bx   ;{cx = (x1,x2)}
  sub ch,cl   ;{ch = x2-x1}
  mov dl,ch
  inc dl      ;{DL -> quantidade de colunas}

  add bl,80   ;{bl = x1+80-x2 -1}
  sub bl,bh   ;{Esse -1 eh anti-bug}
  dec bl
  shl bl,1
  xor bh,bh   ;{BX -> Pular "BX" bytes a cada linha}

  mov al,[c]  ;{Pego o caractere}
  mov ah,[cor];{Pego a cor}
  xor ch,ch

  @looplinhas:

    mov cl,dl
    rep stosw

  cmp dh,0
  je @fim
  dec dh
  add di,bx
  jmp @looplinhas

  @fim:
end;


{
  Quem usava "ClearArea", favor substituir por "clearcharcor"

procedure ClearArea(x1,y1,x2,y2:byte;c:char);
var x,y : byte;
    endereco : word;
begin
  for y:=menori(y1,y2) to maiori(y1,y2) do
    endereco:=y*80;
    for x:=menori(x1,x2) to maiori(x1,x2) do
       putchar(x,y,c);
end;}


function InputTextPadrao(caracs:string):byte;
begin

end;

function InputText(x,y,tamvis,tamstr,cortexto:byte;inicial,caracs:string;corfora:byte;antes,depois:char;saida:string):string;
{Parametros desta funcao:
  x        Posicao X na tela
  y        Posicao Y na tela
  tamvis   Tamanho da caixa (numero de caracteres visiveis)
  cortexto Cor do texto
  inicial  Texto inicial
  caracs   Caracteres permitidos
  corfora  Cor da "borda"
  antes    Caractere da borda esquerda
  depois   Caractere da borda direita
  saida    Caracteres que encerram esta funcao
}
var s:string[255];
    k:char;
(*************************************************

Criar um versao que usa pascal-strings e outra que usa null-term...-string

*************************************************)
begin
  s:=inicial;
  {Exibicao}
  if antes<>#0 then begin
    putcharcor(x         ,y,antes ,corfora);
    putcharcor(x+tamvis+1,y,depois,corfora);
  end;

  {Main Loop}
  repeat

    {Exibicao}
    Clearcharcor(x+1,y,x+tamvis,y,' ',cortexto);
    putstr(x+1,y,copy(s,maiori(1,length(s)-tamvis+1),menori(tamvis,length(s))));

    {Pegar a tecla}
    k:=readkey;

    {Interpretar a tecla}
    if length(s)<tamstr then
      if pos(k,caracs)>0 then s:=s+k;

    {Backspace}
    if (k=#8) and (length(s)>0) then s:=copy(s,1,length(s)-1);

  until (k=#13) or (pos(k,saida)>0);

  {Retorno da funcao}
  if k=#13 then InputText:=s
  else InputText:=k;
end;


function FileExists(FileName: String): Boolean;
{ Boolean function that returns True if the file exists;otherwise,
 it returns False. Closes the file if it exists. }
var
 F: file;
begin
 {$I-}
 Assign(F, FileName);
 FileMode := 0;  { Set file access to read only }
 Reset(F);
 Close(F);
 {$I+}
 FileExists := (IOResult = 0) and (FileName <> '');
end;  { FileExists }


procedure bubblesort(var x:array of integer; n:word);
var i,j:word;
    aux:integer;
    teste:boolean;
begin
 i:=0; while (i<n-1) AND teste do begin {for(i=0; i<n-1 && teste; i++)}
   teste:=false;
   for j:=0 to n-i-1-1 do begin {for(j=0; j<n-i-1; j++)}
     if x[j]>x[j+1] then begin
       teste :=true;
       aux   :=x[j];
       x[j]  :=x[j+1];
       x[j+1]:=aux;
     end;
   end;
 inc(i); end;
end;


procedure selectsort(var x:array of integer; n:word);
var i,indx,j:word;
    maior:integer;
begin
 for i:=n-1 downto 1 do begin  {for(i=n-1; i>0; i--)}
   maior:=x[0];
   indx:=0;
   for j:=1 to i do  {for(j=1; j<=i; j++)}
     if x[j]>maior then begin
       maior:=x[j];
       indx:=j;
     end;
   x[indx]:=x[i];
   x[i]:=maior;
 end;
end;


procedure insersort(var x:array of integer; n:word);
var i,k:word;
    y:integer;
begin
 for k:=1 to n-1 do begin  {for( k=1; k<n; k++)}
   y:=x[k];
   i:=k-1; while (i>=0) AND (y<x[i]) do begin {for( i=k-1; i>=0 && y<x[i]; i--)}
     x[i+1]:=x[i];
   dec(i); end;
   x[i+1]:=y
 end;
end;


procedure shellsort(var x:array of integer; n:word; incs:array of byte; numinc:byte);
var j,k:word;
    y:integer;
    incr,span:byte;
begin
 for incr:=0 to numinc-1 do begin {for(incr=0; incr<numinc; incr++)}
   span:=incs[incr];
   for j:=span to n-1 do begin {for(j=span; j<n; j++)}
     y:=x[j];
     k:=j-span; while (k>=0) AND (y<x[k]) do begin {for(k=j-span; k>=0 && y<x[k]; k-=span)}
       x[k+span]:=x[k];
     dec(k,span); end;
     x[k+span]:=y
   end;
 end;
end;


end.