{---------------------------------------------------------------------------}
{ Unit Sup1  Funzioni/procedure di supporto per la programmazione
{            in Pascal 7.0 - Delphi 1.0  -  By Claudio Fin (C) 1997
{---------------------------------------------------------------------------}

unit Sup1;

interface

uses sysutils;

function Vals(const a:string):longint;
function Strs(a:longint):string;
function DelSpace(const str:string):string;
function Strings(n:byte;car:char):string;
function Lset(const Str:string;N:byte):string;
function Rset(const Str:string;N:byte):string;
function Lcases(const str:string):string;
function Ucases(const str:string):string;
function Bins(valore:longint;n:byte):string;
function Bin(const str:string):longint;
function Rights(const str:string;n:byte):string;
function Hexs(valore:longint;n:byte):string;
function Esa(const str:string):longint;
function EstraiElemento(var riga_input:string):string;
function Angolo(var x,y:real):real;
function Rad(const Gradi:real):real;
function Crop(const a:string; n:integer):string;

type
  Tcalcolatempo=class
    t_start:tdatetime;
    procedure start;
    function stop:longint;
  end;


implementation


(*-----------------------------------------------------------------------*)
(* Toglie N caratteri all'inizio di una stringa.
(*-----------------------------------------------------------------------*)

function crop(const a:string; n:integer):string;
begin
  asm
    push ds
    lds si,a        { DS:SI Indirizzo sorgente }
    les di,@Result  { ES:DI Indirizzo destinazione }
    mov cl,[si]
    mov ch,0        { CX = Lunghezza stringa sorgente }
    jcxz @E1        { Se zero salta a @E1 }
    cmp cx,N        { Confronta CX con N (byte da togliere) }
    jb @E1          { Se N>=alla lunghezza salta a @E1 }
    cld             { Flag direzione incremento }
    mov ax,cx       { AX=lunghezza stringa sorgente}
    sub ax,N        { AX=lunghezza stringa destinazione }
    stosb           { Memorizza AL in byte lungh.stringa destinaz.}
    add si,N        { Imposta indirizzo sorgente }
    inc si
    mov cx,ax       { CX=nr.byte da trasferire }
    rep movsb       { Copia i byte nella stringa risultato }
    jmp @Fine
  @E1:
    mov es:[di],byte(0)
  @Fine:
    pop ds
  end;
end;

(*-----------------------------------------------------------------------*)
(* Toglie i blank all'inizio e alla fine di una stringa.
(*-----------------------------------------------------------------------*)

function delspace(const str:string):string;
begin
  asm
            PUSH DS

  (* Conta gli spazi in testa *)

            LES DI,str          (* ES:DI=indirizzo stringa sorgente *)
            XOR CH,CH           (* Azzera parte alta CX *)
            MOV CL,ES:[DI]      (* CL=Lunghezza stringa sorgente *)
            JCXZ @NULLA         (* Se len=0 salta a @Nulla *)
            INC DI              (* ES:DI punta al primo byte *)
            MOV AL,' '          (* Carattere di confronto *)
            CLD                 (* Direzione incremento *)
            REPE SCASB          (* Conta i blank *)
            JNE @E0             (* Se trovato <> da blank salta a @E0 *)
            DEC CX
    @E0:    INC CX              (* CX=byte da copiare *)

  (* Copia la stringa nel risultato senza i blank iniziali *)

            LDS SI,str          (* DS:SI=INDIRIZZO STRINGA SORGENTE *)
            MOV BL,[SI]         (* BL=LUNGHEZZA STRINGA SORGENTE *)
            XOR BH,BH           (* AZZERA PARTE ALTA DI BX *)
            SUB BL,CL
            INC BL
            ADD SI,BX           (* SI=PUNTA AL PRIMO BYTE DA TRASFERIRE *)
            LES DI,@Result      (* ES:DI=INDIRIZZO RISULTATO *)
            MOV ES:[DI],CL      (* IMPOSTA LUNGHEZZA RISULTATO *)
            INC DI              (* PUNTA AL PRIMO BYTE DEL RISULTATO *)
            REP MOVSB           (* COPIA LA SOTTOSTRINGA *)

  (* Toglie spazi in coda *)

            LES DI,@Result
            MOV BX,DI
            MOV CL,ES:[DI]
            XOR CH,CH
            JCXZ @NULLA
            ADD DI,CX           (* ES:DI PUNTA ALL'ULTIMO BYTE *)
            STD                 (* DIREZIONE DECREMENTO *)
            REPE SCASB          (* CONTA I BLANK IN CODA *)
            JE @E3
            INC CX
    @E3:    MOV ES:[BX],CL      (* IMPOSTA NUOVA LUNGHEZZA *)
            JMP @FINE

    @NULLA: LES DI,@Result      (* Imposta stringa nulla *)
            MOV ES:[DI],CL

    @FINE:  POP DS
  end;
end;

(*-----------------------------------------------------------------------*)
(* Forma una stringa di N caratteri uguali, N=0..255.
(*-----------------------------------------------------------------------*)

function strings(n:byte;car:char):string;
begin
  asm
            LES DI,@Result    (* ES:DI indirizzano il risultato *)
            MOV AL,n
            XOR AH,AH         (* AX=LUNGHEZZA *)
            CLD
            STOSB             (* MEMORIZZA LEN E PUNTA AL PRIMO BYTE *)
            XCHG AX,CX        (* CX=LUNGHEZZA *)
            MOV AL,car        (* AL=carattere di riempimento *)
            REP STOSB         (* Scrittura dei caratteri *)
  end;
end;

(*-----------------------------------------------------------------------*)
(* Formatta la stringa str sulla sinistra di un campo di n blank.
(* I caratteri in eccesso a destra vengono troncati, N=0..255.
(*-----------------------------------------------------------------------*)

function lset(const str:string;n:byte):string;
begin
  asm
            PUSH DS
            LES DI,@Result
            MOV CL,n
            XOR CH,CH
            MOV ES:[DI],CL
            JCXZ @FINE
            INC DI
            MOV BX,DI
            MOV AL,' '
            CLD
            REP STOSB
            MOV DI,BX
            LDS SI,str
            MOV CL,[SI]
            CMP CL,n
            JBE @E1
            MOV CL,n
    @E1:    INC SI
            REP MOVSB
    @FINE:  POP DS
  end;
end;

(*-----------------------------------------------------------------------*)
(* Formatta la stringa str sulla destra di un campo di n blank.
(* I caratteri in eccesso a sinistra vengono troncati, N=0..255.
(*-----------------------------------------------------------------------*)

function Rset(const str:string;N:byte):string;
begin
  asm
            PUSH DS
            LES DI,@Result      (* ES:DI=INDIRIZZO RISULTATO *)
            MOV CL,n
            XOR CH,CH           (* CX=LUNGHEZZA RISULTATO 0..255 *)
            MOV ES:[DI],CL      (* IMPOSTA BYTE LUNGHEZZA *)
            JCXZ @FINE          (* SE ZERO SALTA A FINE *)
            INC DI              (* PUNTA AL PRIMO BYTE DEL RISULTATO *)
            MOV AL,' '
            CLD
            REP STOSB           (* RIEMPIE RISULTATO DI BLANK *)
            DEC DI              (* ES:DI PUNTA A ULTIMO BYTE RISULTATO *)
            LDS SI,str          (* DS:SI=INDIRIZZO SORGENTE *)
            MOV CL,DS:[SI]
            XOR CH,CH           (* CX=LUNGHEZZA SORGENTE *)
            ADD SI,CX           (* SI PUNTA ALL'ULTIMO BYTE SORGENTE *)
            CMP CL,n            (* CONTROLLA CHE LEN NON SIA MAGGIORE *)
            JBE @E1             (* DI LEN DEL RISULTATO, SE LO E' VIENE *)
            MOV CL,n            (* RIDOTTA A N *)
    @E1:    STD
            REP MOVSB           (* TRASFERISCE LA SOTTOSTRINGA *)
    @FINE:  POP DS
  end;
end;

(*-----------------------------------------------------------------------*)
(* Trasforma una stringa in minuscolo.
(*-----------------------------------------------------------------------*)

function lcases(const str:string):string;
begin
  asm
            PUSH DS
            LDS SI,str
            LES DI,@Result
            CLD
            LODSB
            STOSB
            XOR AH,AH
            XCHG AX,CX
            JCXZ @FINE
    @E1:      LODSB
              CMP AL,'A'
              JB @E2
              CMP AL,'Z'
              JA @E2
              ADD AL,32
    @E2:      STOSB
            LOOP @E1
    @FINE:  POP DS
  end;
end;

(*-----------------------------------------------------------------------*)
(* Trasforma una stringa in maiuscolo.
(*-----------------------------------------------------------------------*)

function ucases(const str:string):string;
begin
  asm
            PUSH DS
            LDS SI,str
            LES DI,@Result
            CLD
            LODSB
            STOSB
            XOR AH,AH
            XCHG AX,CX
            JCXZ @FINE
    @E1:      LODSB
              CMP AL,'a'
              JB @E2
              CMP AL,'z'
              JA @E2
              SUB AL,32
    @E2:      STOSB
            LOOP @E1
    @FINE:  POP DS
  end;
end;

(*-----------------------------------------------------------------------*)
(* Converte un valore longint in una stringa binaria di N caratteri.
(* N=0..31, il longint puo'valere al massimo 2147483647.
(*-----------------------------------------------------------------------*)

function bins(valore:longint;n:byte):string;
begin
  asm
            MOV CL,n
            XOR CH,CH
            LES DI,@Result          (* acquisisce addr stringa risultato *)
            MOV ES:[DI],CL          (* imposta lunghezza risultato *)
            ADD DI,CX               (* indirizzo fine stringa risultato *)
            MOV BX,WORD[valore]
            MOV DX,WORD[valore+2]
    @E1:      RCR DX,1
              RCR BX,1
              JC @E2
              MOV BYTE(ES:[DI]),'0'
              jMP @E3
    @E2:      MOV BYTE(ES:[DI]),'1'
    @E3:      DEC DI
            LOOP @E1
  end;
end;

(*-----------------------------------------------------------------------*)
(* Converte una stringa binaria di caratteri 0 e 1 in longint.
(* La stringa puo'essere lunga da 0 a 31 caratteri, caratteri diversi da
(* 0 e 1 vengono interpretati come 0, la funzione fornisce un valore
(* compreso tra 0 e 2147483647, se la stringa supera i 31 caratteri la
(* funzione ritorna 0.
(*-----------------------------------------------------------------------*)

function bin(const str:string):longint;
begin
  asm
            PUSH DS
            XOR BX,BX       (* azzera risultato conversione DX:BX *)
            XOR DX,DX
            LDS SI,str      (* acquisisce indirizzo stringa in ES:SI *)
            MOV CL,[SI]     (* legge lunghezza stringa *)
            XOR CH,CH
            JCXZ @FINE      (* se e'zero salta a fine *)
            CMP CL,31
            JA @FINE        (* se e'maggiore di 31 salta a fine *)
            INC SI
            CLD
    @E0:      LODSB
              CMP AL,'1'
              JNE @E2
              MOV AL,1
              JMP @E3
    @E2:      XOR AL,AL
    @E3:      RCL BX,1
              RCL DX,1
              AND BL,11111110B
              OR BL,AL
            LOOP @E0
    @FINE:  MOV WORD(@Result),BX
            MOV WORD(@Result+2),DX
            POP DS
  end;
end;


(*-----------------------------------------------------------------------*)
(* Fornisce gli ultimi n caratteri della stringa str.
(*-----------------------------------------------------------------------*)

function rights(const str:string;n:byte):string;
begin
  asm
            PUSH DS
            LDS SI,str
            LES DI,@Result
            MOV AL,[SI]
            MOV CL,n
            CMP AL,CL
            JAE @E1
            MOV CL,AL
    @E1:    MOV ES:[DI],CL      (* IMPOSTA LEN RISULTATO *)
            XOR CH,CH
            JCXZ @FINE
            XOR AH,AH
            ADD SI,AX           (* PUNTA ALL'ULTIMO BYTE SORGENTE *)
            STD
            ADD DI,CX           (* PUNTA ALL'ULTIMO BYTE DESTINAZ. *)
            REP MOVSB           (* COPIA LA SOTTOSTRINGA *)
    @FINE:  POP DS
  end;
end;

(*-----------------------------------------------------------------------*)
(* Converte un longint in stringa esadecimale di N caratteri (N=0..8).
(*-----------------------------------------------------------------------*)

function hexs(valore:longint;n:byte):string;
begin
  asm
            LES DI,@Result
            MOV CL,n
            CMP CL,8
            JBE @E1
            MOV CL,8
    @E1:    MOV ES:[DI],CL
            XOR CH,CH
            JCXZ @FINE
            ADD DI,CX
            STD
            MOV BX,WORD[valore]
            MOV DX,WORD[valore+2]
    @E4:      MOV AL,BL
              AND AL,00001111B
              CMP AL,9
              JA @E2
              ADD AL,48
              JMP @E3
    @E2:      ADD AL,55
    @E3:      STOSB
              RCR DX,1
              RCR BX,1
              RCR DX,1
              RCR BX,1
              RCR DX,1
              RCR BX,1
              RCR DX,1
              RCR BX,1
            LOOP @E4
    @FINE:
  end;
end;

(*-----------------------------------------------------------------------*)
(* Converte una stringa esadecimale (da 0 a 8 chr) in longint, i caratteri
(* diversi da 0..9 e a..z vengono interpretati come 0, una stringa in
(* ingresso maggiore di 8 chr viene restituita come 0, la funzione ritorna
(* un valore compreso tra 0 e 2147483647.
(*-----------------------------------------------------------------------*)

function esa(const str:string):longint;
begin
  asm
            PUSH DS
            XOR DX,DX
            XOR BX,BX
            LDS SI,str
            CLD
            LODSB
            CMP AL,8
            JA @FINE
            MOV CL,AL
            XOR CH,CH
    @E5:      LODSB
              CMP AL,'0'
              JB @E1
              CMP AL,'9'
              JA @E1
              SUB AL,48
              JMP @E4
    @E1:      CMP AL,'A'
              JB @E2
              CMP AL,'Z'
              JA @E2
              SUB AL,55
              JMP @E4
    @E2:      CMP AL,'a'
              JB @E3
              CMP AL,'z'
              JA @E3
              SUB AL,87
              JMP @E4
    @E3:      MOV AL,0
    @E4:      RCL BX,1
              RCL DX,1
              RCL BX,1
              RCL DX,1
              RCL BX,1
              RCL DX,1
              RCL BX,1
              RCL DX,1
              AND BL,11110000B
              OR BL,AL
            LOOP @E5
    @FINE:  MOV WORD[@Result],BX
            MOV WORD[@Result+2],DX
            POP DS
  end;
end;

(*-----------------------------------------------------------------------*)
(* Estrae da una stringa una parola cancellandola dalla stringa stessa.
(*-----------------------------------------------------------------------*)

function EstraiElemento(var riga_input:string):string;
var
    st:string;
    fine,trovati_caratteri:boolean;
begin
  asm
            PUSH DS

    (* CONTROLLA SE LENGTH(riga_input)=0
       SE SI RITORNA STRINGA NULLA *)

            LDS SI,riga_input
            MOV CL,[SI]
            XOR CH,CH
            JCXZ @E1SK
            JMP @E2SK
    @E1SK:  JMP @E1
    @E2SK:

    (* IMPOSTA LUNGHEZZA ZERO NEL RISULTATO E FALSE IN
       fine E trovati_caratteri *)

            LES DI,@Result
            XOR AL,AL
            MOV ES:[DI],AL
            MOV fine,0
            MOV trovati_caratteri,0
            CLD
            INC SI                   (* DS:SI PUNTA AL PRIMO BYTE *)
    @E2:      MOV AL,[SI]            (* LEGGE UN BYTE DA riga_input *)
              CMP AL,' '
              JNE @E3

    (* OPERAZIONI SE TROVATO UN BLANK *)

              MOV AL,trovati_caratteri
              CMP AL,1
              JNE @E6
              MOV fine,1
              JMP @E4

    @E6:      MOV BX,SI               (* CANCELLA UN CARATTERE IN TESTA *)
              DEC BYTE[SI-1]
              MOV CL,[SI-1]
              XOR CH,CH
              INC SI
              LES DI,riga_input
              INC DI
              REP MOVSB
              MOV SI,BX
              LES DI,@Result

              MOV AL,[SI-1]
              CMP AL,0
              JNE @E4
              MOV fine,1
              JMP @E4

    (* OPERAZIONI SE TROVATO UN CARATTERE *)

    @E3:      INC BYTE(ES:[DI])      (* AGGIUNGE CARATTERE AL RISULTATO *)
              MOV BX,DI
              MOV CL,ES:[DI]
              XOR CH,CH
              ADD DI,CX
              MOV ES:[DI],AL
              MOV DI,BX

              MOV BX,SI              (* CANCELLA UN CARATTERE IN TESTA *)
              DEC BYTE[SI-1]
              MOV CL,[SI-1]
              XOR CH,CH
              INC SI
              LES DI,riga_input
              INC DI
              REP MOVSB
              MOV SI,BX
              LES DI,@Result

              MOV AL,[SI-1]
              CMP AL,0
              JNE @E5
              MOV fine,1
    @E5:      MOV trovati_caratteri,1

    @E4:      CMP fine,1
            JNE @E2
            JMP @FINE

    @E1:    LDS SI,@Result
            MOV [SI],CL

    @FINE:  POP DS
  end;
end;

{ ------------------------------------------------------------------------ }
{ Procedura per il calcolo dell'angolo in gradi a partire dai valori di
{ X e Y. (Se entrambi sono a zero l'angolo ritornato è 0).
{ ------------------------------------------------------------------------ }

function angolo(var x,y:real):real;
var v,coseno,radianti,gradi:real;
begin
  if x=0 then
    if y=0 then        angolo:=0
    else if y>0 then   angolo:=90
    else               angolo:=270
  else if y=0 then
    if x=0 then        angolo:=0
    else if x>0 then   angolo:=0
    else               angolo:=180
  else if x>0 then
  begin
    V:=sqrt(x*x+y*y);  coseno:=x/v;
    radianti:=arctan(sqrt(1-(coseno*coseno))/coseno);
    if y>0 then angolo:=180*radianti/pi
           else angolo:=360-(180*radianti/pi);
  end
  else if x<0 then
  begin
    V:=sqrt(x*x+y*y);  coseno:=x/v;
    radianti:=arctan(sqrt(1-(coseno*coseno))/coseno);
    if y>0 then angolo:=180+(180*radianti/pi)
           else angolo:=180-(180*radianti/pi);
  end;
end;

{--------------------------------------------------------------------------}

function rad(const Gradi:real):real;
begin Rad:=0.01745329251994*Gradi; end;

{ ------------------------------------------------------------------------ }

function Vals(const a:string):longint;
var b:string[20]; z:longint; uffa:integer;
begin
  b:=delspace(a); z:=0;
  if b='' then Vals:=0 else begin val(a,z,uffa); Vals:=z; end;
end;

{ ------------------------------------------------------------------------ }

function Strs(a:longint):string;
var b:string[15];
begin str(a,b); strs:=b; end;

{ ------------------------------------------------------------------------ }
{  Metodi della classe Tcalcolatempo, calcola la differenza in
{  millisecondi tra la chiamata start e quella stop.
{       start; memorizza il tempo iniziale
{       stop;  fornisce la diff in ms in un longint (al max 24 ore!)
{ ------------------------------------------------------------------------ }

procedure Tcalcolatempo.start;
begin t_start:=time; end;


function Tcalcolatempo.stop:longint;
var h,m,s,ms:word;
    lh,lm,ls,lms,lh1,lm1,ls1,lms1,msec:longint;
begin
    decodetime(time,h,m,s,ms);     lh1:=h;  lm1:=m;  ls1:=s;  lms1:=ms;
    decodetime(t_start,h,m,s,ms);  lh:=h;   lm:=m;   ls:=s;   lms:=ms;
    msec:=( lms1 + 1000*ls1 + 60000*lm1 + 3600000*lh1 ) -
          ( lms  + 1000*ls  + 60000*lm  + 3600000*lh  );
    if msec<0 then msec:=msec+86400000;
    stop:=msec;
end;


end.