home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / SPX10.ZIP / SPX_TPU7.ZIP / SPX_FNC.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-05-05  |  6.9 KB  |  359 lines
  1. Unit SPX_FNC;
  2.  
  3. { SPX Library Version 1.0  Copyright 1993 Scott D. Ramsay }
  4.  
  5. Interface
  6.  
  7. function sgn(h:integer):integer;
  8. function strint(s:string):longint;
  9. function intstr(l:longint):string;
  10. function ups(s:string):string;
  11. function st(h:longint):string;
  12. function compare(s1,s2:string):boolean;
  13. function dtcmp(var s1,s2;size:word):boolean;
  14. function cmp(var s1,s2;size:word):boolean;
  15. function lz(i,w:longint):string;
  16. function vl(h:string):longint;
  17. function spaces(h:integer):string;
  18. function repstr(h:integer;ch:char):string;
  19. procedure ifix(var a:integer;min,max:integer);
  20. procedure rfix(var a:real;min,max:real);
  21. function anything(s:string):boolean;
  22. function exist(f:string):boolean;
  23. function errmsg(n:integer):string;
  24. function TPerror(errorcode:integer) : string;
  25. procedure funpad(var s:string);
  26. procedure unpad(var s:string);
  27. procedure munpad(var s:string;b:byte);
  28. function fpad(s:string;h:integer):string;
  29. procedure pad(var s:string;h:integer);
  30. procedure fix(var s:string;h:string);
  31. procedure fixh(var s:string);
  32. function range(x,y,x1,y1,x2,y2:integer) : boolean;
  33. function rrange(x,y,x1,y1,x2,y2:real) : boolean;
  34. function between(x,x1,x2:longint):boolean;
  35.  
  36. Implementation
  37.  
  38.  
  39. function cmp(var s1,s2;size:word):boolean;
  40. begin
  41.   cmp := dtcmp(s1,s2,size);
  42. end;
  43.  
  44.  
  45. function sgn(h:integer):integer;
  46. begin
  47.   if h<0
  48.     then sgn := -1
  49.     else
  50.       if h>0
  51.         then sgn := 1
  52.         else sgn := 0;
  53. end;
  54.  
  55.  
  56. procedure ifix(var a:integer;min,max:integer);
  57. begin
  58.   if a<min
  59.     then a := min
  60.     else
  61.       if a>max
  62.         then a := max;
  63. end;
  64.  
  65.  
  66. procedure rfix(var a:real;min,max:real);
  67. begin
  68.   if a<min
  69.     then a := min
  70.     else
  71.       if a>max
  72.         then a := max;
  73. end;
  74.  
  75.  
  76. function range(x,y,x1,y1,x2,y2:integer) : boolean;
  77. begin
  78.   range := ((x>=x1) and (x<=x2) and (y>=y1) and (y<=y2));
  79. end;
  80.  
  81. function rrange(x,y,x1,y1,x2,y2:real) : boolean;
  82. begin
  83.   rrange := ((x>=x1) and (x<=x2) and (y>=y1) and (y<=y2));
  84. end;
  85.  
  86.  
  87. procedure fix(var s:string;h:string);
  88. begin
  89.   if pos('.',s)=0
  90.     then s := s+h;
  91. end;
  92.  
  93.  
  94. procedure fixh(var s:string);
  95. var
  96.   d : integer;
  97. begin
  98.   for d := 1 to length(s) do
  99.     if s[d]<#32
  100.       then s[d] := ' ';
  101.   for d := length(s)+1 to 255 do
  102.     s[d] := ' ';
  103. end;
  104.  
  105.  
  106. function strint(s:string):longint;
  107. var
  108.   l : longint;
  109. begin
  110.   move(s[1],l,sizeof(l));
  111.   strint := l;
  112. end;
  113.  
  114.  
  115. function intstr(l:longint):string;
  116. var
  117.   s : string;
  118. begin
  119.   move(l,s[1],sizeof(l));
  120.   s[0] := #4;
  121.   intstr := s;
  122. end;
  123.  
  124.  
  125. function ups(s:string):string;
  126. var
  127.   d : integer;
  128. begin
  129.   for d := 1 to length(s) do
  130.     s[d] := upcase(s[d]);
  131.   ups := s;
  132. end;
  133.  
  134.  
  135. function st(h:longint):string;
  136. var
  137.   s : string;
  138. begin
  139.   str(h,s);
  140.   st := s;
  141. end;
  142.  
  143.  
  144. function compare(s1,s2:string):boolean;
  145. var
  146.   d : byte;
  147.   e : boolean;
  148. begin
  149.   e := true;
  150.   for d := 1 to length(s1) do
  151.     if upcase(s1[d])<>upcase(s2[d])
  152.       then e := false;
  153.   compare := e;
  154. end;
  155.  
  156.  
  157. function dtcmp(var s1,s2;size:word):boolean;
  158. var
  159.   d : word;
  160.   e : boolean;
  161. begin
  162.   e := true;
  163.   d := size;
  164.   while (d>0) and e do
  165.     begin
  166.       dec(d);
  167.       e := (mem[seg(s1):ofs(s1)+d]=mem[seg(s2):ofs(s2)+d]);
  168.     end;
  169.   dtcmp := e;
  170. end;
  171.  
  172.  
  173. function lz(i,w:longint):string;
  174. var
  175.   d : longint;
  176.   s : string;
  177. begin
  178.   str(i,s);
  179.   for d := length(s) to w-1 do
  180.     s := concat('0',s);
  181.   lz := s;
  182. end;
  183.  
  184.  
  185. function vl(h:string):longint;
  186. var
  187.   d : longint;
  188.   e : integer;
  189. begin
  190.   val(h,d,e);
  191.   vl := d;
  192. end;
  193.  
  194.  
  195. function spaces(h:integer):string;
  196. var
  197.   s : string;
  198. begin
  199.   s := '';
  200.   while h>0 do
  201.     begin
  202.       dec(h);
  203.       s := concat(s,' ');
  204.     end;
  205.   spaces := s;
  206. end;
  207.  
  208.  
  209. function repstr(h:integer;ch:char):string;
  210. var
  211.   s : string;
  212. begin
  213.   s := '';
  214.   while h>0 do
  215.     begin
  216.       dec(h);
  217.       s := s+ch;
  218.     end;
  219.   repstr := s;
  220. end;
  221.  
  222.  
  223. function anything(s:string):boolean;
  224. var
  225.   d : integer;
  226.   h : boolean;
  227. begin
  228.   if length(s)=0
  229.     then
  230.       begin
  231.         anything := false;
  232.         exit;
  233.       end;
  234.   h := false;
  235.   for d := 1 to length(s) do
  236.     if s[d]>#32
  237.       then h := true;
  238.   anything := h;
  239. end;
  240.  
  241.  
  242. function exist(f:string):boolean;
  243. var
  244.   fil : file;
  245. begin
  246.   if f=''
  247.     then
  248.       begin
  249.         exist := false;
  250.         exit;
  251.       end;
  252.   assign(fil,f);
  253.  {$i- }
  254.   reset(fil);
  255.   close(fil);
  256.  {$i+ }
  257.   exist := (ioresult=0);
  258. end;
  259.  
  260.  
  261. function errmsg(n:integer):string;
  262. begin
  263.    case n of
  264.       -1 : errmsg := '';
  265.       -2 : errmsg := 'Error reading data file';
  266.       -3 : errmsg := '';
  267.       -4 : errmsg := 'equal current data file name';
  268.      150 : errmsg := 'Disk is write protected';
  269.      152 : errmsg := 'Drive is not ready';
  270.      156 : errmsg := 'Disk seek error';
  271.      158 : errmsg := 'Sector not found';
  272.      159 : errmsg := 'Out of Paper';
  273.      160 : errmsg := 'Error writing to printer';
  274.     1000 : errmsg := 'Record too large';
  275.     1001 : errmsg := 'Record too small';
  276.     1002 : errmsg := 'Key too large';
  277.     1003 : errmsg := 'Record size mismatch';
  278.     1004 : errmsg := 'Key size mismatch';
  279.     1005 : errmsg := 'Memory overflow';
  280.      else errmsg := 'Error result #'+st(n);
  281.    end;
  282. end;
  283.  
  284.  
  285. function TPerror(errorcode:integer) : string;
  286. begin
  287.   case errorcode of
  288.       1: TPerror := 'Invalid DOS function code';
  289.       2: TPerror := 'File not found';
  290.       3: TPerror := 'Path not found';
  291.       4: TPerror := 'Too many open files';
  292.       5: TPerror := 'File access denied';
  293.       6: TPerror := 'Invalid file handle';
  294.       8: TPerror := 'Not enough memory';
  295.      12: TPerror := 'Invalid file access code';
  296.      15: TPerror := 'Invalid drive number';
  297.      16: TPerror := 'Cannot remove current directory';
  298.      17: TPerror := 'Cannot rename across drives';
  299.     100: TPerror := 'Disk read error';
  300.     101: TPerror := 'Disk write error';
  301.     102: TPerror := 'File not assigned';
  302.     103: TPerror := 'File not open';
  303.     104: TPerror := 'File not open for input';
  304.     105: TPerror := 'File not open for output';
  305.     106: TPerror := 'Invalid numeric format';
  306.     200: TPerror := 'Division by zero';
  307.     201: TPerror := 'Range check error';
  308.     202: TPerror := 'Stack overflow error';
  309.     203: TPerror := 'Heap overflow error';
  310.     204: TPerror := 'Invalid pointer operation';
  311.     else TPerror := errmsg(errorcode);
  312.   end;
  313. end;
  314.  
  315.  
  316. procedure funpad(var s:string);
  317. begin
  318.    while s[1]=' ' do
  319.       delete(s,1,1);
  320. end;
  321.  
  322.  
  323. procedure unpad(var s:string);
  324. begin
  325.    while (length(s)>0) and (s[length(s)]<=' ') do
  326.       delete(s,length(s),1);
  327. end;
  328.  
  329.  
  330. procedure munpad(var s:string;b:byte);
  331. begin
  332.    s[0] := char(b);
  333.    while (length(s)>0) and (s[length(s)]<=' ') do
  334.       delete(s,length(s),1);
  335. end;
  336.  
  337.  
  338. function fpad(s:string;h:integer):string;
  339. begin
  340.    while length(s)<h do
  341.       s := concat(s,' ');
  342.    fpad := s;
  343. end;
  344.  
  345.  
  346. procedure pad(var s:string;h:integer);
  347. begin
  348.    while length(s)<h do
  349.       s := concat(s,' ');
  350. end;
  351.  
  352.  
  353. function between(x,x1,x2:longint):boolean;
  354. begin
  355.   between := ((x>=x1) and (x<=x2));
  356. end;
  357.  
  358.  
  359. end.