home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: Graphics / Graphics.zip / os2apipm.zip / OS2API / BUILTIN.ADB < prev    next >
Text File  |  1996-08-10  |  26KB  |  634 lines
  1.  
  2. -- ╔═══════════════════════════════════════════════════════════════════╗
  3. -- ║       D E S I G N   E N G I N E R I N G              ║D║S║        ║
  4. -- ║            S O F T W A R E                           ╚═╩═╝        ║
  5. -- ║                                                                   ║
  6. -- ║        Package  body BUILTIN                                      ║
  7. -- ║                                                                   ║
  8. -- ║        Author :  Leonid Dulman     1995                           ║
  9. -- ║                                                                   ║
  10. -- ╚═══════════════════════════════════════════════════════════════════╝
  11. with Ada.calendar; use Ada.calendar;
  12. with Ada.text_io; use Ada.text_io;
  13. package  body BUILTIN is
  14. -----------------------------------------------------------------------
  15. zero  : constant  character:='0'; one   : constant  character:='1';
  16. two   : constant  character:='2'; three : constant  character:='3';
  17. fore  : constant  character:='4'; five  : constant  character:='5';
  18. six   : constant  character:='6'; seven : constant  character:='7';
  19. eight : constant  character:='8'; nine  : constant  character:='9';
  20. plus  : constant character :='+'; minus : constant character :='-';
  21. probel: constant character :=' '; point : constant  character:='.';
  22. coma  : constant  character:=','; power : constant  character:='e';
  23. digi  : constant integer  :=10;
  24. dig   : constant float    := 10.0; digp  : constant float    := 0.1;
  25. sim:constant string(1..15):="+-.eE0123456789";
  26. upper:constant string(1..57):=
  27. "QWERTYUIOPASDFGHJKLZXCVBNM-------------------------------";
  28. low  :constant string(1..57):=
  29. "qwertyuiopasdfghjklzxcvbnm-------------------------------";
  30. lit     : character               ;
  31. flag  : boolean            :=false ;
  32. flagp : boolean            :=false ;
  33. flag_point  : boolean      :=false ;
  34. flag_power  : boolean      :=false ;
  35. m           : array(1..10) of integer ;
  36. znak        : integer      :=1;
  37. sv,rab:varing;
  38. s4:string(1..4);
  39. s12:string(1..12);
  40. l,k,kk,i,j,l1,l2,n,kip,ip,ie,ih,ik   : integer;
  41. befor,after : integer             ;
  42. dp    : float             := 0.1;
  43. dpp   : float             := 0.1;
  44. flt,fit :float ;
  45. minute,hour,secund:integer;  sec:float;
  46. date:string(1..8):="00.00.00";
  47. s3:string(1..3); s5:string(1..5);
  48. -----------------------------------------------------------------------
  49. procedure err(t:string;l:character) is
  50. begin new_line; put(t); put(" no numeric symbol "); put(l);
  51.                 put(" replace to 0 "); end err;
  52. -----------------------------------------------------------------------
  53. procedure liter(inp:in out float;lit :out character) is
  54.   begin fit:=inp;
  55. for n  in 1..10                                       loop  fit:=fit-1.0;
  56. if fit<0.0 then fit:=dig*(fit+1.0); l1:=n-1; exit; end if; end loop;
  57.                    case  l1 is
  58. when 0 => lit:=zero;  when 1 => lit:=one;  when 2 => lit:=two;
  59. when 3 => lit:=three; when 4 => lit:=fore; when 5 => lit:=five;
  60. when 6 => lit:=six;   when 7 => lit:=seven;when 8 => lit:=eight;
  61. when 9 => lit:=nine;  when others => null;
  62.        end case; inp:=fit;
  63. end liter;
  64. ------------------------------------------------------------------
  65. procedure put_edit(s:string;a:float;pos:integer:=7) is
  66. begin put(s);
  67. if abs(a)<1.0e-50 then  overlay(s12,1," 0.000000000");
  68.                   else s12:=put_f(a,12); end if;
  69. if index(s12,power)>0 then
  70. s4:=right(s12,9);  overlay(s12,pos-3,s4);
  71. end  if;
  72. for i in 1..pos loop put(s12(i)); end loop;
  73. end put_edit;
  74. ------------------------------------------------------------------
  75. procedure put_edit(s:string;a:integer;pos:integer:=4) is
  76. begin put(s); s12:=put_i(a,12);
  77. -- if a>=0 then  s12(1):=probel;end if; text_io.put(s12(1));
  78. if a=0 then put(zero); return; end if;
  79. for i in 1..pos loop put(s12(i-pos+12));  end loop;
  80. end put_edit;
  81. ------------------------------------------------------------------
  82. function date_means return string is
  83. tm:Time;
  84. begin
  85. tm:=Clock;--  date and time ;
  86. i:=day(tm);
  87. s3:=put_i(i,3);
  88. for j in 1..2 loop date(j):=s3(j+1); end loop;
  89. i:=month(tm);s3:=put_i(i,3); for j in 4..5 loop date(j):=s3(j-2); end loop;
  90. i:=year(tm);s5:=put_i(i,5);
  91. for j in 7..8 loop date(j):=s5(j-3); end loop;
  92. for j in 1..8 loop if date(j)=probel then date(j):=zero; end if; end loop;
  93. return date;
  94. end;
  95. ------------------------------------------------------------------
  96. function time_means return string is
  97. Tm:time;
  98. begin
  99. tm:=clock; --  date and time ;
  100. sec:=float(seconds(tm));
  101. hour:=integer(sec/3600.0); sec:=sec-3600.0*float(hour);
  102. minute:=integer(sec/60.0); sec:=sec-60.0*float(minute);
  103. secund:=integer(sec);
  104. s3:=put_i(hour,3); for j in 1..2 loop date(j):=s3(j+1); end loop;
  105. s3:=put_i(minute,3);
  106. for j in 2..3 loop if s3(j) not in '0'..'9' then s3(j):='0'; end if; end loop;
  107. for j in 4..5 loop date(j):=s3(j-2);end loop;
  108. s3:=put_i(secund,3);
  109. for j in 2..3 loop if s3(j) not in '0'..'9' then s3(j):='0'; end if; end loop;
  110. for j in 7..8 loop date(j):=s3(j-5); end loop;
  111. return date;
  112. end;
  113. --------------------------------------------------------------
  114. --
  115. procedure upper_low(s:in out string;uplow:character:='u') is
  116. begin for i in 1..s'length loop lit:=s(i);
  117. case uplow is
  118. when 'u' | 'U' => k:=index(low,lit);  if k>0 then s(i):=upper(k); end if;
  119. when 'l' | 'L' => k:=index(upper,lit);if k>0 then s(i):=low(k);   end if;
  120. when others    => null;
  121. end case; end loop;
  122. end upper_low;
  123. --------------------------------------------------------------
  124. --
  125. procedure ctext(s:in out string) is
  126. st:string(1..s'length);
  127. begin  l:=s'length;
  128.  k:=0;for i in 1..l loop st(i):=probel; end loop;
  129. for i in reverse 1..l loop
  130.   if s(i)/=probel then  k:=i;goto next; end if; end loop;
  131. if k=0 then goto fin; end if;
  132. <<next>> j:=(l-k)/2; -- moving
  133. for i in j+1..k+j  loop st(i):=s(i-j); end loop;
  134. for i in 1..l loop s(i):=st(i); end loop;
  135. <<fin>> null; end ctext;
  136. --------------------------------------------------------------
  137. function substr(s:string;pos:integer:=1;len:integer) return string is
  138. -- ret:string(1..len);
  139. begin i:=len;j:=s'length; if j<i then i:=j; end if;
  140. -- for j in 1..i loop ret(j):=s(j+pos-1); end loop;
  141. return s(1+pos-1..i+pos-1); -- ret;
  142. end substr;
  143. --------------------------------------------------------------
  144. function left(s:string;pos:integer) return string is
  145. -- ret:string(1..pos);
  146. begin i:=min(pos,s'length);
  147. return s(1..i); -- ret;
  148. end left;
  149. --------------------------------------------------------------
  150. function right(s:in string;pos:integer:=1) return string is
  151. begin  k:=s'length;
  152. if k<=0 then goto fin; end if;
  153. <<fin>> return s(pos..k); -- ret;
  154. end right;
  155. --------------------------------------------------------------
  156. function comp_str(s1,s2:in string)return boolean is
  157. ret:boolean:=false;
  158. begin
  159. l1:=s1'length;l2:=s2'length;if l1/=l2 then goto fin;end if;
  160. for i in 1..l1 loop if s1(i)/=s2(i) then ret:=false; exit; end if;
  161. ret:=true; end loop;
  162. <<fin>> return ret;
  163. end comp_str;
  164. --------------------------------------------------------------
  165. procedure clean(s:in out string) is
  166. begin  j:=0; i:=s'length;
  167. for k in 1..s'length           loop
  168. exit when s(k) /= probel ; j:=k; end loop;
  169. for k in 1..i               loop s(k):=s(k+j) ; end loop;
  170. for k in i-j+1..i    loop s(k) :=probel ; end loop;
  171. end clean;
  172. --------------------------------------------------------------
  173. function var_len(s:string)return integer is
  174.  begin i:=s'length;j:=i;
  175. for k in reverse 1..i                  loop
  176.    exit when s(i) /= probel; j:=k; end loop;
  177. return j;
  178. end var_len;
  179. --------------------------------------------------------------
  180. function index(s:string;ss:string)return integer  is
  181.   begin   k:=0; l1:=s'length; l2:=ss'length;
  182. kk:=l1-l2+1 ; -- how many include
  183. if kk<1  then goto fin;  end if;
  184. for i in 1..kk            loop
  185.  for j  in 1..l2   loop  n:=j+i-1;
  186.  if s(n) /= ss(j) then goto next; end if;end loop;
  187. k:=i; goto fin;
  188. <<next>> null;        end loop;
  189. <<fin>> return k; end index;
  190. --------------------------------------------------------------
  191. function verify(s:string;ss:string;pos:integer:=1)return integer  is
  192. begin
  193. for i in pos..s'length  loop  k:=index(ss,s(i));
  194.  if k = 0 then return i; end if;
  195. end loop;
  196. return 0;
  197. end verify;
  198. --------------------------------------------------------------
  199. function index(s:string;ss:character)return integer  is
  200.   begin   k:=0; l:=s'length;
  201. for i in 1..l             loop
  202.  if s(i)  = ss then k:=i; goto fin; end if;
  203. <<next>> null;        end loop;
  204. <<fin>> return k; end index;
  205. --------------------------------------------------------------
  206. function index(s:varing;ss:character)return integer  is
  207.   begin   k:=0; l:=s.len_str;
  208. for i in 1..l             loop
  209.  if s.cnt_str(i)   = ss then k:=i; goto fin; end if;
  210. <<next>> null;        end loop;
  211. <<fin>> return k; end index;
  212. --------------------------------------------------------------
  213. procedure overlay(s:in out string;pos:integer;ss:string)   is
  214. begin  l1:=s'length; l2:=ss'length;
  215. if pos<1 or pos>l1-l2+1 or l2>l1 then goto fin; end if;
  216. for i in pos..pos+l2-1  loop  n:=i-pos+1;s(i):=ss(n); end loop;
  217. <<fin>> null; end overlay;
  218. --------------------------------------------------------------
  219. procedure overlay(s:in out string;pos:integer;ss:character)   is
  220. begin  l:=s'length;  if pos<1 or pos>l  then goto fin; end if;
  221. s(pos):=ss;
  222. <<fin>> null; end overlay;
  223. --------------------------------------------------------------
  224. procedure overlay(s:in out varing;pos:integer;ss:character)   is
  225. begin  l:=s.len_str;  if pos<1 or pos>l  then goto fin; end if;
  226. s.cnt_str(pos):=ss; s.len_str:=max(s.len_str,pos);
  227. <<fin>> null; end overlay;
  228. --------------------------------------------------------------
  229. procedure translate(s:in out string;change,map:string) is
  230. begin
  231. for i in 1..s'length loop
  232.  for j in 1..min(change'length,map'length) loop
  233.   if s(i)=change(j) then s(i):=map(j); end if;
  234.  end loop;
  235. end loop;
  236. end translate;
  237. --------------------------------------------------------------
  238. function get_i(s:in string) return integer is
  239.  begin   i:=0;  flag:=false; znak:=1; flagp:=false;
  240. for k in 1..s'length  loop m(k):=0;
  241. if s(k)=minus then if  znak=1 then znak:=-1; goto next;
  242.               else err("get_i:fusion numbers",s(k)); goto next;     end if; end if;
  243. if s(k)=probel and flag=false then goto next; end if;
  244. if s(k)=plus then  if flagp=false then goto next;
  245.                else flagp:=true; err("get_i:fusion numbers",s(k)); goto next; end if;
  246. end if;
  247. exit when s(k)=probel  and flag=true ;
  248.        case s(k) is
  249. when zero  => m(k):=0; flag:=true; when one   => m(k):=1; flag:=true;
  250. when two   => m(k):=2; flag:=true;
  251. when three => m(k):=3; flag:=true; when fore  => m(k):=4; flag:=true;
  252. when five  => m(k):=5; flag:=true; when six   => m(k):=6; flag:=true;
  253. when seven => m(k):=7; flag:=true; when eight => m(k):=8; flag:=true;
  254. when nine  => m(k):=9; flag:=true; when others=> err("get_i",s(k));
  255.              end case;
  256. i:=i*digi+m(k);
  257. <<next>> null;     end loop;
  258. i:=znak*i;  return i;
  259. end get_i;
  260. --------------------------------------------------------------
  261. function get_f(s:in string) return float   is
  262. znak:integer;  flag:boolean;
  263. -- ss    : string(1..s'length) ;
  264. begin  ip:=0; ih:=1;ik:=10;l:=s'length; dp:=0.1; ie:=l+1; s12:=(others=>probel);
  265. flt:=0.0; flag:=false; flagp:=false; flag_power:=false; znak:=1;
  266. for k in 1..10  loop m(k):=0;  end loop;
  267. for k in 1..l    loop
  268. if s(k)=minus then if  znak=1   then znak:=-1  ; goto next;
  269.                          else err("get_f:",s(k)); goto next;     end if; end if;
  270. if s(k)=probel and flag=false then goto next; end if;
  271. if s(k)=plus then  if flagp=false then flagp:=true;goto next;
  272.                                   else  err("GET_F:",s(k)); goto next; end if;
  273. end if;
  274.  
  275. if s(k)=power then flag_power:=true;ik:=k-1; ie:=k;exit; end if;
  276. exit when s(k)=probel  and flag=true ;
  277.        case  s(k) is
  278. when zero  => m(k):=0; flag:=true;  ik:=k;
  279. when one   => m(k):=1; flag:=true;  ik:=k;
  280. when two   => m(k):=2; flag:=true;  ik:=k;
  281. when three => m(k):=3; flag:=true;  ik:=k;
  282. when fore  => m(k):=4; flag:=true;  ik:=k;
  283. when five  => m(k):=5; flag:=true;  ik:=k;
  284. when six   => m(k):=6; flag:=true;  ik:=k;
  285. when seven => m(k):=7; flag:=true;  ik:=k;
  286. when eight => m(k):=8; flag:=true;  ik:=k;
  287. when nine  => m(k):=9; flag:=true;  ik:=k;
  288. when point => if ip=0 then ip:=k; else err("Get_f:",s(k)); end if; goto next;
  289. when others => err("Get_f:",s(k));
  290.              end case;
  291. if ip=0 then flt:=flt*dig+float(m(k));
  292.         else flt:=flt+dp*float(m(k)); dp:=dp*digp;
  293. end if;
  294. <<next>> null;     end loop;
  295. if ip>ie then new_line;put("GET_F:not integer power                ");
  296. flt:=0.0;goto finish;  end if;
  297. if flag_power=true then  s12(1..l):=s(1..l); -- ss:=s;  ----- exp form ------
  298.   for j in 1..ie loop s12(j):=probel; end loop;clean(s12); kip:=get_i(s12);
  299.  if kip>0 then for k in 1..kip loop flt:=flt*dig ;end loop;
  300.          else for k in 1..abs(kip) loop flt:=flt/dig;end loop; end if;
  301. end if;
  302. flt:=float(znak)*flt;
  303. <<finish>> return flt;
  304. end get_f;
  305. --------------------------------------------------------------
  306. function put_i(item:integer;pos:integer:=6) return string is
  307. s12,sss : string(1..12)  ; j:integer;
  308.  begin
  309. for i in 1..12 loop s12(i):=probel; sss(i):=probel; end loop;
  310. if item=0 then overlay(s12,1," 0"); goto fin; end if;
  311. overlay(sss,1,integer'image(item));
  312. for i in reverse 1..12 loop
  313. if sss(i) /=probel then kk:=i; exit; end if; end loop;
  314. if pos< kk then return sss(2..pos+1); end if;
  315. for i in reverse 1..kk loop j:=i-kk+pos; if j<1 then exit; end if;
  316. s12(j):=sss(i);  end loop;
  317. <<fin>> return s12(1..pos);
  318. end put_i;
  319. --------------------------------------------------------------
  320. function put_e(item:float;pos:integer:=8) return string is
  321. -- s,ss    : string(1..pos)           ;
  322. s12        : string(1..12);
  323. flt:float;   kk:integer;
  324.  begin     flt:=abs(item); s12(1):=plus;  kk:=0;
  325. for k in 1..pos loop s12(k) :=probel;  end loop;
  326. if flt=0.0       then  s12(1):=probel;s12(2):=zero;goto fin; end if;
  327. -- normalizing   ITEM
  328. if flt<1.0 then for  k in 1..72     loop  exit when flt>=1.0;
  329.   flt:=flt*dig;kk:=kk-1;  end loop;
  330.            else for  k in 1..72     loop  exit when flt<10.0;
  331.   flt:=flt/dig;kk:=kk+1;  end loop;
  332. end if;
  333. liter(flt,lit);s12(2):=lit;s12(3):=point;
  334. for k in 4..pos-4 loop liter(flt,lit); s12(k):=lit; end loop;
  335. s12(pos-3):=power;
  336. overlay(s3,1,"   ");
  337. --s3:=put_i(kk,3);
  338. overlay(s3,1,integer'image(kk));
  339. if s3(1)=probel then s3(1):=plus;end if;
  340. for k in 1..3 loop s12(k+pos-3):=s3(k);             end loop;
  341. <<fin>>
  342. if item<0.0   then  s12(1):=minus;else s12(1):=plus; end if;
  343. return s12(1..pos);
  344. end put_e;
  345. --------------------------------------------------------------
  346. function put_f(item:float;pos:integer:=8) return string is
  347. s12     : string(1..12)           ;
  348.  begin   flt:=abs(item);  dp:=0.1; dpp:=0.1;
  349. for k in 1..pos loop s12(k) :=probel;  end loop;
  350. if flt<1.0e-50   then  s12(1):=probel; overlay(s12,pos-2," 0.00000");
  351. -- s12(2):=zero;s12(3):=point;s12(4):=zero;
  352. goto fin;  end if;
  353. for i in 1..pos-3 loop dp:=dp*dpp; end loop;
  354. if flt<=dp then s12:=put_e(item,12);
  355. s4:=right(s12,9);  overlay(s12,pos-3,s4);
  356. goto fin; end if;
  357. for j in 1..pos loop dpp:=digp*dpp; end loop;
  358. for j in 1..2 loop kk:=0;
  359. -- normalized    ITEM
  360. if flt<1.0 then for  k in 1..72     loop  exit when flt>=1.0;
  361.    flt:=flt*dig;kk:=kk-1;  end loop;
  362.            else for  k in 1..72     loop  exit when flt<10.0;
  363.   flt:=flt/dig;kk:=kk+1;  end loop;
  364. end if;
  365.   if kk >=0      then --    number grater for module
  366. befor:=kk+1; after:=pos-befor-2;
  367. if befor>=pos-1 then s12:=put_e(item,12);
  368. s4:=right(s12,9); overlay(s12,pos-3,s4);
  369. goto fin; end if;
  370. for k in 2..befor+1           loop
  371. liter(flt,lit);s12(k):=lit; end loop; s12(befor+2):=point;
  372. for k in befor+3..pos         loop
  373. liter(flt,lit);s12(k):=lit; end loop;
  374.                     else  --            < 1 for mod
  375. s12(2):=zero;s12(3):=point;
  376. for k in 4..4+abs(kk+1)-1    loop s12(k):=zero;               end loop;
  377. for k in 4+abs(kk+1).. pos   loop liter(flt,lit);s12(k):=lit; end loop;
  378.  befor:=abs(kk); end if;
  379. liter(flt,lit);
  380. if lit=five or lit=six or lit=seven or lit=eight or lit=nine then
  381.    flt:=abs(item) + dpp;
  382.                                    else goto fin; end if;
  383.  end  loop;
  384. <<fin>>
  385. if item<0.0 then s12(1):=minus;else s12(1):=probel; end if;
  386. return s12(1..pos);
  387. exception
  388. when others => return "************" ;
  389. end put_f;
  390. ------------------------------------------------------------------
  391. function min(x,y:float) return float is
  392. begin if x<y then return x; end if; return y; end min;
  393. ------------------------------------------------------------------
  394. function max(x,y:float) return float is
  395. begin if x>y then return x; end if; return y; end max;
  396. ------------------------------------------------------------------
  397. function min(x,y:integer) return integer is
  398. begin if x<y then return x;  end if; return y; end min;
  399. ------------------------------------------------------------------
  400. function max(x,y:integer) return integer is
  401. begin if x>y then return x;end if; return y; end max;
  402. ------------------------------------------------------------------
  403. function get_i(s:in varing)     return integer is
  404. begin sv:=s; sv.len_str:=sv.len_str+1; sv.cnt_str(sv.len_str):=probel;
  405. n:=get_i(sv.cnt_str);
  406. return n;
  407. end get_i;
  408. ------------------------------------------------------------------
  409. function get_f(s:in varing)     return float   is
  410. flt:float;
  411. begin sv:=s; sv.len_str:=sv.len_str+1; sv.cnt_str(sv.len_str):=probel;
  412. flt:=get_f(sv.cnt_str);
  413. return flt;
  414. end get_f;
  415. ------------------------------------------------------------------
  416. function put_i(item:in integer;pos:integer:=6) return varing is
  417. -- sss:string(1..pos);
  418. begin
  419. sv.len_str:=pos;   s12:=put_i(item,12);
  420. for i in 1..pos loop s12(i):=s12(12-pos+i); end loop;
  421. for i in 1..pos loop sv.cnt_str(i):=s12(i); end loop;
  422. return sv;
  423. end put_i;
  424. ------------------------------------------------------------------
  425. function put_e(item:in float;pos:integer:=8 ) return varing is
  426. s12:string(1..12);
  427. begin
  428. sv.len_str:=pos;   s12:=put_e(item,12);
  429. s4:=right(s12,9);  overlay(s12,pos-3,s4);
  430. for i in 1..pos loop sv.cnt_str(i):=s12(i); end loop;
  431. return sv;
  432. end put_e;
  433. ------------------------------------------------------------------
  434. function put_f(item:in float;pos:integer:=8 ) return varing is
  435. s12:string(1..12);
  436. begin
  437. sv.len_str:=pos;   s12:=put_f(item,12);
  438. if index(s12,power)>0 then -- put_e
  439. s4:=right(s12,9);  overlay(s12,pos-3,s4);
  440. end if;
  441. for i in 1..pos loop sv.cnt_str(i):=s12(i); end loop;
  442. return sv;
  443. end put_f;
  444. ------------------------------------------------------------------
  445. function substr(s:varing;pos:integer:=1;len:integer) return string is
  446. -- ret:string(1..len);
  447. begin i:=len;j:=s.len_str; if j<i then i:=j; end if;
  448. -- for j in 1..i loop ret(j):=s.cnt_str(j+pos-1); end loop;
  449. return s.cnt_str(pos..j+pos-i); -- ret;
  450. end substr;
  451. ------------------------------------------------------------------
  452. function left(s:varing;pos:integer) return string is
  453. -- ret:string(1..pos);
  454. begin i:=min(pos,s.len_str);
  455. -- for j in 1..i loop ret(j):=s.cnt_str(j); end loop;
  456. return s.cnt_str(1..i); -- ret;
  457. end left;
  458. ------------------------------------------------------------------
  459. function right(s:in varing;pos:integer:=1) return string is
  460. begin
  461. k:=min(s.len_str,pos);
  462. <<fin>> return s.cnt_str(k..s.len_str); -- ret;
  463. end right;
  464. --------------------------------------------------------------
  465. function substr(s:varing;pos:integer:=1;len:integer) return varing is
  466. begin i:=len;j:=s.len_str; if j<i then i:=j; end if;
  467. for j in 1..i loop sv.cnt_str(j):=s.cnt_str(j+pos-1); end loop;
  468. sv.len_str:=i;
  469. return sv;
  470. end substr;
  471. --------------------------------------------------------------
  472. function left(s:varing;pos:integer) return varing is
  473. begin sv:=s; sv.len_str:=min(pos,s.len_str);
  474. return sv;
  475. end left;
  476. --------------------------------------------------------------
  477. function right(s:in varing;pos:integer:=1) return varing is
  478. begin if pos>s.len_str then sv.len_str:=0; goto fin; end if;
  479. sv.len_str:=s.len_str-pos+1;
  480. for j in 1..sv.len_str loop
  481. sv.cnt_str(j):=s.cnt_str(j+pos-1); end loop;
  482. <<fin>> return sv;
  483. end right;
  484. --------------------------------------------------------------
  485. function comp_str(s1,s2:in varing) return boolean is
  486. begin  flag:=false;
  487. l1:=s1.len_str;l2:=s2.len_str;if l1/=l2 then goto fin;end if;
  488. for i in 1..l1 loop if s1.cnt_str(i)/=s2.cnt_str(i) then exit; end if;
  489. flag:=true; end loop;
  490. <<fin>> return flag;
  491. end comp_str;
  492. --------------------------------------------------------------
  493. procedure clean(s:in out varing) is
  494. begin  l:=s.len_str;
  495. j:=0; for k in 1..l                  loop
  496. exit when s.cnt_str(k) /= probel ; j:=k; end loop;
  497. for k in 1..l-j  loop s.cnt_str(k):=s.cnt_str(k+j) ; end loop;
  498. s.len_str:=s.len_str-j;
  499. end clean;
  500. --------------------------------------------------------------
  501. function var_len(s:varing)return integer is
  502. begin j:=s.len_str; return j;
  503. end var_len;
  504. --------------------------------------------------------------
  505. function index(s:varing;ss:string)return integer  is
  506. begin   k:=0;  flag:=true;
  507. l1:=s.len_str; l2:=ss'length; kk:=l1-l2+1 ; -- how many include
  508. if kk<1  then goto fin;  end if;
  509. for i in 1..kk            loop
  510.  for j  in 1..l2   loop  n:=j+i-1;
  511. flag:=flag and (s.cnt_str(n)=ss(j)); end loop;
  512. if flag then return i; end if;
  513. <<next>> null;        end loop;
  514. <<fin>> return k; end index;
  515. --------------------------------------------------------------
  516. function verify(s:varing;ss:string;pos:integer:=1)return integer  is
  517. begin
  518. for i in pos..s.len_str loop k:=index(ss,s.cnt_str(i));
  519.   if k = 0 then return i;  end if;
  520. end loop;
  521. return 0;
  522. end verify;
  523. --------------------------------------------------------------
  524. procedure overlay(s:in out varing;pos:integer;ss:string)   is
  525.   begin  l1:=s.len_str; l2:=ss'length;
  526. if pos<1 then goto fin; end if;
  527. for i in pos..pos+l2-1  loop  n:=i-pos+1;s.cnt_str(i):=ss(n); end loop;
  528. s.len_str:=max(s.len_str,l2+pos-1);
  529. <<fin>> null;
  530. end overlay;
  531. --------------------------------------------------------------
  532. procedure overlay(s:in out varing;pos:integer;ss:varing)   is
  533. begin l1:=s.len_str; l2:=ss.len_str;
  534. if pos<1 or pos>l1-l2+1 or l2>l1 then goto fin; end if;
  535. for i in pos..pos+l2-1  loop
  536.  n:=i-pos+1;s.cnt_str(i):=ss.cnt_str(n); end loop;
  537. <<fin>> null; s.len_str:=max(s.len_str,s.len_str+l2-pos+1);
  538. end overlay;
  539. --------------------------------------------------------------
  540. procedure translate(s:in out varing;change,map:string) is
  541. begin
  542. for i in 1..s.len_str loop
  543.  for j in 1..min(change'length,map'length) loop
  544.   if s.cnt_str(i)=change(j) then s.cnt_str(i):=map(j); end if;
  545.  end loop;
  546. end loop;
  547. end translate;
  548. --------------------------------------------------------------
  549. procedure null_len(s:in out varing) is begin s.len_str:=0;  end null_len;
  550. --------------------------------------------------------------
  551. --
  552. procedure upper_low(s:in out varing;uplow:character:='u') is
  553. begin for i in 1..s.len_str loop lit:=s.cnt_str(i);
  554. case uplow is
  555. when 'u' | 'U' => k:=index(low,lit);  if k>0 then s.cnt_str(i):=upper(k); end if;
  556. when 'l' | 'L' => k:=index(upper,lit);if k>0 then s.cnt_str(i):=low(k); end if;
  557. when others    => null;
  558. end case; end loop;
  559. end upper_low;
  560. --------------------------------------------------------------
  561. function "&" (s1,s2:varing) return varing is
  562. begin l1:=s1.len_str; l2:=s2.len_str; sv.len_str:=l1+l2;
  563.       overlay(sv,1,s1); overlay(sv,l1+1,s2);
  564. return sv; end ;
  565. --------------------------------------------------------------
  566. procedure put(s:varing; pos:integer) is
  567. begin for i in 1..pos loop put(s.cnt_str(i)); end loop;
  568. end put;
  569. --------------------------------------------------------------
  570. procedure  begent(s:in out varing;pictend:character;err:in out boolean) is
  571. elem:character; flag,flb:boolean; i:integer;
  572. begin  s.len_str:=0; err:=false; flag:=true;i:=0; elem:=' '; -- clean
  573. flb:=true; -- beginning blank
  574. loop get(elem);
  575.  if character'pos(elem)>32 then flb:=false; end if; -- string begining
  576.  if flb then goto next; end if;
  577.  if flag or elem /=' ' then i:=i+1; s.cnt_str(i):=elem; end if;
  578.  if flb then goto next; end if;
  579.  if elem =' ' then flag:=false; else flag:=true; end if;
  580.  exit when elem=pictend;
  581.  <<next>> null;
  582. end loop;
  583. s.len_str:=i;
  584. <<pend>>  if err then new_line;
  585.  for ii in 1..i loop elem:=s.cnt_str(ii); put(elem); end loop; put('$');
  586.           end if;
  587. exception
  588. when others => err:=true;
  589. new_line;  put("absent symbol (;) or end of information =>");
  590.  
  591.  for ii in 1..i loop elem:=s.cnt_str(ii); put(elem); end loop; put('$');
  592. end begent;
  593. -------------------------------------------------------------------------
  594. --
  595. -- /* 1-yes error 0-no  error */  ;
  596. procedure helpstr(str:varing;kl:in out integer;
  597.                   err:out boolean; strend:character:=';') is
  598. sv:varing;
  599. begin err:=false; sv:=str;  kl:=0;
  600. for i in 1..str.len_str loop
  601. if sv.cnt_str(i)=coma then sv.cnt_str(i):=probel; end if; -- no coma
  602. end loop ;
  603. clean(sv);  n:=index(sv,strend);
  604. if n=0  then  sv.len_str:=sv.len_str+1; sv.cnt_str(sv.len_str):=probel;
  605.        else sv.cnt_str(sv.len_str):=probel;  end if; -- only number
  606. m:loop -- read
  607. n:=index(sv,probel);  exit when n=0 or n>=sv.len_str;
  608. rab:=left(sv,n-1);
  609. for j in 1..rab.len_str loop
  610. if index(sim,rab.cnt_str(j))=0 then -- mistake
  611. err:=true;
  612. new_line; put("HELPSTR:mistake(non numeric symbol) =>"); put(sv.cnt_str(j));
  613. put(" in the string <<"); put(sv.cnt_str); put(">>");
  614. put(" read numbers =>"); s3:=put_i(kl,3); put(s3);
  615. return; end if;
  616.                                end loop;
  617. kl:=kl+1;
  618. sv:=right(sv,n+1);
  619. clean(sv);
  620. end loop m;
  621. end helpstr ;
  622. --------------------------------------------------------------
  623. function sign(x:integer) return integer is
  624. begin
  625. if x<0 then return -1; elsif x=0 then return 0; else return 1; end if;
  626. end sign;
  627. --------------------------------------------------------------
  628. function sign(x:float) return integer is
  629. begin
  630. if x<0.0 then return -1; elsif x=0.0 then return 0; else return 1; end if;
  631. end sign;
  632. --------------------------------------------------------------
  633. end builtin;
  634.